	program extrait


c   ===================================================================
c		StŽphane ERARD, juillet 95

c	Reads the output files from Etalonne and extracts one spectrum.
c	(ordered odd and even channels, 128 measurements with wavelength)
c   ===================================================================

	implicit none

	integer*2 	i,imo,nspe,imois,ij,jtic,
     &			k,j,nbf,nelt,
     &			ih,im,is,jh,jm,js,N,
     &			ii1,ii2,ip1,ip2,x,y,xold,l,ymax,
     &			buff(72),buff1(72),long

	real*4		lam(129),ax,decal(128),xp(6),yp(6),zp(6),
     &			sc,temps(125,27),
     &			ys,xs,zs,xm,ym,zm,
     &			rm,dani,ta,tb,am,an,an1,r,
     &			sdf,sff,sk,ss,
     &			spec(128),matrice(300,27,128),
     &			dum

	character*85 	nom,nom1,nom2,nom3
	character*15	fic,ch2,ch1
	character*55	ch
	character*5	nomf


	data spec/128*0./


	ch='$1$DUA1:[PCCOMMON.BASEISM.CAL_DATA.MARS]'

	write(*,*)' Root of the file?'
	read(*,5)nomf
	ch2=nomf//'even.cal'
	ch1=nomf//'odd.cal'
99	format(a13)

        if (nomf(1:3).eq.'pho')then
	 ch='$1$DUA1:[PCCOMMON.BASEISM.CAL_DATA.PHOBOS]'
         xold=24
         ymax=25
         Nelt=600
        endif
	if (nomf(1:3).eq.'pav') then
         xold=296
         ymax=8
         Nelt=2365
	endif
        if (nomf(1:3).eq.'bib') then
         xold=274
         ymax=8
         Nelt=2189
        endif
        if (nomf(1:3).eq.'ara') then
         xold=98
         ymax=25
         Nelt=2432
        endif
        if (nomf(1:3).eq.'dae') then
         xold=121
         ymax=25
         Nelt=3013
        endif
        if (nomf(1:3).eq.'syr') then
         xold=121
         ymax=25
         Nelt=3005
        endif
        if (nomf(1:3).eq.'vmc') then
         xold=121
         ymax=25
         Nelt=3008
        endif
        if (nomf(1:3).eq.'aur') then
         xold=121
         ymax=25
         Nelt=3007
        endif
        if (nomf(1:3).eq.'oly') then
         xold=91
         ymax=25
         Nelt=2275
        endif
        if (nomf(1:3).eq.'gor') then
         xold=120
         ymax=25
         Nelt=3000
        endif
        if (nomf(1:3).eq.'asc') then
         xold=120
         ymax=25
         Nelt=2999
        endif
        if (nomf(1:3).eq.'gor') then
         xold=120
         ymax=25
         Nelt=2983
        endif
	write(*,*)' Number of lines: ',xold
	write(*,*)' Number of samples/line:',ymax+1
	ymax=ymax+1
	open(unit=1,file='$1$DUA1:[PCCOMMON.BASEISM.CALIB]lambda.dat',
     &status='old')
c		This file contains the correct wavelengths
	do i=1,128
	  read(1,21)j,dum,lam(i)
	enddo
	close(1)

	long=36
        open(unit=8,file=ch//ch2,form='unformatted',
     *  recl=long,access='direct',status='old')
        open(unit=9,file=ch//ch1,form='unformatted',
     *  recl=long,access='direct',status='old')

	nbf=0
        do x=1,xold
         do y=2,ymax

          nbf=nbf+1
          read(8'nbf)buff               !even channels
          read(9'nbf)buff1              !odd channels

          jh=buff(1)
          jm=buff(2)
          js=buff(3)
          jtic=buff(4)
c          temps(x,y)=jh*3600.+jm*60.+js+jtic*0.125      !Uses sexagesimal time
          if (buff(5).ne.x)type*,'Lézard en x',x,y,buff(5),buff(6)
          if (buff(6).ne.y)type*,'Lézard en y',x,y,buff(5),buff(6)
c          tdet(x,y)=buff(7)
c          mir(x,y)=buff(8)

          do i=1,32
           matrice(x,y,i*2)=buff(i+8)*0.5/32767
           matrice(x,y,i*2-1)=buff1(i+8)*0.5/32767
          enddo
          do i=1,32
           matrice(x,y,i*2+63)=buff(i+40)*0.5/32767
           matrice(x,y,i*2+64)=buff1(i+40)*.5/32767
          enddo

         enddo
        enddo
298     close(8)
        close(9)


c	----- Extracts spectrum -----

	type*,'Uses Orsay notation for lines (1 to max) '
	type*, '& samples (2 to 9 or 26)'
142	type*,'# line (0 to exit), # sample ?'
	accept 34,x
	if(x.eq.0)stop
	accept34,y
	type*, x,y
	if(y.lt.2.or.y.gt.ymax)then
	 write(*,*)'Not a good sample: from 2 to', ymax
	 goto 142
	endif

	  type*,'Output file name?'
	  accept 5,nom3
	  open(4,file=nom3,status='new',shared)
	  do i=1,128
	   write(4,21)i,matrice(x,y,i),lam(i)
	  enddo
	  write(4,*)'Orsay, ',ch2,ch1
	  write(4,*)x,y

	  close(4)
	goto142



141	format(a1)
5	format(A25)
6	format(1x,3(I6,2x))
7	format(1x,A13)
8	format(1x,F6.2,2x,Z4)
21	format(3x,I3,3x,E11.5,3x,F6.4)
34	format(I3)
130	format(1x,I3,3x,3(E14.6))
153	format(f6.4) 
	end
