        program lecspe

c  ------------------------------------------------------------
c		Brigitte Gondet, Oct 90
c  Updated May 1995, StŽphane Erard


c	Convert any spectrum to ISM spectral format: convolve with the 
c	response of each channel (contained in data in the routine
c	conv1, included).
c	Input routines for several usual formats are included (commented)
c	Output format is channel number (integer), reflectance and 
c	wavelength (reals). The 128 lines are recorded. These output 
c	files can be plotted by affspe.pro.

c  ------------------------------------------------------------

        implicit none

        integer*2       i,j,k,N,j0,i0,id,ifi,nbspec,ind

        integer*4       p

        real*4          dlm(200),dlp(200),Spe(200),lam(200),
     &                  tab1(2000),ech1(2000),dum

        character*20    nom1,nom2,ch




        write(6,*)'Input file name?'
        read(5,3)nom1
c	ch='[.recup.brown]'
	ch=' '
        open(3,file=ch//nom1,status='old')


c       ====== Lettura d'un file spam

c       p=511 ! numero di misure nel file input
c       do i=1,p
c        read(3,*)ech1(i)
c        ech1(i)=ech1(i)/256.   !Livello di reflettance
c        tab1(i)=i*2./511.+0.5  !Lunghezza d'onda
c       enddo


c       ====== Reads the usual Relab ascii format (Brown U.)

       read(3,7)p              ! numero di misure nel file input
       write(*,*)p
       do i=1,p
        read(3,*)tab1(i),ech1(i)	!Lambda, level, (+accuracy)
        tab1(i)=tab1(i)/1000.  !converts to micrometers
       write(*,*)tab1(i),ech1(i)
       enddo
       close (3)
        

c       ====== Interpole un spectre impair à partir des pairs

c	open(1,file='ism:alph2.spe', status='old')
c	do i=1,128		!Prend les bons lambdas ISM
c	 read(1,20)j,dum,tab1(i)
c	enddo
c	do i=1,32
c	 tab1(i)=tab1(i*2)
c	enddo
c	do i=33,64
c	 tab1(i)=tab1(i*2-1)
c	enddo
c	close(1)
	
c	read(3,*)p              ! numero di misure nel file input
c	write(*,*)p
c	do i=1,p
c	 read(3,*)dum,ech1(i)
c	write(*,*)tab1(i),ech1(i)
c	enddo
c	close (3)

        
c       ====== Lettura d'un altro tipo di file

c       read(3,7)p              ! numero di misure nel file input
c       write(*,*)p
c       do i=1,p
c        i=0
c233      read(3,22,end=213)tab1(i),ech1(i)
c         tab1(i)=tab1(i)        !micrometers
c        write(*,*)i,tab1(i),ech1(i)
c        i=i+1
c       enddo
c        goto 233
c213     close (3)
c        p=i
c        write(*,*)p


c       ====== Integra con la funzione spettrale di ISM

3427    call conv1(tab1,ech1,p,spe,lam)


c	 extrapolation du premier canal à partir d'un spectre P ISM
c	spe(1)=spe(2)-(lam(2)-lam(1))*(spe(3)-spe(2))/(lam(3)-lam(2))


c       ====== Scrive il risultato
c               Usa il formatto ISM usuale, 128 canali.

        write(6,*)'ISM output file name?'
        read(5,3)nom2
        open(9,file=nom2,status='new')
	do i=1,128
	   write(9,20)i,Spe(i),lam(i)
	enddo
	close(9)


c       ====== E Basta...


2       format(A1)
3       format(A20)
5       format(A13)
7       format(I7)
8       format(5x,F9.4,2(6x,F8.6))
9       format(F10.4,F14.6)
20      format(3x,I3,3x,E11.5,3x,f6.4)  !ISM spectra usual format
21      format(6x,F8.6,7x,f8.6,7x,f8.6)  
22      format(2(F7.4))
        end

c       ===============================================================

        SUBROUTINE CONV1(XB,YB,JT,FLUX,PIX)

        dimension  piX(200),FLUX(200)
        DIMENSION  WVL(12,128),DIST(12,128)
        dimension  aliH(32,12),dliH(32),fliH(12,32)
        dimension  alpH(32,12),dlpH(32),flpH(12,32)
        dimension  aliB(32,12),dliB(32),fliB(12,32)
        dimension  alpB(32,12),dlpB(32),flpB(12,32)
        DIMENSION       XB(2000),YB(2000)       !wavelength, intensity
        real*4          a1,a0,l1,l0,l3(128)
        integer*4       JT

        data dliH/0.,2*.04,.05,.06,.05,9*.05,.04,.06,.04,.05,.04,.05,.04
     1  ,.06,.04,3*.05,.06,.03,3*.05/
        data dlpH/0.,.05,.04,8*.05,.06,5*.05,2*.04,
     1  2*.05,.04,2*.05,.04,2*.05,.06,.05,.04,.05,.05/
         data fLiH/.03797,.1603,.4472,.8228,1.,.8228,.2321,.0126,4*0.,
     1  .045,.225,.5125,.825,1.,.925,.7375,.4,.0833,.0125,0.,0.,
     1  .0125,.05,.3083,.5917,.8167,1.,.9,.7083,.45,.125,.0083,0.,
     1  .0083,.0333,.1167,.5417,.8125,1.,.9667,.7792,.5083,.15,.0167,0.,
     1  .025,.1,.4875,.7917,1.,.9417,.7583,.5042,.1458,.0167,0.,0.,
     1  .025,.1,.4583,.7583,.975,1.,.8042,.5792,.1958,0.025,0.,0.,
     1  .025,.1042,.4125,.7208,.9375,1.,.8417,.5917,.2417,.0333,0.,0.,
     1  .0133,.0667,.3733,.6667,.9022,1.,.8844,.6355,.3022,.0578,0.,0.,
     1  .0125,.0609,.313,.5625,.8391,1.,.9565,.7217,.4609,.125,.0125,0.,
     1  .0083,.0375,.1833,.5208,.7792,1.,.9913,.7292,.4083,.0917,.0083,
     1  0.,.0083,.0333,.1667,.5083,.7875,1.,.9583,.7,.3583,.075,.0083,
     1  0.,.0083,.0417,.2083,.5417,.7833,1.,.9083,.6375,.2917,.05,0.,0.,
     1  .0083,.0458,.25,.5875,.8417,1.,.8333,.5917,.2875,.0625,.0083,0.,
     1  .0083,.05,.225,.55,.8,1.,.8708,.6417,.2583,.05,.0083,0.,
     1  .0125,.0583,.2875,.6833,.9,1.,.8167,.6,.3125,.0708,.0083,0.,
     1  .0087,.028,.0833,.3292,.65,.8625,1.,.8333,.5958,.3083,.0667,
     1  .0087,.0196,.0653,.3398,.6993,.9281,1.,.8497,.5686,.2222,.0327,0.
     1  ,0.,.0083,.0292,.1083,.4667,.7792,.9833,1.,.8333,.5417,.1625,.0167
     1  ,0.,.0125,.0542,.25,.5958,.875,.9792,1.,.725,.375,.0833,.0083,0.
     1  ,.0087,.025,.1,.4292,.7125,.9917,1.,.9417,.6375,.3,.0583,.0083,
     1  .0087,.0375,.1833,.5167,.825,1.,.9583,.875,.5,.225,.0333,0.,
     1  .0087,.0167,.0667,.3417,.6667,.9,1.,.975,.825,.5125,.225,.0333,
     1  .0126,.0672,.3333,.6083,.8949,1.,.9244,.7333,.4,.1167,0.,0.,
     1  .0083,.0292,.1,.4667,.7958,1.,.9542,.7583,.4875,.2042,.0375,0.,
     1  .0083,.0458,.1667,.5958,.8458,1.,.7792,.6133,.3375,.125,.0167,0.
     1  ,.0126,.075,.375,.8208,1.,1.,.7667,.5833,.2333,.0708,0.,0.,
     1  .0253,.1055,.5316,.8312,1.,.8354,.6667,.4683,.1603,.0295,0.,0.,
     1  .0458,.2417,.7437,.9748,1.,.7899,.5924,.2731,.084,3*0.,
     1  .0168,.1008,.5462,.9076,1.,.8823,.6554,.479,.2017,.0504,0.,0.,
     1  .0504,.1933,.6681,1.,.9874,.8067,.542,.4244,.1134,3*0.,
     1  .0526,.3947,.7544,1.,.7763,.6403,.3947,.1681,4*0.,
     1  .217,.7074,1.,.7736,.6509,.4245,.2075,5*0./
        data flpH/.0468,.1404,.3064,.6808,1.,.8808,.2298,5*0.,
     1  .0508,.2161,.5339,.9619,1.,.8813,.3729,.0127,4*0.,
     1  .0248,.02397,.5207,.7851,.9504,1.,.7975,.533,.1446,.0124,2*0.,
     1  .0125,.15,.4917,.7708,.975,1.,.8458,.6208,.2042,.1025,2*0.,
     1  .0083,.0498,.4149,.6805,.9295,1.,.8797,.6431,.2241,.0166,2*0.,
     1  .0083,.0498,.39,.6514,.8631,1.,.8797,.6265,.2489,.0332,.0041,0.,
     1  .0124,.0498,.3236,.6224,.8589,1.,.9295,.6971,.3153,.0705,.0083,
     1  0.,
     1  .0083,.0373,.3153,.5726,.7967,1.,.9709,.7635,.4066,.09958,.0083,
     1  0.,
     1  .0083,.0166,.2738,.5436,.7635,.946,1.,.8299,.556,.1743,.0124,0.,
     1  .0083,.0166,.166,.4398,.7137,.9709,1.,.9377,.6639,.2531,.0166,0.
     1  ,.0083,.0124,.0373,.4274,.6307,.9668,1.,.8838,.5975,.1992,.0166,
     1  0.,
     1  .0125,.0417,.4417,.721,.9917,1.,.8833,.575,.1667,.0125,2*0.,
     1  .0166,.0664,.4398,.7012,1.,.9543,.8133,.4979,.1286,.0125,2*0.,
     1  .0166,.1328,.473,.7012,1.,.9543,.8008,.527,.1743,.0166,2*0.,
     1  .0124,.0744,.4545,.7355,1.,.9504,.7521,.4628,.1364,.0124,2*0.,
     1  .0207,.1411,.4938,.7635,1.,.9543,.805,.5726,.2075,.0207,2*0.,
     1  .0165,.124,.5,.7851,.9876,1.,.8388,.5207,.1322,.0124,2*0.,
     1  .0083,.0207,.1983,.5868,.8678,1.,1.,.7273,.3802,.0868,.0083,0.,
     1  .0083,.0165,.0537,.3802,.6735,.9256,1.,.9834,.719,.3223,.0454,
     1  .0083,
     1  .0083,.0248,.1364,.4876,.7231,.8512,1.,.9752,.624,.2231,.025,
     1  .0083,
     1  .0083,.0372,.3595,.6033,.8182,.8512,1.,.8843,.4917,.1405,.0124,
     1  0.,
     1  .0083,.0166,.0496,.4173,.719,.9752,.9256,1.,.7934,.4669,.1322,
     1  .0165,
     1  .0165,.0248,.1137,.5732,.7892,1.,.8554,.9628,.7934,.4463,.116,
     1  .0124,
     1  .0248,.033,.1074,.5496,.7934,1.,.8388,.8016,.5413,.2521,.033,0.,
     1  .0125,.0167,.0333,.25,.6917,.9417,1.,.8417,.725,.3542,.1083,
     1  .0125,
     1  .0083,.0165,.0496,.4587,.8099,1.,.8347,.7521,.5454,.2397,.0578,
     1  0.,
     1  .0083,.0248,.116,.6529,.8636,1.,.8099,.7273,.4587,.19,.0248,0.,
     1  .0254,.3813,.7627,.9746,1.,.839,.733,.322,.123,3*0.,
     1  .0678,.5763,.9237,1.,.8813,.6779,.5339,.2034,.0466,3*0.,
     1  .0254,.2669,.6779,1.,.9237,.839,.6059,.4152,.1271,3*0.,
     1  .0422,.4768,.7806,1.,.7637,.7342,.5105,.2447,.0337,3*0.,
     1  .2053,.6696,1.,.7723,.7366,.5402,.3482,.0893,4*0./


        data dliB/0.,.029,.0265,-.0015,3*.03,2*.025,.035,.02,.03,3*.025,
     1  .02,2*.025,3*.02,.025,.02,.025,3*.02,2*.025,2*.02,.025/
        data fliB/1.,11*0.,
     1  1.,11*0.,
     1  1.,11*0.,
     1  .0105,.183,.275,.6491,.8889,1.,1.,.7134,.2631,3*0.,
     1  .0402,.0703,.1909,.4824,.8191,1.,.8945,.4975,.1759,3*0.,
     1  .0217,.1174,.3739,.6956,.9739,1.,.7391,.313,.1217,3*0.,
     1  .073,.3047,.6094,.8927,1.,.8069,.4292,.1802,.0343,3*0.,
     1  .0348,.1826,.4609,.7652,1.,.9739,.6522,.3391,.0956,3*0.,
     1  .0257,.133,.3476,.6781,.9442,1.,.8541,.5365,.2489,.0944,2*0.,
     1  .1765,.5508,.9091,1.,.77,.2567,6*0.,
     1  .0278,.2963,.5092,.8241,1.,.7685,.4722,.1574,4*0.,
     1  .1538,.3932,.782,1.,.8461,.5983,.2051,.0342,4*0.,
     1  .1008,.4538,.7143,1.,.9412,.6218,.2857,.0252,4*0.,
     1  .0847,.3644,.6398,1.,.9025,.5932,.2542,.0127,4*0.,
     1  .0889,.4152,.7076,1.,.7203,.4449,.089,5*0.,
     1  .084,.1933,.6176,1.,.9874,.5546,.2689,.0126,4*0.,
     1  .0378,.3613,.7185,1.,.7605,.4286,.0672,5*0.,
     1  .0756,.5126,.8529,1.,.5714,.2731,.0168,5*0.,
     1  .0336,.2773,.6891,1.,.8151,.4117,.0588,5*0.,
     1  .0167,.1583,.4917,.9167,1.,.6667,.2083,.0167,4*0.,
     1  .0083,.0542,.3042,.7125,1.,.8333,.375,.0416,.0083,3*0.,
     1  .0166,.2158,.5187,.9377,1.,.7137,.1826,.0166,4*0.,
     1  .0083,.0458,.2417,.625,1.,.9167,.5583,.0458,.0166,3*0.,
     1  .0166,.1701,.4979,1.,.946,.523,.0664,.0166,4*0.,
     1  .0166,.1375,.4083,.875,1.,.6667,.1667,.0208,.0083,3*0.,
     1  .0083,.033,.2149,.6198,1.,.9091,.4545,.0744,.0166,3*0.,
     1  .0083,.0166,.1,.3875,.8833,1.,.6583,.2083,.0333,.0083,2*0.,
     1  .0083,.0166,.1286,.5228,.9792,1.,.4606,.0996,.0249,3*0.,
     1  .0166,.0498,.3734,.888,1.,.5643,.108,.025,.0083,3*0.,
     1  .0166,.0249,.3817,.9253,1.,.473,.1079,.0249,.0083,3*0.,
     1  .0166,.0333,.275,.9291,1.,.475,.1167,.0208,.0083,3*0.,
     1  .0255,.3149,1.,.9191,.3106,.0638,6*0./


        data dlpB/0.,2*.015,.02,2*.03,.025,2*.03,.025,.02,.03,.03,
     1  .02,.025,.025,.02,.025,.02,.025,.02,.025,.02,.025,.02,
     1  .025,.02,.025,4*.02/
        data flpB/1.,11*0.,
     1  .1154,.5769,.8845,1.,.6538,.1538,6*0.,
     1  .055,.0954,.2364,.4864,.8182,1.,.8591,.5,.1909,.0182,2*0.,
     1  .013,.0346,.0996,.1991,.4112,.7186,.987,1.,.7402,
     1  .3766,.1082,.013,
     1  .0085,.0297,.0932,.2627,.5974,.928,1.,.7797,.4686,.1652,
     1  .0381,0.,
     1  .0126,.063,.2437,.5546,.8655,1.,.8529,.5378,.2437,.0672,2*0.,
     1  .0084,.0462,.1807,.4034,.7563,1.,.9664,.7395,.4454,.1975,
     1  .0336,0.,
     1  .0083,.0875,.25,.55,.8708,1.,.9167,.6167,.3208,.0667,2*0.,
     1  .0586,.1757,.4017,.7531,.9833,1.,.7489,.3765,.1255,.0167,2*0.,
     1  .0508,.1991,.483,.7839,1.,1.,.8559,.4915,.2034,.0508,.0085,0.,
     1  .0083,.0581,.1867,.4357,.6971,.9129,1.,.8548,.5809,.2738,
     1  .0913,.0166,
     1  .021,.1386,.3277,.5966,.8235,1.,.916,.6554,.3487,.0966,
     1  .0126,0.,
     1  .1422,.3598,.6945,.9581,1.,.8075,.4561,.0376,4*0.,
     1  .0083,.0826,.4504,.7273,1.,.9711,.6116,.2479,.0124,3*0.,
     1  .0124,.1826,.4896,.7552,1.,.7676,.4564,.04979,4*0.,
     1  .0251,.3012,.6443,.9874,1.,.6862,.3431,.0251,4*0.,
     1  .0083,.0871,.4066,.7178,1.,.8091,.4813,.0622,4*0.,
     1  .0124,.1653,.5496,.8884,1.,.7107,.2727,.0165,4*0.,
     1  .0083,.0498,.3693,.7095,1.,.805,.4274,.0664,.0083,3*0.,
     1  .0289,.2397,.5258,.9091,1.,.6611,.2603,.0124,.0083,3*0.,
     1  .0083,.1,.3333,.725,1.,.8083,.4042,.0583,4*0.,
     1  .0166,.2448,.4647,.946,1.,.7552,.2407,.0249,4*0.,
     1  .0083,.083,.357,.6556,1.,.8299,.4274,.0332,4*0.,
     1  .0165,.2025,.562,.9504,1.,.6446,.157,.0165,4*0.,
     1  .0083,.0792,.3333,.7,1.,.7917,.4375,.0417,.0083,3*0.,
     1  .0167,.1458,.55,.9583,1.,.625,.15,.025,4*0.,
     1  .0083,.0373,.2614,.6473,1.,.7967,.39,.05394,.01,3*0.,
     1  .0167,.075,.4625,.8333,1.,.575,.1333,.0208,4*0.,
     1  .0083,.025,.1917,.7917,1.,.4583,.0667,.0167,4*0.,
     1  .0125,.0333,.4875,.9542,1.,.3042,.075,.0167,4*0.,
     1  .0165,.0661,.5454,1.,.9504,.2895,.05372,.0083,4*0.,
     1  .0083,.0546,.7143,1.,.7521,.1386,.0252,5*0./


        aliB(1,1)=.761
        alPB(1,1)=.775
        aliH(1,1)=1.63
        alPH(1,1)=1.6
        do i=2,32
        aliH(i,1)=aliH(i-1,1)+dliH(i)
        alPH(i,1)=alPH(i-1,1)+dlPH(i)
        aliB(i,1)=aliB(i-1,1)+dliB(i)
        alPB(i,1)=alPB(i-1,1)+dlPB(i)
        end do
        do i=1,32
        do j=1,12
        aliH(i,j)=aliH(i,1)+.01*(j-1)
        alPH(i,j)=alPH(i,1)+.01*(j-1)
        aliB(i,j)=aliB(i,1)+.005*(j-1)
        alPB(i,j)=alPB(i,1)+.005*(j-1)
        end do
        end do

        do i=1,32
        I1=2*I-1
        I2=2*I
        I3=I1+64
        I4=I2+64
        do j=1,12
        WVL(j,I1)=aliB(i,j)
        WVL(j,I2)=alPB(i,j)
        WVL(j,I3)=alPH(i,j)
        WVL(j,I4)=alIH(i,j)
        DIST(j,I1)=FLIB(j,I)
        DIST(j,I2)=FLPB(J,i)
        DIST(j,I3)=FLPH(J,i)
        DIST(j,I4)=FLIH(J,i)
        end do
        end do

c       At this point,  alpb= monochromator wavelengths;
c			flpb= response at these wavelengths

c	Write a file of spectral response/channel (Reponse.dat)
c       do i=1,32
c        do j=1,12
c         write(4,*)i,j,flpb(j,i),alpb(i,j)
c        enddo
c       enddo
c       do i=1,32
c        do j=1,12
c         write(4,*)i,j,flph(j,i),alph(i,j)
c        enddo
c       enddo
c       close(4)

c	Compute width at half-eight
c       do i=1,128
c        do j=1,11
c         if((dist(j,i).le.0.5).and.(dist(j+1,i).gt.0.5))then
c               a0=(dist(j,i)-dist(j+1,i))/(wvl(j,i)-wvl(j+1,i))
c               l0=(0.5-dist(j,i))/a0+wvl(j,i)
c         endif
c         if((dist(j,i).ge.0.5).and.(dist(j+1,i).lt.0.5))then
c               a1=(dist(j,i)-dist(j+1,i))/(wvl(j,i)-wvl(j+1,i))
c               l1=(0.5-dist(j,i))/a1+wvl(j,i)
c         endif
c        enddo
c         l3(i)=l1-l0
c       enddo

        do i=1,128
        AA=0.
        BB=0.
        DO J=1,12
        AA=AA+DIST(J,I)
        BB=BB+WVL(J,I)*DIST(J,I)
        end do
        piX(i)=BB/AA
        end do
c        Pix= lambda centraux, 1 par canal

        DO I=1,128
        FLUX(I)=0.
        POI=0.
        DO J=1,12
        P=0.
        PPP=0.
        IF(DIST(J,I).EQ.0.) GO TO 23
        DO K=1,JT-1
        IF(WVL(J,I).GE.XB(K).AND.WVL(J,I).LE.XB(K+1)) THEN
        P=(YB(K+1)-YB(K))/(XB(K+1)-XB(K))*(WVL(J,I)-XB(K))+YB(K)
        PPP=P*DIST(J,I)
        GO TO 23
        ENDIF
        end do
23      FLUX(I)=FLUX(I)+PPP
        IF(PPP.EQ.0.) DIST(J,I)=0.
        POI=POI+DIST(J,I)
        END DO
        IF(POI.EQ.0.) GO TO 32
        FLUX(I)=FLUX(I)/POI
32      CONTINUE
        END DO

        RETURN
21      format(3x,I3,3x,E11.5,3x,F6.4) 
        end

