*
*     ------------------
*     PROGRAMME COMETINS    ref : BDL-GF9610
*     ------------------
*
*     Auteurs :
*     P. Rocher et G. Francou.
*     Bureau des Longitudes.
*     Equipe : Dynamique du Systeme Solaire.
*     77, avenue Denfert Rochereau. 75014 PARIS.
*     E-mail : rocher@imcce.fr     francou@imcce.fr
*     tel : (33) 01 40 51 22 72  (33) 01 40 51 22 60
*     fax : (33) 01 46 33 28 34
*
*     Destinataire :
*     J. Bernard - CT/TI/MS/AM.
*     CNES.
*     18 avenue E. Belin 31055 Toulouse Cedex.
*     E-mail : bernard@venus.cst.cnes.fr
*     tel : (33) 05 61 25 00 00
*     fax : (33) 05 61 27 35 40
*
*
*     -----
*     Objet
*     -----
*
*     Installation des fichiers des Cometes.
*     Creation de fichiers a acces direct :   CNESxx.ad
*     a partir de fichiers sequentiel ascii : CNESxx.asc
*     xx : indice de la Comete.
*     Ce travail est realise dans le cadre de la mission Rosetta.
*
*     --------
*     Fichiers
*     --------
*
*     Fichier a lire :
*     Fichier sequentiel des Ephemerides Tchebychev d'une Comete.
*     Nom : CNESxx.asc.
*     Unite logique 10.
*
*     Fichier a creer :
*     Fichier a acces direct des Ephemerides Tchebychev d'une Comete.
*     Nom : CNESxx.ad.
*     Unite logique 20.
*
*     -------------------------------
*     Declarations et initialisations
*     -------------------------------
*
      implicit double precision (a-h,o-z)
      character*2 rep
      character*6 ncnes,niau
      character*30 nom
      character*40 fich1,fich2
      logical fexist
      integer delta
      parameter (ncf=10)
      dimension coef(ncf)
*
*     --------------------------------
*     Installation d'un fichier Comete
*     --------------------------------
*
100   continue
*
*     ----------------------------------------
*     Ouverture du fichier sequentiel original
*     ----------------------------------------
*
      call CLRSCR
      print 1000
      nul1=10
      write (*,1001)
      read (*,'(a)') fich1
      inquire (file=fich1,exist=fexist)
      if (fexist) then
         open (nul1,file=fich1,access='sequential',status='old')
         do n=1,6
            read (nul1,2000,iostat=nerr)
            if (nerr.ne.0) goto 200
         enddo
      else
         print 1002, fich1
         read (*,*)
         stop
      endif
*
*     -----------------------------------------
*     Ouverture du fichier a acces direct copie
*     -----------------------------------------
*
      call CLRSCR
      print 1000
      nul2=20
      n=index(fich1,'.')
      fich2=fich1(1:n)//'ad'
      inquire (file=fich2,exist=fexist)
      if (fexist) then
         print 1003, fich2
         read (*,*)
         stop
      else
         open (nul2,file=fich2,access='direct',recl=80,status='new')
      endif
*
*     ------------------------------------
*     Copie des coefficients de Tchebychev
*     ------------------------------------
*
      nrec=1
      read (nul1,2001,iostat=nerr) nbloc,tdeb,delta,ncnes,niau,nom
      if (nerr.ne.0) goto 200
      write (nul2,rec=nrec,iostat=nerr)
     .      nbloc,tdeb,delta,ncnes,niau,nom
      if (nerr.ne.0) goto 300
      do i=1,3
         read (nul1,2002,iostat=nerr) coef
         if (nerr.ne.0) goto 200
         nrec=nrec+1
         write (nul2,rec=nrec,iostat=nerr) coef
         if (nerr.ne.0) goto 300
      enddo
*
      do n=2,nbloc
         read (nul1,2001,iostat=nerr) nbloc,tdeb,delta,ncnes,niau,nom
         if (nerr.ne.0) goto 200
         do i=1,3
            read (nul1,2002,iostat=nerr) coef
            if (nerr.ne.0) goto 200
            nrec=nrec+1
            write (nul2,rec=nrec,iostat=nerr) coef
            if (nerr.ne.0) goto 300
         enddo
         print 1004, n,nbloc
      enddo
      close (nul1)
      close (nul2)
*
*     ----------------------
*     Fin de l'installation
*     ----------------------
*
      print 1005, fich2
      read (*,*)
      call CLRSCR
      print 1000
      print 1006
      read (*,'(a)') rep
      if (rep.eq.'O'.or.rep.eq.'o'.or.len_trim(rep).eq.0) goto 100
      print 1007
      read (*,*)
      stop
*
*     --------------
*     Erreur Lecture
*     --------------
*
200   continue
      print 1008, fich1
      read (*,*)
      close (nul1)
      close (nul2)
      stop
*
*     ---------------
*     Erreur Ecriture
*     ---------------
*
300   continue
      print 1009, fich2
      read (*,*)
      close (nul1)
      close (nul2)
      stop
*
*     -------
*     Formats
*     -------
*
1000  format (/2x,'----------------------------------------'
     .        /2x,'CNES : INSTALLATION DES FICHIERS COMETES'
     .        /2x,'----------------------------------------')
*
1001  format (/2x,'Entrez le Nom du Fichier a installer : ',$)
1002  format (/2x,'Le fichier : ',a
     .        /2x,'n''exite pas dans le repertoire courant'/
     .        /2x,'Appuyez sur Entree',$)
1003  format (/2x,'Le fichier : ',a
     .        /2x,'exite deja dans le repertoire courant'/
     .        /2x,'Appuyez sur Entree',$)
1004  format (2x,'Copie Bloc : ',i5,' / ',i5)
1005  format (/2x,'INSTALLATION TERMINEE'/
     .        /2x,'Nouveau fichier cree : ',a40/
     .        /2x,'Appuyez sur Entree',$)
1006  format (/2x,'Voulez-vous installer un autre Fichier Comete ',
     .        '(o/n) ? ',$)
1007  format (/2x,'Programme termine'/
     .        /2x,'Appuyez sur Entree',$)
1008  format (/2x,'ERREUR DE LECTURE DU FICHIER : ',a40/
     .        /2x,'Contactez votre correspondant Bdl'/
     .        /2x,'Appuyez sur Entree',$)
1009  format (/2x,'ERREUR D''ECRITURE DU FICHIER : ',a40/
     .        /2x,'Contactez votre correspondant Bdl'/
     .        /2x,'Appuyez sur Entree',$)
*
2000  format (1x)
2001  format (i5,f13.5,i3,2a6,a30)
2002  format (10f14.10)
*
      end
*
*
*
      subroutine CLRSCR
*-----------------------------------------------------------------------
*
*     ref : bdl-gf9504
*
*     Objet :
*     Effacement de l'ecran.
*
*     Remarque :
*     L'effacement d'ecran fonctionne avec les systemes d'exploitation
*     DOS et UNIX seulement.
*     Pour rendre operationnelle la subroutine CLRSCR, il faut retirer
*     les commentaires :
*     *DOS  dans le cas du systeme d'exploitation DOS,
*     *UNX  dans le cas du systeme d'exploitation UNIX.
*
*-----------------------------------------------------------------------
*
*DOS  character*7 escscr
*DOS  escscr=char(27)//char(91)//'2J'//char(27)//char(91)//'H'
*DOS  write (*,'(2x,a)') escscr
*
*UNX  call system ('clear')
*
      character*7 escscr
      escscr=char(27)//char(91)//'2J'//char(27)//char(91)//'H'
      write (*,'(2x,a)') escscr
*
      return
      end
