c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine plotframe(titl,tcl,titr,tcr,signat)
c
c     ---------------------------------------------------------------+--
c     Trace le cadre "CETP" avec titre gauche et droit dans le bandeau,
c     signature et date de production
c     Modification history:
c     16/09/08: Change of the laboratory name , C. Burlaud
c               CETP become LPP
c     ---------------------------------------------------------------+--
c
      character*(*) titl,titr,signat
c      character*64 cetp,cnrs,prodat
      character*64 lpp,cnrs,prodat
      character*25 datim
c
c
c	     cetp='CENTRE D''ETUDES DES ENVIRONNEMENTS TERRESTRE ET PLANETAIRES'
      lpp  = 'LABORATOIRE DE PHYSIQUE DES PLASMAS'
      cnrs = 'CENTRE NATIONAL DE LA RECHERCHE SCIENTIFIQUE'
      tc1  = 0.18
      tcsi = 0.22
      tmar = 0.3
      pvt  = 9.5
c
      call gpagsiz_(psx,psy)
c      
      call dlinwid_(4)
      call dfontyp_('h')
c      
c *** bandeau jaune
c
      call dlinrgb_(1.,1.,0.7)
      call dfilzon_
      call ppagrec_(0.,psy-0.7,psx,0.7)
      call pfilzon_
c
c *** cadre et titre
c
      call dlincol_('n')
      call ppagfra_
c      call ppagcha_(tmar,psy-0.45,-1,tc1,tc1,0.,cetp)
      call ppagcha_(tmar,psy-0.45,-1,tc1,tc1,0.,lpp)
      call ppagcha_(psx-tmar,psy-0.45,+1,tc1,tc1,0.,cnrs)       
      call ppaghli_(psy-0.7)
c
      call ppagcha_(tmar,psy-1.5,-1,tcl,tcl,0.,titl)      
      call ppagcha_((pvt+psx)/2.,psy-1.5+tcr/2.,0,tcr,tcr,0.,titr)      
      call ppaghli_(psy-1.8)
      call ppaglin_(pvt,psy-1.8,9.5,psy-0.7)
c
c *** signature et date
c
      call dfontyp_('tital')
      call gstdati_(datim)
c
      prodat='Production date: '//datim
c
      call ppagcha_(tmar,0.2,-1,tcsi,tcsi,0.,signat)
      call ppagcha_(psx-tmar,0.2,+1,tcsi,tcsi,0.,prodat)
c      
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cdattit_(iyear,imon,iday,dattit)
c
      character*(*) dattit
      character*9 cmon
      character*8 forj
      character*80 format
c
c     ---------------------------------------------------------------+--
c #   compute_date_titre pour le titre droit de la page
c     ---------------------------------------------------------------+--
c
      call cojd00(iyear,imon,iday,jd00)
      call cbesfori(jd00,forj)
      call cmoncar_(imon,cmon)
      call cchalen_(cmon,nbchar)
c
      format='(i4.4,1x,a,1x,i2.2,"  (Julian day "'//forj//'")")'
      write(dattit,format) iyear,cmon(1:nbchar),iday,jd00
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiggrah(valref,valgra,titgra,valdt,nbgma,nbpma)
c
      common /figsiz/ rx,ry
      common /figori/ xz,yz
      common /figlim/ x1,x2,y1,y2
      common /grasiz/ tgrax,tgray,dgxax,dgyay,ncgrax,ncgray
      common /grapos/ ipgrax,ipgray
      common /stisiz/ tgm,tpm
      common /stipos/ ipmabx,ipmahx,ipmagy,ipmady
c
      real valgra(nbgma)
      character*(*) titgra(nbgma)
c
c     ---------------------------------------------------------------+--
c #   plot_figure_graduation_hourly
c
c     plot les graduation d'un axe horaire calcule par cfiggrah
c     P. Robert, CETP, Avril    2005
c     ---------------------------------------------------------------+--
c
clm>    Pour calmer Foresys:
      if (valref.ge.1.E33) write(*,*) 'valref pas bon'
clm<

c
      call sdr_wfilcom('begin pfiggrah')
c
c *** verif que les valeurs des graduation sont entre x1 et x2
c
      tol= (x2-x1)*0.1/15.
c 
      do 10 i=1,nbgma
      if(valgra(i).lt.x1-2.*tol.or. valgra(i).gt.x2+2.*tol)
     &              call uperror_('pfiggrah: time values out of axe')
   10 continue
c
c *** trace des grandes et petites marques, du haut et du bas, 
c     suivant option vers interieur ou exterieur
c
      tgb=tgm*float(ipmabx)
      tpb=tpm*float(ipmabx)
      tgh=tgm*float(ipmahx)
      tph=tpm*float(ipmahx)
c
      ex=rx/(x2-x1)
      valpdt=valdt/float(nbpma+1)
c
      do 20 i=1,nbgma
      xx=xz +(valgra(i)-x1)*ex
      call dpagppo_(xx,yz)
      call ppagpmo_(xx,yz+tgb)
      call dpagppo_(xx,yz+ry)
      call ppagpmo_(xx,yz+ry-tgh)
c
c     Tracé des petites marques avant la pemière grande marque:
      if (i.eq.1) then
         do j=1,nbpma
            xxp=xx-float(j)*valpdt*ex
            if (xxp.ge.xz) then
               call dpagppo_(xxp,yz)
               call ppagpmo_(xxp,yz+tpb)
               call dpagppo_(xxp,yz+ry)
               call ppagpmo_(xxp,yz+ry-tph)
            endif
         enddo
      endif

      do 30 j=1,nbpma
      xxp=xx +float(j)*valpdt*ex
      if(xxp.gt.xz+rx) go to 20
      call dpagppo_(xxp,yz)
      call ppagpmo_(xxp,yz+tpb)
      call dpagppo_(xxp,yz+ry)
      call ppagpmo_(xxp,yz+ry-tph)
   30 continue
   20 continue
c
c *** trace de la valeur horaire des graduations
c
      if(tgrax.lt.0.001) go to 50
c
      dgxax= tgm +0.5*tgrax
      print*, 'dgxax=',dgxax
c
      do 40 i=1,nbgma
      xx=xz +(valgra(i)-x1)*ex
      if(ipgrax.eq.1) then
c                     graduations en haut
                      yy=yz+ry+dgxax+tgrax/2.
                      else
c                     graduations en bas
                      yy=yz-dgxax-tgrax/2.
                      endif
      call ppagcha_(xx,yy,0,tgrax,tgrax,0.,titgra(i))
   40 continue
   50 continue
c
      call sdr_wfilcom('end   pfiggrah')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cfiggrah(t1,t2,valgra,titgra,valdt,nbgma,nbpma)
c
      real valgra(nbgma)
      character*(*) titgra(nbgma)
c
c     ---------------------------------------------------------------+--
c #   compute_figure_graduation_hourly
c
c     Pour un axe horaire, avec t1 et t2 en heure decimale, calcul du
c     nombre de grandes marques, du nombre de petite marques,
c     du tableau de la valeur en heure decimale de chaque grande marque,
c     et du tableau character du titre de chaque grande marque,
c     sous la forme  HH:MM:SS.
c
c     Calcul valable pour des periode de 2 mn a 4 jours.
c                         
c     P. Robert, CETP, Octobre  2000
c             revision Decembre 2000 pour extension a + de 24h
c             revision Octobre  2002 pour arondi des bornes.
c             revision Avril    2005 passage IDL -> F77
c             revision Mars     2010 correction bug precision valgra
c     ---------------------------------------------------------------+--
c
c *** arondi eventuel des bornes a une minute ronde
c
c     on commence par arondir les bornes t1 et t2 a une minute ronde
c     (inferieure et superieure) si la difference est inferieure a
c     la tolerence (0.1cm/15cm)*(t2-t1)
c
      tol= (t2-t1)*0.1/15.
c
      print*, 'roundt1t2: t1,t2 initial=', t1,t2
      print*, '           tol= ',tol, ' soit ',tol*3600.,' sec'
c
      ith= int(t1)
      itm= int((t1-float(ith))*60.)
      t1r= float(ith) +float(itm)/60.
c
      if(abs(t1r-t1).lt.tol) t1=t1r
c
      ith= int(t2)
      itm= int((t2-float(ith))*60.)
      t2r= float(ith) +float(itm+1)/60.
c
      if(abs(t2r-t2).lt.tol) t2=t2r
c
      print*, 'roundt1t2: t1,t2 rounded=', t1,t2
c
c *** on definit 9 echelles caracteristiques; t1,t2 en heures
c
      nbh  = int(t2-t1 +0.01) 
      nb10m= int((t2-t1)*6.   +0.01) 
      nb5m = int((t2-t1)*12.  +0.01) 
      nb2m = int((t2-t1)*30.  +0.01) 
      nb1m = int((t2-t1)*60.  +0.01) 
      nb30s= int((t2-t1)*120. +0.01) 
      nb10s= int((t2-t1)*360. +0.01) 
      nb5s = int((t2-t1)*720. +0.01) 
      nb1s = int((t2-t1)*3600.+0.01) 
c
c *** test de duree minimum
c
      if( (t2-t1)*3600. .lt. 2.) then 
                      print*, '*** cfiggrah: duration.lt.2 s.'
                      print*, '              t1,t2 (hours)=',t1,t2
                      print*, '              duration (mn)=',(t2-t1)*60.
                      print*, '***  arret brutal, pas de .ps'
          STOP 'COGRATIM      *** ABORTED ! T2-T1 < 2S              ***'
                                 endif
c
c *** calcul du nombre de marques et des valeurs associees
c
c     nbgma = nombre de grandes marques, portant une valeur
c     nbpma = nombre de petites marques entre 2 grandes marques
c     ivalg1= heure de la premiere marque, en SECONDES 
c     ivaldt= intervalle entre 2 marques,  en SECONDES
c      valdt= intervalle entre 2 marques,  en HEURES decimales
c
      write(*,*) nb1s
      labtyp=3
      if(nb1s.gt.1) then
                    labtyp=3
                    nbgma= nb1s +1
                    ivaldt=1
                    nbpma=4
                    endif
c
      if(nb5s.gt.1) then
                    labtyp=3
                    nbgma= nb5s +1
                    ivaldt=5
                    nbpma=4
                    endif
c
      if(nb10s.gt.1) then
                    labtyp=3
                    nbgma= nb10s +1
                    ivaldt=10
                    nbpma=4
                    endif
c
      if(nb30s.gt.1) then
                    labtyp=3
                    nbgma= nb30s +1
                    ivaldt=30
                    nbpma=2
                    endif
c
      if(nb1m.gt.1) then
                    labtyp=2
                    nbgma= nb1m +1
                    ivaldt=60
                    nbpma=5
                    endif
c
      if(nb2m.gt.1) then
                    labtyp=2
                    nbgma= nb2m +1
                    ivaldt=120
                    valdt= 1./30.
                    nbpma=3
                    endif
c
      if(nb5m.gt.1) then
                    labtyp=2
                    nbgma= nb5m +1
                    ivaldt=300
                    nbpma=4
                    endif
c
      if(nb10m.gt.1) then
                     labtyp=2
                     nbgma= nb10m +1
                     ivaldt=600
                     nbpma=4
                     endif
c
      if(nbh.gt.1) then
                   labtyp=2
                   nbgma= nbh +1
                   ivaldt=3600
                   nbpma=5
                   endif
c
c *** cas des grandes periodes superieures a 8 heures
c
      if(nbh.gt.8) then
                   labtyp=1
                   nbgma= nbh/2 +1
                   ivaldt=3600*2
                   nbpma=3
                   endif
c
      if(nbh.gt.16) then
                    labtyp=1
                    nbgma= nbh/3 +1
                    ivaldt=3600*3
                    nbpma=5
                    endif
c
      if(nbh.gt.24) then
                    labtyp=1
                    nbgma= nbh/6 +1
                    ivaldt=3600*6
                    nbpma=5
                    endif
c
      if(nbh.gt.48) then
                    labtyp=1
                    nbgma= nbh/12 +1
                    ivaldt=3600*12
                    nbpma=5
                    endif
c
      if(nbh.gt.96) then
                    labtyp=1
                    nbgma= nbh/24 +1
                    ivaldt=3600*24
                    nbpma=5
                    endif

c
c *** valeur en seconde tu temps du debut de la 1ere marque
c     ou de la marque precedente, avant T1
c
      ivalg1=int(t1*3600./float(ivaldt) +0.01)*ivaldt
c
      write(*,*) '//////// nbgma,nbpma',nbgma,nbpma
      write(*,*) '//////// ivaldt,ivalg1 ',ivaldt,ivalg1
c
c *** calcul du temps de chaque graduation, en heures
c *** chargement du tableau des graduations en mode character

      do i=1,nbgma+1
         valgra(i)= float(ivalg1 +(i-1)*ivaldt)/3600.
         isdj= ivalg1 +(i-1)*ivaldt
c
         ih=  isdj/3600
         im= (isdj -ih*3600)/60
         is=  isdj -ih*3600 -im*60
c
         call uencodat(ih,im,is,labtyp,titgra(i))
      enddo
c
      write(*,*) '//////// valgra=',(valgra(i),i=1,nbgma+1)
      write(*,*) '//////// titgra=',(titgra(i)(1:9),i=1,nbgma+1)
c
c *** calcul de l'intervalle des valeurs des graduations en heure dec.
c
      valdt= float(ivaldt)/3600.
c
c *** retrait des marques de debut et de fin si elles sont hors periode

      write(*,*) '//////// valgra(1),t1-tol',valgra(1),t1-tol

      if(valgra(1).lt.t1-tol) then
                              do i=1,nbgma
ccc                                valgra(i)= valgra(i)+valdt
                                valgra(i)= valgra(i+1)
                                titgra(i)= titgra(i+1)
                              enddo
                              endif

      write(*,*) '//////// nbgma,nbpma',nbgma,nbpma
      write(*,*) '//////// valgra=',(valgra(i),i=1,nbgma)
      write(*,*) '//////// titgra=',(titgra(i)(1:9),i=1,nbgma)

      write(*,*)'//////valgra(nbgma),t2+tol',valgra(nbgma),t2+tol

      if(valgra(nbgma-1).gt.t2+tol ) then
                                   nbgma=nbgma-2
                                   endif

      if(valgra(nbgma).gt.t2+tol ) then
                                   nbgma=nbgma-1
                                   endif

      write(*,*) '//////// nbgma,nbpma',nbgma,nbpma
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine uencodat(ih,im,is,labtyp,date)

      character*(*) date

c     ---------------------------------------------------------------+--
c #   encode date from ihnim,is
c     ---------------------------------------------------------------+--

      if(labtyp.eq.1) then
            write(date,"(i3.2,':00')") ih

         elseif(labtyp.eq.2) then
            write(date,"(i2.2,':',i2.2)") ih,im

         elseif(labtyp.eq.3) then
            write(date,"(i2.2,':',i2.2,':',i2.2)") ih,im,is
      endif

      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlabdisy(disy)
c
c     ---------------------------------------------------------------+--
c #   define_label_distance_y in cm.
c     ---------------------------------------------------------------+--
c
c     *** TBD ***
c
      common /labsiz/ tlax,tlay,dlxax,dlyay
c
c     objet    : definit la distance du label y a l'axe y
c
      dlyay=disy
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine plotpalhsbx(ox,oy,sx,sy,xmin,xmax,tgra)
c
c     ---------------------------------------------------------------+--
c     plot d'une palette HSB
c     ---------------------------------------------------------------+--
c
      character*8 forx
c
c *** palette hsb avec cadre
c
      call ppagcmah(ox,oy,sx,sy,1)
      call ppagrec_(ox,oy,sx,sy)
c
c *** graduation de l'axe avec les bornes exactes
c
c *   calcul des intervalles des graduations
c
      call cfiggra_(xmin,xmax,x1a,x2a,bgx,sgx,forx)
c
c *   definition de la figure incluse correspondant aux grad. rondes
c
      call dfigori_(ox,oy)
      call dfigsiz_(sx,sy)
      call dfiglimx(xmin,xmax)
c
c *   trace des graduations
c
      call dstipos_('o ','ii')
      call dstisiz_(sy/5.,sy/10.)
      call dgrasiz_(tgra,tgra)
      call pfiggrax(x1a+bgx,bgx,sgx,forx)
c
      return
      end
c          
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
      subroutine calminmax3spe(spebx,speby,spebz,spec_temp,nx,ny,
     +smin,smax,semin,semax,ifs,ired)
c
c     ---------------------------------------------------------------+--
c     calcul les intensites min et max des 3 spectrogrammes
c     ---------------------------------------------------------------+--
c   
      real spebx(nx,ny),speby(nx,ny),spebz(nx,ny)
      real spec_temp(nx,ny)
c
      pcmin=10.
      pcmax=1.
c     
c     on remplace les pixels en dehors des seuils par la
c     moyenne des pixels à l'intérieur des seuils
      call ecretspec(spebx,spec_temp,nx,ny,semin,semax,ifs)
      call cscasli_(spec_temp,nx,ny,sminx,smaxx,pcmin,pcmax)
      call ecretspec(speby,spec_temp,nx,ny,semin,semax,ifs)
      call cscasli_(spec_temp,nx,ny,sminy,smaxy,pcmin,pcmax)
      call ecretspec(spebz,spec_temp,nx,ny,semin,semax,ifs)
      call cscasli_(spec_temp,nx,ny,sminz,smaxz,pcmin,pcmax)

c      call cscasli_(spebx,nx,ny,sminx,smaxx,pcmin,pcmax)
c      call cscasli_(speby,nx,ny,sminy,smaxy,pcmin,pcmax)
c      call cscasli_(spebz,nx,ny,sminz,smaxz,pcmin,pcmax)
c     
c
c *** correction eventuelle des seuils
c
      write(*,*) 'sminx,smaxx: ',sminx,smaxx
      write(*,*) 'sminy,smaxy: ',sminy,smaxy
      write(*,*) 'sminz,smaxz: ',sminz,smaxz
      write(*,*) 'ired: ',ired
      call corrseuils(semin,semax,ired,sminx,smaxx)
      call corrseuils(semin,semax,ired,sminy,smaxy)
      call corrseuils(semin,semax,ired,sminz,smaxz)

      write(*,*) 'correction eventuelle des seuils'
      write(*,*) 'sminx,smaxx: ', sminx,smaxx
      write(*,*) 'sminy,smaxy: ', sminy,smaxy
      write(*,*) 'sminz,smaxz: ', sminz,smaxz
      smin=min(sminx,sminy,sminz)
      smax=max(smaxx,smaxy,smaxz)
c      
      return
      end
c          
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
      subroutine calminmax4spe(spec1,spec2,spec3,spec4,spec_temp,nx,ny,
     +smin,smax,semin,semax,ifs,ired)
c
c     ---------------------------------------------------------------+--
c     calcul les intensites min et max des 4 spectrogrammes
c     ---------------------------------------------------------------+--
c   
      real spec1(nx,ny),spec2(nx,ny),spec3(nx,ny),spec4(nx,ny)
      real spec_temp(nx,ny)
c
      pcmin=10.
      pcmax=1.
c     
c     on remplace les pixels en dehors des seuils par la
c     moyenne des pixels à l'intérieur des seuils
      call ecretspec(spec1,spec_temp,nx,ny,semin,semax,ifs)
      call cscasli_(spec_temp,nx,ny,smin1,smax1,pcmin,pcmax)
      call ecretspec(spec2,spec_temp,nx,ny,semin,semax,ifs)
      call cscasli_(spec_temp,nx,ny,smin2,smax2,pcmin,pcmax)
      call ecretspec(spec3,spec_temp,nx,ny,semin,semax,ifs)
      call cscasli_(spec_temp,nx,ny,smin3,smax3,pcmin,pcmax)
      call ecretspec(spec4,spec_temp,nx,ny,semin,semax,ifs)
      call cscasli_(spec_temp,nx,ny,smin4,smax4,pcmin,pcmax)

c      call cscasli_(spec1,nx,ny,sminx,smaxx,pcmin,pcmax)
c      call cscasli_(spec2,nx,ny,sminy,smaxy,pcmin,pcmax)
c      call cscasli_(spec3,nx,ny,sminz,smaxz,pcmin,pcmax)
c     
c
c *** correction eventuelle des seuils
c
      write(*,*) 'smin1,smax1: ',smin1,smax1
      write(*,*) 'smin2,smax2: ',smin2,smax2
      write(*,*) 'smin3,smax3: ',smin3,smax3
      write(*,*) 'smin4,smax4: ',smin4,smax4
      write(*,*) 'ired: ',ired
      call corrseuils(semin,semax,ired,smin1,smax1)
      call corrseuils(semin,semax,ired,smin2,smax2)
      call corrseuils(semin,semax,ired,smin3,smax3)
      call corrseuils(semin,semax,ired,smin4,smax4)

      write(*,*) 'correction eventuelle des seuils'
      write(*,*) 'smin1,smax1: ', smin1,smax1
      write(*,*) 'smin2,smax2: ', smin2,smax2
      write(*,*) 'smin3,smax3: ', smin3,smax3
      write(*,*) 'smin4,smax4: ', smin4,smax4
      smin=min(smin1,smin2,smin3,smin4)
      smax=max(smax1,smax2,smax3,smax4)
c      
      return
      end
c          
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
      subroutine calminmax1spe(spebx,spec_temp,nx,ny,
     +smin,smax,semin,semax,ifs,ired)
c
c     ---------------------------------------------------------------+--
c     calcul les intensites min et max des 3 spectrogrammes
c     ---------------------------------------------------------------+--
c   
      real spebx(nx,ny)
      real spec_temp(nx,ny)
c
      pcmin=10.
      pcmax=1.
c     
c     on remplace les pixels en dehors des seuils par la
c     moyenne des pixels à l'intérieur des seuils
      call ecretspec(spebx,spec_temp,nx,ny,semin,semax,ifs)
      call cscasli_(spec_temp,nx,ny,sminx,smaxx,pcmin,pcmax)

c      call cscasli_(spebx,nx,ny,sminx,smaxx,pcmin,pcmax)
c      call cscasli_(speby,nx,ny,sminy,smaxy,pcmin,pcmax)
c      call cscasli_(spebz,nx,ny,sminz,smaxz,pcmin,pcmax)
c     
c
c *** correction eventuelle des seuils
c
      write(*,*) 'sminx,smaxx: ',sminx,smaxx
      write(*,*) 'ired: ',ired
      call corrseuils(semin,semax,ired,sminx,smaxx)

      write(*,*) 'correction eventuelle des seuils'
      write(*,*) 'sminx,smaxx: ', sminx,smaxx
      smin=sminx
      smax=smaxx
c      
      return
      end
c          
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
      subroutine ecretspec(spectro,spectro_temp,nx,ny,semin,semax,ifs)
      real spectro(nx,ny)
      real spectro_temp(nx,ny)
      nb_points=0
      valmoy=0.
      do ix=1,nx
         do iy=ifs+1,ny
            if ((spectro(ix,iy).gt.semin).and.
     +      (spectro(ix,iy).lt.semax)) then
               valmoy=valmoy+spectro(ix,iy)
               nb_points=nb_points+1
            endif
         enddo
      enddo
      valmoy=valmoy/float(nb_points)
      do ix=1,nx
         do iy=ifs+1,ny
            if ((spectro(ix,iy).gt.semin).and.
     +      (spectro(ix,iy).lt.semax)) then
               spectro_temp(ix,iy)=spectro(ix,iy)
            else
               spectro_temp(ix,iy)=valmoy
            endif
         enddo
      enddo
      do ix=1,nx
         do iy=1,ifs
            spectro_temp(ix,iy)=valmoy
         enddo
      enddo
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
      subroutine calseuil(projet,experi,br,semin,semax,ired)
c
c     ---------------------------------------------------------------+--
c     calcul des seuils min et max adaptes a chaque projet
c     ---------------------------------------------------------------+--
c
      character*(*) projet,experi,br
c
      semin= -10.
      semax=   3.
      ired =  15
c
      if(projet(1:7).eq.'CLUSTER') then
                      if(experi(1:5).eq.'STAFF') then
                                    if(br(1:3).eq.'HBR') then
                                                         semin= -9.7
                                                         ired = 30
                                                         else
                                                         semin= -6.45
                                                         endif
                                                  endif
c
                      if(experi(1:3).eq.'EFW') then
                                               semin= -3.1
                                               endif
c
                      if(experi(1:3).eq.'FGM') then
                                               semin= -5.0
                                               endif
                                   endif
c
      if(projet(1:4).eq.'GEOS')   then
                                  semin= -7.2
                                  endif
c
      if(projet(1:6).eq.'STAMOB') then
                                  semin= -7.2
                                  endif
c
      call strlen(projet,np)
      call strlen(experi,ne)
c
      print *
      print 100, ' Seuils recommandes suivant la manip:'
      print 100, ' pour la manip ', projet(1:np),'/',experi(1:ne),'/',
     &             br(1:3),': seuils min et max = ',semin,semax
      print 110, ' et il faudrait forcer la mire sur le rouge de ',ired,
     &           ' %'
c
  100 format(7a,2f7.2)
  110 format(a,i3,a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
      subroutine corrseuils(semin,semax,ired,smi,sma)
c
c     ---------------------------------------------------------------+--
c     correction des seuils pour meilleurs rendu de l'image
c     ---------------------------------------------------------------+--
c
c *** limitation dans les normes admissibles
c
      if(smi.lt.semin) smi=semin
      if(sma.gt.semax) sma=semax
c
c *** decalage vers le rouge (car valeurs generalement peu nombreuses)
c
      dynam= sma-smi
      decal= dynam*float(ired)/100.
      sma= sma-decal
c
c *** re-limitation dans les normes admissibles de sma
c
      if(sma.gt.semax) sma=semax
c
      print*
      print*, 'Seuils min, max cal. et corriges =',smi,sma
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
      subroutine cscanul_(spec,spec_ref,nx,ny,se_ref,se_neg_ref,
     +se_nul_ref,val_zero,val_neg)
c
c
c     ---------------------------------------------------------------+--
c     Valeurs hors limites par rapport à un spectre de référence
c     ---------------------------------------------------------------+--
c


      real spec(nx,ny)
      real spec_ref(nx,ny)
      
      do i=1,nx
         do j=1,ny
            if (spec_ref(i,j).lt.se_neg_ref) then
               spec(i,j)=val_neg
            elseif ((spec_ref(i,j).lt.se_ref).or.
     +              (spec_ref(i,j).gt.se_nul_ref)) then
               spec(i,j)=val_zero
            endif
         enddo
      enddo
      
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigcuf_(ax,ay,n,dx)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_curve from ax(n),ay(n)
c *            when ax is not regularly spaced
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension ax(n),ay(n)
      real dx
c *** trace d'un tableau ay(n)=f(ax(n))
c
      call cfigpag_(ax(1),ay(1),xx,yy)
      call dpagppo_(xx,yy)
c
      do 10 i=2,n
      call cfigpag_(ax(i),ay(i),xx,yy)
      if ((ax(i)-ax(i-1)-dx) .lt. dx/1000.) then 
      call ppagpmo_(xx,yy)
      else
      print *, i,i-1, 'irregularly spaced'
      call dpagppo_(xx,yy)
      endif
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
