h36180
s 00057/00051/01791
d D 1.3 99/07/05 11:19:56 bonmarti 3 2
c Gestion des numeros de cameras et de buffers
e
s 00086/00055/01756
d D 1.2 99/06/11 13:26:55 bonmarti 2 1
c Version du 11 juin 99
e
s 01811/00000/00000
d D 1.1 99/06/11 12:52:51 bonmarti 1 0
c date and time created 99/06/11 12:52:51 by bonmarti
e
u
U
t
T
I 1
c  ms99.f
c********************************************
c
c   ATTENTION   le texte qui suit n'est pas a jour


c
c  Ce programme traite les donnees d'une observation DPSM THEMIS 
c          pour 1 region solaire
c               1 raie (donc 1 angle de reseaux)
c  
c  Version ou l'analyseur de polarisation est fixe (NSTOK=1)
c
c  Sans analyse de polarisation, les 2 champs doivent etre traites
c              separement, comme 2 regions differentes
c Les fenetres sont obligatoirement entrelacees en longheur d'onde,
c     pour chaque polarisation (ou region)  
c     (   kdecal=0,50   ou  0,25,50,75  par exemple 
c     pour nwinp=2       ou  4                       )
c-------------------------
c  Les structures des fichiers sont les suivantes:
c           1 fichier par   region / w /temps
c    
c         w   = fenetres  repaties en   etat pol/ lines       simultane
c 
c                                                angles de reseaux dans line
c                                                             balayage
c         r   = region         (1 chiffre) 
c         l   = line (raie)    (1 chiffre)
c         s   = sto            (1 chiffre)
c
c   dimensions:  i,j     pixels   images brutes               simultane
c                I,J     disque   image soleil simultanees    simultane       
c                n       canaux                               simultane
c                N       ~ lambdas                            simultane
c                sto     eventuellement Q,U,V  (pol= I+/-*)   balayage
c                X,Y     disque   image soleil grand champ    balayage
c                U,V     disque   composite balayage X
c
c
c carac. nom   type   format  dimensions        contenu                unite 
c
c38     w0r0l   b      fts    i,j,sto=1,X,Y    observation                20
c38     w000l   b      fts    i,j,sto=1,X,Y    dark current               21
c38     w-00l   b      fts    i,j,sto=1,X,Y    flat field                 22
c   20  mwrls     x    bin    i,j,sto=1        moyenne dc  sur X,Y        23
c   20  wwrls     y    bin    i,j,sto=1        moyenne ff  sur X,Y        24
c   20  mwrls     g    ascii                   geometrie                  25
c   20  mwrls     z    bin    I,J,n,sto=1      images canaux pour ff      26
c                                                    avec correc dc
c                             +I,2,n           et backgrounds 
c                                                   (lumiere diffusee)
c  
c   20  mwrls     f    bin    I,J,n,sto=1                         |cmf    27 
c                             + 1024,sto=1     flat field + profil moy  
c
c   20  mwrls  c  bin  I,J,n,STO=1,X,Y  images des canaux obs     |bmc 31,32,..
c                                        avec correc dc
c                       +I,2,n           et backgrounds
c                                        (lumiere diffusee)
c
c   20  mwrls  f  bin  (comme fichiers f plus haut)               |cmd 41,42,..
c
c   20  m0rls d q  bin  I,J,N,npol,
c                          sto=1,X,Y  images separees
c                                                     quick-look          51
c
c   20  m0rls  j  ascii                 j pour lambdas de reference        52
c                              
c
c38     q0r01 e   fts  U,V,N,npol       composites quick-look     |dme    53
c                       sto=1,Y
c
c   20  m0rls  j  ascii              j pour lambdas (+geo. jonctions)     54
c
c   20  m0rls d p  bin   I,J,N,npol
c                           sto=1,X,Y    images separees
c                                                             profils     55
c
c38     p0r01 e   fts  U,V,N,npol,      composites profils        |dme    56
c                        sto=1,Y
c*****************************************************************************
c
c     Dans le cas present sto=1, attention a la reduction des dimensions FITS
c     pour b,c,d.
c     Les fichiers FITS de sortie sont prevus pour le moment sans regroupemeent
c     des balayages en X et Y 
c
c*****************************************************************************
c codes decrivant les fichiers en entree ...b.fts:     caracteres 6,7,8,9,10:
c
c     00000   fenetre 0
c     00001   fenetre 1
c     ............
c   exemple: 
c     them_00000_ms_19980910_163224:00_b.fts
c
c*****************************************************************************
c noms des fichiers intemediaires a 20 caracteres (exemple fichier X):
c     x980910_145901_m0112
c                     fenetre, reg, lin, npo
c
c*****************************************************************************
c transport des infos de calibration, et recentrage vmoy en longueur d'onde
c
c  etape code  info                                  1 par    localisation 
c  iflat cmf   ncm,jt100m,ja100m,jb100m,jz100m,kdec  nf,npo,nw     header f
c  ibmc  bmc   ncm,jt100m,ja100m,jb100m,jz100m,kdec  nf,npo,nw     header c
c  id    cmd                                                       header d
c  iquick
c  ir
c  iprof

c*****************************************************************************

      integer dob,tob1,tob2,ddc,tdc1,tdc2,dff,tff1,tff2,dfs,tfs1,tfs2
D 3
     1 sundec,reg,pol
E 3
I 3
     1 sundec,reg,pol, IREP
E 3
      double precision xtab(400,400)
 
      integer*4 tete(512),ftime(10000),sto,corv,kdecal(8)
      integer win(8),coldb(8),nbcln(8),lgndb(8),nblgn(8),
     1        nscanm,nfdeb(2000)
      integer pixstep,pagex,pagey
  
      integer*2 tab(400,400),pm(2000),
     1          tabeco(400,60,32),tabxeco(400,2,8) ! pour economiser
      integer*2 fl(400,60,8)     !  pour economiser les memoires

      character*38 fnom(10000),fic(8), dcn(1000),ffn(1000),
     1             obname,dcname,ffname,bna(26)
      character*20 xname,yname,fname,gname,cname,dname,zname,rname,
     1             xna(26),yna(26),zna(26),fna(26),gna(26),sna(26),
     2             cna(26),dnanfp(10000,2),lname,jname,qname,pname,
     3             kname,dnanfsp(500,2),rnanfsp(500,2),snom
      character key*8,jhd*18,reglin*4,rl*2,nomps*23,hfin*6,blancs*2
      character comm*80
      character*1 lettre(26),let,let1

      data lettre/'0','1','2','3','4','5','6','7','8','9',
     1            'k','l','m','n','o','p','q','r','s','t',
     2            'u','v','w','x','y','z'/
c
c       prevu pour une raie utilisant 8 fenetres maximum parmi 26 maximum
c
I 2
D 3
c Constantes pour traitement des donnees THEMIS
E 3
I 3
c Constantes provisoires pour traitement des donnees THEMIS
E 3
      integer*4 pos_nomcam
I 3
      Character*1 Icam3/'2'/,Icam4/'1'/,Icam8/'3'/
E 3

      pos_nomcam = 8      !position du numero de la camera dans le nom FITS
E 2
D 3
    
E 3
I 3

E 3
      sto=1
      pagex=2
      pagey=1
      blancs='  '
c
      call system('rm ms.lis')
      open(unit=3,file='ms.lis',status='new')
      open(unit=8,file='ms.par',status='old')

      call system('rm test.lis')
      open(unit=9,file='test.lis',status='new')

      call system('rm scan.lis')
      open(unit=7,file='scan.lis',status='new')

        write(3,*)' debut ms99'

c
      rewind(8)
      call sname(8,'ms99  ')
1     format(a)
2     format(12i6)
3     format(6i12)
9     format(a)

      read (8,1)comm
      write(3,1)comm
      read (8,3)dob,tob1,tob2
      write(3,3)dob,tob1,tob2
                              write(7,*)' tob1,tob2  ',tob1,tob2
      read(8,1)comm
      write(3,1)comm
      read(8,3)ddc,tdc1,tdc2
      write(3,3)ddc,tdc1,tdc2
      read(8,1)comm
      write(3,1)comm
      read(8,3)dff,tff1,tff2
      write(3,3)dff,tff1,tff2
      read(8,1)comm
      write(3,1)comm
      read(8,3)dfs,tfs1,tfs2
      write(3,3)dfs,tfs1,tfs2
c       type *,'tdc : ',tdc1,tdc2,' tff : ',tff1,tff2 !!!!!!!!!!!!!!!!!!!!!
      read(8,1)comm
      write(3,1)comm
      read(8,2)reg,lin,lineref,milsec,intert,ntmax
      write(3,2)reg,lin,lineref,milsec,intert,ntmax

        write(reglin(1:2),'(i2)')reg
        write(reglin(3:4),'(i2)')lin
        write(rl(1:1),'(i1)')reg
        write(rl(2:2),'(i1)')lin

      read(8,1)comm
      write(3,1)comm
      read(8,2)ixy,igeo,iflat,ibmc,icmd,iquick,icmr,iprof,
     1         igrayq,igrayp
      write(3,2)ixy,igeo,iflat,ibmc,icmd,iquick,icmr,iprof,
     1         igrayq,igrayp

      read(8,1)comm
      write(3,1)comm
      read(8,2)sundec,iswap,iplotg,iplotf,ihead,ipermu,
     1         igrq,jgrq,igrp,jgrp
      write(3,2)sundec,iswap,iplotg,iplotf,ihead,ipermu,
     1         igrq,jgrq,igrp,jgrp
         if(igrq.eq.0)igrq=1
         if(jgrq.eq.0)jgrq=1
         if(igrp.eq.0)igrp=1
         if(jgrp.eq.0)jgrp=1
c lecture des donnees eventuellement manquantes dans headers
      read(8,1)comm
      write(3,1)comm
      read(8,2)npol,nwinp
      write(3,2)npol,nwinp

        nwin=npol*nwinp

      read(8,1)comm
      write(3,1)comm
      read(8,2)win
      write(3,2)win
                write(7,*)'  win     ',(win(nw),nw=1,nwin)

      read(8,1)comm
      write(3,1)comm
      read(8,2)kdecal
      write(3,2)kdecal

      read(8,1)comm
      write(3,1)comm
      read(8,2)nbcln
      write(3,2)nbcln

      read(8,1)comm
      write(3,1)comm
      read(8,2)nblgn
      write(3,2)nblgn      

      do nw=1,nwin
D 3
      ipiv=win(nw)+1
      let=lettre(ipiv)

E 3
D 2
      fic(nw)='them_b0002_XX_00000000_000000:00_d.fts' 
      write(fic(nw)(8:8),'(a)')let
E 2
I 2
      fic(nw)='them_b0000_XX_00000000_000000:00_d.fts' 
D 3
      write(fic(nw)(pos_nomcam:pos_nomcam),'(a)')let
E 3
I 3
      write(fic(nw)(pos_nomcam-1:pos_nomcam),'(i2.2)')win(nw)
E 3
c-----------------------------------------------------------------------
c     Adapte aux donnees de P Mein de mai 99 en attente de definition 
D 3
      if (ipiv.eq.4) write(fic(nw)(10:10),'(a)') '2'
      if (ipiv.eq.5) write(fic(nw)(10:10),'(a)') '1'
E 3
I 3
      if (win(nw).eq.3) write(fic(nw)(10:10),'(a)') Icam3
      if (win(nw).eq.4) write(fic(nw)(10:10),'(a)') Icam4
      if (win(nw).eq.8) write(fic(nw)(10:10),'(a)') Icam8
E 3
c-----------------------------------------------------------------------
E 2
        write(3,*)' nw, fic(nw) ',nw,fic(nw)
      enddo

D 3

E 3
c Ouverture des 3 fichiers dont les headers fournissent les parametres
c de traitement (sauf dc si ihead=0)

      if (ihead.eq.0)goto6

      type *,' dob,obname',dob,obname
      call fnomw(fic,1,1,dob,tob1,tob1,1,obname,ftime,istop)
c          -----
c      tob1=ftime(1)  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      type *,' obname',obname

      if(tdc1.ne.0)then
        call fnomw(fic,1,1,ddc,tdc1,tdc1,1,dcname,ftime,istop)
c            -----
c        tdc1=ftime(1)
      endif

      call fnomw(fic,1,1,dff,tff1,tff1,1,ffname,ftime,istop)
c          -----
c      tff1=ftime(1)
c      type *,'tob1 : ',tob1      
       type *,'obname : ',obname
c      type *,'dcname : ',dcname
c      type *,'ffname : ',ffname
c      type *,'sundec : ',sundec        

D 3
      call openold38(obname,sundec,20)
         type *,obname
E 3
I 3
      call openold38(file,sundec,20)
E 3
c                                                       b de la fenetre a
      if(tdc1.ne.0)then
I 3
         type*,'DCNAME',dcname
E 3
      call openold38(dcname,sundec,21)
      endif
c                                                     b (dc) de la fenetre a
      call openold38(ffname,sundec,22)
c       type *,ffname
c                                                     b (ff) de la fenetre a

c recherche des fenetres concernees par la raie "lin"
c
c      key='NPOL    '
c      write(key(8:8),'(i1)')lin
c      if(npol.eq.0)call readi(20,key,npol,1)
c      type *,'npol : ',npol

c      key='NWINP   '
c      write(key(8:8),'(i1)')lin
c      if(nwinp.eq.0)call readi(20,key,nwinp,1)
c      type *,'nwinp : ',nwinp

c      key='WIN     '
c      write(key(8:8),'(i1)')lin
c      if(win(1).eq.0)call readi(20,key,win,8)
c      do k=1,8
c      type *,'win(k) : ',win(k)
c      enddo
c                                       Tableaux dim des 8 fenetres a...h      
c      key='COLDB   '
c      write(key(8:8),'(i1)')lin
c      call readi(20,key,coldb,8)

      key='NBCLN   '
      write(key(8:8),'(i1)')lin
      if(nbcln(1).eq.0)call readi(20,key,nbcln,8)
      do k=1,8
      type *,'nbcln(k) : ',nbcln(k)
      enddo
      
c      key='LIGDB   '
c      write(key(8:8),'(i1)')lin
c      call readi(20,key,ligdb,8)

      key='NBLGN   '
      write(key(8:8),'(i1)')lin
      if(nblgn(1).eq.0)call readi(20,key,nblgn,8)
      do k=1,8
      type *,'nblgn(k) : ',nblgn(k)
      enddo
      
c                                        ecrire readi (integer)
c                                               readf (floating)
c                                        dernier param = dimension
c
6     continue  !!!<---

      nwin=npol*nwinp
c                     =nombre max fenetres   
c--------------------------------
c                                     Noms des fichiers xna a 20 caract.
      do nw=1,nwin
          ipiv=win(nw)+1   ! les noms de fenetres commencent a zero
        let=lettre(ipiv)
c
c        type *,'let : ',let,' rl : ',rl
c        type *,'sto : ',sto
        xname='x000000_000000_m'//let//rl//'1'
        write(xname(20:20),'(i1)')sto
c        type *,'xname(1:20) : ',xname(1:20)
        ipiv=ddc-1000000*(ddc/1000000) !!!!!!!!!!!!!!!!!!!!!!!!
c        type *,'ipiv : ',ipiv 
        write(xname(2:7),'(i6)') ipiv

        write(xname(9:14),'(i6)')tdc1


c Afin d'eviter les ' ' dans le nom du fichier
        do ii=1,20
        if(xname(ii:ii).eq.' ') then
         xname(ii:ii)='0'
        endif
        enddo
c        type *,'xname : ',xname

                  xna(nw)=xname
        write(3,*)xna(nw)
      enddo

D 2
c*******************************************************
E 2
I 2
c**************************************************************************
c     IXY
c**************************************************************************
E 2
c
      type *,'ixy : ',ixy
      if(ixy.eq.1)then
c        ***
        if(tdc1.eq.0)goto52

      type*,'creation des fichiers x'
c                         Moyenne des courants d'obscurite: fichiers "x"
c                                     --------------------  ------------
c                         (dependent de la raie (par l'intermediaire du
c                                                temps de pose)
c                          mais pas de la region)
c

c      if(ihead.eq.0)goto8  !!--->
c      call readifits(21,'NAXIS3  ',naxis3,1)
c      call readifits(21,'NAXIS4  ',naxis4,1)
c                                             nclim=naxis3*naxis4
c                                                      X    Y    indep de w

c      naxis1=286
c      naxis2=382
c      naxis3=1
c      naxis4=1
      nclim=1  

c      type *,'NAXIS3 : ',naxis3
c      type *,'NAXIS4 :',naxis4
c      type *,'nclim : ',nclim

D 3
        call fnomw(fic,1,nwin,ddc,tdc1,tdc2,nfm,dcn,ftime,istop)
c            -----
E 3
I 3
        call fnomw(fic,1,1,   ddc,tdc1,tdc2,nfm,dcn,ftime,istop)
c            -----      990617
E 3
         type*,nfm,'  fichiers  a partir de ',dcn(1)
c
c  boucle sur les fenetres
c  -----------------------
        is=nbcln(nw)     !attention nbcol devient nbcln
        js=nblgn(nw)      !attention nblig devient nblgn

      do50 nw=1,nwin
D 3

          ipiv=win(nw)+1
        let=lettre(ipiv)

E 3
c ouverture du fichier dc de la fenetre nw
D 3

E 3
      do n=1,nfm
D 2
        write(dcn(n)(8:8),'(a)')let
E 2
I 2
D 3
        write(dcn(n)(pos_nomcam:pos_nomcam),'(a)')let
E 3
I 3
        write(dcn(n)(pos_nomcam-1:pos_nomcam),'(i2.2)')win(nw)
E 3
c-----------------------------------------------------------------------
c     Adapte aux donnees de P Mein de mai 99 en attente de definition 
D 3
      if (ipiv.eq.4) write(dcn(n)(10:10),'(a)') '2'
      if (ipiv.eq.5) write(dcn(n)(10:10),'(a)') '1'
E 3
I 3
      if (win(nw).eq.3) write(dcn(n)(10:10),'(a)') Icam3
      if (win(nw).eq.4) write(dcn(n)(10:10),'(a)') Icam4
      if (win(nw).eq.8) write(dcn(n)(10:10),'(a)') Icam8
E 3
c-----------------------------------------------------------------------
E 2
c        type *,' courant obscurite  dcn: ', tdc1,tdc2
      enddo
    
           do i=1,400
           do j=1,400
           xtab(i,j)=0.
           enddo
           enddo

          piv=float(nfm)
           
D 2
         do 45 n=1,nfm  
E 2
I 2
         do 45 n=1,nfm
D 3
            type *,'lecture:',dcn(n)  
E 3
I 3
            type *,'lecture:',dcn(n)

E 3
E 2
        call openold38(dcn(n),sundec,21)
c            ---------

c Calcul du nombre de blocs header : inbhead
        call comptehead(21,inbhead)
c            ----------
c        type *,'nbhead :',inbhead

c Calcul de la moyenne

      if(ipermu.eq.0)then
        call moyenne(21,inbhead,iswap,is,js,xtab)
c            -------  
      else
        call moyenne(21,inbhead,iswap,js,is,xtab)   
c            -------        
      endif

45    continue

      if(ipermu.eq.0)then
 
      do i=1,is
      do j=1,js
      tab(i,j)=xtab(i,j)/piv
      enddo
      enddo
      else

      do i=1,is
        ip=is+1-i
      do j=1,js
      tab(ip,j)=xtab(j,i)/piv
      enddo
      enddo
      endif

c   ouverture du fichier xname               23   
        xname=xna(nw)
        call system('rm '//xname)

          type*,' xname ',xname
        call opennew20(xname,sundec,23)
c            ---------                                        23
c        type *,'apres opennew20'
c        
        tete(1)=3
        tete(2)=is
        tete(3)=js
        tete(4)=1
c
        write(23)tete
        do j=1,js
        write(23)(tab(i,j),i=1,is)  !!!! 30 -> 23
          if(j.eq.js/2)type*,' x: tab(1,is,10 , js/2)',
     1                           (tab(i,j),i=1,is,10)
        enddo
c
        close(unit=21)
        close(unit=23)

50    continue
52    continue
      endif

c--------------------------------------------  creation des fichier "y" 's'
c                                              ----------------------------

c      call readifits(22,'NAXIS3  ',naxis3,1)
c      call readifits(22,'NAXIS4  ',naxis4,1)
c                                            nclim=naxis3*naxis4
c      type *,'NAXIS3 : ',naxis3
c      type *,'NAXIS4 :',naxis4
c      type *,'nclim : ',nclim
c                                     (X,Y differents pour dc et ff)
c------------------------------------------------------
c                                  nom des fichiers yna
      do nw=1,nwin

        yname=xna(nw)
        write(yname(1:1),'(a1)')'y'
        snom=xna(nw)
        write(snom(1:1),'(a1)')'s'


c        type *,'yname(1:20) : ',yname(1:20)
        ipiv=dff-1000000*(dff/1000000) !!!!(tff -> dff) et 10000 -> 1000000
      write(yname(2:7),'(i6)')ipiv
        ipiv=dfs-1000000*(dfs/1000000) !!!!(tfs -> dfs) et 10000 -> 1000000
      write(snom(2:7),'(i6)')ipiv

      write(snom(9:14),'(i6)')tfs1

c         ipiv1=tff1
c         iih=ipiv1/3600   !!!!!!!!!!!!!!!!
c         iim=(ipiv1-iih*3600)/60  !!!!!!!!!!!!!!
c         iis=ipiv1-iih*3600-iim*60  !!!!!!!!!!!!!!!!!!!!!!
c         write(yname(9:10),'(i2)') iih    !!!!!!!!!!!!!
c         write(yname(11:12),'(i2)') iim   !!!!!!!!!!!!!!!!
c         write(yname(13:14),'(i2)') iis  !!!!!!!!!!!!!!

c Afin d'eviter les ' ' dans le nom du fichier
        do ii=1,20
        if(yname(ii:ii).eq.' ') then
         yname(ii:ii)='0'
         endif
        if(snom(ii:ii).eq.' ') then
         snom(ii:ii)='0'
         endif
        enddo
c        type *,'sname : ',snom

                     yna(nw)=yname
             write(3,*)yna(nw)
                     sna(nw)=snom
             write(3,*)sna(nw)
      enddo
c-------------------------                     calcul fichiers y
      if(ixy.ne.0)then
c        ---
      type *,' etape creation fichiers y'

      call fnomw(fic,1,nwin,dff,tff1,tff2,nfm,ffn,ftime,istop)
c          -----
      piv=float(nfm)

c      type*,nfm,' fichiers a partir de ',ffn(1)
      write(3,*)nfm,' fichiers a partir de ',ffn(1)

c                           boucle sur les fenetres
      do60 nw=1,nwin
        is=nbcln(nw)  !!!!!!!!!!!!!!!!!!!!!!
        js=nblgn(nw)     !!!!!!!!!!!!!!!!!!!!
D 3
          ipiv=win(nw)+1
        let=lettre(ipiv)
E 3

        do n=1,nfm
D 2
        write(ffn(n)(8:8),'(a)')let
E 2
I 2
D 3
        write(ffn(n)(pos_nomcam:pos_nomcam),'(a)')let
E 3
I 3
        write(ffn(n)(pos_nomcam-1:pos_nomcam),'(i2.2)')win(nw)
E 3
c-----------------------------------------------------------------------
c     Adapte aux donnees de P Mein de mai 99 en attente de definition 
D 3
      if (ipiv.eq.4) write(ffn(n)(10:10),'(a)') '2'
      if (ipiv.eq.5) write(ffn(n)(10:10),'(a)') '1'
E 3
I 3
      if (win(nw).eq.3) write(ffn(n)(10:10),'(a)') Icam3
      if (win(nw).eq.4) write(ffn(n)(10:10),'(a)') Icam4
      if (win(nw).eq.8) write(ffn(n)(10:10),'(a)') Icam8
E 3
c-----------------------------------------------------------------------
E 2
        enddo

c       type*, ' flat field'

        do i=1,400
        do j=1,400
        xtab(i,j)=0.
        enddo
        enddo 
 
       do 56 n=1,nfm

      call openold38(ffn(n),sundec,22)
c          ---------                             ffn  en   22
      call comptehead(22,inbhead)
c          ----------

c Calcul de la moyenne
c          write(3,*)' inbhead,is,js,nfm',inbhead,is,js,nfm

      if(ipermu.eq.0)then
        call moyenne(22,inbhead,iswap,is,js,xtab)
c            ------                         
      else

        call moyenne(22,inbhead,iswap,js,is,xtab)
c            ------          
      endif
 56   continue

      if(ipermu.eq.0)then

      do i=1,is
      do j=1,js
      tab(i,j)=xtab(i,j)/piv
      enddo
      enddo
      else

      do i=1,is
        ip=is+1-i
      do j=1,js
      tab(ip,j)=xtab(j,i)/piv
      enddo
      enddo
      endif

c ouverture du fichier yname                                24

      yname=yna(nw)
        type *,'yname : ',yname
         call system('rm '//yname)
      call opennew20(yname,sundec,24)       
c          ---------                                        24
c      type *,'fichier cree : ',yname

c
      tete(1)=3
      tete(2)=is
      tete(3)=js
      tete(4)=1
c
      write(3,*)'y: tete ',(tete(i),i=1,10)
      write(24)tete   !!!! 31 -> 24

      do j=1,js
      write(24)(tab(i,j),i=1,is)  !!!!!!!!!!!!!  31-> 24
         if(j.eq.js/2)type*,' y: tab(1,is,10 , js/2)',
     1                           (tab(i,j),i=1,is,10)
      enddo
c
      close(unit=22)
      close(unit=24)
       

60    continue
c
      endif

c-------------------  
c-------------------------                     calcul fichiers s
      if(ixy.ne.0)then
c        ---
      type *,' etape creation fichiers s'

      call fnomw(fic,1,nwin,dfs,tfs1,tfs2,nfm,ffn,ftime,istop)
c          -----
      piv=float(nfm)

c      type*,nfm,' fichiers a partir de ',ffn(1)
      write(3,*)nfm,' fichiers a partir de ',ffn(1)

c                           boucle sur les fenetres
      do61 nw=1,nwin
        is=nbcln(nw)  !!!!!!!!!!!!!!!!!!!!!!
        js=nblgn(nw)     !!!!!!!!!!!!!!!!!!!!
D 3
          ipiv=win(nw)+1
        let=lettre(ipiv)
E 3

        do n=1,nfm
D 2
        write(ffn(n)(8:8),'(a)')let
E 2
I 2
D 3
        write(ffn(n)(pos_nomcam:pos_nomcam),'(a)')let
E 3
I 3
        write(ffn(n)(pos_nomcam-1:pos_nomcam),'(i2.2)')win(nw)
E 3
c-----------------------------------------------------------------------
c     Adapte aux donnees de P Mein de mai 99 en attente de definition 
D 3
      if (ipiv.eq.4) write(ffn(n)(10:10),'(a)') '2'
      if (ipiv.eq.5) write(ffn(n)(10:10),'(a)') '1'
E 3
I 3
      if (win(nw).eq.3) write(ffn(n)(10:10),'(a)') Icam3
      if (win(nw).eq.4) write(ffn(n)(10:10),'(a)') Icam4
      if (win(nw).eq.8) write(ffn(n)(10:10),'(a)') Icam8
E 3
c-----------------------------------------------------------------------
E 2
        enddo

c       type*, ' flat field'

        do i=1,400
        do j=1,400
        xtab(i,j)=0.
        enddo
        enddo 
 
       do 55 n=1,nfm

      call openold38(ffn(n),sundec,26)
c          ---------                             sfn  en   26
      call comptehead(26,inbhead)
c          ----------

c Calcul de la moyenne
c          write(3,*)' inbhead,is,js,nfm',inbhead,is,js,nfm

      if(ipermu.eq.0)then
        call moyenne(26,inbhead,iswap,is,js,xtab)
c            ------                         
      else

        call moyenne(26,inbhead,iswap,js,is,xtab)
c            ------          
      endif
55    continue

      if(ipermu.eq.0)then

      do i=1,is
      do j=1,js
      tab(i,j)=xtab(i,j)/piv
      enddo
      enddo
      else

      do i=1,is
        ip=is+1-i
      do j=1,js
      tab(ip,j)=xtab(j,i)/piv
      enddo
      enddo
      endif

c ouverture du fichier snom                                27

      snom=sna(nw)
        type *,'sname : ',snom
         call system('rm '//snom)
      call opennew20(snom,sundec,27)       
c          ---------                                        27
c      type *,'fichier cree : ',snom

c
      tete(1)=3
      tete(2)=is
      tete(3)=js
      tete(4)=1
c
      write(3,*)'y: tete ',(tete(i),i=1,10)
      write(27)tete   !!!! 31 -> 27

      do j=1,js
      write(27)(tab(i,j),i=1,is)  !!!!!!!!!!!!!  31-> 27
         if(j.eq.js/2)type*,' y: tab(1,is,10 , js/2)',
     1                           (tab(i,j),i=1,is,10)
      enddo
c
      close(unit=26)
      close(unit=27)
       

 61   continue
c
      endif
D 2

E 2
I 2
c***********************************************************************
c     GEO
c***********************************************************************
E 2
c-------------------  
c                                  noms fichiers g
      do  nw=1,nwin
      gname=yna(nw)
      write(gname(1:1),'(a)')'g'
      gna(nw)=gname   
      enddo

      if(igeo.ne.0)then
c        ****
c                                        geometrie: fichiers "g"
c                                        ---------  ------------
       type*,'creation fichiers g'
c boucle fenetres
c----------------

      if(iplotg.eq.0)then
      call pgbegin(0,'/xwin',1,1)
      else
      call pgbegin(0,'geo.ps/ps',iplotg,iplotg)
      endif

      do70 nw=1,nwin
        is=nbcln(nw)   !attention nbcol devient nbcln
        js=nblgn(nw)     !attention nblig devient nblgn

      gname=gna(nw)
        call system('rm '//gname)
        call opennew20sf(gname,sundec,25)
c            -----------                                 (sf = avec format??)
c                                           gname en 25
c
        if(tdc1.ne.0)call openold20(xna(nw),sundec,23)
c                        ---------                         x  en 23
        call openold20(sna(nw),sundec,24)
c            ---------                                     s  en 24
       type *,'gname : ',gname
       gna(nw)=gname

       type *,'avant bmg'
        call pgadvance
       call bmg(nw,win,23,24,25,gname)
c           ---          x  y  g titre
c              23 inutilise
       type*,'gna ',gna
       type *,'apres bmg'
      close(unit=23)
      close(unit=24)
      close(unit=25)       

70    continue
      call pgend
      endif
D 2
***********************************************************************
E 2
I 2
c***********************************************************************
c     IFLAT
c***********************************************************************
E 2
c                                        noms fichiers f
      do nw=1,nwin
      fname=yna(nw)   
      write(fname(1:1),'(a)')'f'
      fna(nw)=fname
      enddo
c---------------------------------
c                                           Etape iflat
c                                           ***********
c                   Les 2 polarisations sont traitees ensemble pour bmc 

      if(iflat.ne.0)then
c        *****

        type*,' etape ymz'
      if(iplotf.eq.0)then
      call pgbegin(0,'/xwin',1,1)
      else
      call pgbegin(0,'flat.ps/ps',iplotf,iplotf)
      endif
c                                       flat field: fichiers "f"
c                                       ----------  ------------
c  1 fichier f par fenetre
c      (tous canaux et polarisations + normalisation)

c                                                 etape ymz
c                                                 ---------
c    Boucle fenetres pour calcul fichiers z pour cmf
c    ---------------             -------------------

      do72 nw=1,nwin
      zname=yna(nw)   !!!!!!!!!!!!!!!!!
      write(zname(1:1),'(a)')'z'
      call system('rm '//zname)
      zna(nw)=zname

       naxis3=1
       naxis4=1
       nclim=naxis3*naxis4
c       type *,'avant bmc'

        iyb=0
        ipermuty=0    !!   le fichier y est deja retourne si necessaire
        icalib=0
I 2

E 2
      call bmc('bmc   ',nw,win,naxis3,naxis4,nclim, xna,iyb,yna,bna,
c          ---
c               etiq, fenetre,                   x  0/1   y ou b   

     1         gna,zna,cna,  
c              g   z ou c suivant iyb  

     2         sundec,iswap,ipermuty,icalib,fna,        fl)
c                                           pour calib  economie
72    continue
       type *,'apres ymz'
c--------------------------------------- 

c                                Polarisations traitees separement
c                                car les raies n'ont pas necessairemnent
c                                meme inclinaison
      do 80 npo=1,npol
        nw1=1+(npo-1)*nwinp
        nw2=nw1+nwinp-1

      call cmf('cmf   ',npo,nw1,nw2,win,kdecal,
c          ---
     1           gna,zna,fna,                 fl,tabeco,tabxeco)
c                g   z   f et pour nom pgplot, economie
      type *,'apres cmf'
80    continue

      call pgend
      type *,' Fin etape FLAT'
      endif
c                                  fin etape iflat
D 2
c*******************************************************
c                                               
E 2
I 2
c***********************************************************************
E 2
c                                            Etapes ibmc, iquick,ipro
c                                                   ****  ****** ****
I 2
c**********************************************************************
E 2
c                     noms fichiers sequence necessaires dans les 3 cas  

I 3
        if(ibmc+icmd+iquick+icmr+iprof+igrayq+igrayp.eq.0)goto900

E 3
c                                                fnom(nf)
        ipiv=win(1)+1
        let1=lettre(ipiv)

D 2

      do nw=1,nwin
      write(fic(nw)(6:7),'(i2)')reg
      write(fic(nw)(8:9),'(i2)')lin
        do i=6,9
        if(fic(nw)(i:i).eq.' ')fic(nw)(i:i)='0'
        enddo

E 2
I 2
c+++++++++++++++++++PARTIE SUPRIMEE EN ATTENTE DE DEFINITION DES FICHIERS
c      do nw=1,nwin
c        type *,'avant',fic(nw)
c      write(fic(nw)(6:7),'(i2)')reg
c      write(fic(nw)(8:9),'(i2)')lin
c        type *,'avant',fic(nw)
c        do i=6,9
c        if(fic(nw)(i:i).eq.' ')fic(nw)(i:i)='0'
c        enddo
E 2
        type *,'fic(nw) : ',fic(nw)
D 2
      enddo
E 2
I 2
c      enddo
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
E 2

      nfm=0  !!                 pour rechercher tous les fichiers
        type *,'dob : ',dob
        type *,'tob1 : ',tob1
        type *,'tob2 : ',tob2
      
D 3
      call fnomw(fic,1,nwin,dob,tob1,tob2,nfm,fnom,ftime,istop)
c          -----
        type *,' raie ',reg,'  nfm',nfm
E 3
I 3
      call fnomw(fic,1,1,   dob,tob1,tob2,nfm,fnom,ftime,istop)
c          -----     990617                    out  out  out
        write(3,*),' raie ',reg,'  nfm',nfm
E 3
        type *,fnom(1)
        type *,fnom(nfm) !!!!!!!!!!!!!!!!!!
        write(3,*)' pour ibmc: fnom(1)    ',fnom(1)
        write(3,*)' pour ibmc: fnom(nfm)  ',fnom(nfm)      
c-----
c                                                 dnanfp(nf,p)
      do nf=1,nfm
      do npo=1,npol

        nw1=1+(npo-1)*nwinp

      dname=xna(nw1)
      dname(2:14)=fnom(nf)(17:29)
      write(dname(1:1),'(a)')'d'
      dnanfp(nf,npo)=dname
c     ------
D 3
c                             write(3,*)' pour icmd: dname ',dname
E 3
I 3
                             write(3,*)' pour icmd: dname ',dname
E 3
      enddo
      enddo
c---------                                        nscanmax,nfdeb(nscan)

      call scan(intert,ntmax,ftime,nfm,nscanmax,nfdeb)
D 3
c          ----
E 3
I 3
c          ----   in    in    in    in   out      out
        write(3,*),' intert,ntmax,nfm,nscanmax ',intert,ntmax,nfm,
     1                                                 nscanmax
    
E 3
81    format(2x,a)
82    format(40x,i8)

      do nscan=1,nscanmax
        nf1=nfdeb(nscan)      
          if(nscan.eq.nscanmax)then
                              nf2=nfm
          else
                              nf2=nfdeb(nscan+1)-1
          endif
        write(7,81)dnanfp(nf1,1)
        write(7,81)dnanfp(nf2,1)
          nfs=nf2-nf1+1
        write(7,82)nfs
      enddo
      close(unit=7)

c----                                 dessin
c      nomps='p000000.a000000.ps'
c        ipiv=tob1-10000*(tob1/10000)
c      ipiv=dob-1000000*(dob/1000000)
c      write(nomps(2:7),'(i6)')ipiv
c      write(nomps(10:15),'(i6)')tob1
c        ipiv=win(1)
c                                     la lettre sera celle de la 1ere fenetre                 
c      write(nomps(9:9),'(a)')lettre(ipiv)

c       if(iquick.eq.1)write(nomps(1:1),'(a)')'q'
c       if(iprof.eq.1)write(nomps(1:1),'(a)')'p'
c       do i=1,15 !!!!!!!!!!!!
c       if(nomps(i:i).eq.' ') nomps(i:i)='0' !!!!!!!!!!!!!!
c       enddo  !!!!!!!!!!!!
c                                                   calcul de pixstep a faire

D 3
       if(ibmc+icmd+iquick+icmr+iprof+igrayq+igrayp.eq.0)goto900
E 3
I 3
c       if(ibmc+icmd+iquick+icmr+iprof+igrayq+igrayp.eq.0)goto900
E 3

c10    format(i7)
c12    format(12i6)
c***************************************************  Boucle sur les scans

      do600 nscan=1,nscanmax
                              nf1=nfdeb(nscan)
                              if(nscan.eq.nscanmax)then
                                 nf2=nfm
                              else
                                 nf2=nfdeb(nscan+1)-1
                              endif

                           nfsm=nf2-nf1+1
                              do nfs=1,nfsm
                              nf=nf1+nfs-1

                                do npo=1,npol
                                dnanfsp(nfs,npo)=dnanfp(nf,npo)
c                               -------                                
                                rname=dnanfp(nf,npo)
                                write(rname(1:1),'(a)')'r'
                                rnanfsp(nfs,npo)=rname
c                               -------
                                enddo

                              enddo               

c---------------------------------------------
c                                              Etape bmc
c                                              ---------  

D 3
      do90  nf=nf1,nf2    
E 3
I 3
      write(3,*),' nf1,nf2 ',nf1,nf2
      write(3,*),' fnom(nf) '
      do nf=nf1,nf2
      write(3,*), fnom(nf)
      enddo


      do90  nf=nf1,nf2
E 3
c                                    boucle sur les temps (fichiers)
c
      do90 npo=1,npol
I 3

      write(3,*)' npo ',npo
E 3
        nw1=1+(npo-1)*nwinp
        nw2=nw1+nwinp-1
c                       noms des fichiers b et c (a chaque nf)      
      do nw=nw1,nw2
      obname=fnom(nf)
D 3
      ipiv=Win(nw)+1
D 2
      write(obname(10:10),'(a)')lettre(ipiv)
E 2
I 2
      write(obname(pos_nomcam:pos_nomcam),'(a)')lettre(ipiv)
E 3
I 3
      write(obname(pos_nomcam-1:pos_nomcam),'(i2.2)')win(nw)
E 3
c-----------------------------------------------------------------------
c     Adapte aux donnees de P Mein de mai 99 en attente de definition 
D 3
      if (ipiv.eq.4) write(obname(10:10),'(a)') '2'
      if (ipiv.eq.5) write(obname(10:10),'(a)') '1'
E 3
I 3
      if (win(nw).eq.3) write(obname(10:10),'(a)') Icam3
      if (win(nw).eq.4) write(obname(10:10),'(a)') Icam4
      if (win(nw).eq.8) write(obname(10:10),'(a)') Icam8
E 3
c-----------------------------------------------------------------------
E 2
      bna(nw)=obname          
c     ---
      enddo

c       lire NAXIS3, NAXIS4 
c      call readifits(20,'NAXIS3  ',naxis3,1)
c      call readifits(20,'NAXIS4  ',naxis4,1)
c      type *,'Pour fichier c naxis3 :',naxis3
c      type *,'Pour fichier c naxis4 :',naxis4

      naxis3=1
      naxis4=1
      nclim=naxis3*naxis4

      do nw=nw1,nw2
I 2
c                        is,js finaux
        is=nbcln(nw)
        js=nblgn(nw)

E 2
      cname=xna(nw)
      cname(2:14)=bna(nw)(17:29)
      write(cname(1:1),'(a)')'c'
             if(ibmc.eq.1)call system('rm '//cname)
      cna(nw)=cname
c     ---
      enddo
D 2
c        do nw=nw1,nw2
c        write(3,*),' ibmc: nw, bna,cna: ',nw,bna(nw),cna(nw)
c        enddo   
E 2
I 2
        do nw=nw1,nw2
        write(3,*),' ibmc: nw, bna,cna: ',nw,bna(nw),cna(nw)
        enddo   
E 2
c                                            creation fichiers c

      if(ibmc.ne.0)then
c     -------------

        type*,' nf=',nf,'  etape ibmc'
      do nw=nw1,nw2
        iyb=1
        ipermub=ipermu
        icalib=1

D 2
      call bmc('bmc   ',nw,win,naxis3,naxis4,nclim,
E 2
I 2
      call bmc('bmc   ',nw,win,is,js,nclim,
E 2
c          ---
     1          xna,iyb,   yna,bna, gna, zna,cna,
c                 x        y ou b    g   z ou c  

     2          sundec,iswap,ipermub,icalib,fna,fl)
c                      si b  permutaxes      f  eco
      enddo

      endif
c                                  fin boucle fenetres fichiers c
90    continue

c--------------------------------------------------------  
c                                       Etape icmd
c                                             ----

      if(icmd.ne.0)then
      call system('rm cmd.ps')
      call pgbegin(0,'cmd.ps/ps',3,3)
c          -------
      endif


      do200 nf=nf1,nf2
        ides=1
        if(nf.ne.nf1)ides=0
c                                       boucle sur les temps
      do150 npo=1,npol
c                                  boucle sur les polars
      nw1=1+(npo-1)*nwinp
      nw2=nw1+nwinp-1

      do nw=nw1,nw2
      cna(nw)=xna(nw)
      cna(nw)(2:14)=fnom(nf)(17:29)
      write(cna(nw)(1:1),'(a)')'c'
c           ---
       type*,' ms99: cna ',cna(nw)
      enddo

c              write(3,*)' pour cmd iquick: cna ',cna 

         if(icmd.ne.0)then
c        -------------
        type*,' nf=',nf,'   etape icmd'
      iud=51
      dname=dnanfp(nf,npo)
      call system('rm '//dname)
      call opennew20(dname,sundec,51)
c          ---------                 
       type *,'dname:',dname

      corv=0
c             pas de correction de lambdas (Vitesses) dans l'etape iquick
c             donc pas d'ouverture de 53
      iuj=53
      call cmd('cmd   ',nw1,nw2,nwinp,npo,   cna, dname,   iud,iuj,
c          ---                        head d  in   pour noms       
     1          corv,   tabeco,  ides)
c                in     economie dessin
      close(unit=iud)
      endif

150   continue
200   continue    
      if(icmd.ne.0)call pgend
      type*,' fin etape icmd'
c------
c  Ouvertures pour dme de iquick (utilise les fichiers d de cmd)
 
        if(iquick.ne.0)then
c          -----------

      call system('rm quick.ps')
      call pgbegin(0,'quick.ps/ps',2,1)
c          -------

      do300 npo=1,npol
                    
      qname=dnanfsp(1,npo)
      write(qname(1:1),'(a)')'q'
      call system('rm '//qname)
      call opennew20(qname,sundec,52)
c          ---------

      jname=qname      
      write(jname(1:1),'(a)')'j'
c                             remplace par let2 dans le ss/programme
        type*,' ms99.f: jname ',jname
      call system('rm '//jname)
      call opennew20sf(jname,sundec,53)
c          -----------

       type *,'avant dme : '
       type *,'jname :',jname

c-------------------------------   creation fichiers q

      call dme('quick ',nfsm,npo,dnanfsp,52,53,
D 3
c          ---                         q  j
E 3
I 3
c          ---                           q  j
E 3
c                                     out out
     1          lineref,sundec, ideld)
c                   out    in   out

      close(52)
      close(53)

        if(ideld.ne.0)then
          do nfs=1,nfsm
          dname=dnanfsp(nfs,npo)
          call system('rm '//dname)
          enddo
        endif

300   continue
      call pgend

      type *,'fin etape iquick'!!!!!!!!!!!!!!!!!
      endif

c---------------------------------------------------  icmr
      type *,'icmr'!!!!!!!!!!!!!!!!!

      if(icmr.ne.0)then
      call system('rm cmr.ps')
      call pgbegin(0,'cmr.ps/ps',3,3)
c          -------
      endif

      do400 npo=1,npol

c         a la difference de l'etape icmd
c         le calcul des fichiers r
c         depend des fichiers j de chaque scan


      do350 nfs=1,nfsm
        ides=1
        if(nfs.ne.1)ides=0

c             correction de lambdas (Vitesses) dans l'etape icmr:
c             ouverture de 53 sur fichier j de la polar en cours
      jname=rnanfsp(1,npo)
      write(jname(1:1),'(a)')'j'

      call openold20sf(jname,sundec,53)
c          -----------

      nw1=1+(npo-1)*nwinp
      nw2=nw1+nwinp-1

      do nw=nw1,nw2
      cna(nw)=xna(nw)
               nf=nfs+nfdeb(nscan)-1
      cna(nw)(2:14)=fnom(nf)(17:29)
      write(cna(nw)(1:1),'(a)')'c'
c           ---
       type*,' ms99: cna ',cna(nw)
      enddo

c              write(3,*)' pour icmr: dname ',dname 
c              write(3,*)' pour icmr: cna ',cna 

         if(icmr.ne.0)then
c        -------------
        type*,' nfs=',nfs,'   etape icmr'
      iud=51
      rname=rnanfsp(nfs,npo)
      write(dname(1:1),'(a)')'r'
      call system('rm '//rname)
      call opennew20(rname,sundec,51)
c          ---------                 
       type *,'rname:',rname

      corv=1

      iur=51
      iuj=53
      call cmd('cmr   ',nw1,nw2,nwinp,npo,   cna, rname,   iur,iuj,
c          ---                        head d  in   pour noms       
     1          corv,   tabeco,  ides)
c                in     economie dessin
      close(unit=iur)
      endif

350   continue
      close(53)

400   continue
      if(icmr.ne.0)call pgend

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

c  Ouvertures pour dme de iprof (utilise les fichiers d de cmd)
 
        if(iprof.ne.0)then
c          ----------

      call system('rm prof.ps')
      call pgbegin(0,'prof.ps/ps',2,1)
c          -------

      do500 npo=1,npol
                                   
      pname=rnanfsp(1,npo)
      write(pname(1:1),'(a)')'p'
      call system('rm '//pname)
      call opennew20(pname,sundec,54)
c          ---------

      kname=rnanfsp(1,npo)
      write(kname(1:1),'(a)')'k'
c                             remplace par let2 dans le ss/programme 
      call system('rm '//kname)
      call opennew20sf(kname,sundec,55)
c          -----------
 
       type *,'avant dme : '

c-------------------------------   creation fichiers p

      call dme('prof  ',nfsm,npo,rnanfsp,54,55,
c          ---                           p  k

     1          lineref,sundec, ideld)
c                   out    in   out

      close(53)
      close(54)
      close(55)

        if(ideld.ne.0)then
          do nfs=1,nfsm
          rname=rnanfsp(nfs,npo)
          call system('rm '//rname)
          enddo
        endif

500   continue
      call pgend
      type *,'fin etape iprof'!!!!!!!!!!!!!!!!!
      endif

600   continue
c******************************  fin boucle scans
c--------------------------------------------------------  igrayq
      if(igrayq.ne.0)then

      call system('rm grayq.ps')
      call pgbegin(0,'grayq.ps/ps',igrq,jgrq)
c          -------    
      do npo=1,npol
             
        do nscan=1,nscanmax
        nf=nfdeb(nscan)
        qname=dnanfp(nf,npo)
        write(qname(1:1),'(a)')'q'
        call openold20(qname,sundec,52)
c            ---------
      
          if(nscan.eq.nscanmax)then
                              nf2=nfm
          else
                              nf2=nfdeb(nscan+1)-1
          endif
        dname=dnanfp(nf2,npo)
        write(hfin(1:2),'(a)')blancs
        write(hfin(3:8),'(a)')dname(9:14)
          nfsm=nf2-nf+1

        call gray20('grayq ',52,qname,igrq,jgrq,hfin,nfsm)
c            ------
        close(52)
        enddo

      enddo

      call pgend
      endif

c--------------------------------------------------------  igrayp
      if(igrayp.ne.0)then

      call system('rm grayp.ps')
      call pgbegin(0,'grayp.ps/ps',igrp,jgrp)
c          -------

      do npo=1,npol
  
        do nscan=1,nscanmax
        nf=nfdeb(nscan)
        pname=dnanfp(nf,npo)
        write(pname(1:1),'(a)')'p'
        call openold20(pname,sundec,54)
c            ---------

          if(nscan.eq.nscanmax)then
                              nf2=nfm
          else
                              nf2=nfdeb(nscan+1)-1
          endif
        dname=dnanfp(nf2,npo)
        write(hfin(1:2),'(a)')blancs
        write(hfin(3:8),'(a)')dname(9:14)
          nfsm=nf2-nf+1

        call gray20('grayp ',54,pname,igrp,jgrp,hfin,nfsm) 
c            ------
        close(54)
        enddo

      enddo

      call pgend
      endif
c***************************************************
      
900   continue

      close(unit=3)
      close(unit=8)
      close(unit=9)
      stop
      end
c                               fin ms99.f
c*****************************************************

c*****************************************************************
c------------------------------------
      subroutine readf(iu,key,val,idim)
      dimension val(idim)
      return
      end
c------------------------------------
      subroutine openold20(name,sundec,iu)
      character*20 name
      integer sundec
      open(unit=iu,status='old',form='unformatted',file=name)
      return
      end
c------------------------------------
      subroutine openold20sf(name,sundec,iu)
      character*20 name
      integer sundec
      open(unit=iu,status='old',form='formatted',file=name)
      return
      end
c------------------------------------
      subroutine opennew20(name,sundec,iu)
      character*20 name
      integer sundec
      open(unit=iu,status='new',form='unformatted',file=name)
      return
      end
c------------------------------------
      subroutine opennew20sf(name,sundec,iu)
c                                                   Pourquoi "sf"?
      character*20 name
      integer sundec
      open(unit=iu,status='new',form='formatted',file=name)
      return
      end
c------------------------------------
      subroutine openold38(name,sundec,iu)
      character*38 name
      integer sundec

I 3

E 3
        type*,name
      if(sundec.eq.1) then
        open(unit=iu,status='old',form='unformatted',recl=720,
     2access='direct',file=name)
      else
        open(unit=iu,status='old',form='unformatted',recl=2880,
     2access='direct',file=name)           
       endif
c      type *,'fichier ouvert dans open'
      return
      end
c------------------------------------
      subroutine opennew38(name,sundec,iu)
      character*38 name
      integer sundec
      if(sundec.eq.1) then
        open(unit=iu,status='unknown',form='unformatted',recl=720,
     2access='direct',file=name)
      else
        open(unit=iu,status='unknown',form='unformatted',recl=2880,
     2access='direct',file=name)           
       endif 
      return
      end
c-----------------------------------------
        subroutine readi(iu,key,ivalkey,idim)
        dimension ivalkey(idim)
        character*8 key
        character buf*2880,m*70
        integer num,nbvir,valparouv,valparfer,valvir(10),max
        character*10 valkeycar(8)
        integer*4 valkey(8)
        do num=1,10
         read(iu,rec=num) buf(1:2880)
         i=1
         do nb=1,36
          if(buf(i+10:i+17).eq.key(1:8)) then
            m(1:70)=buf(i+10:i+89)
            do ii=1,70
              if(m(ii:ii).eq.'(') then
                valparouv=ii 
                go to 10
              endif
            enddo
10          do ii=1,70
              if(m(ii:ii).eq.')') then
                valparfer=ii 
                go to 20
              endif
            enddo                
20          nbvir=0
            do ii=1,70
              if(m(ii:ii).eq.',') then
                nbvir=nbvir+1
                valvir(nbvir)=ii
              endif
            enddo
            do l=1,nbvir
            enddo
            do k=1,nbvir+1
               if(k.eq.1) then
                  ii=valparouv
               else
                  ii=valvir(k-1)
               endif
               if(nbvir.eq.0) then
                  jj=valparfer
               else
                  max=nbvir+1
                  if(k.eq.max) valvir(k)=valparfer
                  jj=valvir(k)
               endif
                valkeycar(k)(1:10)=m(ii+1:jj-1)
             enddo
             go to 1000
           else
            i=i+80
           endif
          enddo
         enddo                    
1000         do k=1,nbvir+1
        decode(10,999,valkeycar(k)) ivalkey(k)
999      format(i10)
         enddo     
         return
         end
c----------------------------------------------
         subroutine readifits(iu,key,ivalkey,idim)
         dimension ivalkey(idim)
         character*8 key
         character buf*2880,m*80
         do n=1,10
         read(iu,rec=n) buf(1:2880)
         i=1
         do nb=1,36
         if(buf(i:i+3).eq.'END ') go to 1000
         i=i+80
         enddo
         enddo
1000     continue
         do jj=1,n
         read(iu,rec=jj) buf(1:2880)
         i=1
         do nb=1,36
         if(buf(i:i+7).eq.key)then
         m(1:80)=buf(i:i+79)
         call remplitw(m,ivalkey)
         go to 2000
         endif
         i=i+80
         enddo
         enddo
2000     return
         end          
          
c-------------------------------------------
      Subroutine remplitw(keyword,val)
       character keyword*80,fin*15
       character*80 slash
       integer*4 val,j,i      
       slash='/'
       do i=11,80
       if(keyword(i:i).EQ.slash) then
       j=i
       go to 10
       endif
       enddo
10     write(fin(1:15),'(A15)') keyword(j-15:j-1)
      decode(15,100,fin) val
100   format(i15)
       return
       end
c-------------------------
      Subroutine remplitrw(keyword,val)
       character keyword*80,fin*10
       character*80 slash
       real*4 val      
       slash='/'
       do i=11,80
       if(keyword(i:i).EQ.slash) then
       j=i
       go to 10
       endif
       enddo
10       write(fin(1:10),'(A10)') keyword(j-10:j-1)
       decode(10,200,fin) val
200   format(F10.3)
       return 
      end 
c--------------------------------------
      subroutine comptehead(iu,nb)
      integer nb
      character buf*2880
      do nb=1,10
      read(iu,rec=nb) buf(1:2880)
      i=1
      do n=1,36 
      if(buf(i:i+3).eq.'END ') go to 1000
      i=i+80
      enddo
      enddo
1000  return
      end
c----------------------------------                 
      subroutine moyenne(iu,inbhead,iswap,is,js,xtab)
c                -------
      integer*4 is,js,nclim,t,n,long,num
      integer*2 sort(1440),kswap1(1),kswap2(1)
      double precision xtab(400,400)
       nclim=1

c lecture du fichier, additions et stockage dans xtab(400,400)
        n=inbhead
        i=0
        j=1
        k=1
100      n=n+1

        read(iu,rec=n,iostat=ios)  (sort(t),t=1,1440)
c        type *,'apres read n =',n
        if(ios.lt.0) go to 1000
        t=1
200     i=i+1
        if(i.le.is) go to 500
         if(j.lt.js) then
           j=j+1
           i=1
         else
            if(k.lt.nclim) then
               k=k+1
               j=1
               i=1
            else
               go to 1000
            endif
          endif

500    kswap1(1)=sort(t)
        if(iswap.ne.0)then
        call swap(kswap1,1,kswap2)
c            ----
c          if(t.eq.10)type*,' iswap, kswap1,kswap2',iswap,kswap1,kswap2
        kswap1(1)=kswap2(1)
        endif
            xtab(i,j)=xtab(i,j)+ kswap1(1)
       t=t+1

       if (t.eq.1441) go to 100
       go to 200
1000     continue

          return
          end
c----------------------------------                 
       subroutine swap(in,ncar,out)   
c                 ----
c       in = entree
c       out= sortie
c       ncar=nombre de integer*2 a swaper
c
      integer*2 in(1),out(1),auxi2
      logical*1 low,auxl1(2)
      equivalence (auxi2,auxl1(1))
c
      do i=1,ncar
      auxi2=in(i)
      low=auxl1(1)
      auxl1(1)=auxl1(2)
      auxl1(2)=low
      out(i)=auxi2
      enddo
      return
      end
c----------------------------------
      subroutine scan(intert,ntmax,ftime,nfm,nsc,nfdeb)
c                ----
      dimension nfdeb(2000)
      integer*4 ftime(4000)
      
      if(ntmax.ne.0)then
        nsc=0
      do nf=1,nfm,ntmax
      nsc=nsc+1
      nfdeb(nsc)=nf
      enddo
        return
      endif


      nfdeb(1)=1
      nsc=1
        do nf=2,nfm
        interv=ftime(nf)-ftime(nf-1)
          if(interv.gt.intert)then
          nsc=nsc+1
          nfdeb(nsc)=nf
            write(3,*)' debuts de scans ',ftime(nf)
          endif
        enddo
      return

      end
c------------------------------------------------------------------------
c -----------------------------------------------------------------------
c cette routine retourne les noms complets des fichiers trouves dans
c un intervalle horaire, entre les fenetres nw1 et nw2 (comprises).
c fname contient les noms pour la fenetre nw2
c ftime contient les temps en secondes
c si nfm=1 en entree, le programme ne cherche que le premier fichier
c  (recherche du debut d'une observation) 
c -----------------------------------------------------------------------
      Subroutine fnomw(ftype,nw1,nw2,date,ideb,ifin,nfm,fname,ftime,
D 3
c                -----
E 3
I 3
c                -----   in in  in     in   in   in out  out    out
E 3
     1                 istop)
I 3
c                        in
E 3
      implicit none
c INPUT:
      character jour*8,hdeb*6,hfin*6
c ideb = HHMMSS (heure de debut; exemple 103407 pour 10h34mn07s)
c ifin = HHMMSS (heure de fin;   exemple 110456 pour 11h04mn56s)
c OUTPUT:
      character*38 fname(10000),ftype(8),fic
      integer*4 ftime(10000)
      integer*4 nf,nfm,istop,reg,lin,date,nw1,nw2,nw
c iu = numero de l'unite de lecture
c nf = nombre de fichiers trouves
c fname = tableau contenant le nom des nf fichiers trouves
c ftime = tableau contenant les heures des nf fichiers trouves
c
      character h*6,d*8
      integer*4 ideb,ifin,ih,im,is,i,j,ier,jjj
      integer*4 ideb2,ifin2
      logical*4 present
      character*80 list
c
10    format(a9)
11    format(1x,a6)
D 2
c      read(8,10)ftype
c         istop=0
c         if(ftype.eq.'         '.or.ftype.eq.'end      ')then
c            istop=1
c            return
c         endif
c        write(ftype(1:1),'(a1)')let
E 2
99    format(I6)
I 2

E 2
      encode(6,99,hdeb)ideb
      encode(6,99,hfin)ifin
      type*,'fnom38',ideb,ifin

      nf=0
      read(hdeb(1:2),'(i2)',iostat=ier) ih
      if(ier.ne.0) stop 'Error reading start time 1'
c      type*, ih
      if(ih.lt.0.or.ih.gt.23) stop 'Error reading start time 2'
      read(hdeb(3:4),'(i2)',iostat=ier) im
c      type*,im
      if(ier.ne.0) stop 'Error reading start time 3'
      if(im.lt.0.or.im.gt.59) stop 'Error reading start time 4'
      read(hdeb(5:6),'(i2)',iostat=ier) is
      if(ier.ne.0) stop 'Error reading start time 5'
c      type*,is
      if(is.lt.0.or.is.gt.59) stop 'Error reading start time 6'
      ideb2=ih*3600+im*60+is

      read(hfin(1:2),'(i2)',iostat=ier) ih
      if(ier.ne.0) stop 'Error reading end time'
      if(ih.lt.0.or.ih.gt.23) stop 'Error reading end time'
      read(hfin(3:4),'(i2)',iostat=ier) im
      if(ier.ne.0) stop 'Error reading end time'
      if(im.lt.0.or.im.gt.59) stop 'Error reading end time'
      read(hfin(5:6),'(i2)',iostat=ier) is
      if(ier.ne.0) stop 'Error reading end time'
      if(is.lt.0.or.is.gt.59) stop 'Error reading end time'
      ifin2=ih*3600+im*60+is
       if(ifin2.eq.0) ifin2=ideb2

      nf=0

c                   type*, ' fnom38 secondes ', ideb2,ifin2
      do 1 i=ideb2,ifin2
         ih=i/3600
         im=(i-ih*3600)/60
         is=i-ih*3600-im*60
         write(h(1:2),'(i2)') ih
         write(h(3:4),'(i2)') im
         write(h(5:6),'(i2)') is
c
c          type*,i,ih,im,is
c                            on ne conserve que les temps pour lesquels
c                            tous les fichiers de nw1 a nw2 existent
         do nw=nw1,nw2

         fic=ftype(nw)
I 2
D 3
c--------------------------------------------------------------------------
c     Adapte aux donnees de mai99 de P Mein, en attente de definition
c         if (fic(8:8).eq.'3' ) fic(10:10)='2'
c         if (fic(8:8).eq.'4' ) fic(10:10)='1'
c---------------------------------------------------------------------------
E 3
I 3

E 3
E 2
         write(fic(15:22),'(i8)')date

         write(fic(24:29),'(a6)')h
         do j=1,38         
            if(fic(j:j).eq.' ') fic(j:j)='0'
         end do

D 2
         ier=-1
c                  type*,'nom fichier ',fic

E 2
I 2
         do jjj=0,99
            write(fic(31:32),'(i2.2)') jjj
I 3

E 3
E 2
         inquire(File = Fic, Name=list, exist=present)
D 2
         if (present) ier=0

         open(unit=15,form='unformatted',access='sequential',
     1        file=fic,iostat=ier,status='old',readonly)
         inquire(file=fic,exist=present)

         if(present) ier=0

         close(unit=15)
         if(ier.ne.0) goto 1

         enddo

      nf=nf+1
      if(nf.gt.10000) stop 'Too much files. Max allowed: 10000'
      type *,fic
      fname(nf)=fic
      ftime(nf)=is+60*(im+60*ih)
E 2
I 2
         if(present) then
            nf=nf+1
            if(nf.gt.10000) stop 'Too much files. Max allowed: 10000'
            fname(nf)=fic
            ftime(nf)=is+60*(im+60*ih)
E 2
                              type*, fname(nf)
D 2
      if(nfm.eq.1)return
E 2
I 2
                              if(nfm.eq.1)return
         endif
E 2

I 2
         enddo
         enddo
E 2
1     continue

       nfm=nf
20    format(' No file found')
      if(nf.eq.0)then
         istop=1
         type 20
         write(3,20)
      endif
      if(nf.eq.0) stop 'Error: no files found'
D 2
c      type*,'nfm', nfm
E 2
I 2

E 2
      return
      end


E 1
