*     ----------------
*     PROGRAMME USLP98    GF9806
*     ----------------
*
* --- Objet ------------------------------------------------------------
*
*     Utilitaires pour les fichiers Ephemerides Tchebychev SLP98.
*
*     1. Copie d'un fichier a acces direct avec selection des corps
*        et de l'intervalle de temps.
*     2. Creation d'un fichier sequentiel a partir d'un fichier a
*        acces direct.
*     3. Creation d'un fichier a acces direct a partir d'un fichier
*        sequentiel.
*     4. Visualisation d'un fichier a acces direct par affichage des
*        coefficients de Tchebychev.
*     5. Calcul d'une ephemeride a partir d'un fichier a acces direct.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
      character rep
*
* --- Menu -------------------------------------------------------------
*
100   continue
*
      call EFFECR
      write (*,1000)
*
      read (*,'(a)',iostat=nerr) rep
*
      if (nerr.ne.0) then
         write (*,1001)
         read (*,*)
         goto 100
      endif
*
      select case (rep)
      case ('q','Q')
         write (*,1002)
         read (*,*)
         stop
      case ('1')
         call SLP98COP
      case ('2')
         call SLP98DSQ
      case ('3')
         call SLP98SQD
      case ('4')
         call SLP98VIS
      case ('5')
         call SLP98EPH
      case default
         write (*,1002)
         read (*,*)
      endselect
*
      goto 100
*
* --- Formats ----------------------------------------------------------
*
1000  format (/2x,'------------------------------------------'
     .        /2x,'EPHEMERIDES TCHEBYCHEV SLP98 : UTILITAIRES'
     .        /2x,'------------------------------------------'/
     .        /2x,'1: Copie d''un fichier'
     .        /2x,'2: Creation d''un fichier sequentiel'
     .        /2x,'3: Creation d''un fichier a acces direct'
     .        /2x,'4: Visualisation d''un fichier'
     .        /2x,'5: Calcul d''une Ephemeride'/
     .        /2x,'Q: Quitter'/
     .        /2x,'Entrez votre choix : ',$)
1001  format (/2x,'Erreur de choix : Appuyez sur Entree')
1002  format (/2x,'Fin du programme : Appuyez sur Entree')
*
      end
*
*
*
      subroutine SLP98COP
*-----------------------------------------------------------------------
*
*     Ref : GF9806
*
* --- Objet ------------------------------------------------------------
*
*     Copie d'un Fichier Ephemerides Tchebychev SLP98.
*
*     Le fichier source est a acces direct
*     Le fichier copie est aussi a acces direct.
*
*     La copie est faite avec selection de la periode de temps et
*     des corps concernes.
*
*     La trace de la copie est ecrite dans le fichier : slp98cop.prn.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
      logical fexist
      integer dat1,dat2
      character rep
      character*8 corps(11)
      character*40 fich1,fich2
*
      parameter (lmin=232)
*
      dimension ic(11),loc1(11,3),loc2(11,3),coef1(714),coef2(714)
*
* --- Initialisation ---------------------------------------------------
*
      data corps/
     .'Mercure','Venus','Baryc.TL','Mars','Jupiter','Saturne',
     .'Uranus','Neptune','Pluton','Lune','Soleil'/
*
      data loc1/33*0/
      data loc2/33*0/
      data ic/11*0/
*
      open (10,file='slp98cop.prn')
*
* --- Fichier source ---------------------------------------------------
*
100   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1001)
      read (*,'(a)') fich1
*
      inquire (file=fich1,exist=fexist)
      if (.not.fexist) goto 100
*
      lrec=lmin
      open (11,file=fich1,access='direct',recl=lrec,status='old',
     .      iostat=nerr)
      if (nerr.ne.0) goto 500
*
      read (11,rec=1,iostat=nerr)
     .idf,tdeb1,tfin1,delta,ncoef1,nbloc1,noct1,loc1
      if (nerr.ne.0.or.idf.ne.98) goto 500
*
      close (11)
      call JJDATE (tdeb1,idat1,ih)
      call JJDATE (tfin1,idat2,ih)
*
      call EFFECR
      write (*,1000)
*
      write (*,1002)  fich1,
     .                idf,tdeb1,idat1,tfin1,idat2,delta,ncoef1,
     .                nbloc1,noct1,loc1
      read (*,*)
*
      open (11,file=fich1,access='direct',recl=noct1,status='old',
     .      iostat=nerr)
      if (nerr.ne.0) goto 500
*
* --- Selection de la periode de temps ---------------------------------
*
200   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1003) idat1,idat2
      read (*,'(i10)',iostat=nerr) dat1
      if (nerr.ne.0) goto 200
      call DATEJJ (dat1,0,t1)
      if (t1.eq.0.d0.or.t1.lt.tdeb1.or.t1.gt.tfin1) goto 200
*
      write (*,1004) dat1,idat2
      read (*,'(i10)',iostat=nerr) dat2
      if (nerr.ne.0) goto 200
      call DATEJJ (dat2,0,t2)
      if (t2.eq.0.d0.or.t2.le.t1.or.t2.gt.tfin1) goto 200
*
      tdeb2=tdeb1+dint((t1-tdeb1)/delta)*delta
      tfin2=tfin1-dint((tfin1-t2)/delta)*delta
      if (tdeb2.lt.tdeb1.or.tdeb2.gt.tfin1.or.
     .    tfin2.lt.tdeb1.or.tfin2.gt.tfin1) goto 200
*
      write (*,1005)
      read (*,'(a)') rep
      if (rep.eq.'N'.or.rep.eq.'n') goto 200
*
* --- Selection des corps ----------------------------------------------
*
300   continue
*
      call EFFECR
      write (*,1000)
      write (*,'(2x)')
*
      do i=1,11
         ic(i)=0
         if (loc1(i,3).ne.0) then
            write (*,1006) corps(i)
            read (*,'(a)') rep
!            if (lnblnk_(rep).eq.0.or.rep.eq.'O'.or.rep.eq.'o') then
            if (rep.eq.'O'.or.rep.eq.'o') then
               ic(i)=1
            else
               if (rep.ne.'N'.and.rep.ne.'n') goto 300
            endif
         endif
      enddo
*
      write (*,1005)
      read (*,'(a)') rep
      if (rep.eq.'N'.or.rep.eq.'n') goto 300
*
* --- Fichier copie ----------------------------------------------------
*
400   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1007)
      read (*,'(a)') fich2
      inquire (file=fich2,exist=fexist)
*
      if (fexist) then
         write (*,1008)
         read (*,*)
         goto 400
      endif
*
      write (*,1005)
      read (*,'(a)') rep
      if (rep.eq.'N'.or.rep.eq.'n') goto 400
*
* --- Ecriture du descriptif du fichier copie --------------------------
*
      nbloc2=(tfin2-tdeb2)/delta+1
      irang=1
*
      do i=1,11
         loc2(i,1)=irang
         dlt=loc1(i,2)
         ncf=loc1(i,3)
         if (ic(i).eq.1) then
            loc2(i,2)=loc1(i,2)
            loc2(i,3)=loc1(i,3)
            ni=delta/dlt
            irang=irang+3*ncf*ni
         else
            loc2(i,2)=0
            loc2(i,3)=0
         endif
      enddo
*
      ncoef2=irang-1
      koct=(ncoef2+1)*8
      noct2=max0(koct,lmin)
*
      call JJDATE (tdeb2,idat1,ih)
      call JJDATE (tfin2,idat2,ih)
*
      open (12,file=fich2,access='direct',recl=noct2,status='new',
     .      iostat=nerr)
      if (nerr.ne.0) goto 600
*
      write (12,rec=1,iostat=nerr)
     .idf,tdeb2,tfin2,delta,ncoef2,nbloc2,noct2,loc2
      if (nerr.ne.0) goto 600
*
* --- Copie des coefficients de Tchebychev -----------------------------
*
      call EFFECR
      write (*,1000)
*
      k=(tdeb2-tdeb1)/delta+2
      nmax=nbloc2-1
*
      do n=1,nmax
         read (11,rec=k) dj0,(coef1(i),i=1,ncoef1)
         nb=n+1
         write (*,1009) nb,nbloc2,dj0
         l2=0
         do i=1,11
            if (ic(i).eq.1) then
               l1=loc1(i,1)-1
               dlt=loc2(i,2)
               ncf=loc2(i,3)
               ni=delta/dlt
               lmax=3*ncf*ni
               do l=1,lmax
                  l1=l1+1
                  l2=l2+1
                  coef2(l2)=coef1(l1)
               enddo
            endif
         enddo
         write (12,rec=nb) dj0,(coef2(l),l=1,ncoef2)
         k=k+1
      enddo
*
* --- Fin de la copie --------------------------------------------------
*
      write (*,1010)
      read (*,*)
*
      call EFFECR
      write (*,1000)
      write (10,1000)
*
      write (*,1011)  fich1,fich2,
     .                idf,tdeb2,idat1,tfin2,idat2,delta,ncoef2,
     .                nbloc2,noct2,loc2
      write (10,1011) fich1,fich2,
     .                idf,tdeb2,idat1,tfin2,idat2,delta,ncoef2,
     .                nbloc2,noct2,loc2
      write (*,1012)
      read (*,*)
*
      close (10)
      close (11)
      close (12)
*
      return
*
* --- Erreur -----------------------------------------------------------
*
500   continue
*
      write (*,1013)
      read (*,*)
      close (11)
      goto 100
*
600   continue
      write (*,1013)
      read (*,*)
      close (12)
      goto 400
*
* --- Formats ----------------------------------------------------------
*
1000  format (2x,'-----------------------------------------------'/
     .        2x,'COPIE D''UN FICHIER EPHEMERIDES TCHEBYCHEV SLP98'/
     .        2x,'-----------------------------------------------')
1001  format (/2x,'Entrez le nom du fichier SLP98 source : ',$)
1002  format (/2x,'Fichier Source : ',a40/
     .        /2x,'Descriptif du fichier :'
     .        /2x,'idf   : ',i2
     .        /2x,'tdeb  : ',f9.1,2x,i9,
     .        /2x,'tfin  : ',f9.1,2x,i9,
     .        /2x,'delta : ',f4.1
     .        /2x,'ncoef : ',i5.5
     .        /2x,'nbloc : ',i5.5
     .        /2x,'noct  : ',i5.5/
     .        /2x,'Localisation des Coefficients :'
     .        /2x,'Corps',
     .        1x,' Mer Ven Btl Mar Jup Sat Ura Nep Plu Lun Sol'
     .        /2x,'Adres',1x,11(1x,i3.3)
     .        /2x,'Inter',1x,11(1x,i3.3)
     .        /2x,'Coeff',1x,11(1x,i3.3)/
     .        /2x,'Appuyez sur Entree')
1003  format (/2x,'Entrez la date debut de periode entre ',i9,' et ',i9,
     .        ' : ',$)
1004  format (/2x,'Entrez la date fin   de periode entre ',i9,' et ',i9,
     .        ' : ',$)
1005  format (/2x,'Confirmez-vous votre choix (o/n) ? ',$)
1006  format (2x,'Voulez-vous selectionner ',a8,' (o/n/x) ? ',$)
1007  format (/2x,'Entrez le nom du fichier copie : ',$)
1008  format (/2x,'Fichier deja existant : Appuyez sur Entree'/)
1009  format (2x,'Copie bloc : ',i5,' / ',i5,4x,'DJ',f9.1)
1010  format (/2x,'Copie terminee : Appuyez sur Entree')
1011  format (/2x,'Fichier Source : ',a40
     .        /2x,'Fichier Copie  : ',a40/
     .        /2x,'Descriptif du fichier Copie :'
     .        /2x,'idf   : ',i2
     .        /2x,'tdeb  : ',f9.1,2x,i9,
     .        /2x,'tfin  : ',f9.1,2x,i9,
     .        /2x,'delta : ',f4.1
     .        /2x,'ncoef : ',i5.5
     .        /2x,'nbloc : ',i5.5
     .        /2x,'noct  : ',i5.5/
     .        /2x,'Localisation des Coefficients :'
     .        /2x,'Corps',
     .        1x,' Mer Ven Btl Mar Jup Sat Ura Nep Plu Lun Sol'
     .        /2x,'Adres',1x,11(1x,i3.3)
     .        /2x,'Inter',1x,11(1x,i3.3)
     .        /2x,'Coeff',1x,11(1x,i3.3))
1012  format (/2x,'Appuyez sur Entree')
1013  format (/2x,'Erreur Fichier : Appuyez sur Entree'/)
*
2001  format (/2x,'Fichier inconnu : Appuyez sur Entree'/)
2002  format (/2x,'Erreur de fichier : Appuyez sur Entree'/)
2003  format (/2x,'Erreur de date : Appuyez sur Entree'/)
2004  format (/2x,'Erreur de dates : '/
     .        /2x,'Periode demandee :',2(2x,f9.1)
     .        /2x,'Periode possible :',2(2x,f9.1)/
     .        /2x,'Appuyez sur Entree'/)
2005  format (/2x,'Fichier deja existant : Appuyez sur Entree'/)
*
      end
*
*
*
      subroutine SLP98DSQ
*-----------------------------------------------------------------------
*
*     Ref : GF9806
*
* --- Objet ------------------------------------------------------------
*
*     Creation d'un fichier Ephemerides Tchebychev SLP98 sequentiel
*     a partir d'un fichier Ephemerides Tchebychev SLP98 a acces direct.
*
*     La trace de la copie est ecrite dans le fichier : slp98dsq.prn.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
      logical fexist
      integer dat1,dat2
      character*40 fich1,fich2
*
      dimension coef(714),loc(11,3)
*
      open (10,file='slp98dsq.prn')
*
* --  Fichier a acces direct -------------------------------------------
*
100   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1001)
      read (*,'(a)') fich1
      inquire (file=fich1,exist=fexist)
      if (.not.fexist) goto 100
*
      lrec=228
      open (11,file=fich1,access='direct',recl=lrec,status='old',
     .      iostat=nerr)
      if (nerr.ne.0) goto 300
*
      read (11,rec=1,iostat=nerr)
     .idf,tdeb,tfin,delta,ncoef,nbloc,noct,loc
      if (nerr.ne.0.or.idf.ne.98) goto 300
*
      close (11)
      call JJDATE (tdeb,dat1,ih)
      call JJDATE (tfin,dat2,ih)
*
      call EFFECR
      write (*,1000)
*
      write (*,1002)  fich1,
     .                idf,tdeb,dat1,tfin,dat2,delta,ncoef,
     .                nbloc,noct,loc
      read (*,*)
*
      open (11,file=fich1,access='direct',recl=noct,status='old',
     .      iostat=nerr)
      if (nerr.ne.0) goto 300
*
* --- Fichier sequentiel -----------------------------------------------
*
200   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1003)
      read (*,'(a)') fich2
      inquire (file=fich2,exist=fexist)
*
      if (fexist) then
         write (*,1004)
         read (*,*)
         goto 200
      endif
*
      open (12,file=fich2,access='sequential',status='new',iostat=nerr)
      if (nerr.ne.0) goto 400
*
* --- Copie du fichier -------------------------------------------------
*
      write (12,2001) idf,tdeb,tfin,delta,ncoef,nbloc,noct,loc
*
      nenrgt=(nbloc-1)*(ncoef/3+1)+10
*
      do n=2,nbloc
         num=n-1
         read (11,rec=n) dj0,(coef(l),l=1,ncoef)
         write (12,2002) num,dj0
         write (12,2003) (coef(l),l=1,ncoef)
         write (*,1005) n,nbloc
      enddo
*
* --- Fin de la copie --------------------------------------------------
*
      write (*,1006)
      read (*,*)
*
      call EFFECR
      write (*,1000)
      write (10,1000)
*
      write (*,1007)  fich1,fich2,
     .                idf,tdeb,dat1,tfin,dat2,delta,ncoef,
     .                nbloc,nenrgt,noct,loc
      write (10,1007) fich1,fich2,
     .                idf,tdeb,dat1,tfin,dat2,delta,ncoef,
     .                nbloc,nenrgt,noct,loc
      write (*,1008)
      read (*,*)
*
      close (10)
      close (11)
      close (12)
      return
*
* --- Erreur -----------------------------------------------------------
*
300   continue
*
      write (*,1009)
      read (*,*)
      close (11)
      goto 100
*
400   continue
*
      write (*,1009)
      read (*,*)
      close (12)
      goto 200
*
* --- Formats ----------------------------------------------------------
*
1000  format (2x,'-----------------------------------------'/
     .        2x,'COPIE SLP98 : ACCES DIRECT --> SEQUENTIEL'/
     .        2x,'-----------------------------------------')
1001  format (/2x,'Entrez le nom du fichier SLP98 acces direct : ',$)
1002  format (/2x,'Fichier acces direct : ',a40/
     .        /2x,'Descriptif du fichier :'
     .        /2x,'idf   : ',i2
     .        /2x,'tdeb  : ',f9.1,2x,i9,
     .        /2x,'tfin  : ',f9.1,2x,i9,
     .        /2x,'delta : ',f4.1
     .        /2x,'ncoef : ',i5.5
     .        /2x,'nbloc : ',i5.5
     .        /2x,'noct  : ',i5.5/
     .        /2x,'Localisation des Coefficients :'
     .        /2x,'Corps',
     .        1x,' Mer Ven Btl Mar Jup Sat Ura Nep Plu Lun Sol'
     .        /2x,'Adres',1x,11(1x,i3.3)
     .        /2x,'Inter',1x,11(1x,i3.3)
     .        /2x,'Coeff',1x,11(1x,i3.3)/
     .        /2x,'Appuyez sur Entree')
1003  format (/2x,'Entrez le nom du fichier SLP98 sequentiel : ',$)
1004  format (/2x,'Fichier deja existant : Appuyez sur Entree',$)
1005  format (2x,'Copie bloc : ',i5.5,' / ',i5.5)
1006  format (/2x,'Copie terminee : Appuyez sur Entree')
1007  format (/2x,'Fichier a acces direct lu : ',a40
     .        /2x,'Fichier sequentiel cree   : ',a40/
     .        /2x,'Descriptif des fichiers :'
     .        /2x,'idf   : ',i2
     .        /2x,'tdeb  : ',f9.1,2x,i9,
     .        /2x,'tfin  : ',f9.1,2x,i9,
     .        /2x,'delta : ',f4.1
     .        /2x,'ncoef : ',i5.5
     .        /2x,'nbloc : ',i5.5,7x,i8.8,' enregistrements'
     .        /2x,'noct  : ',i5.5/
     .        /2x,'Localisation des Coefficients :'
     .        /2x,'Corps',
     .        1x,' Mer Ven Btl Mar Jup Sat Ura Nep Plu Lun Sol'
     .        /2x,'Adres',1x,11(1x,i3.3)
     .        /2x,'Inter',1x,11(1x,i3.3)
     .        /2x,'Coeff',1x,11(1x,i3.3))
1008  format (/2x,'Appuyez sur Entree')
1009  format (/2x,'Erreur Fichier : Appuyez sur Entree'/)
*
2001  format (i8/d24.16/d24.16/d24.16/i8/i8/i8,
     .        3(/11(i3.3,1x)))
2002  format (i8.8,d24.16)
2003  format (3d24.16)
*
      end
*
*
*
      subroutine SLP98SQD
*-----------------------------------------------------------------------
*
*     Ref : GF9806
*
* --- Objet ------------------------------------------------------------
*
*     Creation d'un fichier SLP98 Ephemerides Tchebychev a acces direct
*     a partir d'un fichier SLP98 Ephemerides Tchebychev sequentiel.
*
*     La trace de la copie est ecrite dans le fichier : slp98sqd.prn.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
      logical fexist
      integer dat1,dat2
      character*40 fich1,fich2
*
      dimension coef(714),loc(11,3)
*
      open (10,file='slp98sqd.prn')
*
* --- Fichier sequentiel -----------------------------------------------
*
100   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1001)
      read (*,'(a)') fich1
      inquire (file=fich1,exist=fexist)
      if (.not.fexist) goto 100
*
      open (11,file=fich1,access='sequential',status='old',iostat=nerr)
      if (nerr.ne.0) goto 300
*
      read (11,2001,iostat=nerr)
     .idf,tdeb,tfin,delta,ncoef,nbloc,noct,loc
      if (nerr.ne.0) goto 300
*
      call JJDATE (tdeb,dat1,ih)
      call JJDATE (tfin,dat2,ih)
*
      nenrgt=(nbloc-1)*(ncoef/3+1)+10
*
      call EFFECR
      write (*,1000)
*
      write (*,1002)  fich1,
     .                idf,tdeb,dat1,tfin,dat2,delta,ncoef,
     .                nbloc,nenrgt,noct,loc
      read (*,*)
*
* --- Fichier a acces direct -------------------------------------------
*
200   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1003)
      read (*,'(a)') fich2
      inquire (file=fich2,exist=fexist)
*
      if (fexist) then
         write (*,1004)
         read (*,*)
         goto 200
      endif
*
      open (12,file=fich2,access='direct',recl=noct,status='new',
     .      iostat=nerr)
      if (nerr.ne.0) goto 400
*
* --- Copie du fichier -------------------------------------------------
*
      write (12,rec=1) idf,tdeb,tfin,delta,ncoef,nbloc,noct,loc
*
      do n=2,nbloc
         read (11,2002) num,dj0
         read (11,2003) (coef(l),l=1,ncoef)
         write (12,rec=n) dj0,(coef(l),l=1,ncoef)
         write (*,1005) n,nbloc
      enddo
*
* --- Fin de la copie --------------------------------------------------
*
      write (*,1006)
      read (*,*)
*
      call EFFECR
      write (*,1000)
      write (10,1000)
*
      write (*,1007)  fich1,fich2,
     .                idf,tdeb,dat1,tfin,dat2,delta,ncoef,
     .                nbloc,nenrgt,noct,loc
      write (10,1007) fich1,fich2,
     .                idf,tdeb,dat1,tfin,dat2,delta,ncoef,
     .                nbloc,nenrgt,noct,loc
      write (*,1008)
      read (*,*)
*
      close (10)
      close (11)
      close (12)
      return
*
* --- Erreur -----------------------------------------------------------
*
300   continue
*
      write (*,1009)
      read (*,*)
      close (11)
      goto 100
*
400   continue
      write (*,1009)
      read (*,*)
      close (12)
      goto 200
*
* --- Formats ----------------------------------------------------------
*
1000  format (2x,'----------------------------------------'/
     .        2x,'COPIE SLP98 : SEQUENTIEL -> ACCES DIRECT'/
     .        2x,'----------------------------------------')
1001  format (/2x,'Entrez le nom du fichier SLP98 sequentiel : ',$)
1002  format (/2x,'Fichier sequentiel : ',a40/
     .        /2x,'Descriptif du fichier :'
     .        /2x,'idf   : ',i2
     .        /2x,'tdeb  : ',f9.1,2x,i9,
     .        /2x,'tfin  : ',f9.1,2x,i9,
     .        /2x,'delta : ',f4.1
     .        /2x,'ncoef : ',i5.5
     .        /2x,'nbloc : ',i5.5,7x,i8.8,' enregistrements'
     .        /2x,'noct  : ',i5.5/
     .        /2x,'Localisation des Coefficients :'
     .        /2x,'Corps',
     .        1x,' Mer Ven Btl Mar Jup Sat Ura Nep Plu Lun Sol'
     .        /2x,'Adres',1x,11(1x,i3.3)
     .        /2x,'Inter',1x,11(1x,i3.3)
     .        /2x,'Coeff',1x,11(1x,i3.3)/
     .        /2x,'Appuyez sur Entree')
1003  format (/2x,'Entrez le nom du fichier SLP98 acces direct : ',$)
1004  format (/2x,'Fichier deja existant : Appuyez sur Entree',$)
1005  format (2x,'Copie bloc : ',i5.5,' / ',i5.5)
1006  format (/2x,'Copie terminee : Appuyez sur Entree')
1007  format (/2x,'Fichier sequentiel lu       : ',a40
     .        /2x,'Fichier a acces direct cree : ',a40/
     .        /2x,'Descriptif des fichiers :'
     .        /2x,'idf   : ',i2
     .        /2x,'tdeb  : ',f9.1,2x,i9,
     .        /2x,'tfin  : ',f9.1,2x,i9,
     .        /2x,'delta : ',f4.1
     .        /2x,'ncoef : ',i5.5
     .        /2x,'nbloc : ',i5.5,7x,i8.8,' enregistrements'
     .        /2x,'noct  : ',i5.5/
     .        /2x,'Localisation des Coefficients :'
     .        /2x,'Corps',
     .        1x,' Mer Ven Btl Mar Jup Sat Ura Nep Plu Lun Sol'
     .        /2x,'Adres',1x,11(1x,i3.3)
     .        /2x,'Inter',1x,11(1x,i3.3)
     .        /2x,'Coeff',1x,11(1x,i3.3))
1008  format (/2x,'Appuyez sur Entree')
1009  format (/2x,'Erreur Fichier : Appuyez sur Entree'/)
*
2001  format (i8/d24.16/d24.16/d24.16/i8/i8/i8,
     .        3(/11(i3.3,1x)))
2002  format (i8,d24.16)
2003  format (3d24.16)
*
      end
*
*
*
      subroutine SLP98VIS
*-----------------------------------------------------------------------
*
*     Ref : GF9806
*
* --- Objet ------------------------------------------------------------
*
*     Visualisation des Ephemerides Tchebychev SLP98.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
      logical fexist
      integer dat1,dat2
      character rep
      character*40 fich
      character*8 corps(11)
*
      parameter (lmin=232)
*
      dimension loc(11,3),coef(714)
*
* --- Initialisation ---------------------------------------------------
*
      data corps/
     .'MERCURE','VENUS','BARYC.TL','MARS','JUPITER','SATURNE',
     .'URANUS','NEPTUNE','PLUTON','LUNE','SOLEIL'/
*
* --- Fichier SLP98 ----------------------------------------------------
*
100   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1001)
      read (*,'(a)') fich
*
      inquire (file=fich,exist=fexist)
      if (.not.fexist) goto 100
*
      lrec=lmin
      open (10,file=fich,access='direct',recl=lrec,status='old')
      read (10,rec=1) idf,tdeb,tfin,delta,ncoef,nbloc,noct,loc
      if (idf.ne.98) goto 500
*
      close (10)
      call JJDATE (tdeb,dat1,ih)
      call JJDATE (tfin,dat2,ih)
*
      call EFFECR
      write (*,1000)
*
      write (*,1002) fich,
     .               idf,tdeb,dat1,tfin,dat2,delta,ncoef,
     .               nbloc,noct,loc
      read (*,*)
*
      open (10,file=fich,access='direct',recl=noct,status='old',
     .      iostat=nerr)
      if (nerr.ne.0) goto 500
*
* --- Parametres de Recherche ------------------------------------------
*
200   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1003)
      read (*,'(i2)',iostat=nerr) ichoix
      if (nerr.ne.0) goto 200
      if (ichoix.lt.0.or.ichoix.gt.2) goto 200
*
      if (ichoix.eq.0) then
         close (10)
         write (*,1004)
         read (*,*)
         return
      endif
*
      if (ichoix.eq.1) then
         write (*,1005) nbloc
         read (*,'(i6)',iostat=nerr) nrec
         if (nerr.ne.0) goto 200
         if (nrec.lt.2.or.nrec.gt.nbloc) goto 200
      else
         write (*,1006) dat1,dat2
         read (*,'(i10)',iostat=nerr) idat
         if (nerr.ne.0) goto 200
         call DATEJJ (idat,0,t)
         if (t.lt.tdeb.or.t.gt.tfin) goto 200
         nrec=(t-tdeb)/delta+2
         if (t.eq.tfin) nrec=nrec-1
      endif
*
* --- Affichage des Coefficients de Tchebychev -------------------------
*
300   continue
*
      read (10,rec=nrec) dj0,(coef(i),i=1,ncoef)
*
      do j=1,11
*
         if (loc(j,3).ne.0) then
*
            dlt=loc(j,2)
            ncf=loc(j,3)
            ni=delta/dlt
*
            do n=1,ni
*
               iad=loc(j,1)+3*(n-1)*ncf-1
               tj1=dj0+(n-1)*dlt
               tj2=tj1+dlt
               call JJDATE (tj1,idat1,ih)
               call JJDATE (tj2,idat2,ih)
               call EFFECR
               write (*,1007) fich,corps(j),tj1,tj2,idat1,idat2,nrec,n
*
               do i=1,ncf
                  i0=i-1
                  i1=iad+i
                  i2=i1+ncf
                  i3=i2+ncf
                  write (*,1008) i0,coef(i1),coef(i2),coef(i3)
               enddo
*
               write (*,1009)
               read (*,*)
*
            enddo
*
         endif
*
      enddo
*
* --- Test de sortie ---------------------------------------------------
*
400   continue
*
      call EFFECR
      write (*,1000)
*
      rep='$'
      write (*,1010)
      read (*,'(a)') rep
*
      if (rep.eq.'0') then
         close (10)
         write (*,1004)
         read (*,*)
         return
      endif
*
      if (rep.eq.'=') goto 300
*
      if (rep.eq.'+') then
         nrec=min0(nbloc,nrec+1)
         goto 300
      endif
*
      if (rep.eq.'-') then
         nrec=max0(2,nrec-1)
         goto 300
      endif
*
      if (rep.eq.'V'.or.rep.eq.'v') goto 200
*
      if (rep.eq.'F'.or.rep.eq.'f') then
         close (10)
         goto 100
      endif
*
      goto 400
*
* --- Erreur -----------------------------------------------------------
*
500   continue
*
      write (*,1011)
      read (*,*)
      close (10)
      goto 100
*
* --- Formats ----------------------------------------------------------
*
1000  format (2x,'------------------------------------'/
     .        2x,'FICHIER EPHEMERIDES TCHEBYCHEV SLP98'/
     .        2x,'------------------------------------')
1001  format (/2x,'Entrez le Nom du Fichier : ',$)
1002  format (/2x,'Fichier : ',a40/
     .        /2x,'Descriptif du fichier :'
     .        /2x,'idf   : ',i2
     .        /2x,'tdeb  : ',f9.1,2x,i9,
     .        /2x,'tfin  : ',f9.1,2x,i9,
     .        /2x,'delta : ',f4.1
     .        /2x,'ncoef : ',i5.5
     .        /2x,'nbloc : ',i5.5
     .        /2x,'noct  : ',i5.5/
     .        /2x,'Localisation des Coefficients :'
     .        /2x,'Corps',
     .        1x,' Mer Ven Btl Mar Jup Sat Ura Nep Plu Lun Sol'
     .        /2x,'Adres',1x,11(1x,i3.3)
     .        /2x,'Inter',1x,11(1x,i3.3)
     .        /2x,'Coeff',1x,11(1x,i3.3)/
     .        /2x,'Appuyez sur Entree')
1003  format (/2x,'Type de Visualisation :'/
     .        /2x,'1 : Par numero de bloc'
     .        /2x,'2 : Par date du calendrier'/
     .        /2x,'Entrez votre choix (0 : Arret)  ? ',$)
1004  format (/2x,'Visualisation terminee : Appuyez sur Entree',$)
1005  format (//2x,'Entrez un Numero de Bloc entre 00002 et ',i5.5,
     .        2x,'? ',$)
1006  format (//2x,'Entrez une Date du Calendrier entre ',i9,' et ',i9,
     .        2x,'? ',$)
1007  format (2x,'VISUALISATION DU FICHIER : ',a//
     .        2x,a8,2(2x,'DJ',f9.1),2x,2i10,3x,'Bloc no',i5.5,' /',i1/)
1008  format (2x,i2,3(d24.16))
1009  format (/2x,'Appuyez sur Entree pour continuer')
1010  format (/2x,'Voulez-vous :'/
     .        /2x,'0 : Arreter le programme'/
     .        /2x,'= : Visualiser le bloc courant'
     .        /2x,'+ : Visualiser le bloc suivant'
     .        /2x,'- : Visualiser le bloc precedent'
     .        /2x,'v : Un nouveau choix de visualisation'
     .        /2x,'f : Un nouveau fichier a visualiser'/
     .        /2x,'Entrez votre choix ? : ',$)
1011  format (/2x,'Erreur Fichier : Appuyez sur Entree'/)
*
      end
*
*
*
      subroutine SLP98EPH
*-----------------------------------------------------------------------
*
*     Ref : GF9806
*
* --- Objet ------------------------------------------------------------
*
*     Calcul d'ephemerides a partir des Ephemerides Tchebychev SLP98.
*
* --- Parametres -------------------------------------------------------
*
*     d0 : date initiale de l'ephemerides a calculer (*aaaammjj).
*     h0 : heure initiale de l'ephemerides a calculer (hhmmss).
*     nd : nombre de dates a calculer (entier).
*     dt : pas du calcul en jours (reel dp)
*
*     icorps : indice du corps (entier).
*     icent  : indice du centre du repere (entier).
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
      logical fexist
      integer d0,h0
      character rep,saut
      character*24 corps(0:12)
      character*40 fich1,fich2
      character*50 msger(5)
*
      dimension v(9),loc(11,3)
*
* --- Initialisation ---------------------------------------------------
*
      data corps/
     .'Barycentre syst. solaire',
     .'Mercure','Venus','BaryTL','Mars','Jupiter','Saturne',
     .'Uranus','Neptune','Pluton','Lune','Soleil','Terre'/
*
      data msger/
     .'ERREUR de fichier',
     .'ERREUR de dates',
     .'ERREUR de corps',
     .'ERREUR de centre du repere',
     .'ERREUR de calcul position-vitesse-acceleration'/
*
      saut=char(12)
*
      menu1=1
      menu2=1
*
      nul=2
      lmin=232
*
* --- Fichier SLP98 ----------------------------------------------------
*
100   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1001)
      read (*,'(a)') fich1
      inquire (file=fich1,exist=fexist)
*
      if (.not.fexist) then
         write (*,2001)
         read (*,*)
         goto 100
      endif
*
      open (nul,file=fich1,access='direct',recl=lmin,status='old',
     .      iostat=nerr)
*
      if (nerr.ne.0) then
         write (*,2002)
         close (nul)
         read (*,*)
         goto 100
      endif
*
      read (nul,rec=1) idf,tdeb,tfin,delta,ncoef,nbloc,noct,loc
*
      if (idf.ne.98) then
         write (*,2002)
         close (nul)
         read (*,*)
         goto 100
      endif
*
      close (nul)
      call JJDATE (tdeb,idat1,ih)
      call JJDATE (tfin,idat2,ih)
*
      open (nul,file=fich1,access='direct',recl=noct,status='old',
     .      iostat=nerr)
*
      if (nerr.ne.0) then
         write (*,2002)
         close (nul)
         read (*,*)
         goto 100
      endif
*
* --- Fichier des resultats --------------------------------------------
*
200   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1002)
      read (*,'(i16)',iostat=nerr) ifich
*
      if (nerr.ne.0.or.ifich.lt.1.or.ifich.gt.2) then
         write (*,2004)
         read (*,*)
         goto 200
      endif
*
      if (ifich.eq.2) then
         write (*,1003)
         read (*,'(a)') fich2
         inquire (file=fich2,exist=fexist)
         if (fexist) then
            write (*,2003)
            read (*,*)
            goto 200
         else
            open (10,file=fich2,iostat=nerr)
            if (nerr.ne.0) then
               write (*,2002)
               close (10)
               read (*,*)
               goto 200
            endif
         endif
      endif
*
* --- Parametres de datation -------------------------------------------
*
300   continue
*
      if (menu1.eq.0) goto 400
*
      call EFFECR
      write (*,1000)
*
      write (*,1004) idat1,idat2
      read (*,'(i16)',iostat=nerr) d0
*
      if (nerr.ne.0.or.d0.lt.idat1.or.d0.gt.idat2) then
         write (*,2004)
         read (*,*)
         goto 300
      endif
*
      write (*,1005)
      read (*,'(i16)',iostat=nerr) h0
*
      if (nerr.ne.0) then
         write (*,2004)
         read (*,*)
         goto 300
      endif
*
      call DATEJJ (d0,h0,t0)
*
      if (t0.eq.0.d0) then
         write (*,2004)
         read (*,*)
         goto 300
      endif
*
      write (*,1006)
      read (*,'(i16)',iostat=nerr) nd
      if (nerr.ne.0.or.nd.lt.1.or.nd.gt.999) then
         write (*,2004)
         read (*,*)
         goto 300
      endif
*
      write (*,1007)
      read (*,'(f16.5)',iostat=nerr) dt
*
      if (nerr.ne.0.or.dabs(dt).gt.1.d5) then
         write (*,2004)
         read (*,*)
         goto 300
      endif
*
      write (*,1008)
      read (*,'(a)') rep
*
      if (rep.eq.'N'.or.rep.eq.'n') goto 300
*
* --- Parametres corps et centre du repere -----------------------------
*
400   continue
*
      if (menu2.eq.0) goto 500
*
      call EFFECR
      write (*,1000)
*
      write (*,1009)
      read (*,'(i16)',iostat=nerr) icorps
*
      if (nerr.ne.0.or.icorps.lt.1.or.icorps.gt.12) then
         write (*,2004)
         read (*,*)
         goto 400
      endif
*
      call EFFECR
      write (*,1000)
*
      write (*,1010)
      read (*,'(i16)',iostat=nerr) icent
*
      if (nerr.ne.0.or.icent.lt.0.or.icent.gt.12) then
         write (*,2004)
         read (*,*)
         goto 400
      endif
*
      write (*,1008)
      read (*,'(a)') rep
*
      if (rep.eq.'N'.or.rep.eq.'n') goto 400
*
* --- Calcul des ephemerides -------------------------------------------
*
500   continue
*
      t=t0
*
      do n=1,nd
*
         call JJDATE (t,idat,ih)
         call SLP98 (t,icorps,icent,3,nul,v,ierr)
*
         if (ierr.ne.0) then
            call EFFECR
            write (*,2005) msger(ierr-9),fich1,
     .                     idf,tdeb,idat1,tfin,idat2,delta,ncoef,
     .                     nbloc,noct,loc
            close (nul)
            read (*,*)
            return
         endif
*
         if (ifich.eq.1) then
            if (mod(n,3).eq.1) then
               call EFFECR
               write (*,1000)
               write (*,3001) corps(icorps),corps(icent)
            endif
            write (*,3002) t,idat,ih,v
         else
            if (mod(n,12).eq.1)
     .         write (10,3001) corps(icorps),corps(icent)
            write (10,3002) t,idat,ih,v
            write (*,3003) n,nd
         endif
*
         if (ifich.eq.1.and.mod(n,3).eq.0.and.n.ne.nd) then
            write (*,1011)
            read (*,*)
         endif
*
         if (ifich.eq.2.and.(mod(n,12).eq.0.or.n.eq.nd))
     .      write (10,'(a)') saut
*
         t=t+dt
*
      enddo
*
      write (*,1012)
      read (*,*)
*
* --- Test de sortie ---------------------------------------------------
*
600   continue
*
      call EFFECR
      write (*,1000)
*
      write (*,1013)
      read (*,'(i16)',iostat=nerr) irep
*
      if (nerr.ne.0.or.irep.lt.1.or.irep.gt.4) then
         write (*,2004)
         read (*,*)
         goto 600
      endif
*
      if (irep.ne.1) then
         menu1=1
         menu2=1
         if (irep.eq.2) menu2=0
         if (irep.eq.3) menu1=0
         goto 300
      endif
*
      close (nul)
      if (ifich.eq.2) close (10)
*
      return
*
* --- Formats ----------------------------------------------------------
*
1000  format (2x,'-----------------'/
     .        2x,'EPHEMERIDES SLP98'/
     .        2x,'-----------------')
1001  format (/2x,'Nom du fichier SLP98 ? ',$)
1002  format (/2x,'Resultats :'/
     .        /2x,'1: Ecran'
     .        /2x,'2: Fichier'/
     .        /2x,'Entrez votre choix ? ',$)
1003  format (/2x,'Nom du fichier Resultats ? ',$)
1004  format (/2x,'Entrez la date entre ',i9,'  et ',i9,'  :   ',$)
1005  format (/2x,'Entrez l''heure     (code : hhmmss)',12x,':   ',$)
1006  format (/2x,'Entrez le nombre de dates   (<999)',12x,':   ',$)
1007  format (/2x,'Entrez le pas en jours     (f11.5)',12x,':   ',$)
1008  format (/2x,'Confirmez-vous ce choix (o/n) ? ',$)
1009  format (/2x,'Choix du corps :'/
     .        /2x,'01: Mercure   05: Jupiter  09: Pluton'
     .        /2x,'02: Venus     06: Saturne  10: Lune  '
     .        /2x,'03: Bary T-L  07: Uranus   11: Soleil'
     .        /2x,'04: Mars      08: Neptune  12: Terre '/
     .        /2x,'Entrez votre choix ? ',$)
1010  format (/2x,'Choix du centre du repere :'/
     .        /2x,'00: Barycentre du systeme solaire'
     .        /2x,'01: Mercure   05: Jupiter  09: Pluton'
     .        /2x,'02: Venus     06: Saturne  10: Lune  '
     .        /2x,'03: Bary T-L  07: Uranus   11: Soleil'
     .        /2x,'04: Mars      08: Neptune  12: Terre '/
     .        /2x,'Entrez votre choix ? ',$)
1011  format (/2x,'Appuyez sur Entree pour continuer',$)
1012  format (/2x,'Calcul termine : Appuyez sur Entree',$)
1013  format (/2x,'Voulez-vous faire un nouveau calcul ?'/
     .       /2x,'1 : Non'/
     .       /2x,'2 : Avec d''autres dates'
     .       /2x,'3 : Avec d''autres corps'
     .       /2x,'4 : Avec d''autres dates et d''autres corps'/
     .       /2x,'Entrez votre choix ? ',$)
*
2001  format (/2x,'Fichier inconnu : Appuyez sur Entree'/)
2002  format (/2x,'Erreur de fichier : Appuyez sur Entree'/)
2003  format (/2x,'Fichier deja existant : Appuyez sur Entree'/)
2004  format (/2x,'Erreur de reponse : Appuyez sur Entree'/)
2005  format (/2x,a/
     .        /2x,'Verifier la compatibilite des parametres choisis'
     .        /2x,'avec ceux autorises par le fichier : ',a40/
     .        /2x,'idf:   ',i2
     .        /2x,'tdeb:  ',f9.1,2x,i9
     .        /2x,'tfin:  ',f9.1,2x,i9
     .        /2x,'delta: ',f4.1
     .        /2x,'ncoef: ',i5.5
     .        /2x,'nbloc: ',i5.5
     .        /2x,'noct : ',i5.5/
     .        /2x,'Parametres de localisation des coefficients :'/
     .        /2x,'Corps',
     .        1x,' Mer Ven Btl Mar Jup Sat Ura Nep Plu Lun Sol'/
     .        /2x,'Adres',1x,11(1x,i3.3)
     .        /2x,'Inter',1x,11(1x,i3.3)
     .        /2x,'Coeff',1x,11(1x,i3.3)/
     .        /2x,'Appuyez sur Entree')
*
3001  format (/2x,a8,'- Eph.SLP98 Equateur J2000',
     .        '- Centre du repere : ',a24/)
3002  format (2x,'DJ:',f14.5,8x,'Date: ',i9,10x,'Heure: ',i6.6,3x,'TDB'/
     .       2x,'x :',f18.14,4x,'y :',f18.14,4x,'z :',f18.14,' ua'/
     .       2x,'x'':',f18.14,4x,'y'':',f18.14,4x,'z'':',f18.14,' ua/j'/
     .       2x,'x":',f18.14,4x,'y":',f18.14,4x,'z":',f18.14,' ua/j2')
3003  format (2x,i5.5,' / ',i5.5)
*
      end
*
*
*
      subroutine SLP98 (tdj,icorps,icent,ipva,nul,result,ierr)
* -------------------------------------------------------------------
*
*     Ref : GF9806
*
*     Ephemerides du Soleil, de la Lune et des Planetes SLP98.
*
*     Les coordonnees sont calculees a partir des Ephemerides Tchebychev
*     SLP98 lues sur un fichier a acces direct.
*
*     Repere equatorial J2000.
*
* --- Entree -----------------------------------------------------------
*
*     tdj       Date julienne TDB (reel dp).
*
*     icorps    Indice du corps (entier).
*
*               icorps=01 : Mercure      icorps=07 : Uranus
*               icorps=02 : Venus        icorps=08 : Neptune
*               icorps=03 : Baryc. T-L   icorps=09 : Pluton
*               icorps=04 : Mars         icorps=10 : Lune
*               icorps=05 : Jupiter      icorps=11 : Soleil
*               icorps=06 : Saturne      icorps=12 : Terre
*
*     icent     Centre du repere (entier).
*
*               icent=00 : Barycentre du Systeme Solaire
*               icent=01 : Mercure       icent=07 : Uranus
*               icent=02 : Venus         icent=08 : Neptune
*               icent=03 : Baryc. T-L    icent=09 : Pluton
*               icent=04 : Mars          icent=10 : Lune
*               icent=05 : Jupiter       icent=11 : Soleil
*               icent=06 : Saturne       icent=12 : Terre
*
*     ipva      Indice Position-Vitesse-Acceleration (entier).
*
*               ipva=1 : Position.
*               ipva=2 : Position et Vitesse.
*               ipva=3 : Position, Vitesse et Acceleration.
*
*     nul       Numero d'unite logique du fichier SLP98 (entier).
*
* --- Sortie -----------------------------------------------------------
*
*     result    Resultats (reel dp).
*
*               Coordonnees rectangulaires equatoriales J2000.
*
*               Position :
*               result(1) : X (ua).
*               result(2) : Y (ua).
*               result(3) : Z (ua).
*
*               Vitesse :
*               result(4) : X (ua/j).
*               result(5) : Y (ua/j).
*               result(6) : Z (ua/j).
*
*               Acceleration :
*               result(7) : X (ua/j/j).
*               result(8) : Y (ua/j/j).
*               result(9) : Z (ua/j/j).
*
*     ierr      Indice Erreur (entier).
*
*               ierr=0  : Aucune erreur
*               ierr=10 : Erreur de fichier.
*               ierr=11 : Erreur de date (tdj).
*               ierr=12 : Erreur de corps (icorps).
*               ierr=13 : Erreur de centre (icent).
*               ierr=14 : Erreur Position-Vitesse-Acceleration (ipva).
*
*     Remarque :
*
*     On utilise un fichier d'Ephemerides Tchebychev SLP98 qui doit etre
*     ouvert dans la procedure appelante (numero d'unite logique nul).
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
*
      dimension result(9)
      dimension r(9,3),v(9),w(9)
      dimension ic(3),ic0(3),tdj0(3),ipva0(3)
      dimension coef(714),loc(11,3)
      dimension pc(16),vc(16),ac(16)
      dimension eq2000(3,3)
*
* --- Initialisation ---------------------------------------------------
*
      data nul0/0/,irec0/0/
      data ic0/3*0/,tdj0/3*0.d0/,ipva0/3*0/
      data pc/1.d0,2.d0,0.d0,13*0.d0/,npc0/0/,pc2/2.d0/
      data vc/0.d0,1.d0,0.d0,13*0.d0/,ncv0/0/,vc3/100.d0/
      data ac/0.d0,0.d0,4.d0,13*0.d0/,nca0/0/,ac4/100.d0/
*
*
* --- Rapport des masses Terre-Lune ------------------------------------
*
      data rmtl/81.3007d0/
*
* --- Matrice de rotation (Equateur J2000) -----------------------------
*
      data eq2000/
     .+1.000000000000d0,-0.000000479966d0, 0.000000000000d0,
     .+0.000000440360d0,+0.917482137087d0,+0.397776982902d0,
     .-0.000000190919d0,-0.397776982902d0,+0.917482137087d0/
*
* --- Obliquite J2000 --------------------------------------------------
*
*     e = 23d 26'21.448" (0.409092804222 rad)
*
      data ce/0.917482062069d0/
      data se/0.397777155932d0/
*
* --- Lecture des parametres des Ephemerides Tchebychev SLP98 ----------
*
      if (nul.ne.nul0) then
*
         ierr=10
         read (nul,rec=1,iostat=nerr)
     .         idf,tla,tlb,delta,ncoef,nbloc,noct,loc
         if (nerr.ne.0) goto 200
         if (idf.ne.98) goto 200
         if (noct.eq.0) goto 200
*
         f1=-1.d0/(1.d0+rmtl)
         f2=rmtl/(1.d0+rmtl)
*
      endif
*
* --- Test des parametres ----------------------------------------------
*
      ierr=0
      if (tdj.lt.tla.or.tdj.gt.tlb) ierr=11
      if (icorps.lt.1.or.icorps.gt.12) ierr=12
      if (icent.lt.0.or.icent.gt.12) ierr=13
      if (ipva.lt.1.or.ipva.gt.3) ierr=14
      if (ierr.ne.0) goto 200
*
      ncd=3*ipva
      ncas=0
*
      if (icorps.eq.12.or.icent.eq.12) f=f1
      if (icorps.eq.10.or.icent.eq.10) f=f2
*
* --- Lecture des coefficients de Tchebychev ---------------------------
*
      irec=dint((tdj-tla)/delta)+2
      if (irec.gt.nbloc) irec=nbloc
*
      if (nul.ne.nul0.or.irec.ne.irec0) then
         read (nul,rec=irec,iostat=nerr) t0,(coef(i),i=1,ncoef)
         ierr=10
         if (nerr.ne.0) goto 200
         irec0=irec
      endif
*
* --- Cas : Terre-Lune -------------------------------------------------
*
      if ((icent.eq.12.and.icorps.eq.10).or.
     .    (icent.eq.10.and.icorps.eq.12)) then
         ncas=1
         nsub=1
         ic(1)=10
      endif
*
* --- Cas : Barycentre du Systeme Solaire ------------------------------
*
      if (ncas.eq.0.and.icent.eq.0) then
         ncas=2
         if (icorps.eq.11) then
            nsub=1
            ic(1)=11
         else
            if (icorps.eq.12.or.icorps.eq.10) then
               nsub=3
               ic(1)=11
               ic(2)=3
               ic(3)=10
            else
               nsub=2
               ic(1)=11
               ic(2)=icorps
            endif
         endif
      endif
*
* --- Cas : Soleil --------------------------------------------------------
*
      if (ncas.eq.0.and.(icent.eq.11.or.icorps.eq.11)) then
         ncas=3
         if (icorps.eq.12.or.icent.eq.12.or.
     .       icorps.eq.10.or.icent.eq.10) then
            nsub=2
            ic(1)=3
            ic(2)=10
         else
            nsub=1
            if (icent.eq.11) ic(1)=icorps
            if (icorps.eq.11) ic(1)=icent
         endif
      endif
*
* --- Cas : Terre ou Lune ----------------------------------------------
*
      if (ncas.eq.0.and.
     .   (icorps.eq.12.or.icent.eq.12.or.
     .    icorps.eq.10.or.icent.eq.10)) then
         ncas=4
         if (icorps.eq.3.or.icent.eq.3) then
            nsub=1
            ic(1)=10
         else
            nsub=3
            if (icent.eq.12.or.icent.eq.10) ic(1)=icorps
            if (icorps.eq.12.or.icorps.eq.10) ic(1)=icent
            ic(2)=3
            ic(3)=10
         endif
      endif
*
* --- Autres cas -------------------------------------------------------
*
      if (ncas.eq.0) then
         ncas=5
         nsub=2
         ic(1)=icorps
         ic(2)=icent
      endif
*
* --- Debut Boucle Substitution du temps -------------------------------
*
      do 100 n=1,nsub
*
         if (nul.eq.nul0.and.
     .       ic(n).eq.ic0(n).and.
     .       tdj.eq.tdj0(n).and.
     .       ipva.le.ipva0(n)) goto 100

         ic0(n)=ic(n)
         tdj0(n)=tdj
         ipva0(n)=ipva
*
         k=ic(n)
         iad=loc(k,1)
         dlt=loc(k,2)
         ncf=loc(k,3)
*
         ierr=12
         if (ncf.eq.0) goto 200
*
         ni=dint((tdj-t0)/dlt)+1
         if (tdj.eq.t0+delta) ni=ni-1
         l=iad+3*ncf*(ni-1)
         tz=t0+(ni-1)*dlt
*
* ------ Calcul des Positions ------------------------------------------
*
         cp=2.d0*(tdj-tz)/dlt-1.d0
         pc(2)=cp
*
         if (pc(2).ne.pc2.or.ncf.gt.npc0) then
            npc0=ncf
            pc2=pc(2)
            dt=cp+cp
            do i=3,ncf
               pc(i)=dt*pc(i-1)-pc(i-2)
            enddo
         endif
*
         do i=1,3
            r(i,n)=0.d0
            do j=1,ncf
               jp=ncf-j+1
               jt=l+ncf*(i-1)+jp-1
               r(i,n)=r(i,n)+pc(jp)*coef(jt)
            enddo
         enddo
*
         if (ipva.eq.1) goto 100
*
* ------ Calcul des Vitesses -------------------------------------------
*
         cv=2.d0/dlt
         vc(3)=dt+dt
*
         if (vc(3).ne.vc3.or.ncf.gt.ncv0) then
            ncv0=ncf
            vc3=vc(3)
            do i=4,ncf
               vc(i)=dt*vc(i-1)+2.d0*pc(i-1)-vc(i-2)
            enddo
         endif
*
         do i=1,3
            r(i+3,n)=0.d0
            do j=2,ncf
               jp=ncf-j+2
               jt=l+ncf*(i-1)+jp-1
               r(i+3,n)=r(i+3,n)+vc(jp)*coef(jt)
            enddo
            r(i+3,n)=r(i+3,n)*cv
         enddo
*
         if (ipva.eq.2) goto 100
*
* ------ Calcul des Accelerations --------------------------------------
*
         ca=cv*cv
         ac(4)=24.d0*cp
*
         if (ac(4).ne.ac4.or.ncf.gt.nca0) then
            nca0=ncf
            ac4=ac(4)
            do i=5,ncf
               ac(i)=dt*ac(i-1)+4.d0*vc(i-1)-ac(i-2)
            enddo
         endif
*
         do i=1,3
            r(i+6,n)=0.D0
            do j=3,ncf
               jp=ncf-j+3
               jt=l+ncf*(i-1)+jp-1
               r(i+6,n)=r(i+6,n)+ac(jp)*coef(jt)
            enddo
            r(i+6,n)=r(i+6,n)*ca
         enddo
*
* --- Fin Boucle Substitution du temps ---------------------------------
*
100   continue
*
* --- Rangement des Resultats ------------------------------------------
*
      select case (ncas)
*
* ------ Cas : Terre-Lune ----------------------------------------------
*
         case(1)
            is=+1
            if (icent.eq.10) is=-1
            do i=1,ncd
               v(i)=r(i,1)*is
            enddo
*
* ------ Cas : Barycentre du Systeme Solaire ---------------------------
*
         case(2)
            do i=1,ncd
               v(i)=r(i,1)
               if (icorps.ne.11) then
                  v(i)=v(i)+r(i,2)
                  if (icorps.eq.12.or.icorps.eq.10) then
                     v(i)=v(i)+f*r(i,3)
                  endif
               endif
            enddo
*
* ------ Cas : Soleil -----------------------------------------------------
*
         case(3)
            is=+1
            if (icorps.eq.11) is=-1
            do i=1,ncd
               v(i)=r(i,1)*is
               if (icorps.eq.12.or.icent.eq.12.or.
     .             icorps.eq.10.or.icent.eq.10) then
                  v(i)=v(i)+f*r(i,2)*is
               endif
            enddo
*
* ------ Cas : Terre ou Lune -------------------------------------------
*
         case(4)
            is=+1
            if (icorps.eq.12.or.icorps.eq.10) is=-1
            if (icorps.eq.3.or.icent.eq.3) then
               do i=1,ncd
                  v(i)=-f*r(i,1)*is
               enddo
            else
               do i=1,ncd
                  v(i)=(r(i,1)-r(i,2)-f*r(i,3))*is
               enddo
            endif
*
* ------ Autres Cas ----------------------------------------------------
*
         case (5)
            do i=1,ncd
               v(i)=r(i,1)-r(i,2)
            enddo
*
      endselect
*
* --- Passage au repere equatorial J2000 -------------------------------
*
      if (icorps.ne.9) then
*
         do l=1,ipva
            k=3*(l-1)
            do i=1,3
               w(i+k)=0.d0
               do j=1,3
                  w(i+k)=w(i+k)+eq2000(i,j)*v(j+k)
               enddo
            enddo
         enddo
*
      else
*
         do l=1,ipva
            k=3*(l-1)
            w(k+1)=v(k+1)
            w(k+2)=v(k+2)*ce-v(k+3)*se
            w(k+3)=v(k+2)*se+v(k+3)*ce
         enddo
*
      endif
*
      do i=1,ncd
         result(i)=w(i)
      enddo
*
      ierr=0
      nul0=nul
*
* --- Sortie -----------------------------------------------------------
*
200   continue
*
      if (ierr.ne.0) nul0=0
*
      return
      end
*
*
*
      subroutine JJDATE (tdj,idate,iheure)
*-----------------------------------------------------------------------
*
*     Ref : GF9802
*
* --- Objet ------------------------------------------------------------
*
*     Changement de calendrier : Date julienne -> Gregorien/Julien.
*
* --- Entree -----------------------------------------------------------
*
*     tdj         Date julienne (reel dp).
*
* --- Sortie -----------------------------------------------------------
*
*     idate       Date gregorienne codee *aaaammjj (entier).
*     iheure      Heure codee hhmmss (entier).
*
* --- Remarque ---------------------------------------------------------
*
*     On utilise le formulaire de J. Meeus.
*     La date julienne tdj doit etre superieure ou egale a 0.
*     si tdj<0, alors idate=0 et iheure=0.
*
*     L'annee est comptee en millesimes astronomiques.
*     L'annee 1 avant J.C. des historiens correspond a l'an 0 des
*     astronomes et ainsi de suite.
*     Ex : l'an 80 avant J.C. correspond a l'an astronomique -79.
*
* --- Rappel -----------------------------------------------------------
*
*     Le calendier Gregorien commence le 15/10/1582 a 0h (DJ2299160.5).
*     Avant cette date, on utilise le calendrier Julien.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
*
* --- Initialisation ---------------------------------------------------
*
      idate=0
      iheure=0
      if (tdj.lt.0.d0) return
*
      t=tdj+0.5d0/86400.d0+0.5d0
      z=dint(t)
      f=t-z
      a=z
*
* --- Calcul -----------------------------------------------------------
*
      if (z.ge.2299161.d0) then
         x=dint((z-1867216.25d0)/36524.25d0)
         a=z+1.d0+x-dint(x/4.d0)
      endif
*
      b=a+1524.d0
      c=dint((b-122.1d0)/365.25d0)
      d=dint(365.25d0*c)
      e=dint((b-d)/30.6001d0)
      jour=b-d-dint(30.6001d0*e)
      mois=e-1.d0
*
      if (e.gt.13.5d0) mois=e-13.d0
      ian=c-4716.d0
      if (mois.lt.2.5d0) ian=c-4715.d0
      is=+1
      if (ian.lt.0) is=-1
*
      idate=((iabs(ian)*100+mois)*100+jour)*is
*
      f=f*24.d0
      ih=f
      f=(f-ih)*60.d0
      im=f
      f=(f-im)*60.d0
      is=f
*
      iheure=(ih*100+im)*100+is
*
* --- Sortie -----------------------------------------------------------
*
      return
      end
*
*
*
      subroutine DATEJJ (idate,iheure,tdj)
*-----------------------------------------------------------------------
*
*     Ref : GF9802
*
* --- Objet ------------------------------------------------------------
*
*     Changement de calendrier : Gregorien/Julien -> Date julienne.
*
* --- Entree -----------------------------------------------------------
*
*     idate       Date du calendrier codee *aaaammjj (entier).
*     iheure      Heure codee hhmmss (entier).
*
* --- Sortie -----------------------------------------------------------
*
*     tdj         Date julienne (reel dp).
*
* --- Remarque ---------------------------------------------------------
*
*     On utilise le formulaire de J. Meeus.
*     Cette fonction n'est valable que pour les dates posterieures au
*     1/1/4713 12h avant J.C.
*
*     L'annee est comptee en millesimes astronomiques.
*     L'annee 1 avant J.C. des historiens correspond a l'an 0 des
*     astronomes et ainsi de suite.
*     Ex : l'an 80 avant J.C. correspond a l'an astronomique -79.
*
* --  Rappel -----------------------------------------------------------
*
*     Le calendier Gregorien commence le 15/10/1582 a 0h (DJ2299160.5).
*     Avant cette date, on utilise le calendrier Julien.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
*
* --- Initialisation ---------------------------------------------------
*
      tdj=0.d0
      jour=idate
      ian=jour/10000
*
      if (ian.lt.-4712) return
      jour=iabs(jour-ian*10000)
      mois=jour/100
      if (mois.lt.1.or.mois.gt.12) return
      jour=jour-mois*100
      if (jour.lt.0.or.jour.gt.31) return
      is=iheure
      ih=iheure/10000
      if (ih.lt.0.or.ih.gt.24) return
      is=is-ih*10000
      im=is/100
      if (im.lt.0.or.im.gt.60) return
      is=is-im*100
      if (is.lt.0.or.is.gt.60) return
*
* --- Calcul -----------------------------------------------------------
*
      y=ian
      m=mois
      b=0.d0
      c=0.d0
*
      if (mois.le.2) then
         y=y-1.d0
         m=m+12
      endif
*
      if (idate.gt.15821004.and.idate.lt.15821015) return
      if (idate.ge.15821015) then
         a=dint(y/100.d0)
         b=2.d0-a+dint(a/4.d0)
      else
         if (y.lt.0) c=-0.75d0
      endif
*
      tdj=dint(365.25d0*y+c)+dint(30.6001d0*(m+1))+jour+
     .    dfloat(ih)/24.d0+dfloat(im)/1440.d0+dfloat(is)/86400.d0+
     .    1720994.5d0+b
*
* --- Sortie -----------------------------------------------------------
*
      return
      end
*
*
*
      subroutine EFFECR
*-----------------------------------------------------------------------
*
*     Ref : GF9806
*
* --- Objet ------------------------------------------------------------
*
*     Effacement de l'ecran.
*
      call system ('clear')
*
      return
      end
