*     ---------------
*     PROGRAM EXTRACT
*     ---------------
*
*     BDL-GF9612
*
*     This program allows to extract a sub-file from a direct access
*     binary file SLP96 with selection of the time span.
*
*     The selected time span has to be within the interval covered by
*     the ephemerides of the initial direct access binary file SLP96.
*
*     Uses the subroutine : EXTRACT.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
      character*40 a,fname1,fname2
*
* --- Parameters -------------------------------------------------------
*
*     fname1  = name of the initial direct access binary file SLP96.
*     fname2  = name of the new direct access binary file SLP96.
*
*     lrec    = record length in bytes.
*
      lrec=5576
*
*     lu1     = logical unit of the initial file SLP96.
*     lu2     = logical unit of the new file SLP96.
*
      lu1     = 11
      lu2     = 12
*
*     tjd1    = starting Julian date of the selected time span.
*     tjd2    = ending Julian date of the selected time span.
*
* --- Read the parameters ----------------------------------------------
*
100   continue
*
      write (*,'(//2x,''SLP96 : EXTRACT (BDL-GF9612)''//)')
*
      write (*,'(2x,''Name of the initial file  : '',$)')
      read (*,'(a40)') fname1
      open (lu1,file=fname1,access='direct',recl=lrec,status='old',
     .      iostat=nerr)
      if (nerr.ne.0) stop '  Initial file error '
      read (lu1,rec=1,iostat=nerr) idf,tla,tlb
      if (nerr.ne.0) stop '  Initial file error '
      close (lu1)
*
      write (*,'(2x,''Name of the new file      : '',$)')
      read (*,'(a40)') fname2
*
      write (*,'(/2x,''Starting Julian date between '',f9.1,
     .       '' and '',f9.1,'' : '',$)') tla,tlb
      read (*,'(f15.5)',iostat=nerr) tjd1
*
      if (nerr.ne.0) then
         write (*,'(/2x,''Error in the Julian date : Press Enter'')')
         read (*,*)
         goto 100
      endif
*
      write (*,'(2x,''Ending   Julian date between '',f9.1,
     .       '' and '',f9.1,'' : '',$)') tjd1,tlb
      read (*,'(f15.5)',iostat=nerr) tjd2
*
      if (nerr.ne.0) then
         write (*,'(/2x,''Error in the Julian date : Press Enter'')')
         read (*,*)
         goto 100
      endif
*
200   continue
*
      write (*,'(/2x,''Confirm your choice (y/n) ? '',$)')
      read (*,'(a40)') a
      if (a(1:1).eq.'n'.or.a(1:1).eq.'N') goto 100
      if (a(1:1).ne.'y'.and.a(1:1).ne.'Y') goto 200
      write (*,'(/2x,''Executing ... '')')
*
* --- Extraction -------------------------------------------------------
*
      call EXTRACT (fname1,lu1,fname2,lu2,tjd1,tjd2,ierr)
*
      if (ierr.ne.0) then
         write (*,'(/2x,''Error'',i3/)') ierr
         stop
      endif
*
      write (*,'(/2x,''New file created : '',a)') fname2
*
300   continue
*
      write (*,'(/2x,''Another Extraction (y/n) ? '',$)')
      read (*,'(a40)') a
      if (a(1:1).eq.'y'.or.a(1:1).eq.'Y') goto 100
      if (a(1:1).ne.'n'.and.a(1:1).ne.'N') goto 300
*
      write (*,'(/2x,''Program ended''/)')
      stop
*
      end
*
*
*
*     ---------------------------------------------------------
      subroutine EXTRACT (fname1,lu1,fname2,lu2,tjd1,tjd2,ierr)
*     ---------------------------------------------------------
*
*     BDL-GF9612
*
*     Extraction of Ephemerides SLP96.
*
*
*     This subroutine extracts a sub-file from a direct access binary
*     file SLP96 with selection of the time span.
*
*     The selected time span has to be within the interval covered by
*     the ephemerides of the initial direct access binary file SLP96.
*
* --- Input ------------------------------------------------------------
*
*               Initial direct access binary file SLP96 :
*     fname1    Name of the file (character*40)
*     lu1       Logical Unit of the file (integer).
*
*               New direct access binary file SLP96 :
*     fname2    Name of the file (character*40)
*     lu2       Logical Unit of the file (integer).
*
*     tjd1      Starting Julian date of the selected time span.
*     tjd2      Ending Julian date of the selected time span.
*
* --- Output -----------------------------------------------------------
*
*     ierr      Error index (integer).
*
*               ierr=0 : no error.
*               ierr=1 : error in the initial file SLP96.
*               ierr=2 : error in the time span.
*               ierr=3 : error in the new file SLP96.
*
* --- Declarations -----------------------------------------------------
*
      implicit double precision (a-h,o-z)
      character*40 fname1,fname2
      logical fexist
*
      parameter (lrec=5576,lcoef=lrec/8+1)
*
      dimension coef(lcoef),loc(11,3)
*
* --- Open the initial direct access binary file SLP96 -----------------
*
      inquire (file=fname1,exist=fexist)
*
      if (.not.fexist) then
         ierr=1
         return
      endif
*
      open (lu1,file=fname1,access='direct',recl=lrec,status='old',
     .      iostat=nerr)
*
      if (nerr.ne.0) then
         ierr=1
         return
      endif
*
      read (lu1,rec=1,iostat=nerr)
     .     idf,tla1,tlb1,delta,ncoef,nblock1,nbytes,loc
*
* --- Selected time span -----------------------------------------------
*
      if (tjd1.gt.tjd2.or.
     .    tjd1.lt.tla1.or.tjd1.gt.tlb1.or.
     .    tjd2.lt.tla1.or.tjd2.gt.tlb1) then
         ierr=2
         return
      endif
*
      tla2=tla1+dint((tjd1-tla1+1.d-5)/delta)*delta
      tlb2=tlb1-dint((tlb1-tjd2+1.d-5)/delta)*delta
*
      nblock2=dint((tlb2-tla2+1.d-5)/delta)+1
*
* --- Open the new direct access binary file SLP96 ---------------------
*
      inquire (file=fname2,exist=fexist)
*
      if (fexist) then
         ierr=3
         return
      endif
*
      open (lu2,file=fname2,access='direct',recl=lrec,status='new',
     .      iostat=nerr)
*
      if (nerr.ne.0) then
         ierr=3
         return
      endif
*
* --- Extraction -------------------------------------------------------
*
      write (lu2,rec=1) idf,tla2,tlb2,delta,ncoef,nblock2,nbytes,loc
*
      nr1=dint(tla2-tla1+1.d-5)/delta+1
      nr2=1
      nmax=nblock2-1
*
      do n=1,nmax
*
         nr1=nr1+1
         nr2=nr2+1
*
         read (lu1,rec=nr1) tjd0,(coef(i),i=1,ncoef)
         write (lu2,rec=nr2) tjd0,(coef(i),i=1,ncoef)
*
      enddo
*
* --- Exit -------------------------------------------------------------
*
      close (lu1)
      close (lu2)
*
      ierr=0
      return
*
      end
