c
c XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c XX                                                                  XX
c XX  Patrick ROBERT, PatCie, 1986  --> a ce jour                     XX
c XX  Copyright 1986-2009  Patrick ROBERT, all rights reserved        XX
c XX                                                                  XX
c XX           -----------------                                      XX
c XX                                                                  XX
c XX V1.0 Version initiale  depuis archives :                Fev 1986 XX
c XX V2.0 Decoupage et structuration des call :              Fev 1986 XX
c XX V3.0 Creation du driver PostScript  :                   Mar 1990 XX
c XX V4.0 Refonte generale et nomage codifie des modules :   Mai 1993 XX
c XX V5.0 Usage des polices PS standards :                   Mar 1995 XX
c XX V6.0 Nouveaux modules de calcul et traces :             Dec 1995 XX
c XX V7.0 Redefinition des categories et des roles,                   XX
c XX      stucturation de l'arborescence en modules :        Dec 1996 XX
c XX V7.1 - V7.4 ameliorations et corrections diverses                XX
c XX V7.5 Extension a 8 bits des polices standards PS :      Dec 1997 XX
c XX V7.6 Nouveaux modules de trace :                        Mar 1998 XX
c XX V7.7 Optimisation pour ecriture de texte :              Nov 1998 XX
c XX V8.0 Gestion des polices proportionnelles PS :          Oct 1999 XX
c XX V8.1 Refonte generale des common et simplifications,             XX
c XX      Suppression de l'interface en pixels,                       XX
c XX      trace entierement vectoriel, gestion des images :  Nov 1999 XX
c XX V8.2 Introduction des formats A3,A2,A1 et A0 :          Avr 2000 XX
c XX V8.3 Corrections qq bugs :                              Dec 2001 XX
c XX V8.4 Resolution de quelques pb de polices Bold :        Dec 2003 XX
c XX V8.5 Corrections qq bugs :                              Avr 2005 XX
c XX V8.6 nouveaux ajustements pour le calcul des                     XX
c XX      graduations pour grandes valeurs proches :         Aou 2005 XX
c XX V8.7 Compatibilite pour divers Ghostview (Sun, Win) :   Nov 2005 XX
c XX V8.8 Verification FORESYS et introduction de plusieurs           XX
c XX      mires de couleur :                                 Jan 2006 XX
c XX V8.9 Compatibilite pour G77 PC windows :                Feb 2006 XX
c XX V9.0 25 mires de couleurs, possibilite mires a la carte Jun 2006 XX
c XX V9.1 Suppression drivers inacheves autre que PostScript,         XX
c XX      intro lines tiretees, formats en maj. ou minusc.,           XX
c XX      new routines de temps, refonte des categories :    Oct 2007 XX
c XX V9.2 Correction calcul Page Bounding Box :              Nov 2007 XX
c XX V9.3 fonction puissances pour portabilite (x**n) :      Nov 2007 XX
c XX V9.4 corr. bugs sur cfiggra_ et nb pages dans driver :  Mai 2008 XX
c XX V9.5 Intro fonctions calendrier, unicite du code SUN-PC,         XX
c XX      Activation dfigout_ et evite depass. format ds PS           XX
c XX      Optimisation distance graduations & labels a l'axe Jun 2008 XX
c XX V9.6 Full gfortran compatible                           Jun 2010 XX
c XX                                                                  XX
c XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
c
      subroutine capowex_(a,x,apowx)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_a_power_x i.e. a**x for code portability
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      if(a.lt.0.) call uperror_('capowex_ : a must be > 0')
c
      arg=x*log(a)
      argm=37.*log(10.)
      if(arg.gt.argm) call uperror_('capowex_ : a**x must be < 1.e37')
      apowx= exp(x*log(a))
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cbesfor_(x,format)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_best_format as '(f3.1)' for x=2.5
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      character*(*) format
      character*1 ia
c
      data epsi  /1.e-36/
      save epsi
c
c     calcule le format optimum d'un nombre donne x
c
c
      ll=len(format)
      if(ll.lt.8) call uperror_('cbesfor_: format < 8 caracteres')
c
      xx=abs(x)
c
      if(xx.lt.epsi) then
                     format='(f2.0)'
                     return
                     endif
c
c
      call cmanexp_(xx,rma,ie)
      call csigdig_(rma,nosd)
c
c *** format f: fn1.n2 avec chiffre np.n2
c
      if(xx.lt.1.) then
                   n1=nosd+2+abs(ie)
                   lim=9
                   else
                   n1=max(nosd+1,ie+1)
                   lim=8
                   endif
c
      if(n1.gt.lim) then
                  ia='e'
                  n2=nosd
                  n1=n2+6
c
                  else
                  ia='f'
                  if(xx.lt.1.) then
                               n2=nosd+abs(ie)
                               else
                               n2=n1-ie-1
                               endif
                  endif
c
      if(x.lt.0.) n1=n1+1
c
      if(n1.lt.10) then
                   write(format,101) ia,n1,n2
                   else
                   write(format,102) ia,n1,n2
                   endif
c
  101 format('(',a1,i1,'.',i1,')')
  102 format('(',a1,i2,'.',i1,')')
c
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cbesfori(ix,format)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_best_format_integer as '(i3)' for ix=124
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      character*(*) format
c
c     calcule le format optimum d'un nombre donne ix
c
c
      ll=len(format)
      if(ll.lt.8) call uperror_('cbesfori: format < 8 caracteres')
c
      iax=abs(ix)
c
      if(iax.eq.0) then
                   format='(i1)'
                   return
                   endif
c
      n1=int(alog10(float(iax))) +1
      if(ix.lt.0) n1=n1+1
c
      if(n1.lt.10) then
                   write(format,101) n1
                   else
                   write(format,102) n1
                   endif
c
  101 format('(i',i1,')')
  102 format('(i',i2,')')
c
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ccarpol_(x,y,r,teta)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_cartesian_to_polar degrees
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      data epsi  /1.e-35/
      save epsi
c
c
      dspi=180./acos(-1.)
c
      if(abs(x).lt.epsi.and.abs(y).lt.epsi) then
                                            teta=0.
                                            r=0.
                                            return
                                            endif
c
      tetar=atan2(y,x)
      teta=tetar*dspi
      if(teta.lt.0.) teta=teta+360.
      r=sqrt(x*x+y*y)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ccarsph_(x,y,z,r,teta,phi)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_cartesian_to_spherical degrees
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      data epsi  /1.e-35/
      save epsi
c
      dspi=180./acos(-1.)
c
c     conversion de coordonnees cartesiennes en spheriques
c
c
      r=sqrt(x*x+y*y+z*z)
      rp=amax1(r,epsi)
      teta=dspi*acos(z/rp)
      phi=0.
      if(abs(x).gt.epsi.and.abs(y).gt.epsi) phi=dspi*atan2(y,x)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cchalen_(chast,nbcha)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_character_length without end blanks
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) chast
c
c     calcule la longueur utile d'une chaine de caracteres
c     les blancs de fin sont ignores
c
c
      nbc=len(chast)
      if(nbc.gt.255) then
                     print*, '***probleme avec cchalen, nbc=',nbc
                     call uperror_('cchalen_:nbc GT 255 !!!')
                     endif
c
      do 10 i=1,nbc
      ii=nbc-i+1
      if(chast(ii:ii).ne.' ') go to 12
   10 continue
      ii=0
   12 continue
c
      nbcha=ii
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cchatim_(ctime,ih,im,is)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_time_character_to_time '13:03:05' to 13 03 05
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) ctime
c
      read(ctime,100) ih,im,is
c
  100 format(i2,1x,i2,1x,i2)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cchawid_(chast,numfon,height,width)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_character_width from height in cm
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      real fonwid(255,13)
      save fonwid
c
      character*(*) chast
c
c
c *** calcul des largeurs des fonts disponibles
c
      call sdr_gfonwid(fonwid,nbfon)
c
c *** calcul du corps de la fonte utilisee selon sa hauteur
c
      call cfonbod_(numfon,height,fonbod)
c
c *** calcul du nb de caracteres de la chaine
c
      call cchalen_(chast,nc)
c
c *** calcul du rapport avec la fonte 10 de reference
c
      sca=fonbod/10.
      width=0.
c
c *** somme des tailles de chaque caracteres (blanc=32 par defaut)
c
      do 20 i=1,nc
      ich= ichar(chast(i:i))
      if(ich.eq.0) ich=32
      width= width + fonwid(ich,numfon)*sca
   20 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ccirarc_(x1,y1,x2,y2,r,xc,yc,tet1,tet2)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_circular_arc from 2 points and radius
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      pi=acos(-1.)
      pisd=pi/180.
c
c *** calcul de alpha=(tet1+tet2)/2 et beta=(tet1-tet2)/2
c     2 solutions pour alpha et beta
c
      alpha1= -atan((x1-x2)/(y1-y2))
      alpha2= -atan((x1-x2)/(y1-y2)) +pi
c
      call cvecmod_(x1-x2, y1-y2, 0., rmod)
c
      beta1=  asin(rmod/(2.*r))
      beta2= -asin(rmod/(2.*r))
c
c *** donc 4 solutions pour tet1 et tet2
c
      tet1a= (alpha1-beta1)
      tet2a= (alpha1+beta1)
c
      tet1b= (alpha1-beta2)
      tet2b= (alpha1+beta2)
c
      tet1c= (alpha2-beta1)
      tet2c= (alpha2+beta1)
c
      tet1d= (alpha2-beta2)
      tet2d= (alpha2+beta2)
c
c *** condition tet2 > tet1 pour elimination de solutions (ita=0)
c
      if(tet1a.gt.tet2a) then
                         ita=0
                         else
                         ita=1
                         endif
c
      if(tet1b.gt.tet2b) then
                         itb=0
                         else
                         itb=1
                         endif
c
      if(tet1c.gt.tet2c) then
                         itc=0
                         else
                         itc=1
                         endif
c
      if(tet1d.gt.tet2d) then
                         itd=0
                         else
                         itd=1
                         endif
c
c *** calcul du centre: 2 solutions x 4 pour teta
c
      xc1a= x1-r*cos(tet1a)
      yc1a= y1-r*sin(tet1a)
c
      xc2a= x2-r*cos(tet2a)
      yc2a= y2-r*sin(tet2a)
      if(abs(xc1a-xc2a).gt.0.0001.or.abs(yc1a-yc2a).gt.0.0001) ita=0
c
c
      xc1b= x1-r*cos(tet1b)
      yc1b= y1-r*sin(tet1b)
c
      xc2b= x2-r*cos(tet2b)
      yc2b= y2-r*sin(tet2b)
      if(abs(xc1b-xc2b).gt.0.0001.or.abs(yc1b-yc2b).gt.0.0001) itb=0
c
c
      xc1c= x1-r*cos(tet1c)
      yc1c= y1-r*sin(tet1c)
c
      xc2c= x2-r*cos(tet2c)
      yc2c= y2-r*sin(tet2c)
      if(abs(xc1c-xc2c).gt.0.0001.or.abs(yc1c-yc2c).gt.0.0001) itc=0
c
c
      xc1d= x1-r*cos(tet1d)
      yc1d= y1-r*sin(tet1d)
c
      xc2d= x2-r*cos(tet2d)
      yc2d= y2-r*sin(tet2d)
      if(abs(xc1d-xc2d).gt.0.0001.or.abs(yc1d-yc2d).gt.0.0001) itd=0
c
c *** choix des solutions; il ne doit en rester qu'une
c
      isol=0
c
      if(ita.eq.1) then
                   isol=isol+1
                   xc=xc1a
                   yc=yc1a
                   tet1=tet1a
                   tet2=tet2a
                   endif
c
      if(itb.eq.1) then
                   isol=isol+1
                   xc=xc1b
                   yc=yc1b
                   tet1=tet1b
                   tet2=tet2b
                   endif
c
      if(itc.eq.1) then
                   isol=isol+1
                   xc=xc1c
                   yc=yc1c
                   tet1=tet1c
                   tet2=tet2c
                   endif
c
      if(itd.eq.1) then
                   isol=isol+1
                   xc=xc1d
                   yc=yc1d
                   tet1=tet1d
                   tet2=tet2d
                   endif
c
      if(isol.eq.0) call uperror_('ccirarc_:pas de solution !!!')
      if(isol.gt.1) call uperror_('ccirarc_:plusieurs solutions !!! ')
c
      tet1=tet1/pisd
      tet2=tet2/pisd
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ccollev_(level,hue,sat,bri)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_color_values for given level of current colormap
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      common /colmap/ hueu,satu,briu,nbcolu
      common /colmac/ comapu
c
      real hueu(256),satu(256),briu(256)
      character*10 comapu
      character*10 colmap
      save colmap
c
c *** mire utilisee et nombre de niveaux
c
      call gcolmap_(colmap,nlevel)
c
c *** test si le niveau demande est dans la mire courante
c
      if(level.lt.1)  call uperror_('dlincoln: level number < 1')
      if(level.gt.nlevel) then
                          print*, 'ROGRALIB/dlincoln: '//
     &                         'level number too large for colormap'
                          print*, 'level asked     : ',level
                          print*, 'current colormap: ',comapu
                          print*, 'Number of levels: ',nlevel
        call uperror_('dlincoln: level number too large for colormap')
                          endif
c
      hue=hueu(level)
      sat=satu(level)
      bri=briu(level)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cdatdoy_(idoy,iyear,imonth,iday)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_date_from_day_of_year and for a given year
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992 (Rocotlib)
c
c *   input  : iyear,idoy (idoy=1 for january 1)
c *   output : imonth,iday
c     ---------------------------------------------------------------+--
c
      dimension month(12)

      data month/31,28,31,30,31,30,31,31,30,31,30,31/
      data ily /-1/
      save month,ily
c
c
      call cleayea_(iyear,ily)
c
      if(idoy.gt.365.and.ily.eq.0) then
            print*,'*** Rogralib/cdatdoy: idoy= ',idoy
            print*,'*** Rogralib/cdatdoy: iyear is not a leap year'
            print*,'                      no more than 365 day'
            call uperror_('cdatdoy: cdatdoy: iyear is not a leap year')
                                   endif
c
      if(idoy.lt.1) then
             print*,'*** Rogralib/cdatdoy: idoy= ',idoy
             print*,'*** Rogralib/cdatdoy: day of the year must be GT 0'
             call uperror_('cdatdoy: day of the year must be GT 0')
                    endif
c
      if(ily.eq.1) then
                   month(2)=29
                   else
                   month(2)=28
                   endif
c
      m=0
c
      do 10 im=1,12
      mp=m
      m=m+month(im)
      if(idoy.le.m) go to 20
   10 continue
   20 continue
c
      imonth=im
      iday=idoy-mp
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cdatj70_(jd70,iyear,imonth,iday)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_Julianday_1970_year_month_day integer values
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992 (Rocotlib)
c
c *   input  : jd70  julian day 1970 (0= 1/1/1970)
c *   output : iyear,imonth,iday
c     ---------------------------------------------------------------+--
c
      data ily /-1/
      save ily
c
c
      jd1= -1
c
      do 10 iy=1970,3000
      call cleayea_(iy,ily)
      jdp=jd1
      if(ily.eq.1) then
                   jd1=jd1+366
                   else
                   jd1=jd1+365
                   endif
      if(jd1.ge.jd70) then
                      iyear=iy
                      go to 20
                      endif
c
   10 continue
      print*,'*** Rogralib/cdatj70: jd70= ',jd70
      print*,'*** Rogralib/cdatj70: jul. day correspond to year GT 3000'
      call uperror_('cdatj70: jul. day correspond to year GT 3000')
c
   20 continue
      jd=jd70-jdp
      call cdatdoy_(jd,iy,imonth,iday)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cdatsoy_(imonth,iday,iyear,ih,im,is,isoy)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_date_and_time to second of the year
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension njn(12),njb(12)
      save njn,njb
c
      data njn/0,31,59,90,120,151,181,212,243,273,304,334/
      data njb/0,31,60,91,121,152,182,213,244,274,305,335/
c
      data epsi  /1.e-35/
      save epsi
c
c
      iyear_mod4=iyear/4
      rb=float(iyear)/4.-float(iyear_mod4)
c
      if(abs(rb).gt.epsi) then
                          nj=njn(imonth)
                          else
                          nj=njb(imonth)
                          endif
c
      isoy=is+im*60+ih*3600+iday*86400+nj*86400
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cdechex_(inu,hnu)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_decimal_to_hex
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*2 hnu
c
c
      inu1=inu/16
      if(inu1.le.9) then
                    hnu(1:1)=char(inu1+48)
                    else
                    hnu(1:1)=char(inu1+87)
                    endif
c
      inu2=inu-inu1*16
c
      if(inu2.le.9) then
                    hnu(2:2)=char(inu2+48)
                    else
                    hnu(2:2)=char(inu2+87)
                    endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cellarc_(x1,y1,x2,y2,a,b,xc,yc,tet1,tet2)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_elliptical_arc from 2 points and a,b
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      pi=acos(-1.)
      pisd=pi/180.
      bsa=b/a
c
c *** calcul de alpha=(tet1+tet2)/2 et beta=(tet1-tet2)/2
c     2 solutions pour alpha et beta
c
      alpha1= -atan(bsa*(x1-x2)/(y1-y2))
      alpha2= -atan(bsa*(x1-x2)/(y1-y2)) +pi
c
      r=sqrt( (b*cos(alpha1))**2 + (a*sin(alpha1))**2)
c
      call cvecmod_(x1-x2, y1-y2, 0., rmod)
c
      beta1=  asin(rmod/(2.*r))
      beta2= -asin(rmod/(2.*r))
c
c *** donc 4 solutions pour tet1 et tet2
c
      tet1a= (alpha1-beta1)
      tet2a= (alpha1+beta1)
c
      tet1b= (alpha1-beta2)
      tet2b= (alpha1+beta2)
c
      tet1c= (alpha2-beta1)
      tet2c= (alpha2+beta1)
c
      tet1d= (alpha2-beta2)
      tet2d= (alpha2+beta2)
c
c *** condition tet2 > tet1 pour elimination de solutions (ita=0)
c
      if(tet1a.gt.tet2a) then
                         ita=0
                         else
                         ita=1
                         endif
c
      if(tet1b.gt.tet2b) then
                         itb=0
                         else
                         itb=1
                         endif
c
      if(tet1c.gt.tet2c) then
                         itc=0
                         else
                         itc=1
                         endif
c
      if(tet1d.gt.tet2d) then
                         itd=0
                         else
                         itd=1
                         endif
c
c *** calcul du centre: 2 solutions x 4 pour teta
c
      xc1a= x1-a*cos(tet1a)
      yc1a= y1-b*sin(tet1a)
c
      xc2a= x2-a*cos(tet2a)
      yc2a= y2-b*sin(tet2a)
      if(abs(xc1a-xc2a).gt.0.0001.or.abs(yc1a-yc2a).gt.0.0001) ita=0
c
c
      xc1b= x1-a*cos(tet1b)
      yc1b= y1-b*sin(tet1b)
c
      xc2b= x2-a*cos(tet2b)
      yc2b= y2-b*sin(tet2b)
      if(abs(xc1b-xc2b).gt.0.0001.or.abs(yc1b-yc2b).gt.0.0001) itb=0
c
c
      xc1c= x1-a*cos(tet1c)
      yc1c= y1-b*sin(tet1c)
c
      xc2c= x2-a*cos(tet2c)
      yc2c= y2-b*sin(tet2c)
      if(abs(xc1c-xc2c).gt.0.0001.or.abs(yc1c-yc2c).gt.0.0001) itc=0
c
c
      xc1d= x1-a*cos(tet1d)
      yc1d= y1-b*sin(tet1d)
c
      xc2d= x2-a*cos(tet2d)
      yc2d= y2-b*sin(tet2d)
      if(abs(xc1d-xc2d).gt.0.0001.or.abs(yc1d-yc2d).gt.0.0001) itd=0
c
c *** choix des solutions; il ne doit en rester qu'une
c
      isol=0
c
      if(ita.eq.1) then
                   isol=isol+1
                   xc=xc1a
                   yc=yc1a
                   tet1=tet1a
                   tet2=tet2a
                   endif
c
      if(itb.eq.1) then
                   isol=isol+1
                   xc=xc1b
                   yc=yc1b
                   tet1=tet1b
                   tet2=tet2b
                   endif
c
      if(itc.eq.1) then
                   isol=isol+1
                   xc=xc1c
                   yc=yc1c
                   tet1=tet1c
                   tet2=tet2c
                   endif
c
      if(itd.eq.1) then
                   isol=isol+1
                   xc=xc1d
                   yc=yc1d
                   tet1=tet1d
                   tet2=tet2d
                   endif
c
      if(isol.eq.0) call uperror_('cellarc_:pas de solution !!!')
      if(isol.gt.1) call uperror_('cellarc_:plusieurs solutions !!! ')
c
      tet1=tet1/pisd
      tet2=tet2/pisd
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cfiggra_(xmin,xmax,x1,x2,bgx,sgx,fx)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_figure_graduations from xmin and xmax dat
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character fx*(*)
c
      data rmax  /1.e+35/
      data epsi  /1.e-35/
      save rmax,epsi
c
c     calcule les parametres de graduation de  l'histogramme
c
c
      ll=len(fx)
      if(ll.lt.8) call uperror_('cfiggra_: format < 8 caracteres')
c
      xmi=xmin
      xma=xmax
c
      if(abs(xmi).lt.epsi) xmi=0.
      if(abs(xma).gt.rmax) xma=sign(rmax,xma)
c
      if(abs(xma-xmi).lt.epsi) then
           call upwarni_('cfiggra_: min and max of array are identical')
                               if(abs(xmi).lt.epsi) then
                                                    xmi=-1.e-31
                                                    xma= 1.e-31
                                                    else
                                                    xma=xmi*1.001
                                                    xmi=xmi*0.999
                                                    endif
                               endif
c
      call cgraste_(xmi,xma,bgx,sgx,x1,x2)
      call cgrafor_(x1,x2,bgx,fx)
      call uverfor_(fx,'cfiggra')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cfiggraa(x,n,x1,x2,bgx,sgx,fx)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_figure_graduations_array from 1 array x(n)
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension x(n)
      character*(*) fx
c
c
c *** calcule les parametres de graduation de la courbe x(n)
c
c
      ll=len(fx)
      if(ll.lt.8) call uperror_('cfiggraa: format < 8 caracteres')
c
      call cminmax_(x,n,xmi,xma)
c
      call cfiggra_(xmi,xma,x1,x2,bgx,sgx,fx)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cfigpag_(fx,fy,px,py)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_figure_to_page_units
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /figlim/ x1,x2,y1,y2
      common /figsiz/ rx,ry
      common /figori/ xz,yz
      common /figsca/ ex,ey
      common /figout/ ifigout
c
c
      px=xz+(fx-x1)/ex
      py=yz+(fy-y1)/ey
c
c *** on empeche evnetuellement de depasser les bords de la figure
c
      if(ifigout.eq.0) then
                       if(px.lt.xz) px=xz
                       if(py.lt.yz) py=yz
c
                       xf=xz+rx
                       yf=yz+ry
c
                       if(px.gt.xf) px=xf
                       if(py.gt.yf) py=yf
                       endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cfonbod_(numfon,height,fonbod)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_font_body from fontyp number and height
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
c *** taile en cm pour la fonte 10 suivant le type
c
      if(numfon.ge.1.and.numfon.le. 4) hh= 98.2/500.
      if(numfon.ge.5.and.numfon.le. 8) hh=119.3/500.
      if(numfon.ge.9.and.numfon.le.12) hh=129.0/500.
      if(numfon.eq.13                ) hh=119.0/500.
c
c *** calcul du corps
c
      fonbod= 10.*height/hh
c
      if(abs(fonbod).gt.1000.) fonbod=1000.
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cfonnum_(fontyp,numfon)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_font_number from fontyp, as 7 for 'tital'
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) fontyp
      character*(5) fonava(13)
      character*255 com
      save fonava,com
c
c
      call sdr_gfontyp(fonava,nbfon)
c
      lf= min(5,len(fontyp))
c
      do 10 i=1,nbfon
      if(fontyp(1:lf).eq.fonava(i)(1:lf)) go to 20
   10 continue
c
      write(com,100) (fonava(j),j=1,nbfon)
  100 format(20(a,', '))
      call cchalen_(com,ncom)
      call upwarni_('cfonnum_: Unknowed fontyp type, set to Courier')
      call upwarni_('cfonnum_: possible fontyps: '//com(1:ncom))
      numfon= 1
c
   20 continue
      numfon=i
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cfontyp_(numfon,fontyp)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_font_type from numfon as 'tital' for 7
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) fontyp
      character*5 fonava(13)
      save fonava
c
c
      call sdr_gfontyp(fonava,nbfon)
c
      fontyp=fonava(numfon)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cgrafor_(x1,x2,bgx,fx)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_graduations_format from axe's boundaries+big step
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) fx
      character*8 fx1,fx2,fx3
      character*1 if1,if2,if3,ifg
      save fx1,fx2,fx3, if1,if2,if3,ifg
c
      data epsi  /1.e-35/
      save epsi
c
c *** calcule le format des graduations d'apres x1,x2 et bgx
c
c
      ll=len(fx)
      if(ll.lt.8) call uperror_('cgrafor_: format <  8 caracteres')
      if(x1.gt.x2)         call uperror_('cgrafor_: x1 > x2')
      if((x2-x1) .lt.epsi) call uperror_('cgrafor_: x1 = x2')
      if(abs(bgx).lt.epsi) call uperror_('cgrafor_: bgx nul')
c
      nbsti=int((x2-x1)/bgx)
c
      a1=x1
      a2=x1+bgx
      a3=x1+float(nbsti)*bgx
c
      call cbesfor_(a1,fx1)
      call cbesfor_(a2,fx2)
      call cbesfor_(a3,fx3)
c
      call udecfor_(fx1,if1,n1,nd1)
      call udecfor_(fx2,if2,n2,nd2)
      call udecfor_(fx3,if3,n3,nd3)
c
      aama=amax1(abs(a1),abs(a2),abs(a3))
c
      if(abs(a1)/aama.lt.1.e-5) then
                                n1=0
                                nd1=0
                                if1='i'
                                endif
c
      if(abs(a2)/aama.lt.1.e-5) then
                                n2=0
                                nd2=0
                                if2='i'
                                endif
c
      if(abs(a3)/aama.lt.1.e-5) then
                                n3=0
                                nd3=0
                                if3='i'
                                endif
c
      n =max(n1,n2,n3)
      nd=max(nd1,nd2,nd3)
c
      ifg='i'
      if(if1.eq.'f'.or.if2.eq.'f'.or.if3.eq.'f') ifg='f'
      if(if1.eq.'e'.or.if2.eq.'e'.or.if3.eq.'e') ifg='e'
c
      call uencfor_(fx,ifg,n,nd)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cgraste_(x1,x2,bgx,sgx,x1a,x2a)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_graduations_steps from axe's boundaries
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /n_marques/ n_tick_min,n_tick_max
c
      data epsi  /1.e-35/
      data epsi2 /1.e-06/
      save epsi,epsi2
c
c *** calcule les graduations et arondi les bornes
c
c
      if(abs(x2-x1).lt.epsi) call uperror_('cgraste: x1=x2')
c
      if(x1*x2.ge.0.) go to 40
c
c ***  x1 negatif et x2 positif
c
      x1a=abs(x1)
      x2a=abs(x2)
      xsa=epsi
      if(x1a.gt.xsa) xsa=x1a
      if(x2a.gt.xsa) xsa=x2a
      if(xsa.lt.epsi) call uperror_(
     &                   'cgraste:1 for x1<0 and x2>0, then dx<epsilum')
      call cxtouim_(xsa)
      if(xsa.lt.epsi) call uperror_(
     &                   'cgraste:2 for x1<0 and x2>0, then dx<epsilum')
      call ucgraste(xsa,bgx,sgx)
c
      if(x1a.gt.x2a) then
                     x1a=sign(xsa,x1)
                     n=int(x2a/bgx)+1
                     x2a=float(n)*bgx
c
                     else
                     x2a=sign(xsa,x2)
                     n=int(x1a/bgx)+1
                     x1a=-float(n)*bgx
                     endif
      go to 80
c
   40 continue
c
c *** x1 et x2 meme signe
c
      if(abs(x2).gt.abs(x1)) go to 50
c
c *** x1 et x2 negatifs
c
      x1a=x1
      x2a=x2
      call cxtolim_(x1a)
c
c     salade sur la precision de la difference
c     on met x2a a la valeur donne par sa precision limitee a 4 chiffres
c
      dx=x2a-x1a
      call cxtouim_(dx)
      preci=dx/x1a
      call cmanexp_(preci,rman,ipreci)
      ipreci=iabs(ipreci)
      if(ipreci.gt.4) ipreci=4
      x2a=x1a+dx
      call cxtogpr_(x2a,ipreci)
c
c     recalcul de dx avec un x2a a 4 chiffres seulement
c
      dx=x2a-x1a
      call cxtouim_(dx)
      if(dx.lt.epsi) call uperror_(
     &                   'cgraste:3 for x1<0 and x2<0, then dx<epsilum')
      call ucgraste(dx,bgx,sgx)
      go to 80
c
   50 continue
c
c *** x1 et x2 positifs
c
      x1a=x1
      x2a=x2
      call cxtouim_(x2a)
c
c     salade sur la precision de la difference
c     on met x1a a la valeur donne par sa precision limitee a 4 chiffres
c
      dx=x2a-x1a
c /// dbug print*, 'cgraste 1 :x1,x2,x2a,dx=',x1,x2,x2a,dx
      call cxtouim_(dx)
c /// dbug print*, 'cgraste 2 :dx,preci,ipreci,x1a=',dx,preci,ipreci,x1a
      preci=dx/x2a
      call cmanexp_(preci,rman,ipreci)
      ipreci=iabs(ipreci)
      if(ipreci.gt.4) ipreci=4
      x1a=x2a-dx
      call cxtogpr_(x1a,ipreci)
c
c     recalcul de dx avec un x1a a 4 chiffres seulement
c
      dx=x2a-x1a
      call cxtouim_(dx)
      if(dx.lt.epsi) call uperror_(
     &                   'cgraste:4 for x1>0 and x2>0, then dx<epsilum')
      call ucgraste(dx,bgx,sgx)
c
   80 continue
c
c *** ajustement fin des bornes commun aux 3 possibilites
c
c
c *   on enleve les grandes marques inutiles
c
      n1=int((x1-x1a)/bgx+epsi2)
      n2=int((x2a-x2)/bgx+epsi2)
c
      x1a=x1a+float(n1)*bgx
      x2a=x2a-float(n2)*bgx
c
      ngm=int((x2a-x1a)/bgx+epsi2)
c
c *   si on n'a pas assez de grandes marques, on recalcule bgx et sgx
c     et re-ajustement fin
c
      if(ngm.lt.n_tick_min) then
                   bgx1=bgx*2.
                   call ucgraste(bgx1,bgx,sgx)
clm                   bgx=bgx
clm                   sgx=sgx
c
                   n1=int((x1-x1a)/bgx+epsi2)
                   n2=int((x2a-x2)/bgx+epsi2)
c
                   x1a=x1a+float(n1)*bgx
                   x2a=x2a-float(n2)*bgx
c
                   ngm=int((x2a-x1a)/bgx+epsi2)
                   endif
c
c *   si on a trop de grandes marques, on recalcule bgx et sgx
c     et re-ajustement fin
c
      if(ngm.gt.n_tick_max) then
                   bgx=bgx*2.
                   sgx=sgx*2.
c
                   n1=int((x1-x1a)/bgx+epsi2)
                   n2=int((x2a-x2)/bgx+epsi2)
c
                   x1a=x1a+float(n1)*bgx
                   x2a=x2a-float(n2)*bgx
c
                   ngm=int((x2a-x1a)/bgx+epsi2)
                   endif
c     Si on n'a qu'une grande marque, on recalcule bgx et sgx
c     et re-ajustement fin
      if(ngm.eq.1) then
                   bgx1=bgx
                   call ucgraste(bgx1,bgx,sgx)
                   bgx=bgx*2.
                   sgx=sgx*2.
c
                   n1=int((x1-x1a)/bgx+epsi2)
                   n2=int((x2a-x2)/bgx+epsi2)
c
                   x1a=x1a+float(n1)*bgx
                   x2a=x2a-float(n2)*bgx
c
                   ngm=int((x2a-x1a)/bgx+epsi2)
c
c *                re-belote si une seule grande marque, mais  on  ne
c                  fait pas de re-ajustement des bornes
c
                   if(ngm.eq.1) then
                                bgx2=bgx
                                call ucgraste(bgx2,bgx,sgx)
                                ngm=int((x2a-x1a)/bgx+epsi2)
                                endif
                   endif
c
c *   test si ngm est bien >0
c
      if(ngm.lt.1) then
                   x1a=x1a-bgx
                   x2a=x2a+bgx
                   call upwarni_('Number of big sticks < 1 in cgraste_')
                   return
                   endif
c
c *   on a bien ngm >1, on gratte les petites marques de la borne sup.
c
      nsginu=int((x2a-x2)/sgx +epsi2)
      x2a=x2a-float(nsginu)*sgx
c
c     on evite que le maximum touche le haut: ecart de 4% minimum
c
      dmin=0.04*(x2a-x1a)
      dact=x2a-x2
      if(dact.lt.dmin) then
                           nsg=int(dmin/sgx +0.5)
                           nsg=max(nsg,1)
                           nsg=min(nsg,9)
                           x2a=x2a+float(nsg)*sgx
                           endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cgrasts_(x1,x2,bgx,sgx,x1a,x2a)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_graduations_steps_simple with x2a=-x1a=bgx
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c *** calcule les graduations et arondi les bornes x1a=-x2a
c
      data epsi  /1.e-35/
      save epsi
c
      if(abs(x2-x1).lt.epsi) call uperror_('cgrasts: x1=x2')
      call cgraste_(x1,x2,bgx,sgx,x1a,x2a)
c
      if(abs(x1a).gt.bgx) bgx=abs(x1a)
      if(abs(x2a).gt.bgx) bgx=abs(x2a)
      sgx=bgx/2.
      x1a=-bgx
      x2a= bgx
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine chsbrgb_(hue,sat,bri,r,g,b)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_hsb_to_rgb
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      rhue=hue
      rsat=sat
      rbri=bri
c
      call ubounds_(rhue,0.,1.)
      call ubounds_(rsat,0.,1.)
      call ubounds_(rbri,0.,1.)
c
      if(rsat.lt.1.e-20) then
                        r=rbri
                        g=rbri
                        b=rbri
                        return
                        endif
c
c *** modif PR par rapport a l'algo de base pour que on ait bien
c     chsbrvb * crvbhsb reciproque
c
      rbri2=rbri/2.
c
      if(rbri2.lt.0.5) then
                     rm2=rbri2*(1.+rsat)
                     else
                     rm2=rbri2 +rsat -rbri2*rsat
                     endif
c
      rm1=2.*rbri2 - rm2
c
      call uhuergb_(rm1,rm2,rhue+1./3.,r)
      call uhuergb_(rm1,rm2,rhue      ,g)
      call uhuergb_(rm1,rm2,rhue-1./3.,b)
c
c XX     call ubounds_(r,0.,1.)
c XX     call ubounds_(g,0.,1.)
c XX     call ubounds_(b,0.,1.)
c
c
c *** autre methode - marche que pour S=1 ou 0
c
c /// unti=1./3.
c /// pisd=3.1415927/180.
c /// hdeg=rhue*360.
c
c /// if(hdeg.le.120.) then
c ///               b=unti*(1-rsat)
c ///               r=unti*(1.+rsat*cos(hdeg*pisd)/cos((60.-hdeg)*pisd))
c ///               g= 1-(b+r)
c
c ///               r=r*bri
c ///               g=g*bri
c ///               b=b*bri
c ///               return
c ///               endif
c
c /// if(hdeg.le.240.) then
c ///               hdeg=hdeg-120.
c ///               r=unti*(1-rsat)
c ///               g=unti*(1.+rsat*cos(hdeg*pisd)/cos((60.-hdeg)*pisd))
c ///               b= 1-(r+g)
c
c ///               r=r*bri
c ///               g=g*bri
c ///               b=b*bri
c ///               return
c ///               endif
c
c /// if(hdeg.le.360.) then
c ///               hdeg=hdeg-240.
c ///               g=unti*(1-rsat)
c ///               b=unti*(1.+rsat*cos(hdeg*pisd)/cos((60.-hdeg)*pisd))
c ///               r= 1-(g+b)
c
c ///               r=r*bri
c ///               g=g*bri
c ///               b=b*bri
c ///               return
c ///               endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cicorgb_(ico,ir,ig,ib)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_ico_to_rgb ico [0-16777215] ir,ig,ib [0-255]
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c     ex: pour ico=8332313 -> (ir,ig,ib)=(127,36,25)
c
      ir= ico/65536
      ig=(ico - ir*65536)/256
      ib= ico - ir*65536 - ig*256
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cimahsy_(ima,nx,ny)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_image_to_horizontal_symetrie
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      integer ima(nx,ny)
c
c
      nx2=nx/2
c
      do 10 ix=1,nx2
      jx=nx+1-ix
c
      do 10 iy=1,ny
      isave=ima(ix,iy)
      ima(ix,iy)=ima(jx,iy)
      ima(jx,iy)=isave
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cimasizc(cima,nxmax,nx,ny)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_image_size_character cima(nxmax,ny) ->cima(nx,ny)
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c     permet d'utiliser un tableau dimensionne a (nx,ny) dans une
c     subroutine alors qu'il est dimensionne a (nxmax,nymax) dans le
c     programme principal. Il ne peut plus ensuite etre utilise
c     normalement dans le programme principal.
c
      character*(*) cima(nxmax*ny)
c
c
      kt=0
      kr=0
c
      do j=1,ny
      do i=1,nxmax
      kt=kt+1
      if(i.le.nx) then
                  kr=kr+1
                  cima(kr)=cima(kt)
                  endif
      enddo
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cimasizi(iima,nxmax,nx,ny)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_image_size_integer iima(nxmax,ny) to iima(nx,ny)
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c     permet d'utiliser un tableau dimensionne a (nx,ny) dans une
c     subroutine alors qu'il est dimensionne a (nxmax,nymax) dans le
c     programme principal. Il ne peut plus ensuite etre utilise
c     normalement dans le programme principal.
c
      integer iima(nxmax*ny)
c
c
      kt=0
      kr=0
c
      do j=1,ny
      do i=1,nxmax
      kt=kt+1
      if(i.le.nx) then
                  kr=kr+1
                  iima(kr)=iima(kt)
                  endif
      enddo
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cimasizr(rima,nxmax,nx,ny)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_image_size_real  rima(nxmax,ny) to rima(nx,ny)
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c     permet d'utiliser un tableau dimensionne a (nx,ny) dans une
c     subroutine alors qu'il est dimensionne a (nxmax,nymax) dans le
c     programme principal. Il ne peut plus ensuite etre utilise
c     normalement dans le programme principal.
c
      real rima(nxmax*ny)
c
c
      kt=0
      kr=0
c
      do j=1,ny
      do i=1,nxmax
      kt=kt+1
      if(i.le.nx) then
                  kr=kr+1
                  rima(kr)=rima(kt)
                  endif
      enddo
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cleayea_(iyear,ileap)
c
c
c     ---------------------------------------------------------------+--
c *   Object : compute_leap_year with ileap=1 for leap year, 0 if not
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992 (Rocotlib)
c
c *   input  : iyear (ex: 1980)
c *   output : ileap (1 or 0 if iyear is or not a leap year)
c     ---------------------------------------------------------------+--
c
      if(iyear.lt.1900) then
                    print*,'*** Rogralib/cleayea_: iyear= ',iyear
                    print*,'*** Rogralib/cleayea_: iyear must be > 1900'
                    call uperror_('cleayea_: iyear must be > 1900')
                        endif
c
      ir=iyear-(iyear/4)*4
      if(ir.eq.0) then
                  ileap=1
                  else
                  ileap=0
                  endif
c
      is=iyear-(iyear/100)*100
      if(is.eq.0) then
                  ir=iyear-(iyear/400)*400
                  if(ir.eq.0) then
                              ileap=1
                              else
                              ileap=0
                              endif
                  else
                  return
                  endif
c
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cmanexp_(x,rma,ie)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_mantisse_and_exponent
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c *   revision 2007 pour les valeurs negatives
c
      data epsi  /1.e-36/
      save epsi
c
c
      if(abs(x).lt.epsi) then
                         rma=0.
                         ie=0
                         return
                         endif
c
      xx=abs(x)
      if(xx.gt.1.) then
                   ie=int(alog10(xx))+1
                   else
                   ie=int(alog10(xx))
                   endif
c /// dbug    print*, 'cmanexp 1 : x,xx,ie=',x,xx,ie
c
      call ctenpon_(ie,die)
c /// dbug    print*, 'cmanexp 2 : ie,die=',ie,die
c
      rma=xx/die
c
      if(rma.lt.0.1) then
                     rma=rma*10.
                     ie=ie-1
                     endif
c
      if(rma.ge.1.) then
                    rma=rma/10.
                    ie=ie+1
                    endif
c
      rma=sign(rma,x)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cmatlim_(rma,nx,ny,rmamin,rmamax)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_matrice_limits of rma(nx,ny)
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      real rma(nx,ny)
c
      data rmax  /1.e+35/
      data epsi  /1.e-35/
      save rmax,epsi
c
      rmamin=  rmax
      rmamax= -rmax
c
      do 10 ix=1,nx
      do 10 iy=1,ny
      if(rma(ix,iy).lt.rmamin) rmamin=rma(ix,iy)
      if(rma(ix,iy).gt.rmamax) rmamax=rma(ix,iy)
   10 continue
c
      sdx=rmamax-rmamin
      adx=abs(sdx)
      if(adx.lt.epsi) then
                call upwarni_('cmatlim_: min & max of array identical')
                 print*, 'min=',rmamin,' max=',rmamax
                 if(abs(rmamin).lt.epsi) rmamin=0.
                 rmamax=rmamin*1.01
                 print*, 'tooked values min=',rmamin,' max=',rmamax
                 print*
                 endif
c
      if(sdx.lt.0.) then
                    call upwarni_('cmatlim_: min greater than max')
                    print*, 'min=',rmamin,' max=',rmamax
                    if(abs(rmamin).lt.epsi) rmamin=0.
                    rmamax=rmamin*1.01
                    print*, 'tooked values min=',rmamin,' max=',rmamax
                    print*
                    endif
c
      if(abs(rmamin-rmax).lt.epsi)
     &                           call uperror_('cminma2: xmin unknowed')
      if(abs(rmamax+rmax).lt.epsi)
     &                           call uperror_('cminma2: xmax unknowed')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cmatlimp(rma,nx,ny,rmamin,rmamax,ixmi,iymi,ixma,iyma)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_matrice_limits_positions of rma(nx,ny)
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      real rma(nx,ny)
c
      data rmax  /1.e+35/
      data epsi  /1.e-35/
      save rmax,epsi
c
      rmamin=  rmax
      rmamax= -rmax
c
      do 10 ix=1,nx
      do 10 iy=1,ny
      if(rma(ix,iy).lt.rmamin) then
                               rmamin=rma(ix,iy)
                               ixmi=ix
                               iymi=iy
                               endif
      if(rma(ix,iy).gt.rmamax) then
                               rmamax=rma(ix,iy)
                               ixma=ix
                               iyma=iy
                               endif
   10 continue
c
      sdx=rmamax-rmamin
      adx=abs(sdx)
      if(adx.lt.epsi) then
                call upwarni_('cmatlimp: min & max of array identical')
                 print*, 'min=',rmamin,' max=',rmamax
                 if(abs(rmamin).lt.epsi) rmamin=0.
                 rmamax=rmamin*1.01
                 print*, 'tooked values min=',rmamin,' max=',rmamax
                 print*
                 endif
c
      if(sdx.lt.0.) then
                    call upwarni_('cmatlimp: min greater than max')
                    print*, 'min=',rmamin,' max=',rmamax
                    if(abs(rmamin).lt.epsi) rmamin=0.
                    rmamax=rmamin*1.01
                    print*, 'tooked values min=',rmamin,' max=',rmamax
                    print*
                    endif
c
      if(abs(rmamin-rmax).lt.epsi)
     &                           call uperror_('cminma2: xmin unknowed')
      if(abs(rmamax+rmax).lt.epsi)
     &                           call uperror_('cminma2: xmax unknowed')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cminmax_(ax,n,axmin,axmax)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_mini_maxi of array ax(n)
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      real ax(n)
c
      data rmax  /1.e+35/
      data epsi  /1.e-35/
      save rmax,epsi
c
c
      axmin= rmax
      axmax=-rmax
c
      kmin=0
      kmax=0
c
      do 10 i=1,n
      if(ax(i).lt.axmin) then
                         axmin=ax(i)
                         kmin=1
                         endif
      if(ax(i).gt.axmax) then
                         axmax=ax(i)
                         kmax=2
                         endif
   10 continue
c
      if(kmin.eq.0.or.kmax.eq.0) then
                 call upwarni_('cminmax: min et max of array undefined')
                 print*, 'array content undefined, set to zero'
                 print*, 'min and max set to 0. and 1.e-30'
                 axmin=0.
                 axmax=1.e-30
                 do 20 i=1,n
                 ax(i)=0.
   20            continue
                 return
                                 endif
c
c
      sdx=axmax-axmin
      adx=abs(sdx)
      if(adx.lt.epsi) then
                 call upwarni_('cminmax: min et max of array identical')
                 print*, 'min=',axmin,' max=',axmax
                 if(abs(axmin).lt.epsi) axmin=0.
                 axmax=axmin+epsi*1.e6
                 print*, 'tooked values min=',axmin,' max=',axmax
                 print*
                 endif
c
      if(sdx.lt.0.) then
                    call upwarni_('cminmax: min greater than max')
                    print*, 'min=',axmin,' max=',axmax
                    if(abs(axmin).le.epsi) then
                                           axmin=0.
                                           axmax=epsi
                                           else
                                           axmax=axmin+abs(axmin)
                                           endif
                    print*, 'tooked values min=',axmin,' max=',axmax
                    print*
                    endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cmodpha_(cbx,rmx,rpx)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_module_phase of oa complex number
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      complex cbx
c
      pisd=acos(-1.)/180.
c
      rmx=cabs(cbx)
c
      rpx=atan2(aimag(cbx),real(cbx))/pisd
c
      if(rmx.lt.1.e-36) rpx=0.
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cmoncar_(imonth,cmonth)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_month_number_to_char 3-> 'March' (cmonth*9)
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) cmonth
      character*9   cmon12(12)
      save cmon12
c
      data cmon12/'January','February','March','April','May','June',
     &      'July','August','September','October','November','December'/
c
      im=imonth
      if(im.lt. 1) im= 1
      if(im.gt.12) im=12
c
      cmonth=cmon12(im)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cpagfig_(px,py,fx,fy)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_page_to_figure_units
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figlim/ x1,x2,y1,y2
      common /figori/ xz,yz
      common /figsca/ ex,ey
c
c
      fx=x1+(px-xz)*ex
      fy=y1+(py-yz)*ey
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cplarot_(xc,yc,angle,x1,y1,x2,y2)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_plane_rotation from center and angle
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      data epsi  /1.e-35/
      save epsi
c
      pisd=acos(-1.)/180.
c
      if(abs(x1-xc).lt.epsi.and.abs(y1-yc).lt.epsi) then
                                                    x2=x1
                                                    y2=y1
                                                    return
                                                    endif
c
      st=sin(angle*pisd)
      ct=cos(angle*pisd)
c
      xp=x1-xc
      yp=y1-yc
c
      r=sqrt(xp*xp + yp*yp)
c
      sa=yp/r
      ca=xp/r
c
      sapt=sa*ct + st*ca
      capt=ca*ct - sa*st
c
      x2=r*capt + xc
      y2=r*sapt + yc
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cpolcar_(r,teta,x,y)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_polar_to_cartesian degrees
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      pisd=acos(-1.)/180.
c
c
      tetar=teta*pisd
      x=r*cos(tetar)
      y=r*sin(tetar)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cranval_(ranval)
c
c     ---------------------------------------------------------------0--
c *   Object : compute_random_value between 0. and 1.
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------0--
c
c     ------------------------------------------------------------------
c     BY P.W.DALY, patch the RANDOM function to portable RANDIM
c     modified P. Robert, september 1994
c     output: ranval between 0. and 1.
c     ------------------------------------------------------------------
c     Random Number Generators
c     From Numerical Recipes chapter 7.1
c
c     modified P. robert, september 1994
c
c     RANDIM(idum)  -  portable (i.e. machine independent)
c                      no sequential correlations
c                      virtually infinite period
c                      high and low order done separately
c                      BUT is relatively slow
c
c     Routines return a uniform random deviate between 0.0 and 1.0.
c     Set IDUM to any negative value to initialize or reinitialize the
c     sequence.
c     ------------------------------------------------------------------
c
      dimension r(97)
      parameter (m1=259200,ia1=7141,ic1=54773,rm1=1./float(m1))
      parameter (m2=134456,ia2=8121,ic2=28411,rm2=1./float(m2))
      parameter (m3=243000,ia3=4561,ic3=51349)
      data iff/0/
clm>
      save r,iff
clm<
c
c *** modi intro PR pour eviter l'argument idum
c
      data idum /-2/
      save idum
c
      idum=idum+1
c *** fin de modif
c
      if(idum.lt.0.or.iff.eq.0) then
        iff=1
        ix1=mod(ic1-idum,m1)
        ix1=mod(ia1*ix1+ic1,m1)
        ix2=mod(ix1,m2)
        ix1=mod(ia1*ix1+ic1,m1)
        ix3=mod(ix1,m3)
c
        do 10 j=1,97
          ix1=mod(ia1*ix1+ic1,m1)
          ix2=mod(ia2*ix2+ic2,m2)
          r(j)=(float(ix1)+float(ix2)*rm2)*rm1
   10  continue
c
        idum=1
      endif
c
      ix1=mod(ia1*ix1+ic1,m1)
      ix2=mod(ia2*ix2+ic2,m2)
      ix3=mod(ia3*ix3+ic3,m3)
      j=1+(97*ix3)/m3
      if(j.gt.97.or.j.lt.1) stop '*** pb cranval_, j.gt.97.or.j.lt.1'
      ranval=r(j)
      r(j)=(float(ix1)+float(ix2)*rm2)*rm1
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine crgbhsb_(r,g,b,hue,sat,bri)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_rgb_to_hsb all [0.-1.]
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      rr=r
      gg=g
      bb=b
      epsi2=1.e-6
      hue=99.99
      sat=99.99
      bri=99.99
c
      call ubounds_(rr,0.,1.)
      call ubounds_(gg,0.,1.)
      call ubounds_(bb,0.,1.)
c
      c1=min(rr,gg,bb)
      c2=max(rr,gg,bb)
c
      bri=(c1+c2)/2.
c
      if(abs(c2-c1).lt.epsi2) then
c                             *** couleur indefinie
                              sat=0.
                              hue=0.
                              return
                              endif
c
      if(bri.lt.0.5) then
                     sat=(c2-c1)/(c2+c1)
                     else
                     sat=(c2-c1)/(2.-c2-c1)
                     endif
c
      if(abs(rr-c2).lt.epsi2) then
                              hue=(gg-bb)/(c2-c1)
                              else
                        if(abs(gg-c2).lt.epsi2) then
                                                hue=2. + (bb-rr)/(c2-c1)
                                                else
                                                hue=4. + (rr-gg)/(c2-c1)
                                                endif
                               endif
c
      hue=hue/6.
      if(hue.lt.0.) hue=hue+1.
c
c *** modif PR
      bri=2.*bri
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine crgbico_(ir,ig,ib,ico)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_rgb_to_ico ir,ig,ib [0-255] ico [0-16777215]
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c     ex: pour (ir,ig,ib)=(127,36,25) -> ico=8332313
c
c     ico est le numero de la couleur parmis les 16 M (256**3)
c
      call uboundi_(ir,0,255)
      call uboundi_(ig,0,255)
      call uboundi_(ib,0,255)
c
      ico= 65536*ir + 256*ig + ib
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cscahis_(sca,nx,ny,scamin,scamax,isto,n)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_scalar_istogramme of sca(nx,ny) for n levels
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      real      sca(nx,ny)
      integer  isto(n)
c
c
      do 10 ih=1,n
      isto(ih)=0
   10 continue
c
c *** calcul de l'histogramme de l'image
c
      scalong=scamax-scamin
      if(scalong.lt.1.e-30) call uperror_('cscahis_: max .le. min')
c
      do 20 ix=1,nx
      do 20 iy=1,ny
c
      niv=int(((sca(ix,iy)-scamin)/scalong )*float(n-1)) +1
      if(niv.lt.1) niv=1
      if(niv.gt.n) niv=n
c
      do 30 ih=1,n
      if(niv.eq.ih) isto(ih)=isto(ih)+1
   30 continue
   20 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cscaima_(sca,nx,ny,scamin,scamax,ima,sbla,swhi)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_scalar_to_image sca(nx,ny),ima(nx,ny) (ico unit)
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /colmap/ hueu,satu,briu,nbcolu
c
      real hueu(256),satu(256),briu(256)
c
      real    sca(nx,ny)
      integer ima(nx,ny), ico(256)
      save ico
c
c     On etale l'image entre les valeurs scamin et scamax de sca(nx,ny)
c     On met en noir  ce qui est inferieur a sbla (seuil du black)
c     On met en blanc ce qui est superieur a swhi (seuil du white)
c     pas de noir et blanc si sbla=swhi
c
c *** conversion de la colormap courante en rgb
c
      do 10 i=1,nbcolu
c
      call chsbrgb_(hueu(i),satu(i),briu(i),r,g,b)
c
      ir=int(r*255.)
      ig=int(g*255.)
      ib=int(b*255.)
c
      call crgbico_(ir,ig,ib,ico(nbcolu+1-i)) ! voir le sens bleu->rouge
c
   10 continue
c
c *** valeurs du noir et du blanc
c
      call crgbico_(  0,  0,  0,inoir)
      call crgbico_(255,255,255,iblan)
c
c *** calcul de l'image sur scamin a scamax
c     valeurs hors sbla a swhi en noir ou blanc
c
      scalong=scamax-scamin
      if(scalong.lt.1.e-30) call uperror_('cscaima_: max .le. min')
c
      do 20 ix=1,nx
      do 20 iy=1,ny
c
      niv=int(((sca(ix,iy)-scamin)/scalong )*float(nbcolu-1)) +1
c
      if(niv.lt. 1) niv= 1
      if(niv.gt.nbcolu) niv=nbcolu
      ima(ix,iy)=ico(niv)
c
      epsilon=abs(scalong*1.E-4)
c
      if ((swhi-sbla).gt.epsilon) then
             if(sca(ix,iy).lt.sbla) ima(ix,iy)=inoir
             if(sca(ix,iy).gt.swhi) ima(ix,iy)=iblan
      endif
c
   20 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cscalog_(sca,nx,ny,valzer,valneg)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_scalar_image_to_log_values
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      real sca(nx,ny)
      real valzer,valneg
c
c
c *** le passage en log n'est possible que pour sca <1.e-20
c     on peut imposer des valeurs pour sca=0 et sca <0
c     sca(nx,ny)=alog10(sca(nx,ny))
c
      do 10 ix=1,nx
      do 10 iy=1,ny
      if(sca(ix,iy).gt.1.e-20) then
                               sca(ix,iy)=alog10(sca(ix,iy))
                               else
                               if(sca(ix,iy).lt.0.) then
                                                    sca(ix,iy)= valneg
                                                    else
                                                    sca(ix,iy)= valzer
                                                    endif
                               endif
   10 continue
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cscamul_(sca,nx,ny,rmul)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_scalar_image_to_sca*rmul
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      real sca(nx,ny)
c
c     sca(nx,ny)=sca(nx,ny)*rmul
c
      do 10 ix=1,nx
      do 10 iy=1,ny
      sca(ix,iy)=sca(ix,iy)*rmul
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cscasli_(sca,nx,ny,scamin,scamax,pcmin,pcmax)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_scalar_significant_min_max sca(nx,ny) %min, %max
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      real sca(nx,ny)
      integer isto(20)
c
      data nhis /20/
      save isto,nhis
c
c *** calcul des min et max significatif pour le calcul
c     d'une image et sa visualisation
c
c *** calcul des min et max vrais
c
      call cmatlim_(sca,nx,ny,scamin,scamax)
      call cscahis_(sca,nx,ny,scamin,scamax,isto,nhis)
c
c *** calcul du nb de points de l'histrogramme
c
      nbp=0
c
      do 10 i=1,nhis
      nbp=nbp+isto(i)
   10 continue
c
clm      nbmin= nbp*pcmin/100.
clm      nbmax= nbp*pcmax/100.
      nbmin= int(float(nbp)*pcmin/100.)
      nbmax= int(float(nbp)*pcmax/100.)
      dx= (scamax-scamin)/float(nhis)
c
c *** elimination des premieres colonnes de l'histogramme
c     si elles ne contiennent pas assez de points
c     (moins de percen % du total)
c
      do 20 i=1,nhis
      if(isto(i).lt.nbmin) then
                           scamin=scamin+dx
                           else
                           go to 30
                           endif
   20 continue
   30 continue
c
      do 40 i=1,nhis
      if(isto(nhis-i+1).lt.nbmax) then
                                  scamax=scamax-dx
                                  else
                                  go to 50
                                  endif
   40 continue
   50 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine csigdig_(x,nosd)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_significant_digits for a real number
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*15 mot
      save mot
c
c *** calcule le nb. de chiffre significatif  de x (max 6)
c
c
      call cmanexp_(x,rma,ie)
c
      write(mot,1) rma
c
c ///      if(mot(10:10).eq.'9') then
c ///                            if(x.gt.0.) x=x +0.1e-6*(10.**ie)
c ///                            if(x.lt.0.) x=x -0.1e-6*(10.**ie)
c ///                            call cmanexp_(x,rma,ie)
c ///                            write(mot,1) rma
c ///                            endif
c
      do 10 i=1,6
      nosd=7-i
      ii=10-i
      if(mot(ii:ii).ne.'0') return
   10 continue
c
    1 format(f9.6)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine csor3ra_(ar0,ar1,ar2,n,n1,n2,isens)
c
c     ---------------------------------------------------------------0--
c *   Object : compute_sorting_of_3_real_array ar1,ar2 associated to ar0
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------0--
c
      real ar0(n), ar1(n), ar2(n)
      real olar0 , olar1 , olar2
c
      character*80 com
      save com
c
c
c     ar0 est le tableau a trier
c     ar1 est un 1er  tableaux associe a rearranger
c     ar2 est un 2eme tableaux associe a rearranger
c     n est la dimension des tableaux
c     n1 est l'indice de depart de ar0
c     n2 est l'indice de fin
c     isens= 1 tri ascendant
c     isens=-1 tri descendant
c
c
      if(n1.lt.1) n1=1
      if(isens.ne.1.and.isens.ne.-1) then
                                     write(com,100) isens
                                     call uperror_(com)
                                     endif
c
  100 format('csor3ra_: code de tri illegal',i3,' doit etre +/-1')
c
c
      n2m1=n2 - 1
c
      do 1 io=n1,n2m1
      iop1=io + 1
c
      do 2 ki=iop1,n2
      if(isens.eq.-1) then
                      if(ar0(io).le.ar0(ki)) then
                                             go to 5
                                             else
                                             go to 2
                                             endif
                      else
                      if(ar0(io).le.ar0(ki)) then
                                             go to 2
                                             else
                                             go to 5
                                             endif
                      endif
c
    5 olar0  =ar0(io)
      ar0(io)=ar0(ki)
      ar0(ki)=olar0
c
      olar1  =ar1(io)
      ar1(io)=ar1(ki)
      ar1(ki)=olar1
c
      olar2  =ar2(io)
      ar2(io)=ar2(ki)
      ar2(ki)=olar2
c
    2 continue
    1 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine csoydat_(isoy,imonth,iday,nbyear,ih,im,is)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_second_of_the_year to date and time
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension nj(12)
c
      data nj/0,31,59,90,120,151,181,212,243,273,304,334/
      save nj
c
c      on suppose l'annee non bissextile
c
      nbyear =isoy/(365*24*3600)
      tt=float(isoy-3600*24*365*nbyear)
c
      nbday =int(tt/(24.*3600.))
      tt=tt-24.*3600.*float(nbday)
c
      ih  =int(tt/3600.)
      tt=tt-3600.*float(ih)
c
      im  =int(tt/60.)
      tt=tt-60.*float(im)
c
      is  =int(tt)
c
      do 10 i=2,12
      if(nbday.le.nj(i)) then
                         imonth=i-1
                         iday=nbday-nj(imonth)
                         return
                         endif
   10 continue
c
      call uperror_('csoydat_: parametres d''entree incorrects')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine csphcar_(r,teta,phi,x,y,z)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_spherical_to_cartesian degrees
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      pisd=acos(-1.)/180.
c
c
c *** conversion de coordonnees spheriques en cartesiennes
c
c
      x=r*sin(teta*pisd)*cos(phi*pisd)
      y=r*sin(teta*pisd)*sin(phi*pisd)
      z=r*cos(teta*pisd)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ctenpon_(n,power)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_ten_power_n i.e. 10**n for code portability
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      if(n.eq.0) then
                 power=1.
                 return
                 endif
c
      if(n.gt.30) then
                  power=1.e30
                  return
                  endif
c
      if(n.lt.-30) then
                   power=1.e-30
                   return
                   endif
c
      ie=abs(n)
      power=10.
c
      do i= 2,ie
      power=power*10.
      enddo
c
      if(n.lt.0) power=1./power
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ctimcha_(ih,im,is,ctime)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_time_number_to_char  '13:03:05'
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) ctime
c
      write(ctime,100) ih,im,is
c
      if(ctime(1:1).eq.' ') ctime(1:1)='0'
      if(ctime(4:4).eq.' ') ctime(4:4)='0'
      if(ctime(7:7).eq.' ') ctime(7:7)='0'
c
  100 format(i2.2,':',i2.2,':',i2.2)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ctimmil_(milday,ih,im,is,ims)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_milday_to_ih_im_is_ims integers values
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2001 (Rocotlib)
c
c *   input  : milday millisecond of the day
c *   output : ih,im,is,ims
c     ---------------------------------------------------------------+--
c
c
      nj= milday/86400000
      mil2= milday-nj*86400000
c
      if(nj.ne.0) then
          print*, '*** ctimmil: milday=',milday,' > 86 400 000'
          print*, '            assumed:',mil2
          call upwarni_('ctimmil_: milday > 86 400 000, modified...')
          endif
c
      ih=  milday/3600000
      im= (milday-ih*3600000)/60000
      is= (milday-ih*3600000-im*60000)/1000
      ims= milday-ih*3600000 -im*60000 -is*1000
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ctwopon_(n,ipower)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_two_power_n i.e. 2**n for code portability
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      if(n.eq.0) then
                 ipower=1
                 return
                 endif
c
      if(n.lt.0) call uperror_('ctwopon_ : n must be > 0')
c
      nmax=2147483647
      if(n.gt.nmax) call uperror_('ctwopon_ : n must be < 2147483647')
c
c
      ipower=2
c
      do i= 2,n
      ipower=ipower*2
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cvecmod_(x,y,z,rmod)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_vector_modulus from 3 components
c *   Class  : compute modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      rmod=sqrt(x*x + y*y + z*z)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cxtogpr_(x,nosd)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_x_to_given_precision with numb. of signi. digits
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call cmanexp_(x,rm,ie)
c
      nosd1=max(abs(nosd),1)
c
      call ctenpon_(nosd1,pow)
      rmn=abs(rm)*pow
      irm=int(rmn)
      rm2=float(irm)/pow
      call ctenpon_(ie,powie)
      x=sign(rm2,rm)*powie
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cxtolim_(x)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_x_to_low_integer_mantissa ex: 13.25 -> 10.
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      data epsi  /1.e-35/
      save epsi
c
c *** arondi x a sa mantisse entiere inferieure
c
c
      if(abs(x).lt.epsi) then
                         x=0.
                         return
                         endif
c
      call csigdig_(x,nosd)
c
      if(nosd.eq.1) then
                    return
c
                    else
                    call cmanexp_(x,rm,ie)
                    rm10=rm*10.
                    if(rm.gt.0.) then
                                 rm10a=float(int(rm10))
                                 else
                                 rm10a=float(int(rm10))-1.
                                 endif
                    call ctenpon_(ie,pow)
                    x=(rm10a/10.)*pow
                    return
                    endif
c
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cxtouim_(x)
c
c     ---------------------------------------------------------------+--
c *   Object : convert_x_to_upper_integer_mantissa ex: 13.25 -> 20.
c *   Class  : convert modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      data epsi  /1.e-35/
      save epsi
c
c *** arondi x a sa mantisse entiere superieure
c
c
      if(abs(x).lt.epsi) then
                         x=0.
                         return
                         endif
c
      call csigdig_(x,nosd)
c /// dbug              print*, 'cxtouim 1 : x,nosd=',x,nosd
c
      if(nosd.eq.1) then
                    return
c
                    else
                    call cmanexp_(x,rm,ie)
c /// dbug              print*, 'cxtouim 2 : x,rm,ie=',x,rm,ie
                    rm10=rm*10.
                    if(rm.gt.0.) then
                                 rm10a=float(int(rm10))+1.
                                 else
                                 rm10a=float(int(rm10))
                                 endif
                    call ctenpon_(ie,pow)
c /// dbug              print*, 'cxtouim 3 : rm10a,ie,pow=',rm10a,ie,pow
                    x=(rm10a/10.)*pow
c /// dbug              print*, 'cxtouim 4 : x,nosd=',x,nosd
                    return
                    endif
c
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dclogra_
c
c     ---------------------------------------------------------------+--
c *   Object : define_close_graphical_file and terminate the plot
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /pagnum/ npage
      common /numvec/ nbppo,nbpmo,nbtpo,nbtmo
      common /boupag/ xminb,xmaxb,yminb,ymaxb
      common /statim/ jj1,mm1,ian1,ih1,im1,is1,ims1,nc
      common /statim1/ datim1
      common /npsfil/ psfil
c
      character*29    datim1
      character*255   psfil
      character*8 time
      character*29 datim2
c
      save time,datim2
c
c
      call sdr_updbbox
      call sdr_dclogra
      call sys_gdattim(mm2,jj2,ian2,ih2,im2,is2)
c
      call gusdati_(datim2)
      call gditime_(time)
c
      nbv=nbppo+nbpmo
      print 110, time,' : End of page ',npage
      print 140,'nb vectors    :',nbv,nbppo,nbpmo
      print 150,'XY min-max    :',xminb,xmaxb,yminb,ymaxb
c
      call cchalen_(datim1,nc1)
      call cchalen_(datim2,nc2)
      
      print 100
      print 120, 'ROGRALIB / Starting plot : ',datim1(1:nc1),' U.T.'
      print 120, '         / Ending   plot : ',datim2(1:nc2),' U.T.'
c
      call cdatsoy_(mm1,jj1,ian1,ih1,im1,is1,iseca1)
      call cdatsoy_(mm2,jj2,ian2,ih2,im2,is2,iseca2)
c
      idif=iseca2-iseca1
c
      call csoydat_(idif,imois,jj,nban,ih,im,is)
c
      if(idif.le.86400) then
                        print 132, 'Duration      :',ih,im,is
                        else
                        print 134, 'Duration      :',jj,ian2,ih,im,is
                        endif
c
      nbtpo=nbtpo+nbppo
      nbtmo=nbtmo+nbpmo
      nbv=nbtpo+nbtmo
c
      call gditime_(time)
c
      print 140,'nb pages      :',npage
      print 140,'nb vectors    :',nbv,nbtpo,nbtmo
      print 120,'ROGRALIB / time ',time,' : Close PostScript file ',
     &                                      psfil(1:nc)
      print 120,'                           ---> Ready to print'
      print 200
c
c
  100 format(1x,79('-'))
  110 format(1x,'ROGRALIB / time ',2a,i5)
  120 format(1x,10a)
  132 format(10x,'/ ',a,                     i2,'h ',i2,' m ',i2,' s')
  134 format(10x,'/ ',a,i3,' j ',i1,' an',5x,i2,'h ',i2,' m ',i2,' s')
  140 format(10x,'/ ',a,2i8,' up,',i8,' down')
  150 format(10x,'/ ',a,3x,2f8.2,4x,2f8.2)
  200 format(1x,79('='))
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dcolmap_(colmap)
c
c     ---------------------------------------------------------------+--
c *   Object : define_color_map among existing color map
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /colmap/ hueu,satu,briu,nbcolu
      common /colmac/ comapu
      common /allmapn/ nbcmap
      common /allmapc/ comaps
c
      real hueu(256),satu(256),briu(256)
      character*10 comapu
      character*10 comaps(25)

      character*(*) colmap
c
c
      comapu='Undefined '
      nbcmap=25
c
c *** chargement des noms des palettes pre-definies:
c
      comaps(1)='classic022'
c
      do i=2,nbcmap
      if(i.le.7) then
                 im=i-1
                 else
                 im=mod(i-2,6)+1
                 endif
      call ctwopon_(im+2,np)
      write(comaps(i)(8:10),'(i3.3)') np
      enddo
c
      do i=2,7
      comaps(i)(1:7)='spectro'
      enddo
c
      do i=8,13
      comaps(i)(1:7)='rainbow'
      enddo
c
      do i=14,19
      comaps(i)(1:7)='fullhue'
      enddo
c
      do i=20,25
      comaps(i)(1:7)='greylev'
      enddo
c
c *** initialisations
c
      kpal=0
c
c *** calcul des hue, sat, bri pour la palette choisie
c
c ** palette classique (adaptee aux imprimantes)
c
      if(colmap.eq.'classic022') then
          nbcolu=22
c
          hueu( 1) = 0.8710
          hueu( 2) = 0.0000
          hueu( 3) = 0.0323
          hueu( 4) = 0.0645
          hueu( 5) = 0.0968
          hueu( 6) = 0.1290
          hueu( 7) = 0.1613
          hueu( 8) = 0.1935
          hueu( 9) = 0.2258
          hueu(10) = 0.2581
          hueu(11) = 0.2903
          hueu(12) = 0.3097
          hueu(13) = 0.3333
          hueu(14) = 0.4065
          hueu(15) = 0.4452
          hueu(16) = 0.4839
          hueu(17) = 0.5161
          hueu(18) = 0.5613
          hueu(19) = 0.5935
          hueu(20) = 0.6666
          hueu(21) = 0.7097
          hueu(22) = 0.7419
c
          do i=1,nbcolu
          satu(i)=1.
          briu(i)=1.
          enddo
c
          comapu=colmap
          print 100, ' ROGRALIB / Color map set : ',comapu
          return
          endif ! classic022
c
c /// toutes les mires sont maintenant du type "xxxxxxx016"
c     calcul du nombre de point de la mire
c
      if(colmap(8:10).eq.'008') nbcolu=  08
      if(colmap(8:10).eq.'016') nbcolu=  16
      if(colmap(8:10).eq.'032') nbcolu=  32
      if(colmap(8:10).eq.'064') nbcolu=  64
      if(colmap(8:10).eq.'128') nbcolu= 128
      if(colmap(8:10).eq.'256') nbcolu= 256
c
      if(nbcolu.eq.0) then
                 print 100, ' Color map asked: ',colmap
                 print 100, ' must be one of :'
                 do i=1,nbcmap
                 print 100, '                  ',comaps(i)
                 enddo
                 call uperror_('ccolmap_: color map unknown')
                 endif
c
c
c ** palette spectro couleurs (adaptee aux spectrogrammes)
c
      if(colmap(1:7).eq.'spectro') then
c
c *      chargement des hue, sat, bri
c
         do i=1,nbcolu
c
c        Etalement des couleurs du rouge au violet:
c
         colstep=float(i)/float(nbcolu)-.15
         if (colstep.lt.0.) colstep=colstep+1.
         hueu(i)=colstep
         satu(i)=1.
c
c        Plus de jaune dans le vert clair:
c
         if(colstep.gt.0.15.and.colstep.lt.0.3) then
                 briu(i)=1.
                 a=0.15/(0.3*0.3 -0.15*0.15)
                 b=0.15-a*0.15*0.15
                 do j=1,5
                 hueu(i)=a*hueu(i)*hueu(i)+b
                 enddo
c
c            Plus de cyan dans le bleu clair:
c
               elseif (colstep.gt.0.5.and.colstep.lt.0.675) then
                       briu(i)=1.-0.09*(colstep-0.5)/.175
                       a=0.175/(0.675*0.675 -0.5*0.5)
                       b=0.5-a*0.5*0.5
                       do j=1,5
                       hueu(i)=a*hueu(i)*hueu(i) +b
                       enddo
c
c            Fin de la mire (violet) plus foncee:
c
               elseif (colstep.gt.0.6751.and.colstep.lt.0.851) then
                       briu(i)=0.85-((colstep-.7)/.175)/1.5
c
c            Debut de la mire tout en rouge, mais de plus en plus fonce:
c
               elseif (colstep.gt.0.85) then
                       hueu(i)=1.
                       call capowex_(colstep -0.55, 0.9, briu(i))
                       briu(i)=briu(i)/0.45
               else
                       briu(i)=1.
               endif
c
         if(briu(i).gt.1.0) briu(i)=1.0
         enddo
c
         comapu=colmap
         print 100, ' ROGRALIB / Color map set : ',comapu
         return
         endif ! spectro
c
c
c XXX palette de niveaux de gris: lineaire, du blanc vers le noir
c
      if(colmap(1:7).eq.'greylev') then
c
          do i=1,nbcolu
          hueu(i)=0.
          satu(i)=0.
          briu(i)=float(nbcolu-i)/float(nbcolu-1)
          enddo
c
          comapu=colmap
          print 100, ' ROGRALIB / Color map set : ',comapu
          return
          endif ! greylevel
c
c
c XXX palette de couleur full hue:
c                         toute la gamme du hue, lineaire et periodique
c                         du rouge vers le bleu, avec retour au rouge
c                         soit le hue de 0.(rouge) a 1. (re-rouge)
c
      if(colmap(1:7).eq.'fullhue') then
c
          do i=1,nbcolu
          hueu(i)= float(i-1)/float(nbcolu-1)
          satu(i)=1.
          briu(i)=1.
          enddo
c
          comapu=colmap
          print 100, ' ROGRALIB / Color map set : ',comapu
          return
          endif ! fullhue
c
c
c XXX palette de couleur rainbow:
c                       arc en ciel comme le full hue,  lineaire,
c                       mais limite du rouge pur au magenta pur,
c                       en passant par le bleu (huered=0.)
c
      huemag= 0.833333
c
      if(colmap(1:7).eq.'rainbow') then
c
          do i=1,nbcolu
          hueu(i)= float(i-1)*(huemag)/float(nbcolu-1)
          satu(i)=1.
          briu(i)=1.
          enddo
c
          comapu=colmap
          print 100, ' ROGRALIB / Color map set : ',comapu
          return
          endif ! rainbow
c
c *** aucune palette ne correspond au nom donne en argument
c
      if(kpal.eq.0) then
                 print 100, ' Color map asked: ',colmap
                 print 100, ' must be one of :'
                 do i=1,nbcmap
                 print 100, '                  ',comaps(i)
                 enddo
                 call uperror_('ccolmap_: color map unknown')
                 endif
c
  100 format(2a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dcolmapu(colmapu,nlevel,hue,sat,bri)
c
c     ---------------------------------------------------------------+--
c *   Object : define_color_map_user , from hue(256),sat(256),bri(256)
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /colmap/ hueu,satu,briu,nbcolu
      common /colmac/ comapu
c
      real hueu(256),satu(256),briu(256)
      character*10 comapu
c
      real hue(nlevel),sat(nlevel),bri(nlevel)
c
      character*(*) colmapu
c
      do i=1,nlevel
      hueu(i)=hue(i)
      satu(i)=sat(i)
      briu(i)=bri(i)
      enddo
c
      nbcolu=nlevel
      comapu=colmapu
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfigdef_
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_default for position of tit,lab,sti,grad
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call dfigzat_(1.)
      call dtitpos_('top')
      call dlabpos_('c','c')
      call dlabseny('v')
      call dstipos_('oi','ii')
      call dgrapos_('bottom','left')
      call dfigout_('n')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfiglim_(xmin,xmax,ymin,ymax)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_limit
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call dfiglimx(xmin,xmax)
      call dfiglimy(ymin,ymax)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfiglimx(xmin,xmax)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_limit_x
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figlim/ x1,x2,y1,y2
      common /figsiz/ rx,ry
      common /figsca/ ex,ey
c
      data epsi  /1.e-35/
      save epsi
c
c
      x1=xmin
      x2=xmax
c
      if(abs(x2-x1).lt.epsi)
     &             call uperror_('dfiglimx: bornes x identiques')
c
      if(x1.gt.x2)
     &     call uperror_('dfiglimx: x1 plus grand que x2')
c
      if(rx.le.epsi)
     &     call uperror_('dfiglimx: dimension de la figure pas definie')
c
      ex=(x2-x1)/rx
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfiglimy(ymin,ymax)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_limit_y
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /figlim/ x1,x2,y1,y2
      common /figsiz/ rx,ry
      common /figsca/ ex,ey
c
      data epsi  /1.e-35/
      save epsi
c
c
      y1=ymin
      y2=ymax
c
      if(abs(y2-y1).lt.epsi)
     &     call uperror_('dfiglimy: bornes y identiques')
c
      if(y1.gt.y2)
     &     call uperror_('dfiglimy: y1 plus grand que y2')
c
      if(ry.le.epsi)
     &     call uperror_('dfiglimy: dimension de la figure pas definie')
c
      ey=(y2-y1)/ry
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfigori_(figorx,figory)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_origine in cm of the lower left corner
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call dfigorix(figorx)
      call dfigoriy(figory)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfigorix(figorx)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_origine_x in cm of the lower left corner
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figori/ xz,yz
      common /pagsiz/ tpx,tpy
c
c
      if(figorx.ge.tpx) call uperror_('dfigori_: ox > size of page x')
c
      xz=figorx
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfigoriy(figory)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_origine_y in cm of the lower left corner
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figori/ xz,yz
      common /pagsiz/ tpx,tpy
c
c
      if(figory.ge.tpy) call uperror_('dfigori_: oy > size of page y')
c
      yz=figory
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfigout_(yeno)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_out 'no'= no trepassing fig. limits
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figout/ ifigout
c
      character*(*) yeno
c
      if(yeno(1:1).eq.'y') then
                           ifigout=1
                           else
                           ifigout=0
                           endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfigppo_(pox,poy)
c
c     ------------------------------------------------------------------
c *   Object : define_figure_pen_position in cm.
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      call cfigpag_(pox,poy,x1,y1)
      call dpagppo_(x1,y1)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfigsiz_(figsix,figsiy)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_size in cm.
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figsiz/ rx,ry
      common /pagsiz/ tpx,tpy
c
c *** definit la taille de la figure
c
      if(figsix.lt.tpx/100.) then
            call upwarni_('!!!')
            print*, 'figsix=',figsix
            print*, 'tpx=   ',tpx
         call uperror_('dfigsiz_: taille x de la fig. inf. a tpagx/100')
                             endif
c
      if(figsiy.lt.tpy/100.) then
            call upwarni_('!!!')
            print*, 'figsiy=',figsiy
            print*, 'tpy=   ',tpy
         call uperror_('dfigsiz_: taille y de la fig. inf. a tpagy/100')
                             endif
c
      if(figsix.gt.tpx) then
            call upwarni_('!!!')
            print*, 'figsix=',figsix
            print*, 'tpx=   ',tpx
            call uperror_('dfigsiz_: taille x de la fig. sup. a tapagx')
                        endif
c
      if(figsiy.gt.tpy) then
            call upwarni_('!!!')
            print*, 'figsiy=',figsiy
            print*, 'tpy=   ',tpy
            call uperror_('dfigsiz_: taille y de la fig. sup. a tapagy')
                        endif
c
      rx=figsix
      ry=figsiy
c
c *** calcul des positions, taille des marques, titres etc.
c
      call dfigdef_
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfigzat_(zoatt)
c
c     ---------------------------------------------------------------+--
c *   Object : define_figure_zoom_attribute for grad.,lab.,marks,title
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /biggra/ diafig,unifig,zofiat
      common /figsiz/ rx,ry
c
c *** definit un coef. sur tailles/defaut (mar,gra,lab,tit)
c
      zofiat=zoatt
      diafig=sqrt(rx*rx + ry*ry)
      unifig=diafig*zofiat
c
      bsti=unifig/60.
      ssti=unifig/120.
c
      grax=unifig/60.
      gray=unifig/60.
c
      rlax=unifig/40.
      rlay=unifig/40.
c
      tits=unifig/25.
c
      call dstisiz_(bsti,ssti)
      call dgrasiz_(grax,gray)
      call dlabsiz_(rlax,rlay)
      call dtitsiz_(tits)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfilzon_
c
c     ---------------------------------------------------------------+--
c *   Object : define_fill_zone start of a path to fill
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call sdr_dfilzon
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfonnum_(numfon)
c
c     ---------------------------------------------------------------+--
c *   Object : define_font_number
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /fonnum/ nufon, bodfon
c
      character*16 com
c
c
      nufon=numfon
c
      write(com,100) 'dfonnum_: ',numfon
      call sdr_wfilcom(com)
c
  100 format(a,i3)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfontyp_(fontyp)
c
c     ---------------------------------------------------------------+--
c *   Object : define_font_type as 'c','h','hbobl',...
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) fontyp
c
c     fontyp='*' --> police dessinnees par la bibliotheque (obsolete)
c
c     fontyp='c' --> police Courier disponible sur le driver
c            'h'            Helvetica
c            't'            Times
c            's'            Symbol
c             hbold, hobli, hbobl etc... voir sys_gfontyp
c
      call cfonnum_(fontyp,numfon)
      call dfonnum_(numfon)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dfoofon_(fontyp,fonsiz)
c
c     ---------------------------------------------------------------+--
c *   Object : define_foot_font as 'tital', 0.3 cm
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /foofon/ ifonf, hfonf
c
      character*(*) fontyp
c
c               ----------
c
      call cfonnum_(fontyp,ifonf)
c
      hfonf=fonsiz
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dgrapos_(grapox,grapoy)
c
c     ---------------------------------------------------------------+--
c *   Object : define_graduations_position on the figure (b,t and l,r)
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /grapos/ ipgrax,ipgray
c
      character*(*) grapox,grapoy
c
c
      ipgrax=2
      ipgray=2
c
clm      if(grapox(1:1).eq.'t') then
clm                             ipgrax= 1
clm                             else
clm                             ipgrax= 0
clm                             endif
clm      if(grapoy(1:1).eq.'r') then
clm                             ipgray= 1
clm                             else
clm                             ipgray= 0
clm                             endif
      if(grapox(1:1).eq.'t') ipgrax= 1
      if(grapox(1:1).eq.'b') ipgrax= 0
      if(grapoy(1:1).eq.'r') ipgray= 1
      if(grapoy(1:1).eq.'l') ipgray= 0
c
      if(ipgrax.eq.2) call uperror_('dgrapos_: grapox=b or t only')
      if(ipgray.eq.2) call uperror_('dgrapos_: grapoy=l or r only')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dgrasiz_(grasix,grasiy)
c
c     ---------------------------------------------------------------+--
c *   Object : define_graduations_size in cm.
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call dgrasizx(grasix)
      call dgrasizy(grasiy)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dgrasizx(grasix)
c
c     ---------------------------------------------------------------+--
c *   Object : define_graduations_size of x axis in cm.
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /grasiz/ tgrax,tgray,dgxax,dgyay,ncgrax,ncgray
c
c
      if(grasix.lt.0.)
     &   call uperror_('dgrasiz_: taille des graduations X negative')
c
      tgrax=grasix
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dgrasizy(grasiy)
c
c     ---------------------------------------------------------------+--
c *   Object : define_graduations_size of y axis in cm.
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /grasiz/ tgrax,tgray,dgxax,dgyay,ncgrax,ncgray
c
c
      if(grasiy.lt.0.)
     &   call uperror_('dgrasiz_: taille des graduations Y negative')
c
      tgray=grasiy
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dheafon_(fontyp,fonsiz)
c
c     ---------------------------------------------------------------+--
c *   Object : define_header_font as 'tital', 0.3 cm
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /heafon/ ifonh, hfonh
c
      character*(*) fontyp
c
c               ----------
c
      call cfonnum_(fontyp,ifonh)
c
      hfonh=fonsiz
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dheapos_(iposhe,disthe)
c
c     ---------------------------------------------------------------+--
c *   Object : define_header_position as ipos -1,0,1 and oy from bottom
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /heapos/ ipohea,dishea
c
c               ----------
c
      ipohea=iposhe
      dishea=disthe
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dimasha_
c
c     ---------------------------------------------------------------+--
c *   Object : define_image_shape must be followed by contour drawing
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call sdr_dimasha
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlabpos_(labpox,labpoy)
c
c     ---------------------------------------------------------------+--
c *   Object : define_labels_position on the figure (l,c,r and b,c,t)
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /labpos/ iplabx,iplaby
c
      character*(*) labpox,labpoy
c
c
      iplabx=2
      iplaby=2
c
      if(labpox(1:1).eq.'l') iplabx=-1
      if(labpox(1:1).eq.'c') iplabx= 0
      if(labpox(1:1).eq.'r') iplabx= 1
c
      if(labpoy(1:1).eq.'b') iplaby=-1
      if(labpoy(1:1).eq.'c') iplaby= 0
      if(labpoy(1:1).eq.'t') iplaby= 1
c
      if(iplabx.eq.2) call uperror_('dlabpos_: labpox=l,c or r only')
      if(iplaby.eq.2) call uperror_('dlabpos_: labpoy=b,c or t only')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlabseny(labsey)
c
c     ---------------------------------------------------------------+--
c *   Object : define_labels_sens on the figure (h or v, only labely)
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /labsen/ islaby
c
      character*(*) labsey
c
c
      islaby=2
c
      if(labsey(1:1).eq.'v') islaby= 0
      if(labsey(1:1).eq.'h') islaby= 1
c
      if(islaby.eq.2) call uperror_('dlabseny: labsey= v or h only')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlabsiz_(rlasix,rlasiy)
c
c     ---------------------------------------------------------------+--
c *   Object : define_labels_size in cm.
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /labsiz/ tlax,tlay,dlxax,dlyay
c
c *** definit la taille des labels
c
c
      if(rlasix.lt.0.)
     &     call uperror_('dlabsiz_: taille du label X negative')
      if(rlasiy.lt.0.)
     &     call uperror_('dlabsiz_: taille du label Y negative')
c
      tlax=rlasix
      tlay=rlasiy
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlincol_(col)
c
c     ---------------------------------------------------------------+--
c *   Object : define_line_color as 'r' or nrgbcmypwi
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) col
c
      common /lincol/ rc,gc,bc,hue,sat,bri,icol
c
c *** valeurs possibles: black, red, green, blue, cyan,
c                        magenta, yellow, pink, white, ignore
c
      r=0.
      g=0.
      b=0.
      icol=0
c
      if(col(1:1).eq.'r') then
                          r=1.
                          g=0.
                          b=0.
                          icol=1
                          go to 10
                          endif
c
      if(col(1:1).eq.'g') then
                          r=0.
                          g=1.
                          b=0.
                          icol=2
                          go to 10
                          endif
c
      if(col(1:1).eq.'b') then
                          r=0.
                          g=0.
                          b=1.
                          icol=3
                          go to 10
                          endif
c
      if(col(1:1).eq.'c') then
                          r=0.
                          g=1.
                          b=1.
                          icol=4
                          go to 10
                          endif
c
      if(col(1:1).eq.'m') then
                          r=1.
                          g=0.
                          b=1.
                          icol=5
                          go to 10
                          endif
c
      if(col(1:1).eq.'y') then
                          r=1.
                          g=1.
                          b=0.
                          icol=6
                          go to 10
                          endif
c
      if(col(1:1).eq.'p') then
                          r=1.
                          g=0.8
                          b=0.8
                          icol=7
                          go to 10
                          endif
c
      if(col(1:1).eq.'w') then
                          r=1.
                          g=1.
                          b=1.
                          icol=8
                          go to 10
                          endif
c
      if(col(1:1).eq.'i') then
                          return
                          endif
   10 continue
c
      rc=r
      gc=g
      bc=b
c
      call crgbhsb_(rc,gc,bc,hue,sat,bri)
      call sdr_dlincol('rgb',r,g,b)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlincoln(level)
c
c     ---------------------------------------------------------------+--
c *   Object : define_line_color from level of current color map
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
c
      common /colmap/ hueu,satu,briu,nbcolu
      common /colmac/ comapu
c
      real hueu(256),satu(256),briu(256)
      character*10 comapu
      character*10 colmap
c
c *** mire utilisee et nombre de niveaux
c
      call gcolmap_(colmap,nlevel)
c
c *** test si le niveau demande est dans la mire courante
c
      if(level.lt.1)  call uperror_('dlincoln: level number < 1')
      if(level.gt.nlevel) then
                          print*, 'ROGRALIB/dlincoln: '//
     &                         'level number too large for colormap'
                          print*, 'level asked     : ',level
                          print*, 'current colormap: ',comapu
                          print*, 'Number of levels: ',nlevel
        call uperror_('dlincoln: level number too large for colormap')
                          endif
c
      h=hueu(level)
      s=satu(level)
      b=briu(level)
c
      call sdr_dlincol('hsb',h,s,b)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlincon_
c
c     ---------------------------------------------------------------+--
c *   Object : define_line_continue, remove dash line option
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      call sdr_dlincon
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlindas_(size1,blank1,size2,blank2)
c
c     ---------------------------------------------------------------+--
c *   Object : define_line_dash, from given parameters
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
c *** le trait tirete est constitue d'un premier trait de taille size1,
c     puis d'un espace blanc de taille blank1, puis d'un deuxieme trait
c     suivi d'un deuxieme blanc.
c
      if(size1.lt.0.)  call upwarni_('dlindas_: size1  <0, abs() taken')
      if(size2.lt.0.)  call upwarni_('dlindas_: size2  <0, abs() taken')
      if(blank1.lt.0.) call upwarni_('dlindas_: blank1 <0, abs() taken')
      if(blank2.lt.0.) call upwarni_('dlindas_: blank2 <0, abs() taken')
c
      total= abs(size1) +abs(size2) +abs(blank1) +abs(blank2)
c
      epsi=1./1000.
      if(total.lt.epsi) then
                    print*, 'ROGRALIB/dlindas_: size or blank too small'
                    print*, 'size1 = ',size1
                    print*, 'size2 = ',size2
                    print*, 'blank1= ',blank1
                    print*, 'blank2= ',blank2
                    call uperror_('dlindas_: size or blank too small')
                        endif
c
      call sdr_dlindas(size1,blank1,size2,blank2)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlinhsb_(h,s,b)
c
c     ---------------------------------------------------------------+--
c *   Object : define_line_hsb color components as h,s,b values
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /lincol/ rc,gc,bc,hue,sat,bri,icol
c
c *** valeurs possibles: h s b entre 0. et 1.
c
c
      hue=h
      sat=s
      bri=b
c
      if(hue.lt.0.) hue=0.
      if(sat.lt.0.) sat=0.
      if(bri.lt.0.) bri=0.
c
      if(hue.gt.1.) hue=1.
      if(sat.gt.1.) sat=1.
      if(bri.gt.1.) bri=1.
c
      call chsbrgb_(hue,sat,bri,rc,gc,bc)
      call sdr_dlincol('hsb',hue,sat,bri)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlinrgb_(r,g,b)
c
c     ---------------------------------------------------------------+--
c *   Object : define_line_rgb color components as r,g,b values
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /lincol/ rc,gc,bc,hue,sat,bri,icol
c
c *** valeurs possibles: r g b entre 0. et 1.
c
c
      rc=r
      gc=g
      bc=b
c
      if(rc.lt.0.) rc=0.
      if(gc.lt.0.) gc=0.
      if(bc.lt.0.) bc=0.
c
      if(rc.gt.1.) rc=1.
      if(gc.gt.1.) gc=1.
      if(bc.gt.1.) bc=1.
c
      call crgbhsb_(rc,gc,bc,hue,sat,bri)
      call sdr_dlincol('rgb',rc,gc,bc)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dlinwid_(iwidth)
c
c     ---------------------------------------------------------------+--
c *   Object : define_lines_width in pixel, for next drawn lines
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /linwid/ iwid
c
      iwid=iwidth
c
      call sdr_dlinwid(iwidth)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dopegra_(ifc,psfile)
c
c     ---------------------------------------------------------------+--
c *   Object : define_open_graphical_file and start the plot
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /numvec/ nbppo,nbpmo,nbtpo,nbtmo
      common /pagnum/ npage
      common /pagsiz/ tpx,tpy
      common /statim/ jj1,mm1,ian1,ih1,im1,is1,ims1,nc
      common /statim1/ datim1
      common /npsfil/ psfil
      common /boupag/ xminb,xmaxb,yminb,ymaxb
c
      character*(*) psfile
c
      character*29  datim1
      character*255 psfil
      character*18 usdate
      character*8  time
      save usdate,time
c
      data rmax  /1.e+36/
      save rmax
c
c
      call cchalen_(psfile,nc)
c
      psfil=psfile(1:nc)
c
      call sys_gdattim(mm1,jj1,ian1,ih1,im1,is1)
      call gusdate_(usdate)
      call gusdati_(datim1)
      call gditime_(time)
      call glibver_(ver)
c
      print 100
      print 200,    'time '//time,' : Running ROGRALIB V ',ver,usdate
      print 400, '               ',' : Opening PostScript file ',
     &                  psfile(1:nc),' (unit ',ifc,')'
      print 110
c
      npage=0
      nbtpo=0
      nbtmo=0
c
      xminb=  rmax
      yminb=  rmax
      xmaxb= -rmax
      ymaxb= -rmax
c
      call sdr_dopegra(ifc,psfile(1:nc))
c
      tpx=18.6
      tpy=27.3
c
      call dpagnew_
      call dpagdef_
c
c *** initialisation standard pour une figure quelconque
c     (dfigdef_ est appelle par dfigsiz_)
c
      call dfigori_(4.,8.)
      call dfigsiz_(15.,10.)
      call dstinum_(9,9)
c
      call sdr_wfilcom('end   dopegra')
c
  100 format(1x,79('='))
  110 format(1x,79('-'))
  200 format(1x,'ROGRALIB / ',2a,f3.1,1x,a)
  400 format(1x,'         ',4a,i2,a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dpagdef_
c
c     ---------------------------------------------------------------+--
c *   Object : define_page_default set standard page default attributes
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      tchea=0.25
c
      call dfontyp_('h')
      call dlinwid_(3)
      call dpagsca_(1.,1.)
      call dpagfor_('p')
      call dheafon_('tital',tchea)
      call dpagsiz_(18.6,27.3,1.2,1.2)
      call dheapos_(1,tchea +0.2)
      call dfoofon_('tital',tchea)
      call dcolmap_('classic022')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dpagfor_(pl)
c
      character*(*) pl
c
c     ---------------------------------------------------------------+--
c *   Object : define_page_format 'p' as portrait or 'l' as landscape
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsiz/ tpx,tpy
      common /pagfor/ iorpag
c
c *** on reperes le sens courant
c
      tpmin=min(tpx,tpy)
      tpmax=max(tpx,tpy)
c
      if(pl(1:1).eq.'p') then
                         iorpag=0
                         tpx=tpmin
                         tpy=tpmax
                         return
                         endif
c
      if(pl(1:1).eq.'l') then
                         iorpag=1
                         tpx=tpmax
                         tpy=tpmin
                         return
                         endif
c
      call uperror_('dpagfor_: only "p" or "l"')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dpagnew_
c
c     ---------------------------------------------------------------+--
c *   Object : define_page_new with preceding page attribute
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagnum/ npage
      common /numvec/ nbppo,nbpmo,nbtpo,nbtmo
      common /fonnum/ nufon, bodfon
      common /boupag/ xminb,xmaxb,yminb,ymaxb
c
      character*8 time
      data rmax  /1.e+36/
      save rmax,time
c
c
      call sdr_wfilcom('begin dpagnew_')
      call sdr_dpagnew(nupa)
      call sdr_dfonnab(nufon,bodfon)
c
c *** on termine la page precedente eventuelle
c
      call gditime_(time)
      npage=npage+1
c
      if(npage.gt.1) then
                     call sdr_updbbox
c
                     nbv=nbppo+nbpmo
                     print 100, time,'    : End of page ',npage-1
                     print 140,'nb vectors    :',nbv,nbppo,nbpmo
                     print 150,'XY min-max    :',xminb,xmaxb,yminb,ymaxb
c
                     nbtpo=nbtpo+nbppo
                     nbtmo=nbtmo+nbpmo
c
                     nbppo=0
                     nbpmo=0
c
                     xminb=  rmax
                     yminb=  rmax
                     xmaxb= -rmax
                     ymaxb= -rmax
c
                     print 200
                     endif
c
c
      print 100, time,' : Begin  page  ',npage,' Please wait...'
c
      call sdr_wfilcom('end   dpagnew_')
c
  100 format(1x,'ROGRALIB / time ',2a,i4,a)
  140 format(10x,'/ ',a,2i8,' up,',i8,' down')
  150 format(10x,'/ ',a,3x,2f8.2,4x,2f8.2)
  200 format(1x,a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dpagori_(pagorx,pagory)
c
c     ---------------------------------------------------------------+--
c *   Object : define_page_origine default=(0.,0.)
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagori/ popagx,popagy
c
      popagx=pagorx
      popagy=pagory
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dpagppo_(pox,poy)
c
c     ---------------------------------------------------------------+--
c *   Object : define_page_pen_position in cm, without plot
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /numvec/ nbppo,nbpmo,nbtpo,nbtmo
      common /penpos/ pepox,pepoy
      common /pagsiz/ tpx,tpy
      common /pagfor/ iorpag
      common /pagori/ popagx,popagy
      common /boupag/ xminb,xmaxb,yminb,ymaxb
c
c *** deplacement elementaire de plume  sans trace
c
      posx= pox-popagx
      posy= poy-popagy
c
      if(iorpag.eq.0) then
                      xx=posx
                      yy=posy
                      else
                      xx=tpy-posy
                      yy=posx
                      endif
c
      call sdr_dpagppo(xx,yy)
c
      nbppo=nbppo+1
      pepox=xx
      pepoy=yy
c
c *** update des extrema du trace (page/paysage cm unit)
c
      xminb= min(xminb, xx)
      yminb= min(yminb, yy)
      xmaxb= max(xmaxb, xx)
      ymaxb= max(ymaxb, yy)
c
      call sdr_updbbox
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dpagsca_(scax,scay)
c
c     ---------------------------------------------------------------+--
c *   Object : define_page_scale_factor default=(1.,1.)
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsca/ zomx,zomy
c
c
      zomx=scax
      zomy=scay
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dpagsiz_(pagsix,pagsiy,rmargex,rmargey)
c
c     ---------------------------------------------------------------+--
c *   Object : define_page_size in cm. erase default size
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsiz/ tpx,tpy
c
      tpx=pagsix
      tpy=pagsiy
c
c *** attention! les marges sont en plus
c
c     exemple: call dpagsiz_(19.,27.7,2.,2.) pour a4= 21 x29.7
c     sans marges a droite ni en haut
c
c     pour A4 avec marges de 1.2 cm tout autour, il faut
c     un call dpagsiz_(18.6,27.3,1.2,1.2)
c
      call sdr_dpagsiz(pagsix,pagsiy,rmargex,rmargey)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dstinum_(nmin,nmax)
c
c     ---------------------------------------------------------------+--
c *   Object : define_sticks_number , i.e. min and max big sticks number
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /n_marques/ n_tick_min,n_tick_max
c
      n_tick_min=nmin
      n_tick_max=nmax
c
      if (nmin.lt.2) then
           write(*,*) 'dstinum_ WARNING nmin<2 -> set to default nmin=2'
                     endif
c
      if (nmax.gt.9) then
           write(*,*) 'dstinum_ WARNING nmax>9 -> set to default nmax=9'
           n_tick_max=9
                     endif
c
      if (nmin.gt.nmax) then
           write(*,*) 'dstinum_ WARNING nmin>nmax -> set to default ',
     &                'nmin=2 and nmax=9'
           n_tick_min=2
           n_tick_max=9
                        endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dstipos_(stipox,stipoy)
c
c     ---------------------------------------------------------------+--
c *   Object : define_sticks_position as 'ii',io,oo,oi,' ' in,out,no
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /stipos/ ipmabx,ipmahx,ipmagy,ipmady
c
      character*(*) stipox,stipoy
c
c
      ipmabx=2
      ipmahx=2
      ipmagy=2
      ipmady=2
c
c *   tirets des graduations du bas
c
      if(stipox(1:1).eq.'i') ipmabx= 1
      if(stipox(1:1).eq.' ') ipmabx= 0
      if(stipox(1:1).eq.'o') ipmabx=-1
c
c *   tirets des graduations du haut
c
      if(stipox(2:2).eq.'i') ipmahx= 1
      if(stipox(2:2).eq.' ') ipmahx= 0
      if(stipox(2:2).eq.'o') ipmahx=-1
c
c *   tirets des graduations de gauche
c
      if(stipoy(1:1).eq.'i') ipmagy= 1
      if(stipoy(1:1).eq.' ') ipmagy= 0
      if(stipoy(1:1).eq.'o') ipmagy=-1
c
c *   tirets des graduations de droite
c
      if(stipoy(2:2).eq.'i') ipmady= 1
      if(stipoy(2:2).eq.' ') ipmady= 0
      if(stipoy(2:2).eq.'o') ipmady=-1
c
      if(ipmabx.eq.2)
     &     call uperror_('dstipos_: stipox(1:1)="i","o" or " " only')
      if(ipmahx.eq.2)
     &     call uperror_('dstipos_: stipox(2:2)="i","o" or " " only')
      if(ipmagy.eq.2)
     &     call uperror_('dstipos_: stipoy(1:1)="i","o" or " " only')
      if(ipmady.eq.2)
     &     call uperror_('dstipos_: stipoy(2:2)="i","o" or " " only')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dstisiz_(stisil,stisis)
c
c     ---------------------------------------------------------------+--
c *   Object : define_sticks_size long and short sticks in cm.
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /stisiz/ tgm,tpm
c
c *** definit la taille des grandes et petites marques
c
c
      if(stisil.lt.0.)
     &    call uperror_('dstisiz_: taille des grandes marques negative')
      if(stisis.lt.0.)
     &    call uperror_('dstisiz_: taille des petites marques negative')
c
      tgm=stisil
      tpm=stisis
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dtitpos_(titpo)
c
c     ---------------------------------------------------------------+--
c *   Object : define_title_position on the figure (top or bottom)
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /titpos/ ipotit
c
      character*(*) titpo
c
c
      if(titpo(1:1).ne.'t'.and.
     &   titpo(1:1).ne.'b')
     &     call uperror_('dtitpos_:  titpo t or b only')
c
      if(titpo(1:1).eq.'b') then
                            ipotit=0
                            else
                            ipotit=1
                            endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine dtitsiz_(titsi)
c
c     ---------------------------------------------------------------+--
c *   Object : define_title_size in cm.
c *   Class  : define modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /titsiz/ ttit,dtax
c
c
      if(titsi.lt.0.)
     &              call uperror_('dtitsiz_: taille du titre negative')
c
      ttit=titsi
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gboubox_(x1ups,x2ups,y1ups,y2ups,upstocm)
c
c     ---------------------------------------------------------------+--
c *   Object : give_bounding_box, in PostScript units, and conv ps to cm
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      common /sdrbbo/ xmip,xmap,ymip,ymap, xmimip,xmamap,ymimip,ymamap
c
      x1ups=xmip
      x2ups=xmap
      y1ups=ymip
      y2ups=ymap
c
      upstocm= 2.54/72.
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gclopar_(imonth,iday,iyear,ih,im,is)
c
c     ---------------------------------------------------------------+--
c *   Object : compute_clock_parameters at the time call
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call sys_gdattim(imonth,iday,iyear,ih,im,is)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gcolmap_(colmap,nlevel)
c
c     ---------------------------------------------------------------+--
c *   Object : give_color_map name and nb. of color levels
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      common /colmap/ hueu,satu,briu,nbcolu
      common /colmac/ comapu
c
      real hueu(256),satu(256),briu(256)
      character*10 comapu
c
      character*(*) colmap
c
      if(len(colmap).lt.10)
     &        call uperror_('gcolmap_: lenght of colmap must be GE 10')
      colmap=comapu
      nlevel=nbcolu
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gcolmapa(colmap,nbmap)
c
c     ---------------------------------------------------------------+--
c *   Object : give_color_map_array names and nb levels for all maps
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      common /allmapn/ nbcmap
      common /allmapc/ comaps
c
      character*10 comaps(25)
      character*(*) colmap(25)
c
      if(len(colmap(1)).lt.10)
     &        call uperror_('gcolmapa: lenght of colmap must be GE 10')
c
      if(nbcmap.gt.25)
     &        call uperror_('gcolmapa: number of colmap must be LE 25')
      nbmap=nbcmap
c
      do i=1,nbcmap
      colmap(i)=comaps(i)
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gcolmapv(colmap,nlevel,hue,sat,bri)
c
c     ---------------------------------------------------------------+--
c *   Object : give_color_map_values of colormap, n,hue(n),sat(n),bri(n)
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      common /colmap/ hueu,satu,briu,nbcolu
      common /colmac/ comapu
c
      real hueu(256),satu(256),briu(256)
      character*10 comapu
c
      real hue(nlevel) ,sat(nlevel) ,bri(nlevel)
      character*(*) colmap
c
      if(len(colmap).lt.10)
     &        call uperror_('gcolmapv: lenght of colmap must be GE 10')
      colmap=comapu
      nlevel=nbcolu
c
      do i=1,nlevel
      hue(i)=hueu(i)
      sat(i)=satu(i)
      bri(i)=briu(i)
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gdidate_(date10)
c
c     ---------------------------------------------------------------+--
c *   Object : give_digital_date as '2007-09-27'
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ---------------------------------------------------------------+--
c
      character*(*) date10
c
      ll=len(date10)
      if(ll.lt.10)
     & call uperror_('gditime_: character variable less than 10 carac.')
c
      call sys_gdattim(mm,jj,ian,ih,im,is)
c
      write(date10,100) ih,im,is
c
  100 format(i4.4,'-',i2.2,'-',i2.2)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gditime_(time8)
c
c     ---------------------------------------------------------------+--
c *   Object : give_digital_time as '13:03:25'
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) time8
c
      ll=len(time8)
      if(ll.lt.8)
     &  call uperror_('gditime_: character variable less than 8 carac.')
c
      call sys_gdattim(mm,jj,ian,ih,im,is)
c
      write(time8,100) ih,im,is
c
  100 format(i2.2,':',i2.2,':',i2.2)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfiglimx(xmin,xmax)
c
c     ---------------------------------------------------------------+--
c *   Object : give_figure_limit_x for x axe
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /figlim/ x1,x2,y1,y2
c
      xmin=x1
      xmax=x2
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfiglimy(ymin,ymax)
c
c     ---------------------------------------------------------------+--
c *   Object : give_figure_limit_y for y axe
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /figlim/ x1,x2,y1,y2
c
      ymin=y1
      ymax=y2
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfigori_(figorx,figory)
c
c     ---------------------------------------------------------------+--
c *   Object : give_figure_origine in cm. from lower left corner
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figori/ xz,yz
c
c *** valeur de la position des origines de la figure
c
      figorx=xz
      figory=yz
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfigsca_(figscx,figscy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_figure_scale in axe's uni/cm
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figsca/ ex,ey
c
      if(abs(ex).lt.1.e-20) call uperror_('gfigsca_: scale x undefined')
      if(abs(ey).lt.1.e-20) call uperror_('gfigsca_: scale y undefined')
c
      figscx=ex
      figscy=ey
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfigsiz_(figsix,figsiy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_figure_size in cm.
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figsiz/ rx,ry
c
c *** valeur de la taille de la figure en cm (=dim. axes)
c
      figsix=rx
      figsiy=ry
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfigzat_(zoatt)
c
c     ---------------------------------------------------------------+--
c *   Object : give_figure_zoom_attribute for grad.,labels,marks,title
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /biggra/ diafig,unifig,zofiat
c
      data epsi  /1.e-35/
      save epsi
c
      if(diafig.lt.epsi)
     &     call uperror_('gfigzat_: taille de la figure non definie')
c
      zoatt=unifig/diafig
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfonnum_(numfon)
c
c     ---------------------------------------------------------------+--
c *   Object : give_font_number
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /fonnum/ nufon, bodfon
c
c
      numfon=nufon
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfontyp_(fontyp)
c
c     ---------------------------------------------------------------+--
c *   Object : give_font_type as  'c','h','hbold',...
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /fonnum/ nufon, bodfon
c
      character*(*) fontyp
c
      call cfontyp_(nufon,fontyp)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfrdate_(date17)
c
c     ---------------------------------------------------------------+--
c *   Object : give_french_date as '21 Septembre 1988' (17c.)
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) date17
      character*9 mois(12)
      integer lm(12)
      save mois,lm
c
      data mois/'Janvier','Fevrier','Mars','Avril','Mai','Juin',
     &'Juillet','Aout','Septembre','Octobre','Novembre','Decembre'/
c
      data lm/7,7,4,5,3,4,7,4,9,7,8,8/
c
c
      ll=len(date17)
      if(ll.lt.17)
     &     call uperror_('gfrdate_: date inferieur a 17 caracteres')
c
      call sys_gdattim(mm,jj,ian,ih,im,is)
      write(date17,100) jj,mois(mm)(1:lm(mm)),ian
c
  100 format(i2,1x,a,1x,i4)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gfrdati_(dati28)
c
c     ---------------------------------------------------------------+--
c *   Object : give_french_date_and_time '23 Octobre 1992 - 23:50:10'
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) dati28
      character*17 date
      character*8 time
      save date,time
c
c
      ll=len(dati28)
      if(ll.lt.28)
     &     call uperror_('gfrdati_: variable dati less than 28 charac.')
c
      call gfrdate_(date)
      call cchalen_(date,nd)
      call gditime_(time)
c
      write(dati28,100) date(1:nd),time
c
  100 format(a,' - ',a8)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ggrapos_(grapox,grapoy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_graduations_position in character*1 variable
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /grapos/ ipgrax,ipgray
c
      character*(*) grapox,grapoy
c
c
      grapox='?'
      grapoy='?'
c
      if(ipgrax.eq.1) then
                      grapox(1:1)='t'
                      else
                      grapox(1:1)='b'
                      endif
c
      if(ipgray.eq.1) then
                      grapoy(1:1)='r'
                      else
                      grapoy(1:1)='l'
                      endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ggrasiz_(grasix,grasiy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_graduations_size in cm.
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /grasiz/ tgrax,tgray,dgxax,dgyay,ncgrax,ncgray
c
c *** valeur de la taille des graduations en cm
c
      grasix=tgrax
      grasiy=tgray
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine glabpos_(labpox,labpoy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_labels_position in character*1 variable
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /labpos/ iplabx,iplaby
c
      character*(*) labpox,labpoy
c
c
      labpox='?'
      labpoy='?'
c
      if(iplabx.eq.0) then
                      labpox(1:1)='c'
                      else
                      if(iplabx.eq. 1) labpox(1:1)='r'
                      if(iplabx.eq.-1) labpox(1:1)='l'
                      endif
c
      if(iplaby.eq.0) then
                      labpoy(1:1)='c'
                      else
                      if(iplaby.eq. 1) labpoy(1:1)='t'
                      if(iplaby.eq.-1) labpoy(1:1)='b'
                      endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine glabsiz_(rlasix,rlasiy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_labels_size in cm.
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /labsiz/ tlax,tlay,dlxax,dlyay
c
c
      rlasix=tlax
      rlasiy=tlay
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gleadim_(x0,y0,sx,sy,ipos,sxe,sye,x1,x2,y1,y2,yt)
c
c     ---------------------------------------------------------------+--
c *   Object : give_leaf_dimensions of usefull square of the leaf
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c     utilitaire pour ppagleaf:
c     trace d'une feuille d'arbre, origine = pointe basse de la tige
c     ipos= -1, feuille vers la gauche, +1 vers la droite
c
c     donne:
c          sxe,sye: largeur et hauteur "efficace" du carre de la feuille
c          x1,x2  : position des bords verticaux
c          y1,y2  : position des bords horizontaux
c          yt     : hauteur de la tige
c
c
      x1= x0 +float(ipos)*sx*0.12
      x2= x0 +float(ipos)*sx*0.913
c
      y1= y0 +sy*0.045
      y2= y0 +sy*0.945
c
      yt= sy*0.07
c
      sxe= abs(x2-x1)
      sye= abs(y2-y1)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine glibver_(ver)
c
c     ------------------------------------------------------------------
c *   Object : give_library_version as 8.0
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      ver= 9.6
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine glincol_(col)
c
c     ---------------------------------------------------------------+--
c *   Object : give_line_color as 'n', or rgbcmypw
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) col
c
      common /lincol/ rc,gc,bc,hue,sat,bri,icol
c
c *** valeurs possibles: black, red, green, blue, cyan,
c                        magenta, yellow, pink, white
c
      col='n'
      if(icol.eq.1) col='r'
      if(icol.eq.2) col='g'
      if(icol.eq.3) col='b'
      if(icol.eq.4) col='c'
      if(icol.eq.5) col='m'
      if(icol.eq.6) col='y'
      if(icol.eq.7) col='p'
      if(icol.eq.8) col='w'
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine glinhsb_(h,s,b)
c
c     ---------------------------------------------------------------+--
c *   Object : give_line_hsb color components as h,s,b values
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /lincol/ rc,gc,bc,hue,sat,bri,icol
c
c
      h=hue
      s=sat
      b=bri
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine glinrgb_(r,g,b)
c
c     ---------------------------------------------------------------+--
c *   Object : give_line_rgb color components as r,g,b values
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /lincol/ rc,gc,bc,hue,sat,bri,icol
c
c
      r=rc
      g=gc
      b=bc
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine glinwid_(iwidth)
c
c     ---------------------------------------------------------------+--
c *   Object : give_lines_width in pixel, for current drawn lines
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /linwid/ iwid
c
      iwidth=iwid
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gpagfor_(pl)
c
      character*(*) pl
c
c     ---------------------------------------------------------------+--
c *   Object : give_page_format 'p' as portrait or 'l' as landscape
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagfor/ iorpag
c
      if(iorpag.eq.0) then
                      pl='p'
                      return
                      endif
c
      if(iorpag.eq.1) then
                      pl='l'
                      return
                      endif
c
      call uperror_('gpagfor_: error iorpag only 0 or 1')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gpagnum_(nupag)
c
c     ---------------------------------------------------------------+--
c *   Object : give_page_number of the current page
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /pagnum/ npage
c
      nupag=npage
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gpagori_(pagorx,pagory)
c
c     ---------------------------------------------------------------+--
c *   Object : give_page_origine in cm
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagori/ popagx,popagy
c
      pagorx=popagx
      pagory=popagy
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gpagppo_(pox,poy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_page_pen_position in cm
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /penpos/ pepox,pepoy
c
      pox=pepox
      poy=pepoy
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gpagsca_(scax,scay)
c
c     ---------------------------------------------------------------+--
c *   Object : give_page_scale_factor from lower left corner
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsca/ zomx,zomy
c
      scax=zomx
      scay=zomy
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gpagsiz_(pagsix,pagsiy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_page_size in cm.
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsiz/ tpx,tpy
c
      pagsix=tpx
      pagsiy=tpy
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gpripar_
c
c     ------------------------------------------------------------------
c *   Object : give_print_parameters
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      character*1 for,fontyp,col
      character*1 grapox,grapoy, labpox,labpoy, titpo
      character*2 stipox,stipoy

      save for,fontyp,col,grapox,grapoy, labpox,labpoy, titpo
      save stipox,stipoy
c
      call gpagfor_(for)
      call gpagori_(pagox,pagoy)
      call gpagsiz_(pagsx,pagsy)
      call gpagsca_(scalx,scaly)
      call gpagnum_(num)
c
      call gfontyp_(fontyp)
      call glincol_(col)
      call glinwid_(iwi)
c
      call ggrapos_(grapox,grapoy)
      call glabpos_(labpox,labpoy)
      call gstipos_(stipox,stipoy)
      call gtitpos_(titpo)
c
      call ggrasiz_(grasix,grasiy)
      call glabsiz_(rlasix,rlasiy)
      call gstisiz_(stisix,stisiy)
      call gtitsiz_(titsi)
c
      print 100
      print 100, 'page  format       =',for
      print 300, 'page  origine x-y  =',pagox,pagoy
      print 300, 'page  size    x-y  =',pagsx,pagsy
      print 300, 'page  scale   x-y  =',scalx,scaly
      print 200, 'page  number       =',num
c
      print 100
      print 100, 'character font     =',fontyp
      print 100, 'lines color        =',col
      print 200, 'lines width        =',iwi
      print 100
c
      print 500, 'graduation position=',grapox,grapoy
      print 500, 'label      position=',labpox,labpoy
      print 500, 'sticks     position=',stipox,stipoy
      print 500, 'titre      position=',titpo
c
      print 300, 'graduation size    =',grasix,grasiy
      print 300, 'label      size    =',rlasix,rlasiy
      print 300, 'sticks     size    =',stisix,stisiy
      print 300, 'titre      size    =',titsi
      print 100
c
  100 format(a,2x,a)
  200 format(a,i3)
  300 format(a,2f12.4)
clm  400 format(a,2(6x,i6))
  500 format(a,2(5x,a))
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gasdati_(dati26)
c
c     ---------------------------------------------------------------+--
c *   Object : give_atro_date_time as '1992, Oct. 23, 18:12 UT'
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2008
c     ---------------------------------------------------------------+--
c
      character*(*) dati26
      character*9 mois(12)
      integer lm(12)
      save mois,lm
c
      data mois/'January','February','March','April','May','June',
     &'July','August','September','October','November','December'/
c
      data lm/7,8,5,5,3,4,4,6,9,7,8,8/
c
c
      ll=len(dati26)
      if(ll.lt.26)
     &     call uperror_('gasdati_: date inferieur a 26 caracteres')
c
      call sys_gdattim(mm,jj,ian,ih,im,is)
      write(dati26,100) ian,mois(mm)(1:lm(mm)),jj,ih,im
c
  100 format(i4.4,', ',a3,'. ',i2.2,' - ',i2.2,':',i2.2,' UT')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gstdati_(dati25)
c
c     ---------------------------------------------------------------+--
c *   Object : give_standart_date_time as 'October 23, 18:12, 1992'
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) dati25
      character*18 date
      character*8 time
      save date,time
c
      ll=len(dati25)
      if(ll.lt.25)
     &     call uperror_('gstdati_: variable dati less than 25 charac.')
c
      call gusdate_(date)
      call cchalen_(date,nd)
      call gditime_(time)
c
      write(dati25,100) date(1:nd-5),' ',time(1:5),date(nd-5:nd)
c
  100 format(4a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gstipos_(stipox,stipoy)
c
c     ---------------------------------------------------------------+--
c *   Object : give_sticks_position in character*1 variable
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /stipos/ ipmabx,ipmahx,ipmagy,ipmady
c
      character*(*) stipox,stipoy
c
c *** valeur de la position des marques (int,ext)/figure
c
c
c
c     convention: 1=marques a l'interieur
c                 0=marques a l'exterieur de la figure
c
      stipox='??'
      stipoy='??'
c
      if(ipmabx.eq.1) then
                      stipox(1:1)='i'
                      else
                      stipox(1:1)='o'
                      endif
c
      if(ipmahx.eq.1) then
                      stipox(2:2)='i'
                      else
                      stipox(2:2)='o'
                      endif
c
      if(ipmagy.eq.1) then
                      stipoy(1:1)='i'
                      else
                      stipoy(1:1)='o'
                      endif
c
      if(ipmady.eq.1) then
                      stipoy(2:2)='i'
                      else
                      stipoy(2:2)='o'
                      endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gstisiz_(stisil,stisis)
c
c     ---------------------------------------------------------------+--
c *   Object : give_sticks_size in cm.
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /stisiz/ tgm,tpm
c
c     objet   : valeur de la taille des grandes et petites marques en cm
c
      stisil=tgm
      stisis=tpm
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gtitpos_(titpo)
c
c     ---------------------------------------------------------------+--
c *   Object : give_title_position in character*1 variable
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /titpos/ ipotit
c
      character*(*) titpo
c
      if(ipotit.eq.0) then
                      titpo='b'
                      else
                      titpo='t'
                      endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gtitsiz_(titsi)
c
c     ---------------------------------------------------------------+--
c *   Object : give_title_size in cm.
c *   Class  : give modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /titsiz/ ttit,dtax
c
c *** valeur de la taille du titre
c
      titsi=ttit
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gusdate_(date18)
c
c     ---------------------------------------------------------------+--
c *   Object : give_us_date as 'September 21, 1988' (18c.)
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) date18
      character*9 mois(12)
      integer lm(12)
      save mois,lm
c
      data mois/'January','February','March','April','May','June',
     &'July','August','September','October','November','December'/
c
      data lm/7,8,5,5,3,4,4,6,9,7,8,8/
c
c
      ll=len(date18)
      if(ll.lt.18)
     &     call uperror_('gusdate_: date inferieur a 18 caracteres')
c
      call sys_gdattim(mm,jj,ian,ih,im,is)
      write(date18,100) mois(mm)(1:lm(mm)),jj,ian
c
  100 format(a,1x,i2,',',1x,i4)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine gusdati_(dati29)
c
c     ---------------------------------------------------------------+--
c *   Object : give_us_date_time as 'October 23, 1992 - 23:50:10'
c *   Class  : give date/time modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) dati29
      character*18 date
      character*8 time
      save date,time
c
c
      ll=len(dati29)
      if(ll.lt.29)
     &     call uperror_('gusdati_: variable dati less than 29 charac.')
c
      call gusdate_(date)
      call cchalen_(date,nd)
      call gditime_(time)
c
      write(dati29,100) date(1:nd),time
c
  100 format(a,' - ',a8)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigarr_(orix,oriy,ipos,bodyl,bodyw,headl,headw,angle)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_arrow
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      call cfigpag_(orix,oriy,xx,yy)
      call gfigsca_(scax,scay)
c
      cbl=bodyl/scax
      cbw=bodyw/scay
c
      chl=headl/scax
      chw=headw/scay
c
      call ppagarr_(xx,yy,ipos,cbl,cbw,chl,chw,angle)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigcha_(orix,oriy,ipos,sizx,sizy,angle,chast)
c
      character*(*) chast
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_character_string size in cm
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      call cfigpag_(orix,oriy,xx,yy)
      call ppagcha_(xx,yy,ipos,sizx,sizy,angle,chast)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigcir_(xc,yc,r,teta1,teta2,dteta)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_circular_arc
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c *** scale X is assumed to compute the radius
c
      call gfigsca_(scx,scy)
      call cfigpag_(xc,yc,xcp,ycp)
c
      rp=r/scx
c
      call ppagcir_(xcp,ycp,rp,teta1,teta2,dteta)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigcor_
      common /figsiz/ rx,ry
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_corners
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call ppagrco_(0.,0.,rx,ry,ry/20.)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigculd(x1,dx,ay,n1,n2,nstep)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_curve_loop_dx
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension ay(n2)
c
c *** trace du tableau ty(n) pour x=x1+(n-1)*dx
c
      call cfigpag_(x1,ay(n1),xx,yy)
      call dpagppo_(xx,yy)
c
      x=x1
c
      do 10 i=n1+1,n2,nstep
      x=x+dx
      call cfigpag_(x,ay(i),xx,yy)
      call ppagpmo_(xx,yy)
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigcur_(ax,ay,n)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_curve from ax(n),ay(n)
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension ax(n),ay(n)
c
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)
      call ppagpmo_(xx,yy)
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigcurd(x1,dx,ay,n)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_curve_dx from x1
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension ay(n)
c
c *** trace du tableau ty(n) pour x=x1+(n-1)*dx
c
      call cfigpag_(x1,ay(1),xx,yy)
      call dpagppo_(xx,yy)
c
      x=x1
c
      do 10 i=2,n
      x=x+dx
      call cfigpag_(x,ay(i),xx,yy)
      call ppagpmo_(xx,yy)
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigcurl(ax,ay,n1,n2,nstep)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_curve_loop n=n1,n2,nstep
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension ax(n2),ay(n2)
c
c *** trace d'un tableau ay(n)=f(tx(n))
c
      if(n1.ge.n2) call uperror_('pfigcurl_: n1.ge.n2')
c
      call cfigpag_(ax(n1),ay(n1),xx,yy)
      call dpagppo_(xx,yy)
c
      do 10 i=n1+1,n2,nstep
      call cfigpag_(ax(i),ay(i),xx,yy)
      call ppagpmo_(xx,yy)
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigcurs(ax,ay,n,ipos,sizx,sizy,symb,col)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_curve_symbol size in cm
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension ax(n),ay(n)
      character*(*) symb,col
      character*1 pcol
      save pcol
c
c *** trace d'un tableau ay(n)=f(ax(n)) avec un symbol sur chaque point
c
c
c *** trace de la courbe avec la couleur courante
c
      call pfigcur_(ax,ay,n)
c
c *** changement de couleur pour les symboles
c
      call glincol_(pcol)
      call dlincol_(col)
c
c *** trace des symboles et remplissage,
c     contour des symbol avec la couleur de ligne
c
      do 10 i=1,n
      call dlincol_(col)
      call pfigsym_(ax(i),ay(i),ipos,sizx,sizy,symb)
      call pfilzon_
      call dlincol_(pcol)
      call pfigsym_(ax(i),ay(i),ipos,sizx,sizy,symb)
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigell_(xc,yc,a,b,rincli,teta1,teta2,dteta)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_elliptical_arc
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      call gfigsca_(scx,scy)
      call cfigpag_(xc,yc,xcp,ycp)
c
      ap=a/scx
      bp=b/scy
c
      call ppagell_(xcp,ycp,ap,bp,rincli,teta1,teta2,dteta)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigfra_
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_frame
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figsiz/ rx,ry
      common /figori/ xz,yz
c
c *** trace du cadre autour de la figure
c
      call sdr_wfilcom('begin pfigfra_')
c
      call dpagppo_(xz,yz)
      call ppagpmo_(xz+rx,yz)
      call ppagpmo_(xz+rx,yz+ry)
      call ppagpmo_(xz,yz+ry)
      call ppagpmo_(xz,yz)
c
      call sdr_wfilcom('end   pfigfra_')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiggrax(xref,bgx,sgx,forx)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_graduations_x as '(f3.0)',' ','*'
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
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
      character*(*) forx
      character*8   form
      character*1 ifg
      save form,ifg
c
      data epsi  /1.e-35/
      save epsi
c
c *** trace les graduations de l'axe x
c     bgx,sgx= bigstep and small step des graduation x
c
      call sdr_wfilcom('begin pfiggrax')
c
c *** verification du format
c
      if(forx.ne.' ') then
                      call uverfor_(forx,'pfiggrax')
                      call udecfor_(forx,ifg,ncgrax,ndec)
                      if((ifg.eq.'f' .or. ifg.eq.'F')
     &                .and.ndec.eq.0) then
                                      call uencfor_(form,'i',ncgrax-1,0)
                                      else
                                      form=forx
                                      endif
                      tgx=tgrax
                      else
                      form='*'
                      tgx=0.
                      endif
c
c *** verification des graduations
c
      if(bgx.lt.epsi) call uperror_('pfiggrax: big graduation <epsi')
      if(sgx.lt.epsi) call uperror_('pfiggrax: small graduation <epsi')
c
c *** valeur par defaut pour xref: si xref = 0 et qu'il n'est pas entre
c     x1 et x2, on prend xref= x1
c
      xref2=xref
      if(abs(xref).lt.epsi.and.(xref.lt.x1.or.xref.gt.x2)) xref2=x1
c
c *** trace des graduations
c
      yzp=yz+ry
      tgbx=tgm*float(ipmabx)
      tpbx=tpm*float(ipmabx)
      tghx=tgm*float(ipmahx)
      tphx=tpm*float(ipmahx)
c
c
      if (ipgrax.eq.1) then
c                      graduations en haut
                       if(ipmahx.eq.-1) then
                                        dg=tgm*1.5
                                        else
                                        dg=tgm*0.5
                                        endif
      call ppagaxex(xz,yz ,rx,x1,x2,xref2,bgx,sgx,-tgbx,-tpbx,0.,0.,'*')
      call ppagaxex(xz,yzp,rx,x1,x2,xref2,bgx,sgx, tghx, tphx,
     &                                                     tgx,-dg,form)
c
                       else
c                      graduations en bas
                       if(ipmabx.eq.-1) then
                                        dg=tgm*1.5
                                        else
                                        dg=tgm*0.5
                                        endif
      call ppagaxex(xz,yzp,rx,x1,x2,xref2,bgx,sgx, tghx, tphx,0.,0.,'*')
      call ppagaxex(xz,yz ,rx,x1,x2,xref2,bgx,sgx,-tgbx,-tpbx,
     &                                                      tgx,dg,form)
c
                       endif
c
      dgxax=dg
c
      call sdr_wfilcom('end   pfiggrax')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiggray(yref,bgy,sgy,fory)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_graduations_y as '(f3.0)',' ','*'
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
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
      character*(*) fory
      character*8   form
      character*1 ifg
      save form,ifg
c
      data epsi  /1.e-35/
      save epsi
c
c
c *** trace les graduations de l'axe y
c     bgy,sgy=bigstep and small step des graduation y
c
      call sdr_wfilcom('begin pfiggray')
c
c *** verification du format
c
      if(fory.ne.' ') then
                      call uverfor_(fory,'pfiggray')
                      call udecfor_(fory,ifg,ncgray,ndec)
                      if((ifg.eq.'f' .or. ifg.eq.'F')
     &                .and.ndec.eq.0) then
                                      ncgray= ncgray-1
                                      call uencfor_(form,'i',ncgray,0)
                                      else
                                      form=fory
                                      endif
                      tgy=tgray
                      else
                      form='*'
                      tgy=0.
                      endif
c
c *** verification des graduations
c
      if(bgy.lt.epsi) call uperror_('pfiggray: big graduation <epsi')
      if(sgy.lt.epsi) call uperror_('pfiggray: small graduations <epsi')
c
c
c *** valeur par defaut pour yref: si yref = 0 et qu'il n'est pas entre
c     y1 et y2, on prend yref= y1
c
      yref2=yref
      if(abs(yref).lt.epsi.and.(yref.lt.y1.or.yref.gt.y2)) yref2=y1
c
c *** trace des graduations
c
      xzp=xz+rx
      tggy=tgm*float(ipmagy)
      tpgy=tpm*float(ipmagy)
      tgdy=tgm*float(ipmady)
      tpdy=tpm*float(ipmady)
c
      if (ipgray.eq.1) then
c                    * graduations a droite
                       if(ipmady.eq.-1) then
                                        dg=tgm*1.5
                                        else
                                        dg= tgm*0.5
                                        endif
      call ppagaxey(xz ,yz,ry,y1,y2,yref2,bgy,sgy, tggy, tpgy,0.,0.,'*')
      call ppagaxey(xzp,yz,ry,y1,y2,yref2,bgy,sgy,-tgdy,-tpdy,tgy,
     &                                                         -dg,form)
c
                       else
c                    * graduation a gauche
                       if(ipmagy.eq.-1) then
                                        dg=tgm*1.5
                                        else
                                        dg= tgm*0.5
                                        endif
      call ppagaxey(xzp,yz,ry,y1,y2,yref2,bgy,sgy,-tgdy,-tpdy,0.,0.,'*')
      call ppagaxey(xz ,yz,ry,y1,y2,yref2,bgy,sgy, tggy, tpgy,tgy,
     &                                                          dg,form)
c
                       endif
c
      dgyay=dg
c
      call sdr_wfilcom('end   pfiggray')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiggri_(dx,dy)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_grid on the entire figure
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      call gfiglimx(x1,x2)
      call gfiglimy(y1,y2)
c
c *** trace des lignes tous les dx,dy
c
      call pfiggrix(x1,x2,dx,y1,y2)
      call pfiggriy(y1,y2,dy,x1,x2)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiggrix(x1,x2,dx,y1,y2)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_grid as vertical bars along x
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c *** trace des lignes verticales tous les dx cm
c
      nbar=int((x2-x1)/dx)+1
c
      do i=1,nbar
      x=float(i-1)*dx +x1
      call pfiglin_(x,y1,x,y2)
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiggriy(y1,y2,dy,x1,x2)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_grid as horizontal bars along y
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c *** trace des lignes horizontales tous les dy cm
c
      nbar=int((y2-y1)/dy)+1
c
      do i=1,nbar
      y=float(i-1)*dy +y1
      call pfiglin_(x1,y,x2,y)
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfighis_(x1,dx,ay,n,col)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_histogram
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension ay(n)
      character*(*) col
      character*1   col1
      save col1
c
c *** trace du tableau ay(n) pour x=x1+(n-1)*dx
c
      x1a=x1-dx/2.
      x1b=x1+dx/2.
c
      call glincol_(col1)
c
      do 20 k=1,2
c
      if(k.eq.1) then
                 if(col(1:1).eq.' ') go to 20
                 call dlincol_(col)
                 else
                 call dlincol_(col1)
                 endif
c
      call gfiglimy(ymin,ymax)
      call dfigppo_(x1a,ymin)
      call pfigpmo_(x1a,ay(1))
      call pfigpmo_(x1b,ay(1))
c
      do 10 i=2,n
      xia=x1a+float(i-1)*dx
      xib=x1b+float(i-1)*dx
      call pfigpmo_(xia,ay(i))
      call pfigpmo_(xib,ay(i))
   10 continue
      call pfigpmo_(xib,ymin)
      call pfigpmo_(x1a,ymin)
c
      if(k.eq.1) call pfilzon_
c
   20 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfighli_(y)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_horizontal_line
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figsiz/ rx,ry
      common /figori/ xz,yz
c
c
      call cfigpag_(0.,y,bid,yy)
      if(yy.lt.yz.or.yy.gt.yz+ry) return
c
      call dpagppo_(xz,yy)
      call ppagpmo_(xz+rx,yy)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigima_(orix,oriy,ipos,sizx,sizy,angle,image,nx,ny)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_image image in ico values
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      integer image(nx,ny)
c
c
      call gfigsca_(scx,scy)
      call cfigpag_(orix,oriy,opx,opy)
c
      spx=sizx/scx
      spy=sizy/scy
c
      call ppagima_(opx,opy,ipos,spx,spy,angle,image,nx,ny)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiglab_(labelx,labely)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_label
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) labelx,labely
c
      call pfiglabx(labelx)
      call pfiglaby(labely)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiglabx(labelx)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_label_x
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) labelx
c
      common /figsiz/ rx,ry
      common /figori/ xz,yz
      common /labsiz/ tlax,tlay,dlxax,dlyay
      common /labpos/ iplabx,iplaby
      common /grasiz/ tgrax,tgray,dgxax,dgyay,ncgrax,ncgray
      common /grapos/ ipgrax,ipgray
c
c
      call cchalen_(labelx,nx)
      if(nx.eq.0) return
c
      call sdr_wfilcom('begin pfiglabx')
c
c *** calcul de la largeur des caracteres du label
c
      call gfonnum_(numfon)
      call cchawid_(labelx,numfon,tlax,wid)
c
      if(wid.gt.rx) tlax=tlax*rx/wid
c
      if(iplabx.eq. 0) x=xz+rx/2.-wid/2.
      if(iplabx.eq.-1) x=xz
      if(iplabx.eq. 1) x=xz+rx -wid
c
c *** distance du label a l'axe
c
ccc   dlxax=dgxax+tgrax+tlax
      dlxax=dgxax+tgrax+tgrax
c
      if(ipgrax.eq.0) then
                      y=yz-dlxax-tlax
                      else
                      y=yz+ry+dlxax
                      endif
c
c *** trace du label
c
      call ppagcha_(x,y,-1,tlax,tlax,0.,labelx)
c
      call sdr_wfilcom('end   pfiglabx')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiglaby(labely)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_label_y
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      character*(*) labely
c
      common /figsiz/ rx,ry
      common /figori/ xz,yz
      common /labsiz/ tlax,tlay,dlxax,dlyay
      common /labpos/ iplabx,iplaby
      common /labsen/ islaby
      common /grasiz/ tgrax,tgray,dgxax,dgyay,ncgrax,ncgray
      common /grapos/ ipgrax,ipgray
c
c
      call cchalen_(labely,ny)
      if(ny.eq.0) return
c
      call sdr_wfilcom('begin pfiglaby')
c
c *** calcul de la largeur des caracteres du label
c
      call gfonnum_(numfon)
      call cchawid_(labely,numfon,tlay,wid)
c
      if(wid.gt.ry) tlay=tlay*ry/wid
c
c *** distance du label a l'axe
c
      call cchawid_('1',numfon,tgray,wid1)
      dlyay=dgyay +float(ncgray)*wid1 +wid1
c
c *** calcul du x,y pour le trace du label
c     x,y : point inf. gauche du label
c
      if(ipgray.eq.0) then
                      x=xz-dlyay
                      else
                      x=xz+rx+dlyay+tlay
                      endif
c
c *** correction selon orientation du label y
c
      if(islaby.eq.0) then
                      aa=90.
                      else
                      aa=0.
                      if(ipgray.eq.0) x= x -wid
                      endif
c
c dbg print*, 'ipgray,tlay,wid1,ncgray,dgyay,dlyay,x=',
c dbg&         ipgray,tlay,wid1,ncgray,dgyay,dlyay,x
c
      if(iplaby.eq.-1) y=yz
      if(iplaby.eq. 0) y=yz +ry/2. -wid/2.
      if(iplaby.eq. 1) y=yz+ry -wid
c
c *** trace du label
c
      call ppagcha_(x,y,-1,tlay,tlay,aa,labely)
c
      call sdr_wfilcom('end   pfiglaby')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiglea_(x0,y0,sx,sy,ipos)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_leaf
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      call gfigsca_(scx,scy)
      call cfigpag_(x0,y0,x0p,y0p)
c
      sxp=sx/scx
      syp=sy/scy
c
      call ppaglea_(x0p,y0p,sxp,syp,ipos)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigleg_(orix,oriy,ipos,ssx,ssy,symb,col,slx,sly,leg)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_legende size in cm
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*)  symb, col, leg
      character*8 pcol
      save pcol
c
c
c *** trace du symbole colore
c
      call glincol_(pcol)
      call dlincol_(col)
      call pfigsym_(orix,oriy,ipos,ssx,ssy,symb)
      call pfilzon_
      call dlincol_(pcol)
      call pfigsym_(orix,oriy,ipos,ssx,ssy,symb)
c
c *** trace de la legende
c
      call cfigpag_(orix,oriy,cmx,cmy)
c
      if(ipos.eq.0) then
                    xl=cmx + ssx/2. + slx
                    yl=cmy - sly/2.
                    else
                    yl=cmy + ssy/2. -sly/2.
                    if(ipos.eq.-1) then
                                   xl=cmx + ssx + slx
                                   else
                                   xl=cmx + slx
                                   endif
                    endif
c
      call ppagcha_(xl,yl,-1,slx,sly,0.,leg)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfiglin_(orix,oriy,endx,endy)
c
c     ------------------------------------------------------------------
c *   Object : plot_figure_line
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      call cfigpag_(orix,oriy,x1,y1)
      call cfigpag_(endx,endy,x2,y2)
c
      call ppaglin_(x1,y1,x2,y2)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigpmo_(tox,toy)
c
c     ------------------------------------------------------------------
c *   Object : plot_figure_pen_motion
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      call cfigpag_(tox,toy,x1,y1)
      call ppagpmo_(x1,y1)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigros_(xc,yc,r,angle)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_rotation_symbol Earth's rotation symbol
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      a1=angle +  45.
      a2=a1    + 270.
c
      call pfigcir_(xc,yc,r,a1,a2,10.)
c
      pisd=acos(-1.)/180.
c
      xf=xc + r*cos(a2*pisd)
      yf=yc + r*sin(a2*pisd)
c
      tet=a2+70.
      tet2=(90.-tet)*pisd
c
      a=0.50*r
      b=0.30*r
c
      xa=xf-a*cos(tet*pisd)
      ya=yf-a*sin(tet*pisd)
c
      xa1= xa +b*cos(tet2)
      ya1= ya -b*sin(tet2)
c
      xa2= xa -b*cos(tet2)
      ya2= ya +b*sin(tet2)
c
      call pfiglin_(xf,yf,xa1,ya1)
      call pfiglin_(xf,yf,xa2,ya2)
c
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigsta_(y,x1,x2,iwidth,col)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_status i.e. horizontal limited line
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) col
      character*1   col0
      save col0
c
      call cfigpag_(x1,y,xx1,yy)
      call cfigpag_(x2,y,xx2,yy)
c
      call glinwid_(iwid0)
      call dlinwid_(iwidth)
c
      call glincol_(col0)
      call dlincol_(col)
c
      call dpagppo_(xx1,yy)
      call ppagpmo_(xx2,yy)
c
      call dlinwid_(iwid0)
      call dlincol_(col0)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigsym_(orix,oriy,ipos,sizx,sizy,symb)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_symbol size in cm
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*)  symb
c
c
      call cfigpag_(orix,oriy,xx,yy)
      call ppagsym_(xx,yy,ipos,sizx,sizy,symb)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigtav_(orix,oriy,ipos,sizx,sizy,angle,tex,val,format)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_text_and_value
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) tex,format
c
c
      call cfigpag_(orix,oriy,xx,yy)
      call gfigsca_(scax,scay)
c
      cmx=sizx/scax
      cmy=sizy/scay
c
      call ppagtav_(xx,yy,ipos,cmx,cmy,angle,tex,val,format)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigtit_(title)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_title
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) title
c
      common /figsiz/ rx,ry
      common /figori/ xz,yz
      common /titsiz/ ttit,dtax
      common /titpos/ ipotit
      common /grapos/ ipgrax,ipgray
      common /labsiz/ tlax,tlay,dlxax,dlyay
c
      data epsi  /1.e-35/
      save epsi
c
c
      if(ttit.lt.epsi) return
c
      call cchalen_(title,nct)
      if(nct.eq.0) return
c
      call sdr_wfilcom('begin pfigtit_')
c
c *** calcul de la largeur des caracteres du titre
c
      call gfonnum_(numfon)
      call cchawid_(title,numfon,ttit,wid)
c
      if(wid.gt.rx) then
                    tc=ttit*rx/wid
                    else
                    tc=ttit
                    endif
c
c *** distance du titre a l'axe
c
      if(ipgrax.eq.ipotit) then
                           dtax=dlxax+tlax+tc*1.5
                           else
                           dtax=tc*1.5
                           endif
c
      x=xz+rx/2.
      if(ipotit.eq.1) then
                      y=yz+ry+dtax
                      else
                      y=yz-dtax-tc
                      endif
c
c *** trace du titre
c
      call ppagcha_(x,y,0,tc,tc,0.,title)
c
      call sdr_wfilcom('end   pfigtit_')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigval_(orix,oriy,ipos,sizx,sizy,angle,value,format)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_value
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) format
c
c
      call cfigpag_(orix,oriy,xx,yy)
      call ppagval_(xx,yy,ipos,sizx,sizy,angle,value,format)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfigvli_(x)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_figure_vertical_line
c *   Class  : plot figure modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figsiz/ rx,ry
      common /figori/ xz,yz
c
c
      call cfigpag_(x,0.,xx,yy)
      if(xx.lt.xz.or.xx.gt.xz+rx) return
c
      call dpagppo_(xx,yz)
      call ppagpmo_(xx,yz+ry)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine pfilzon_
c
c     ---------------------------------------------------------------+--
c *   Object : plot_fill_zone zone defined before
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call sdr_pfilzon
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagarr_(orix,oriy,ipos,bodyl,bodyw,headl,headw,angle)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_arrow
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      real x(9),y(9)
      save x,y
c
      data epsi  /1.e-35/
      save epsi
c
c
      pisd=acos(-1.)/180.
c
      if(abs(bodyl).lt.epsi.and.abs(bodyw).lt.epsi) return
c
      ax=bodyl-headl
      bx=headl
      cy=bodyw/2.
      dy=headw/2.
c
      if(ipos.eq.-1) then
                     xx=orix
                     yy=oriy
                     else
                     if(ipos.eq.1) then
                                   xx=orix-bodyl*cos(angle*pisd)
                                   yy=oriy-bodyl*sin(angle*pisd)
                                   else
                                   xx=orix-bodyl*cos(angle*pisd)/2.
                                   yy=oriy-bodyl*sin(angle*pisd)/2.
                                   endif
                     endif
c
      x(1)= 0.
      x(2)= 0.
      x(3)= ax
      x(4)= ax
      x(5)= ax+bx
      x(6)= ax
      x(7)= ax
      x(8)= 0.
      x(9)= 0.
c
      y(1)=  0.
      y(2)= -cy
      y(3)= -cy
      y(4)= -dy
      y(5)=  0.
      y(6)=  dy
      y(7)=  cy
      y(8)=  cy
      y(9)=  0.
c
      do 10 i=1,9
      call cplarot_(0.,0.,angle,x(i),y(i),x2,y2)
      x(i)=xx+x2
      y(i)=yy+y2
   10 continue
c
      call dpagppo_(x(1),y(1))
c
      do 20 i=2,9
      call ppagpmo_(x(i),y(i))
   20 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagaxex(ox,oy,rx,x1,x2,xref,bgx,sgx,tgm,tpm,tg,dga,fg)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_axe_x, with no predefined options
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) fg
      character*8  fg_8
      character*16  for
      character*1 ifg
      save fg_8,for,ifg
c
      data epsi /1.e-10/
      save epsi
c
c *** trace les graduations d'un axe X entierement defini
c     modif P. Robert, Aout 2005, pour graduations quelconques
c
c      ox,oy=coordonnees en cm de l'origine de l'axe
c      rx=longueur en cm de l'axe x
c
c      x1,x2 : valeurs en unite d'axe des bornes, en ox et ox+rx
c      xref  : valeur de reference pour les graduations, multiple de bgx
c      bgx   : big   graduation x, intervalle entre 2 grandes marques
c      sgx   : small graduation x, intervalle entre 2 petites marques
c
c      tgm   : taille en cm des grandes marques
c      tpm   : taille en cm des petites marques
c      tg    : taille en cm des graduations
c      dga   : distance en cm des graduations a l'axe
c      fg    : format des graduations  ex'  >(f7.2)>
c
c *** on ne fait rien si la taille des marques est trop petite
c
      if(abs(tgm).lt.epsi) return
c
c *** nombre maximum de grandes marques gauches et droites
c
      ngmg= int((xref-x1)/bgx +0.1) +1
      ngmd= int((x2-xref)/bgx +0.1) +1
c
c *** modif des intervalle de graduation si pas assez de grandes marques
c
      if(ngmg +ngmd.le.1) then
                          bgx=bgx/2.
                          sgx=sgx/2.
                          ngmg= int((xref-x1)/bgx +0.1) +1
                          ngmd= int((x2-xref)/bgx +0.1) +1
                          endif
c
c *** nombre de petites marques entre 2 grandes marques
c
      npm= int(bgx/sgx +0.1) -1
c
c *** position en cm de la graduation de reference
c
      dx= x2-x1
      oxref= ox +(xref-x1)*rx/dx
c
      bgxcm= bgx*rx/dx
      sgxcm= sgx*rx/dx
c
c *** calcul du format si option '*'
c
      fg_8=fg
      if(fg_8(1:1).eq.'*'.or.fg_8(1:3).eq.'(*)') then
                                             call cbesfor_(xref+bgx,for)
                                             else
                                             for=fg
                                             endif
c
c *   verif
c
      call uverfor_(for,'ppagaxex')
      call udecfor_(for,ifg,ncfgra,ndec)
      if(ncfgra.le.0) call uperror_('ppagaxex: abnormal format')
c
c *** correction eventuelle de la taille des graduations
c
      if(bgxcm.lt.tg*float(ncfgra+2)) then
                                      tcx=bgxcm/float(ncfgra+2)
                                      else
                                      tcx=tg
                                      endif
c
      if(tcx.lt.tg/1.5) then
                        tcy=tcx*1.5
                        else
                        tcy=tg
                        endif
c
      if(dga.gt.0.) then
                    isig=1
                    else
                    isig=-1
                    endif
c
      dga2=dga +float(isig)*tcy/2.
c
c XXX on trace les graduations a partir de la valeur de reference xref,
c     a gauche et puis a droite
c
c *** graduation de l'axe a gauche de la grad. de reference
c
c
cc *   tolerence pour la precision de la position des graduations
c
      epsicm=1.e-3
c
      do 10 i= 1,ngmg+2
      xi = oxref -float(i-1)*bgxcm
      gra=  xref -float(i-1)*bgx
c
      if(xi.ge.ox-epsicm.and.xi.le.ox+rx+epsicm) then
c *                grandes marques
                   call dpagppo_(xi,oy)
                   call ppagpmo_(xi,oy-tgm)
c *                graduation correspondante
                   if(x1.lt.0.) then
                                xig=xi-tcx/4.
                                else
                                xig=xi
                                endif
                   call ppagval_(xig,oy-dga2,0,tcx,tcy,0.,gra,for)
                   endif
c
c *   petites marques
c
      do 20 j=1,npm
      xj= xi -float(j)*sgxcm
      if(xj.ge.ox-epsicm.and.xj.le.ox+rx+epsicm) then
                   call dpagppo_(xj,oy)
                   call ppagpmo_(xj,oy-tpm)
                   endif
   20 continue
c
   10 continue
c
c
c *** graduation de l'axe a droite de la grad. de reference
c
      do 30 i= 1,ngmd+2
      xi = oxref +float(i-1)*bgxcm
      gra=  xref +float(i-1)*bgx
c
      if(xi.le.ox+rx+epsicm.and.xi.ge.ox-epsicm.and.i.gt.1) then
c *                grandes marques
                   call dpagppo_(xi,oy)
                   call ppagpmo_(xi,oy-tgm)
c *                graduation correspondante
                   if(x1.lt.0.) then
                                xig=xi-tcx/4.
                                else
                                xig=xi
                                endif
                   call ppagval_(xig,oy-dga2,0,tcx,tcy,0.,gra,for)
                   endif
c
c *   petites marques
c
      do 40 j=1,npm
      xj= xi +float(j)*sgxcm
      if(xj.le.ox+rx+epsicm.and.xj.ge.ox-epsicm) then
                                   call dpagppo_(xj,oy)
                                   call ppagpmo_(xj,oy-tpm)
                                   endif
   40 continue
c
   30 continue
c
c *** trait plein sur l'axe
c
      call dpagppo_(ox,oy)
      call ppagpmo_(ox+rx,oy)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagaxey(ox,oy,ry,y1,y2,yref,bgy,sgy,tgm,tpm,tg,dga,fg)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_axe_y, with no predefined options
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) fg
      character*8  fg_8
      character*16  for
      character*1 ifg
      save fg_8,for,ifg
c
      data epsi /1.e-10/
      save epsi
c
c *** trace les graduations d'un aye Y entierement defini
c     modif P. Robert, Aout 2005, pour graduations quelconques
c
c      ox,oy=coordonnees en cm de l'origine de l'aye
c      ry=longueur en cm de l'aye y
c
c      y1,y2 : valeurs en unite d'aye des bornes, en oy et oy+ry
c      yref  : valeur de reference pour les graduations, multiple de bgy
c      bgy   : big   graduation y, intervalle entre 2 grandes marques
c      sgy   : small graduation y, intervalle entre 2 petites marques
c
c      tgm   : taille en cm des grandes marques
c      tpm   : taille en cm des petites marques
c      tg    : taille en cm des graduations
c      dga   : distance en cm des graduations a l'aye
c      fg    : format des graduations  ey'  >(f7.2)>
c
c *** on ne fait rien si la taille des marques est trop petite
c
      if(abs(tgm).lt.epsi) return
c
c *** nombre maximum de grandes marques gauches et droites
c
      ngmg= int((yref-y1)/bgy +0.1) +1
      ngmd= int((y2-yref)/bgy +0.1) +1
c
c *** modif des intervalle de graduation si pas assez de grandes marques
c
      if(ngmg +ngmd.le.1) then
                          bgy=bgy/2.
                          sgy=sgy/2.
                          ngmg= int((yref-y1)/bgy +0.1) +1
                          ngmd= int((y2-yref)/bgy +0.1) +1
                          endif
c
c *** nombre de petites marques entre 2 grandes marques
c
      npm= int(bgy/sgy +0.1) -1
c
c *** position en cm de la graduation de reference
c
      dy= y2-y1
      oyref= oy +(yref-y1)*ry/dy
c
      bgycm= bgy*ry/dy
      sgycm= sgy*ry/dy
c
c *** calcul du format si option '*'
c
      fg_8=fg
      if(fg_8(1:1).eq.'*'.or.fg_8(1:3).eq.'(*)') then
                                             call cbesfor_(yref+bgy,for)
                                             else
                                             for=fg
                                             endif
c
c *   verif
c
      call uverfor_(for,'ppagaxey')
      call udecfor_(for,ifg,ncfgra,ndec)
      if(ncfgra.le.0) call uperror_('ppagaxey: abnormal format')
c
c *** correction eventuelle de la taille des graduations
c
      if(tg/bgycm.ge.0.6) then
                          tcy=0.6*bgycm
                          else
                          tcy=tg
                          endif
      tcx=tcy
c
      if(dga.gt.0.) then
c                 * graduations a gauche      
                    isig=1
                    else
c                 * graduations a droite                    
                    isig=-1
                    endif
c
c
c XXX on trace les graduations a partir de la valeur de reference yref,
c     a gauche et puis a droite (en dessous et au dessus)
c
c *** graduation de l'axe a gauche de la grad. de reference
c
c *   tolerence pour la precision de la position des graduations
c
      epsicm=1.e-3
      do 10 i= 1,ngmg+2
      yi = oyref -float(i-1)*bgycm
      gra=  yref -float(i-1)*bgy
c
      if(yi.ge.oy-epsicm.and.yi.le.oy+ry+epsicm) then
c *            grandes marques
               call dpagppo_(ox,yi)
               call ppagpmo_(ox+tgm,yi)
c *            graduation correspondante
               call ppagval_(ox-dga,yi-tcy*0.5,isig,tcx,tcy,0.,gra,for)
               endif
c
c *   petites marques
c
      do 20 j=1,npm
      yj= yi -float(j)*sgycm
      if(yj.ge.oy-epsicm.and.yj.le.oy+ry+epsicm) then
                                   call dpagppo_(ox,yj)
                                   call ppagpmo_(ox+tpm,yj)
                                   endif
   20 continue
c
   10 continue
c
c
c *** graduation de l'axe a droite  de la grad. de reference
c
      do 30 i= 1,ngmd+2
      yi = oyref +float(i-1)*bgycm
      gra=  yref +float(i-1)*bgy
c
      if(yi.le.oy+ry+epsicm.and.yi.ge.oy-epsicm.and.i.gt.1) then
c *            grandes marques
               call dpagppo_(ox,yi)
               call ppagpmo_(ox+tgm,yi)
c *            graduation correspondante
               call ppagval_(ox-dga,yi-tcy*0.5,isig,tcx,tcy,0.,gra,for)
               endif
c
c *   petites marques
c
      do 40 j=1,npm
      yj= yi +float(j)*sgycm
      if(yj.le.oy+ry+epsicm.and.yj.ge.oy-epsicm) then
                                   call dpagppo_(ox,yj)
                                   call ppagpmo_(ox+tpm,yj)
                                   endif
   40 continue
c
   30 continue
c
c *** trait plein sur l'axe
c
      call dpagppo_(ox,oy)
      call ppagpmo_(ox,oy+ry)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagcha_(orix,oriy,ipos,sizx,height,angle,chast)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_character_string ipos=-1,0,+1 sizx not used
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) chast
c
      common /numvec/ nbppo,nbpmo,nbtpo,nbtmo
      common /penpos/ pepox,pepoy
      common /fonnum/ nufon, bodfon
      common /pagfor/ iorpag
      common /pagori/ popagx,popagy
      common /pagsiz/ tpx,tpy
      common /boupag/ xminb,xmaxb,yminb,ymaxb
c
      data epsi  /1.e-35/
      save epsi
c
      pisd=acos(-1.)/180.
c
c *** trace d un texte
c
c     ipos=-1 origine coin inf gauche
c     ipos= 0 origine au milieu
c     ipos= 1 origine coin inf droit
c
c
c *** on arrete si taille nulle ou chaine blanche
c
clm>
clm   Astuce pour utiliser le sizx afin de "calmer" foresys
      if(sizx.lt.height/10.) call uperror_('ppagcha_: sizx <height/10.')
clm<
c
c
      if(height.lt.epsi) return
c
      call cchalen_(chast,n)
      if(n.eq.0) return
c
c *** test ipos
c
      if(ipos.eq.-1.
     &or.ipos.eq. 0.
     &or.ipos.eq. 1) then
c                    OK
                     else
                     call uperror_('ppagcha_: ipos # of -1,0,+1')
                     endif
c
c *** calcul de la longueur de la chaine en cm
c
      call cchawid_(chast,nufon,height,width)
c
c *** influence de l'angle pour le positionnement
c
      ar= angle*pisd
      ax= width*cos(ar)
      ay= width*sin(ar)
      bx=height*sin(ar)
      by=height*cos(ar)
c
c *** position standard coin inferieur gauche (ipos= -1)
c
      xx=orix-popagx
      yy=oriy-popagy
c
c *** on ramene les coordonnees au point inf. gauche
c     pour l'option centree ou cadree a droite
c
      if(ipos.eq.0) then
                    xx=orix-popagx-ax/2.+bx/2.
                    yy=oriy-popagy-ay/2.-by/2.
                    endif
c
      if(ipos.eq.1) then
                    xx=orix-popagx-ax+bx/2.
                    yy=oriy-popagy-ay
                    endif
c
c *** on ne trace rien si la coordonnee est en dehors de la page
c
c /// if(xx.lt.0.or.xx.gt.tpx) return
c /// if(yy.lt.0.or.yy.gt.tpy) return
c
c /// trace du texte par police interne  espacement fixe
c
c /// OBSOLETE
c
c /// correction de l'angle si format paysage
c
c ///     if(iorpag.eq.0) then
c ///                     apl=angle
c ///                     else
c ///                     apl=angle+90.
c ///                     endif
c
c /// if(ifon.eq.0) then
c ///               do 10 i=1,n
c ///               xxi=xx+(i-1)*ax
c ///               yyi=yy+(i-1)*ay
c ///               call upchael_(chast(i:i),xxi,yyi,sizx,height,apl)
c ///  10           continue
c ///               return
c ///               endif
c
c *** trace du texte par appel au generateur graphique du driver
c
c **  calcul et reinitialisation eventuelle du corps de la fonte
c
      call cfonbod_(nufon,height,fonbod)
      call sdr_dfonnab(nufon,fonbod)
c
c *** correction  si format paysage
c
      if(iorpag.eq.0) then
                      x1=xx
                      y1=yy
                      apl=angle
c
                      else
                      x1= tpy-yy
                      y1=xx
                      apl=angle+90.
                      endif
c
c **  trace
c
      call sdr_ppagcha(chast(1:n),x1,y1,apl)
c
      nbppo=nbppo+1
      pepox=xx
      pepoy=yy
c
c *** update des extrema du trace (page/paysage cm unit)
c
      ca= cos(apl*pisd)
      sa= sin(apl*pisd)
c
      x2= x1 + width*ca
      x3= x2 -height*sa
      x4= x1 -height*sa
c
      y2= y1 + width*sa
      y3= y2 +height*ca
      y4= y1 +height*ca
c
      xminb= min(xminb, x1,x2,x3,x4)
      yminb= min(yminb, y1,y2,y3,y4)
      xmaxb= max(xmaxb, x1,x2,x3,x4)
      ymaxb= max(ymaxb, y1,y2,y3,y4)
c
      call sdr_updbbox
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagchav(x,y,ipos,tax,tay,texte)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_character_string_v vertically, top to bottom
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) texte
c
      data epsi  /1.e-35/
      save epsi
c
c
c *** trace d'un texte vertical (enseigne)
c
c
      if(tax.lt.epsi) return
      if(tay.lt.epsi) return
c
      call cchalen_(texte,nbcara)
c
      do 10 i=1,nbcara
      yy=y+float(nbcara-1)*tay
      call ppagcha_(x,yy,ipos,tax,tay,0.,texte(i:i))
   10 continue
c
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagcir_(xc,yc,r,teta1,teta2,dteta)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_circular_arc
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      if(teta2.gt.teta1) then
                         n=int((teta2-teta1)/dteta+0.5)
                         else
                         n=int((teta2-teta1+360.)/dteta+0.5)
                         endif
c
      call cpolcar_(r,teta1,x,y)
      call dpagppo_(x+xc,y+yc)
c
      do 10 i=1,n
      tet=float(i)*dteta+teta1
      call cpolcar_(r,tet,x,y)
      call ppagpmo_(x+xc,y+yc)
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagcmah(orix,oriy,sizx,sizy,isens)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_palette horizontal, isens=+1 -> red on right
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /colmap/ hueu,satu,briu,nbcolu
c
      real hueu(256),satu(256),briu(256)
c
      integer imaico(256,1)
      save imaico
c
c
c *** conversion de la color map courante en code ico
c
      do 10 i=1,nbcolu
c
      if(isens.gt.0) then
                     ii= nbcolu-i+1
                     else
                     ii=i
                     endif
c
      call chsbrgb_(hueu(ii),satu(ii),briu(ii),r,g,b)
c
      ir=int(r*255.)
      ig=int(g*255.)
      ib=int(b*255.)
c
      call crgbico_(ir,ig,ib,imaico(i,1))
c
   10 continue
c
c *** trace
c
      call ppagima_(orix,oriy,-1,sizx,sizy,0.,imaico,nbcolu,1)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagcmav(orix,oriy,sizx,sizy,isens)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_palette vertical, isens=+1 -> red on top
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /colmap/ hueu,satu,briu,nbcolu
c
      real hueu(256),satu(256),briu(256)
c
      integer imaico(256,1)
      save imaico
c
c
c *** conversion de la color map courante en code ico
c
      do 10 i=1,nbcolu
c
      if(isens.gt.0) then
                     ii= nbcolu-i+1
                     else
                     ii=i
                     endif
c
      call chsbrgb_(hueu(ii),satu(ii),briu(ii),r,g,b)
c
      ir=int(r*255.)
      ig=int(g*255.)
      ib=int(b*255.)
c
      call crgbico_(ir,ig,ib,imaico(i,1))
c
   10 continue
c
c *** trace
c
      call ppagima_(orix-sizx,oriy,-1,sizx,sizy,90.,imaico,nbcolu,1)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagcor_
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_corners
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsiz/ tpx,tpy
c
c
      call sdr_wfilcom('begin ppagcor_')
      call ppagrco_(0.,0.,tpx,tpy,tpy/20.)
      call sdr_wfilcom('end   ppagcor_')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagell_(xc,yc,a,b,rincli,teta1,teta2,dteta)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_elliptical_arc
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      pisd=acos(-1.)/180.
c
      n=int((teta2-teta1)/dteta+0.5)
c
      tetr=teta1*pisd
      x=a*cos(tetr) + xc
      y=b*sin(tetr) + yc
      call cplarot_(xc,yc,rincli,x,y,x2,y2)
      call dpagppo_(x2,y2)
c
      do 10 i=1,n
      tet=float(i)*dteta+teta1
      tetr=tet*pisd
      x=a*cos(tetr) + xc
      y=b*sin(tetr) + yc
      call cplarot_(xc,yc,rincli,x,y,x2,y2)
      call ppagpmo_(x2,y2)
   10 continue
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagfoo_(foot)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_foot add ps name
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagnum/ npage
      common /npsfil/ psfil
      common /foofon/ ifonf, hfonf
c
      character*(*) foot
      character*255 psfil
      character*255 com
      save com
c
c
      call sdr_wfilcom('begin ppagfoo_')
c
      call cchalen_(foot,ncf)
      call cchalen_(psfil,ncp)
c
      if(npage.eq.1) then
                     write(com,100) foot(1:ncf),psfil(1:ncp)
                     else
                     write(com,200) foot(1:ncf),psfil(1:ncp),npage
                     endif
c
      call gfonnum_(ifon)
      call dfonnum_(ifonf)
      call ppagcha_(0.2,hfonf/2.+0.07,-1,hfonf,hfonf,0.,com)
      call dfonnum_(ifon)
c
      call sdr_wfilcom('end   ppagfoo_')
c
  100 format(2a)
  200 format(2a,' - Page',i3)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagfra_
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_frame
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsiz/ tpx,tpy
c
c
      call sdr_wfilcom('begin ppagfra_')
c
      call dpagppo_(0.,0.)
      call ppagpmo_(tpx,0.)
      call ppagpmo_(tpx,tpy)
      call ppagpmo_(0.,tpy)
      call ppagpmo_(0.,0.)
c
      call sdr_wfilcom('end   ppagfra_')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppaggri_
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_grid on the entire page
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
c *** trace du cadre de la page
c
      call gpagsiz_(sx,sy)
c
c *** trace des lignes tous les cm.
c
      do ix=1,int(sx),1
      call ppagvli_(float(ix))
      enddo
c
      do iy=1,int(sy),1
      call ppaghli_(float(iy))
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppaggrix(x1,x2,dx,y1,y2)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_grid_x as vertical bars along x
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c *** trace des lignes verticales tous les dx cm
c
      nbar=int((x2-x1)/dx)+1
c
      do i=1,nbar
      x=float(i-1)*dx +x1
      call ppaglin_(x,y1,x,y2)
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppaggriy(y1,y2,dy,x1,x2)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_grid_y as horizontal bars along y
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c *** trace des lignes horizontales tous les dy cm
c
      nbar=int((y2-y1)/dy)+1
c
      do i=1,nbar
      y=float(i-1)*dy +y1
      call ppaglin_(x1,y,x2,y)
      enddo
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppaghea_(header)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_header add st.datime
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsiz/ tpx,tpy
      common /heafon/ ifonh, hfonh
      common /heapos/ ipohea,dishea
c
      character*(*) header
      character*26  asdati
      character*255 hhdat
c
      save asdati,hhdat
c
c
      call sdr_wfilcom('begin ppaghea_')
c
      call gasdati_(asdati)
      call cchalen_(header,nch)
c
      hhdat=header(1:nch)//' '//asdati
c
c *   position
      if(ipohea.eq.0) then
                      ox=tpx/2.
                      else
                      if(ipohea.eq.1) then
                                      ox=tpx -0.2
                                      else
                                      ox= 0.2
                                      endif
                      endif
      oy=tpy-dishea
c
c *   plot
c
      call gfonnum_(ifon)
      call dfonnum_(ifonh)
      call ppagcha_(ox,oy,ipohea,hfonh,hfonh,0.,hhdat)
      call dfonnum_(ifon)
c
      call sdr_wfilcom('end   ppaghea_')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppaghli_(y)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_horizontal_line
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsiz/ tpx,tpy
c
c
      call dpagppo_(0.,y)
      call ppagpmo_(tpx,y)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagima_(orix,oriy,ipos,sizx,sizy,angle,image,nx,ny)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_image image in ico values
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      integer image(nx,ny)
c
      common /numvec/ nbppo,nbpmo,nbtpo,nbtmo
      common /penpos/ pepox,pepoy
      common /pagfor/ iorpag
      common /pagori/ popagx,popagy
      common /pagsiz/ tpx,tpy
      common /boupag/ xminb,xmaxb,yminb,ymaxb
c
      pisd=acos(-1.)/180.
c
      if(nx .gt.300000) call uperror_(
     &'ppagima_:nb. points en x >300000')
c
      call sdr_wfilcom('begin ppagima_')
c
c *** test ipos
c
      if(ipos.eq.-1.
     &or.ipos.eq. 0.
     &or.ipos.eq. 1) then
c                    OK
                     else
                     call uperror_('ppagima_: ipos # of -1,0,+1')
                     endif
c
c *** influence de l'angle sur le positionnement
c
      ar=angle*pisd
      ax= sizx*cos(ar)
      ay= sizx*sin(ar)
      bx= sizy*sin(ar)
      by= sizy*cos(ar)
c
c *** position standard coin inferieur gauche (ipos= -1)
c
      xx=orix-popagx
      yy=oriy-popagy
c
c *** on ramene les coordonnees au point inf. gauche
c     pour l'option centree ou cadree a droite
c
      if(ipos.eq.0) then
                    xx=orix-popagx-ax/2.+bx/2.
                    yy=oriy-popagy-ay/2.-by/2.
                    endif
c
      if(ipos.eq.1) then
                    xx=orix-popagx-ax+bx/2.
                    yy=oriy-popagy-ay
                    endif
c
c *** on ne trace rien si la coordonnee est en dehors de la page
c
c /// if(xx.lt.0.or.xx.gt.tpx) return
c /// if(yy.lt.0.or.yy.gt.tpy) return
c
c *** correction de l'angle si format paysage
c
      if(iorpag.eq.0) then
                      x1=xx
                      y1=yy
                      apl=angle
c
                      else
                      x1=tpy-yy
                      y1=xx
                      apl=angle+90.
                      endif
c
c *** trace de l'image
c
      call sdr_ppagima(x1,y1,sizx,sizy,apl,image,nx,ny)
c
      nbppo=nbppo+1
      pepox=xx
      pepoy=yy
c
c *** update des extrema du trace (page/paysage cm unit)
c
      ca= cos(apl*pisd)
      sa= sin(apl*pisd)
c
      x2= x1 +sizx*ca
      x3= x2 -sizy*sa
      x4= x1 -sizy*sa
c
      y2= y1 +sizx*sa
      y3= y2 +sizy*ca
      y4= y1 +sizy*ca
c
      xminb= min(xminb, x1,x2,x3,x4)
      yminb= min(yminb, y1,y2,y3,y4)
      xmaxb= max(xmaxb, x1,x2,x3,x4)
      ymaxb= max(ymaxb, y1,y2,y3,y4)
c
      call sdr_updbbox
      call sdr_wfilcom('end   ppagima_')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppaglea_(x0,y0,sx,sy,ipos)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_pag_leaf
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c     trace d'une feuille d'arbre, origine = pointe basse de la tige
c     ipos=-1, feuille vers la gauche, +1 vers la droite
c
      real arci1x(7),arci1y(7),trai1x(4),trai1y(4)
      real arci2x(7),arci2y(7),trai2x(4),trai2y(4)
c
      real tra1x(4),tra1y(4)
      real tra2x(4),tra2y(4)
c
      real centx(7),centy(7)
      real teta1(7),teta2(7)
c
c *** save for gfotran
c
      save arci1x,arci1y,trai1x,trai1y
      save arci2x,arci2y,trai2x,trai2y
c
      save tra1x,tra1y
      save tra2x,tra2y
c
      save centx,centy
      save teta1,teta2
c
c *** ancienne version queue longue
c
c /// data arci1x /  0.0, -9.0, -9.0, -9.8, -1.8, -1.8,  0.0 /
c /// data arci1y /  0.0,  3.2,  7.9,  9.7,  7.2,  3.2,  1.2 /
c /// data arci2x / -1.9, -7.0, -9.8, -8.5, -3.8,  0.0,  0.0 /
c /// data arci2y /  1.2,  1.2,  9.7,  9.2,  9.2,  1.2,  0.0 /
c
c *** new version queue courte
c
      data arci1x /  0.0, -8.3, -8.3, -9.1, -1.1, -1.1, -0.3 /
      data arci1y /  0.0,  2.4,  7.1,  8.9,  6.4,  2.4,  0.7 /
      data arci2x / -1.2, -6.3, -9.1, -7.8, -3.1, -0.3,  0.0 /
      data arci2y /  0.4,  0.4,  8.9,  8.4,  8.4,  0.7,  0.0 /
c
c
c *** concordance des bords avec les cercles
c
      trai1x(1)=arci2x(1)
      trai1y(1)=arci2y(1)
c
      trai2x(1)=arci2x(2)
      trai2y(1)=arci2y(2)
c
c
      trai1x(2)=arci1x(2)
      trai1y(2)=arci1y(2)
c
      trai2x(2)=arci1x(3)
      trai2y(2)=arci1y(3)
c
c
      trai1x(3)=arci2x(4)
      trai1y(3)=arci2y(4)
c
      trai2x(3)=arci2x(5)
      trai2y(3)=arci2y(5)
c
c
      trai1x(4)=arci1x(5)
      trai1y(4)=arci1y(5)
c
      trai2x(4)=arci1x(6)
      trai2y(4)=arci1y(6)
c
c
c *** hauteur et largeur de la feuille, avec pointe et tige
c     (9.8 x 9.7)
c
      wfeuil=arci1x(1)-arci2x(3)
      hfeuil=arci2y(3)-arci1y(1)
c
c *** facteur de normalisation de hf et wf pour (1,1)
c
      fnorx=1./wfeuil
      fnory=1./hfeuil
c
c *** axes des ellipses correspondant aux cercles "scales"
c
      a=2.*fnorx*sx
      b=2.*fnory*sy
c
c *** correction par facteur d'echelle des arcs de cercles
c
      do 10 i=1,7
c
      x1= -float(ipos)*arci1x(i)*fnorx*sx +x0
      y1=              arci1y(i)*fnory*sy +y0
      x2= -float(ipos)*arci2x(i)*fnorx*sx +x0
      y2=              arci2y(i)*fnory*sy +y0
c
      if(ipos.eq.-1) then
      call cellarc_(x1,y1,x2,y2,a,b,centx(i),centy(i),teta1(i),teta2(i))
                     else
      call cellarc_(x2,y2,x1,y1,a,b,centx(i),centy(i),teta1(i),teta2(i))
                     endif
c
   10 continue
c
c *** correction par facteur d'echelle des lignes droites
c
      do 20 it=1,4
c
      tra1x(it)= -float(ipos)*trai1x(it)*fnorx*sx +x0
      tra1y(it)=              trai1y(it)*fnory*sy +y0
      tra2x(it)= -float(ipos)*trai2x(it)*fnorx*sx +x0
      tra2y(it)=              trai2y(it)*fnory*sy +y0
c
   20 continue
c
c *** trace de la feuille
c
      if(ipos.eq.-1) then
           call ppagell_(centx(1),centy(1),a,b,0.,teta1(1),teta2(1), 3.)
           call ppaglin_(tra1x(1),tra1y(1),       tra2x(1),tra2y(1))
           call ppagell_(centx(2),centy(2),a,b,0.,teta2(2),teta1(2),-3.)
           call ppaglin_(tra1x(2),tra1y(2),       tra2x(2),tra2y(2))
           call ppagell_(centx(3),centy(3),a,b,0.,teta1(3),teta2(3), 3.)
           call ppagell_(centx(4),centy(4),a,b,0.,teta1(4),teta2(4), 3.)
           call ppaglin_(tra1x(3),tra1y(3),       tra2x(3),tra2y(3))
           call ppagell_(centx(5),centy(5),a,b,0.,teta2(5),teta1(5),-3.)
           call ppaglin_(tra1x(4),tra1y(4),       tra2x(4),tra2y(4))
           call ppagell_(centx(6),centy(6),a,b,0.,teta1(6),teta2(6), 3.)
           call ppagell_(centx(7),centy(7),a,b,0.,teta1(7),teta2(7), 3.)
                     else
           call ppagell_(centx(1),centy(1),a,b,0.,teta2(1),teta1(1),-3.)
           call ppaglin_(tra2x(1),tra2y(1),       tra1x(1),tra1y(1))
           call ppagell_(centx(2),centy(2),a,b,0.,teta1(2),teta2(2), 3.)
           call ppaglin_(tra2x(2),tra2y(2),       tra1x(2),tra1y(2))
           call ppagell_(centx(3),centy(3),a,b,0.,teta2(3),teta1(3),-3.)
           call ppagell_(centx(4),centy(4),a,b,0.,teta2(4),teta1(4),-3.)
           call ppaglin_(tra2x(3),tra2y(3),       tra1x(3),tra1y(3))
           call ppagell_(centx(5),centy(5),a,b,0.,teta1(5),teta2(5), 3.)
           call ppaglin_(tra2x(4),tra2y(4),       tra1x(4),tra1y(4))
           call ppagell_(centx(6),centy(6),a,b,0.,teta2(6),teta1(6),-3.)
           call ppagell_(centx(7),centy(7),a,b,0.,teta2(7),teta1(7),-3.)
                     endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppaglin_(orix,oriy,endx,endy)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_line
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call dpagppo_(orix,oriy)
      call ppagpmo_(endx,endy)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagpmo_(tox,toy)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_pen_motion from cur. pos.
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /numvec/ nbppo,nbpmo,nbtpo,nbtmo
      common /penpos/ pepox,pepoy
      common /pagsiz/ tpx,tpy
      common /pagfor/ iorpag
      common /pagori/ popagx,popagy
      common /boupag/ xminb,xmaxb,yminb,ymaxb
c
c *** deplacement elementaire de plume avec trace
c
      posx= tox-popagx
      posy= toy-popagy
c
      if(iorpag.eq.0) then
                      xx=posx
                      yy=posy
                      else
                      xx=tpy-posy
                      yy=posx
                      endif
c
      call sdr_ppagpmo(xx,yy)
c
      nbpmo=nbpmo+1
      pepox=xx
      pepoy=yy
c
c *** update des extrema du trace (page/paysage cm unit)
c
      xminb= min(xminb, xx)
      yminb= min(yminb, yy)
      xmaxb= max(xmaxb, xx)
      ymaxb= max(ymaxb, yy)
c
      call sdr_updbbox
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagrco_(orix,oriy,sizx,sizy,sizcor)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_rectangle_corner
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      call dpagppo_(orix,oriy+sizcor)
      call ppagpmo_(orix,oriy)
      call ppagpmo_(orix+sizcor,oriy)
      call dpagppo_(orix+sizx-sizcor,oriy)
      call ppagpmo_(orix+sizx,oriy)
      call ppagpmo_(orix+sizx,oriy+sizcor)
      call dpagppo_(orix+sizx,oriy+sizy-sizcor)
      call ppagpmo_(orix+sizx,oriy+sizy)
      call ppagpmo_(orix+sizx-sizcor,oriy+sizy)
      call dpagppo_(orix+sizcor,oriy+sizy)
      call ppagpmo_(orix,oriy+sizy)
      call ppagpmo_(orix,oriy+sizy-sizcor)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagrec_(orix,oriy,sizx,sizy)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_rectangle
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      call dpagppo_(orix,oriy)
      call ppagpmo_(orix+sizx,oriy)
      call ppagpmo_(orix+sizx,oriy+sizy)
      call ppagpmo_(orix,oriy+sizy)
      call ppagpmo_(orix,oriy)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagsym_(orix,oriy,ipos,sizx,sizy,symb)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_symbol
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c
      common /biggra/ diafig,unifig,zofiat
c
      character*(*) symb
      character*4 perm(12)
      character*48 com
c
      real x(37),y(37)
c
      save perm,com,x,y
c
      data epsi  /1.e-35/
      save epsi
c
      data perm/'tria','carr','plus','croi','octo','dode','diam',
     &          'star','pota','circ','hmar','vmar'/
c
c
c     objet:trace d'un symbole centre si ipos=0, coin inf. gauche si non
c
c
      if(abs(sizx).lt.epsi.and.abs(sizy).lt.epsi) return
c
      l=len(symb)
      if(l.lt.4) call uperror_('ppagsymb_: length of symb must be ge 4')
c
      do 102 ns=1,12
      if(symb(1:4).eq.perm(ns)) go to 104
  102 continue
      write(com,100) symb(1:4),perm
  100 format('ppagsym_: ',a,'# de ',10(1x,a4))
      call uperror_(com)
c
  104 continue
c
      if(sizx.gt.0.) then
                     sx=sizx
                     else
                     sx=unifig*0.05
                     endif
c
      if(sizy.gt.0.) then
                     sy=sizy
                     else
                     sy=unifig*0.05
                     endif
c
      if(ipos.eq.0) then
                    xx=orix-sx/2.
                    yy=oriy-sy/2.
                    else
                    xx=orix
                    yy=oriy
                    endif
c
      xc=xx+sx/2.
      yc=yy+sy/2.
c
      go to (1,2,3,4,5,6,7,8,9,10,11,12), ns
c
    1 continue
c
c *** triangle
c
      call dpagppo_(xx,yy)
      call ppagpmo_(xx+sx,yy)
      call ppagpmo_(xx+sx/2.,yy+sy)
      call ppagpmo_(xx,yy)
      return
c
    2 continue
c
c *** carre
c
      call dpagppo_(xx,yy)
      call ppagpmo_(xx+sx,yy)
      call ppagpmo_(xx+sx,yy+sy)
      call ppagpmo_(xx,yy+sy)
      call ppagpmo_(xx,yy)
      return
c
    3 continue
c
c *** signe +
c
      call dpagppo_(xx   ,yc)
      call ppagpmo_(xx+sx,yc)
      call dpagppo_(xc   ,yy)
      call ppagpmo_(xc   ,yy+sy)
      return
c
    4 continue
c
c *** croix en X
c
      call dpagppo_(xx,yy)
      call ppagpmo_(xx+sx,yy+sy)
      call dpagppo_(xx,yy+sy)
      call ppagpmo_(xx+sx,yy)
      return
c
    5 continue
c
c *** octogone
c
      dx=sx/4.
      dy=sy/4.
c
      call dpagppo_(xx+dx,yy)
      call ppagpmo_(xx,yy+dy)
      call ppagpmo_(xx,yy+3.*dy)
      call ppagpmo_(xx+dx,yy+4.*dy)
      call ppagpmo_(xx+3.*dx,yy+4.*dy)
      call ppagpmo_(xx+4.*dx,yy+3.*dy)
      call ppagpmo_(xx+4.*dx,yy+dy)
      call ppagpmo_(xx+3.*dx,yy)
      call ppagpmo_(xx+dx,yy)
      return
c
    6 continue
c
c *** dodecagone
c
      dx=sx/8.
      dy=sy/8.
c
      call dpagppo_(xc-dx,yc+4.*dy)
      call ppagpmo_(xc-3.*dx,yc+3.*dy)
      call ppagpmo_(xc-4.*dx,yc+dy)
      call ppagpmo_(xc-4.*dx,yc-dy)
      call ppagpmo_(xc-3.*dx,yc-3.*dy)
      call ppagpmo_(xc-dx,yc-4.*dy)
      call ppagpmo_(xc+dx,yc-4.*dy)
      call ppagpmo_(xc+3.*dx,yc-3.*dy)
      call ppagpmo_(xc+4.*dx,yc-dy)
      call ppagpmo_(xc+4.*dx,yc+dy)
      call ppagpmo_(xc+3.*dx,yc+3.*dy)
      call ppagpmo_(xc+dx,yc+4.*dy)
      call ppagpmo_(xc-dx,yc+4.*dy)
      return
c
    7 continue
c
c *** diamant
c
      call dpagppo_(xx,yc)
      call ppagpmo_(xc,yy)
      call ppagpmo_(xx+sx,yc)
      call ppagpmo_(xc,yy+sy)
      call ppagpmo_(xx,yc)
      return
c
    8 continue
c
c *** star
c
      call dpagppo_(xx   ,yy)
      call ppagpmo_(xc   ,yy+sy)
      call ppagpmo_(xx+sx,yy)
      call ppagpmo_(xx   ,yc+sy/6.)
      call ppagpmo_(xx+sx,yc+sy/6.)
      call ppagpmo_(xx   ,yy)
      return
c
    9 continue
c
c *** potatoes
c
      dx=sx/8.
      dy=sy/8.
c
      call dpagppo_(xx       ,yy+2.*dy)
      call ppagpmo_(xx+0.2*dx,yy+3.0*dy)
      call ppagpmo_(xx+0.5*dx,yy+4.0*dy)
      call ppagpmo_(xx+1.0*dx,yy+5.0*dy)
      call ppagpmo_(xx+2.0*dx,yy+6.0*dy)
      call ppagpmo_(xx+3.0*dx,yy+7.0*dy)
      call ppagpmo_(xx+4.0*dx,yy+7.5*dy)
      call ppagpmo_(xx+5.0*dx,yy+7.8*dy)
      call ppagpmo_(xx+6.0*dx,yy+8.0*dy)
      call ppagpmo_(xx+7.0*dx,yy+7.8*dy)
      call ppagpmo_(xx+7.8*dx,yy+7.0*dy)
      call ppagpmo_(xx+8.0*dx,yy+6.0*dy)
      call ppagpmo_(xx+7.8*dx,yy+5.0*dy)
      call ppagpmo_(xx+7.5*dx,yy+4.0*dy)
      call ppagpmo_(xx+7.0*dx,yy+3.0*dy)
      call ppagpmo_(xx+6.0*dx,yy+2.0*dy)
      call ppagpmo_(xx+5.0*dx,yy+1.0*dy)
      call ppagpmo_(xx+4.0*dx,yy+0.5*dy)
      call ppagpmo_(xx+3.0*dx,yy+0.2*dy)
      call ppagpmo_(xx+2.0*dx,yy+0.0*dy)
      call ppagpmo_(xx+1.0*dx,yy+0.2*dy)
      call ppagpmo_(xx+0.2*dx,yy+1.0*dy)
      return
c
   10 continue
c
c *** circle (10 degrees step)
c
      dx=sx/2.
      dy=sy/2.
c
      xxc=xx+sx/2.
      yyc=yy+sy/2.
c
      x( 1) = xxc + ( 1.00000*dx)
      y( 1) = yyc + ( 0.00000*dy)
c
      x( 2) = xxc + ( 0.98481*dx)
      y( 2) = yyc + ( 0.17365*dy)
c
      x( 3) = xxc + ( 0.93969*dx)
      y( 3) = yyc + ( 0.34202*dy)
c
      x( 4) = xxc + ( 0.86603*dx)
      y( 4) = yyc + ( 0.50000*dy)
c
      x( 5) = xxc + ( 0.76604*dx)
      y( 5) = yyc + ( 0.64279*dy)
c
      x( 6) = xxc + ( 0.64279*dx)
      y( 6) = yyc + ( 0.76604*dy)
c
      x( 7) = xxc + ( 0.50000*dx)
      y( 7) = yyc + ( 0.86603*dy)
c
      x( 8) = xxc + ( 0.34202*dx)
      y( 8) = yyc + ( 0.93969*dy)
c
      x( 9) = xxc + ( 0.17365*dx)
      y( 9) = yyc + ( 0.98481*dy)
c
      x(10) = xxc + ( 0.00000*dx)
      y(10) = yyc + ( 1.00000*dy)
c
      x(11) = xxc + (-0.17365*dx)
      y(11) = yyc + ( 0.98481*dy)
c
      x(12) = xxc + (-0.34202*dx)
      y(12) = yyc + ( 0.93969*dy)
c
      x(13) = xxc + (-0.50000*dx)
      y(13) = yyc + ( 0.86603*dy)
c
      x(14) = xxc + (-0.64279*dx)
      y(14) = yyc + ( 0.76605*dy)
c
      x(15) = xxc + (-0.76604*dx)
      y(15) = yyc + ( 0.64279*dy)
c
      x(16) = xxc + (-0.86602*dx)
      y(16) = yyc + ( 0.50000*dy)
c
      x(17) = xxc + (-0.93969*dx)
      y(17) = yyc + ( 0.34202*dy)
c
      x(18) = xxc + (-0.98481*dx)
      y(18) = yyc + ( 0.17365*dy)
c
      x(19) = xxc + (-1.00000*dx)
      y(19) = yyc + ( 0.00000*dy)
c
      x(20) = xxc + (-0.98481*dx)
      y(20) = yyc + (-0.17365*dy)
c
      x(21) = xxc + (-0.93969*dx)
      y(21) = yyc + (-0.34202*dy)
c
      x(22) = xxc + (-0.86603*dx)
      y(22) = yyc + (-0.50000*dy)
c
      x(23) = xxc + (-0.76605*dx)
      y(23) = yyc + (-0.64279*dy)
c
      x(24) = xxc + (-0.64279*dx)
      y(24) = yyc + (-0.76604*dy)
c
      x(25) = xxc + (-0.50000*dx)
      y(25) = yyc + (-0.86602*dy)
c
      x(26) = xxc + (-0.34202*dx)
      y(26) = yyc + (-0.93969*dy)
c
      x(27) = xxc + (-0.17365*dx)
      y(27) = yyc + (-0.98481*dy)
c
      x(28) = xxc + ( 0.00000*dx)
      y(28) = yyc + (-1.00000*dy)
c
      x(29) = xxc + ( 0.17364*dx)
      y(29) = yyc + (-0.98481*dy)
c
      x(30) = xxc + ( 0.34202*dx)
      y(30) = yyc + (-0.93969*dy)
c
      x(31) = xxc + ( 0.50000*dx)
      y(31) = yyc + (-0.86603*dy)
c
      x(32) = xxc + ( 0.64278*dx)
      y(32) = yyc + (-0.76605*dy)
c
      x(33) = xxc + ( 0.76604*dx)
      y(33) = yyc + (-0.64279*dy)
c
      x(34) = xxc + ( 0.86602*dx)
      y(34) = yyc + (-0.50000*dy)
c
      x(35) = xxc + ( 0.93969*dx)
      y(35) = yyc + (-0.34202*dy)
c
      x(36) = xxc + ( 0.98481*dx)
      y(36) = yyc + (-0.17365*dy)
c
      x(37) = xxc + ( 1.00000*dx)
      y(37) = yyc + ( 0.00000*dy)
c
c
      call dpagppo_(x(1),y(1))
c
      do 101 i=2,37
      call ppagpmo_(x(i),y(i))
  101 continue
      return
c
   11 continue
c
c *** horizontal mark
c
      call dpagppo_(xx   ,yc)
      call ppagpmo_(xx+sx,yc)
      return
c
   12 continue
c
c *** vertical mark
c
      call dpagppo_(xc   ,yy)
      call ppagpmo_(xc   ,yy+sy)
      return
c
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagtav_(orix,oriy,ipos,sizx,sizy,angle,tex,val,format)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_text_and_value
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) tex
      character*(*) format
      character*1 ifg
      character*255 com
      save com
c
      data epsi  /1.e-35/
      save epsi
c
c
c *** trace un nombre avec un texte devant
c
c      orix,oriy=coordonnees en cm du texte a tracer
c      val=valeur flottante du nombre a tracer
c      format=format du nb a tracer ex: '(f9.3)'
c      sizx,sizy=taille en cm du nb a tracer
c      angle=angle en degres de l'inclinaison sur l'horizontale
c      (sens direct) du trace
c      ipos=-1 origine coin inf. gauche
c      ipos= 0 origine au milieu
c      ipos= 1 origine coin inf. droit
c
c
      if(sizx.lt.epsi) return
      if(sizy.lt.epsi) return
c
      call uverfor_(format,'ppagtav_')
      call udecfor_(format,ifg,n,nd)
c
      if(n.eq.0) return
      if(val.gt.0.) then
                    iv=int(val+0.5)
                    else
                    iv= -int(abs(val)+0.5)
                    endif
c
      if(ifg.eq.'i' .or.  ifg.eq.'I') write(com,format) iv
      if(ifg.ne.'i' .and. ifg.ne.'I') write(com,format) val
c
      call cchalen_(tex,nc)
      com=tex(1:nc)//com
c
      call ppagcha_(orix,oriy,ipos,sizx,sizy,angle,com)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagval_(orix,oriy,ipos,sizx,sizy,angle,value,format)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_value
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) format
      character*1 ifg
      character*64 texte
c
      data epsi  /1.e-35/
      save epsi
c
c
c *** trace un nombre selon un format donne
c
c      orix,oriy=coordonnees en cm du nb a tracer
c      value=valeur flottante du nombre a tracer
c      format=format du nb a tracer ex: '(f9.3)'
c      sizx,sizy=taille en cm du nb a tracer
c      angle=angle en degres de l'inclinaison sur l'horizontale
c      (sens direct) du trace
c      ipos=-1 origine coin inf. gauche
c      ipos= 0 origine au milieu
c      ipos= 1 origine coin inf. droit
c
c
      if(sizx.lt.epsi) return
      if(sizy.lt.epsi) return
c
      call uverfor_(format,'ppagval_')
      call udecfor_(format,ifg,n,nd)
c
      if(n.eq.0) return
      if(value.gt.0.) then
                      iv=int(value+0.5)
                      else
                      iv= -int(abs(value)+0.5)
                      endif
c
      if(ifg.eq.'i' .or.  ifg.eq.'I') write(texte,format) iv
      if(ifg.ne.'i' .and. ifg.ne.'I') write(texte,format) value
c
      call ppagcha_(orix,oriy,ipos,sizx,sizy,angle,texte)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ppagvli_(x)
c
c     ---------------------------------------------------------------+--
c *   Object : plot_page_vertical_line
c *   Class  : plot page modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /pagsiz/ tpx,tpy
c
c
      call dpagppo_(x,0.)
      call ppagpmo_(x,tpy)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine rdimbmp_(ifc,fichbmp,nx,ny)
      common /ibmp_comp/ ibmp
c
c     ------------------------------------------------------------------
c *   Object : read_dimension_image_bmp for 24 bits file
c *   Class  : read modules of Rogralib Software
c *   Author : P. Robert, CRPE, 1992, mod. L.M. 2007
c     ------------------------------------------------------------------
c
      character*(*) fichbmp
      integer first_4octets(4)
c PR  character*128 file_type
c
c
c *** ouverture du fichier bmp
c
      close(ifc)
clm      open (ifc,file=fichbmp,status='old')
cbmp      open (ifc,file=fichbmp,status='old',form='binary')
      open(ifc,file=fichbmp,status='old',form='unformatted',
     &access='direct',recl=1)
      ibmp=0
c PR  file_type='unknown'
c PR  n_oct_tot=26 ! on lit 26 octets au max dans rdimbmp_
c     Le fichier est-t-il un BMP ?
      do ibid=1,4
clm         call roctfil_(ifc,first_4octets(ibid),n_oct_tot,file_type)
         call roctfil_(ifc,first_4octets(ibid))
      enddo
      if ((first_4octets(1).eq.66).and.(first_4octets(2).eq.77)) then
c PR     file_type='BMP_UNIX'
      else
         if ((first_4octets(4).eq.66).and.(first_4octets(3).eq.77)) then
c PR        file_type='BMP_PC'
         else
c PR        file_type='wrong_type'
         endif
      endif
c
c *** lecture de l'entete inutile
c
      do ibid=5,18
cbmp10      n_oct_tot=200
cbmp10      do ibid=5,200
clm         call roctfil_(ifc,ib0,n_oct_tot,file_type)
         call roctfil_(ifc,ib0)
      enddo
cbmp10      stop
c
c *** lecture des dimensions de l'image
c
clm      call roctfil_(ifc,i1,n_oct_tot,file_type)
clm      call roctfil_(ifc,i2,n_oct_tot,file_type)
clm      call roctfil_(ifc,i3,n_oct_tot,file_type)
clm      call roctfil_(ifc,i4,n_oct_tot,file_type)
      call roctfil_(ifc,i1)
      call roctfil_(ifc,i2)
      call roctfil_(ifc,i3)
      call roctfil_(ifc,i4)
c
      nx=i1 + i2*256 + i3*256*256 + i4*256*256*256
c
clm      call roctfil_(ifc,j1,n_oct_tot,file_type)
clm      call roctfil_(ifc,j2,n_oct_tot,file_type)
clm      call roctfil_(ifc,j3,n_oct_tot,file_type)
clm      call roctfil_(ifc,j4,n_oct_tot,file_type)
      call roctfil_(ifc,j1)
      call roctfil_(ifc,j2)
      call roctfil_(ifc,j3)
      call roctfil_(ifc,j4)
c
      ny=j1 + j2*256 + j3*256*256 + j4*256*256*256
c
c
c *** fermeture du fichier
c
      close(ifc)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine rimabmp_(ifc,fichbmp,imaico,nx,ny)
      common /ibmp_comp/ ibmp
c
c     -------------------------------------------------------------------
c *   Object : read_image_bmp for 24 bits file, nx-ny defined, ico format
c *   Class  : read modules of Rogralib Software
c *   Author : P. Robert, CRPE, 1992, mod. L.M. 2007
c     ------------------------------------------------------------------
c
c
      character*(*) fichbmp
c PR  character*128 file_type
      integer imaico(nx,ny)
      integer first_4octets(4)
c
c
c *** ouverture du fichier bmp
c
      close(ifc)
clm      open (ifc,file=fichbmp,status='old')
cbmp      open (ifc,file=fichbmp,status='old',form='binary')
      open(ifc,file=fichbmp,status='old',form='unformatted',
     &access='direct',recl=1)
      ibmp=0
c
c PR  n_oct_tot=54+3*nx*ny ! nombre d'octets total dans l'image
c
c PR  file_type='unknown'
c     Le fichier est-t-il un BMP ?
      do ibid=1,4
clm         call roctfil_(ifc,first_4octets(ibid),n_oct_tot,file_type)
         call roctfil_(ifc,first_4octets(ibid))
      enddo
      if ((first_4octets(1).eq.66).and.(first_4octets(2).eq.77)) then
c PR     file_type='BMP_UNIX'
      else
         if ((first_4octets(4).eq.66).and.(first_4octets(3).eq.77)) then
c PR        file_type='BMP_PC'
         else
c PR        file_type='wrong_type'
         endif
      endif
c
c *** lecture de l'entete inutile
c
      do 6 ibid=5,18
clm      call roctfil_(ifc,ib0,n_oct_tot,file_type)
      call roctfil_(ifc,ib0)
    6 continue
c
c *** lecture des dimensions de l'image
c
clm      call roctfil_(ifc,i1,n_oct_tot,file_type)
clm      call roctfil_(ifc,i2,n_oct_tot,file_type)
clm      call roctfil_(ifc,i3,n_oct_tot,file_type)
clm      call roctfil_(ifc,i4,n_oct_tot,file_type)
      call roctfil_(ifc,i1)
      call roctfil_(ifc,i2)
      call roctfil_(ifc,i3)
      call roctfil_(ifc,i4)
c
      nx2=i1 + i2*256 + i3*256*256 + i4*256*256*256
c
clm      call roctfil_(ifc,j1,n_oct_tot,file_type)
clm      call roctfil_(ifc,j2,n_oct_tot,file_type)
clm      call roctfil_(ifc,j3,n_oct_tot,file_type)
clm      call roctfil_(ifc,j4,n_oct_tot,file_type)
      call roctfil_(ifc,j1)
      call roctfil_(ifc,j2)
      call roctfil_(ifc,j3)
      call roctfil_(ifc,j4)
c
c *** verif avec les dimensions declarees pour le tableau
c
      ny2=j1 + j2*256 + j3*256*256 + j4*256*256*256
c
      if(nx.ne.nx2.or.
     &   ny.ne.ny2) then
                    print*
                    print*, 'error in rimabmp_'
                    print*, 'no previous reading of dim. of bmp file'
                    print*, 'rimabmp_ must be preceded by rdimbmp_'
                    call uperror_('rimabmp_: no previous rdimbmp_ call')
                    endif
c
c *** fin de lecture de l'entete
c
      do 8 ibid=27,54
clm      call roctfil_(ifc,ib0,n_oct_tot,file_type)
      call roctfil_(ifc,ib0)
    8 continue
c
c *** lecture de l'image .bmp / passage au format ico
c
      do 10 iy=1,ny
      do 10 ix=1,nx
c
clm      call roctfil_(ifc,ib,n_oct_tot,file_type)
clm      call roctfil_(ifc,ig,n_oct_tot,file_type)
clm      call roctfil_(ifc,ir,n_oct_tot,file_type)
      call roctfil_(ifc,ib)
      call roctfil_(ifc,ig)
      call roctfil_(ifc,ir)
      call crgbico_(ir,ig,ib,ico)
      imaico(ix,iy)=ico
   10 continue
c
      close(ifc)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine roctfil_(ifc,io)
c
c     ------------------------------------------------------------------
c *   Object : read_octet_on_file for opened direct file
c *   Class  : read modules of Rogralib Software
c *   Author : P. Robert, CRPE, 1992
c     ------------------------------------------------------------------
c
c
      character*1 cha
      integer fgetc
c
      data nberr/0/
      save nberr
c
c *** lecture octet par octet
c
      ier=fgetc(ifc,cha)
      io=ichar(cha)
c
      if(ier.eq.-1) then
                    nberr=nberr+1
                    print*, nberr, 'EOF encoutered, io set to 999'
                    io=999
                    return
                    endif
c
      if(ier.ne.0) then
                   nberr=nberr+1
                   print*, nberr, 'error fgetc, ier=',ier
                   if(nberr.gt.100) stop '> 100 errors in roctfil_'
                   endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dclogra
c
c     ------------------------------------------------------------------
c *   Object : system_drv, close_graphical_file close PostScript file
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
      common /sdrbbo/ xmip,xmap,ymip,ymap, xmimip,xmamap,ymimip,ymamap
c
      if(lc.eq.1) write(ifc,100) 'stroke'
c
c *** conversion en entier des Bounding Box (obligatoire)
c
      ixmip=int(xmip)
      iymip=int(ymip)
      ixmap=int(xmap) +1
      iymap=int(ymap) +1
c
      ixmimip=int(xmimip)
      iymimip=int(ymimip)
      ixmamap=int(xmamap) +1
      iymamap=int(ymamap) +1
c
c *** cloture du PostScript
c
      write(ifc,100)
      write(ifc,100) '% ROGRALIB / sps_dclogra : '//
     &               'system_postscript_close_graphical_file'
      write(ifc,100) 'restore'
      write(ifc,100) 'showpage'
      write(ifc,100) '%%PageTrailer'
      write(ifc,300) '%%PageBoundingBox: ', ixmip,iymip,ixmap,iymap
      write(ifc,100)
      write(ifc,100) '%%Trailer'
      write(ifc,300) '%%BoundingBox: ', ixmimip,iymimip,ixmamap,iymamap
c /// write(ifc,100) 'end'
c /// write(ifc,100) 'cleartomark countdictstack exch sub { end }'//
c ///&               ' repeat restore'
      write(ifc,300) '%%Pages: ',numpag
      write(ifc,100) '%%EOF'
c
      close(ifc)
c
  100 format(a)
  300 format(a,4i8)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dfilzon
c
      common /sdrcom/ ifc,lc,numpag,is
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_fill_zone
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
c *** empeche la demande de stroke dans sps_ppagpmo
c     permet d'enchainer des utilitaires de trace pour faire une ligne
c     continue jusqu'a la commande pfilzon
c
      is=1
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dfonnab(numfon,bodfon)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_font_number_and_body as 5, 10.25
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
c
      character*29  fonp(13)
c
      save fonp, numpre, bodpre
c
      data numpre /0/
      data bodpre /0./
c
      data fonp( 1)/'Patrick_Courier              '/
      data fonp( 2)/'Patrick_Courier-Bold         '/
      data fonp( 3)/'Patrick_Courier-Oblique      '/
      data fonp( 4)/'Patrick_Courier-BoldOblique  '/
      data fonp( 5)/'Patrick_Times-Roman          '/
      data fonp( 6)/'Patrick_Times-Bold           '/
      data fonp( 7)/'Patrick_Times-Italic         '/
      data fonp( 8)/'Patrick_Times-BoldItalic     '/
      data fonp( 9)/'Patrick_Helvetica            '/
      data fonp(10)/'Patrick_Helvetica-Bold       '/
      data fonp(11)/'Patrick_Helvetica-Oblique    '/
      data fonp(12)/'Patrick_Helvetica-BoldOblique'/
      data fonp(13)/'Symbol                       '/
c
c *** achtung Patrick_Symbol does not work...
c     use Symbol which is already exented to ascii-8
c
      if(lc.eq.1) then
                  write(ifc,100) 'stroke'
                  write(ifc,100)
                  endif
c
c *** Courier 10 par defaut; tailles limitees
c
      if(numfon.lt.1.or.numfon.gt.13) then
                                      nnf=1
                                      else
                                      nnf=numfon
                                      endif
c
      ffb=bodfon
      if(ffb.lt.0.001) ffb=   10.
      if(ffb.lt.   1.) ffb=    1.
      if(ffb.gt.1000.) ffb= 1000.
c
c *** longueur du texte fonp(nnf
c
      nbc=29
c
      do 10 i=1,nbc
      ii=nbc-i+1
      if(fonp(nnf)(ii:ii).ne.' ') go to 12
   10 continue
      ii=0
   12 continue
c
      nbcha=ii
c
      if((nnf.ne.numpre).or.(abs(ffb-bodpre).gt.1.E-6)) then
         write(ifc,200) fonp(nnf)(1:nbcha),ffb
      endif
      lc=0
      numpre=nnf
      bodpre=ffb
c
  100 format(a)
  200 format('/',a,' findfont ',f7.2,' scalefont setfont')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dimasha
c
      common /sdrcom/ ifc,lc,numpag,is
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_image_shape
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      if(lc.eq.1) then
                  write(ifc,100) 'stroke'
                  write(ifc,100)
                  endif
c
      write(ifc,100)
      write(ifc,100) '% ROGRALIB / sps_dimasha: '//
     &               'system_drv, define_image_shape'
      write(ifc,100) 'gsave'
      write(ifc,100) 'newpath'
c
      is=1
      lc=0
c
  100 format(a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dlincol(mode,c1,c2,c3)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_line_color rgb or hsb components
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c
c     input : mode ('rgb' (default) or 'hsb'
c     input : c1,c2,c3 components, values between 0. and 1.
c     output: none
c     ------------------------------------------------------------------
c
      character*(*) mode
c
      common /sdrcom/ ifc,lc,numpag,is
c
      if(lc.eq.1) then
                  write(ifc,100) 'stroke'
                  write(ifc,100)
                  endif
c
      cc1=c1
      cc2=c2
      cc3=c3
c
      if(cc1.gt.1.) cc1=1.
      if(cc2.gt.1.) cc2=1.
      if(cc3.gt.1.) cc3=1.
c
      if(cc1.lt.0.) cc1=0.
      if(cc2.lt.0.) cc2=0.
      if(cc3.lt.0.) cc3=0.
c
c
      if(mode.eq.'hsb') then
                        write(ifc,200) cc1,cc2,cc3, 'sethsbcolor'
                        else
                        write(ifc,200) cc1,cc2,cc3, 'setrgbcolor'
                        endif
      lc=0
c
  100 format(a)
  200 format(3f5.2,1x,a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dlincon
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_line_continue, remove dash option
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
c
      write(ifc,200)
c
  200 format('[] 0 setdash')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dlindas(size1,blank1,size2,blank2)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_line_dash from given parameters
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
      common /pagsiz/ tpx,tpy
c
c *** le trait tirete est constitue d'un premier trait de taille size1,
c     puis d'un espace blanc de taille blank1, puis d'un deuxieme trait
c     suivi d'un deuxieme blanc.
c
c *** test si pas de valeurs delirantes
c
      s1=abs(size1)
      s2=abs(size2)
      b1=abs(blank1)
      b2=abs(blank2)
c
      diag= sqrt(tpx*tpx + tpy*tpy)
c
      if(s1.gt.diag) s1= diag/4.
      if(s2.gt.diag) s2= diag/4.
      if(b1.gt.diag) b1= diag/4.
      if(b2.gt.diag) b2= diag/4.
c
c *** conversion en ups
c
      ucm= 72./2.54
c
      s1ups=s1*ucm
      s2ups=s2*ucm
      b1ups=b1*ucm
      b2ups=b2*ucm
c
      write(ifc,200) s1ups,b1ups,s2ups,b2ups
c
  200 format('[',3(f4.1,' '),f4.1,'] 0 setdash')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dlingle(gle)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_grey_level between 0. and 1.
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
c
      if(lc.eq.1) then
                  write(ifc,100) 'stroke'
                  write(ifc,100)
                  endif
c
      cgl=gle
      if(cgl.gt.1.) cgl=1.
      if(cgl.lt.0.) cgl=0.
c
      write(ifc,200) cgl, 'setgray'
      lc=0
c
  100 format(a)
  200 format(f5.2,1x,a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dlinwid(iwidth)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_line_width in pixels
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
c
      if(lc.eq.1) then
                  write(ifc,100) 'stroke'
                  write(ifc,100)
                  endif
c
c *** taille du pixel en resolution 300 p/pouce
c
      dot= 72./300.
c
      write(ifc,200) float(iwidth)*dot, 'setlinewidth'
      lc=0
c
  100 format(a)
  200 format(f7.2,1x,a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dopegra(ifcps,psfile)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, begin_plot open PostScript file
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c
c     input : ifcps, psfile
c     output: spax,spay
c     ------------------------------------------------------------------
c
      character*(*) psfile
      character date*29
c
      common /sdrcom/ ifc,lc,numpag,is
      common /sdrpag/ supsx,supsy, smarx,smary,ifor
      common /sdrbbo/ xmip,xmap,ymip,ymap, xmimip,xmamap,ymimip,ymamap
c
      integer supsx(5), supsy(5)
      character*16 carspe(135)
      save carspe
c
c *** verif que le fichier se termine par '.ps'
c
      call cchalen_(psfile,nc)
c
      if(psfile(nc-2:nc).ne.'.ps') then
           call upwarni_('name of graphical file must be a .ps file,'//
     &                   ' suffix .ps added')
                  psfile=psfile(nc:nc)//'.ps'
                    endif
c
c *** chargement de la table des caracteres speciaux
c
      data (carspe(i),i=1,99) /
     &                         '/grave          ',
     &                         '/acute          ',
     &                         '/circumflex     ',
     &                         '/tilde          ',
     &                         '/macron         ',
     &                         '/breve          ',
     &                         '/dotaccent      ',
     &                         '/dieresis       ',
     &                         '/ring           ',
     &                         '/cedilla        ',
     &                         '/hungarumlaut   ',
     &                         '/ogonek         ',
     &                         '/caron          ',
     &                         '/dotlessi       ',
     &                         '/quotesingle    ',
     &                         '/grave          ',
     &                         '/bar            ',
     &                         '/quotesinglbase ',
     &                         '/florin         ',
     &                         '/quotedblbase   ',
     &                         '/ellipsis       ',
     &                         '/dagger         ',
     &                         '/daggerdbl      ',
     &                         '/circumflex     ',
     &                         '/perthousand    ',
     &                         '/Scaron         ',
     &                         '/guilsinglleft  ',
     &                         '/OE             ',
     &                         '/quoteleft      ',
     &                         '/quoteright     ',
     &                         '/quotedblleft   ',
     &                         '/quotedblright  ',
     &                         '/bullet         ',
     &                         '/endash         ',
     &                         '/emdash         ',
     &                         '/tilde          ',
     &                         '/trademark      ',
     &                         '/scaron         ',
     &                         '/guilsinglright ',
     &                         '/oe             ',
     &                         '/Ydieresis      ',
     &                         '/space          ',
     &                         '/exclamdown     ',
     &                         '/currency       ',
     &                         '/yen            ',
     &                         '/brokenbar      ',
     &                         '/section        ',
     &                         '/dieresis       ',
     &                         '/copyright      ',
     &                         '/ordfeminine    ',
     &                         '/guillemotleft  ',
     &                         '/logicalnot     ',
     &                         '/hyphen         ',
     &                         '/registered     ',
     &                         '/macron         ',
     &                         '/degree         ',
     &                         '/plusminus      ',
     &                         '/twosuperior    ',
     &                         '/threesuperior  ',
     &                         '/acute          ',
     &                         '/mu             ',
     &                         '/paragraph      ',
     &                         '/periodcentered ',
     &                         '/cedilla        ',
     &                         '/onesuperior    ',
     &                         '/ordmasculine   ',
     &                         '/guillemotright ',
     &                         '/onequarter     ',
     &                         '/onehalf        ',
     &                         '/threequarters  ',
     &                         '/questiondown   ',
     &                         '/Agrave         ',
     &                         '/Aacute         ',
     &                         '/Acircumflex    ',
     &                         '/Atilde         ',
     &                         '/Adieresis      ',
     &                         '/Aring          ',
     &                         '/AE             ',
     &                         '/Ccedilla       ',
     &                         '/Egrave         ',
     &                         '/Eacute         ',
     &                         '/Ecircumflex    ',
     &                         '/Edieresis      ',
     &                         '/Igrave         ',
     &                         '/Iacute         ',
     &                         '/Icircumflex    ',
     &                         '/Idieresis      ',
     &                         '/Eth            ',
     &                         '/Ntilde         ',
     &                         '/Ograve         ',
     &                         '/Oacute         ',
     &                         '/Ocircumflex    ',
     &                         '/Otilde         ',
     &                         '/Odieresis      ',
     &                         '/multiply       ',
     &                         '/Oslash         ',
     &                         '/Ugrave         ',
     &                         '/Uacute         ',
     &                         '/Ucircumflex    '/
c
      data (carspe(i),i=100,135) /
     &                         '/Udieresis      ',
     &                         '/Yacute         ',
     &                         '/Thorn          ',
     &                         '/germandbls     ',
     &                         '/agrave         ',
     &                         '/aacute         ',
     &                         '/acircumflex    ',
     &                         '/atilde         ',
     &                         '/adieresis      ',
     &                         '/aring          ',
     &                         '/ae             ',
     &                         '/ccedilla       ',
     &                         '/egrave         ',
     &                         '/eacute         ',
     &                         '/ecircumflex    ',
     &                         '/edieresis      ',
     &                         '/igrave         ',
     &                         '/iacute         ',
     &                         '/icircumflex    ',
     &                         '/idieresis      ',
     &                         '/eth            ',
     &                         '/ntilde         ',
     &                         '/ograve         ',
     &                         '/oacute         ',
     &                         '/ocircumflex    ',
     &                         '/otilde         ',
     &                         '/odieresis      ',
     &                         '/divide         ',
     &                         '/oslash         ',
     &                         '/ugrave         ',
     &                         '/uacute         ',
     &                         '/ucircumflex    ',
     &                         '/udieresis      ',
     &                         '/yacute         ',
     &                         '/thorn          ',
     &                         '/ydieresis      '/
c
c
c *** chargement des la tailles des pages possibles, en unites ps,
c      selon les formats supportes
c     (on suppose toujours l'orientation portrait)
c
      supsx(1)= 2380
      supsx(2)= 1684
      supsx(3)= 1190
      supsx(4)=  842
      supsx(5)=  595
c
      supsy(1)= 3368
      supsy(2)= 2380
      supsy(3)= 1684
      supsy(4)= 1190
      supsy(5)=  842
c
c
c *** unites et conversions
c
c     1 pouce= 2.54    cm
c     1 pouce= 72      ups
c     1 ups  = 1/72    pouce
c     1 ups  = 2.54/72 cm      (=  0.0352777 cm)
c     1 cm   = 72/2.54 ups     (= 28.3465    ups)
c
c *** pour memoire:
c
c     format US letter
c     (8.5 x 11) pouces = (21.59 x 27.94) cm = (612 x 792) ups
c
c     format A4 utilise par defaut:
c     (595 x 842) ups = (8.263 x 11.694) pouces = (20.9903 x 29.704) cm
c
c *** Bounding Box :  en attente, calcule a la fin du job
c     attention: pas plus de 2**31-1 soit 2.e9 pour conversion en entier
c
      xmip=   1.e9
      xmap=   0.
      ymip=   1.e9
      ymap=   0.
c
      xmimip= 1.e9
      xmamap= 0.
      ymimip= 1.e9
      ymamap= 0.
c
c *** ouverture du fichier et initialisations
c
      ifc=ifcps
      numpag=0
c
      close(ifc)
      open (ifc,file=psfile)
c
      call gusdati_(date)
      call cchalen_(psfile,nc)
      call glibver_(ver)
c
c *** entete fichier
c
      write(ifc,100) '%!PS-Adobe-2.0'
      write(ifc,110) '%%Creator: Patrick ROBERT- ROGRALIB Software V',
     &                                                      ver
      write(ifc,100) '%%CreationDate: ',date
      write(ifc,100) '%%Title: ',psfile(1:nc)
      write(ifc,100) '%%For: Patrick ROBERT'
      write(ifc,100) '%%BoundingBox: (atend)'
c /// write(ifc,100) '%%DocumentData: Clean7bit'
      write(ifc,101) '%%DocumentMedia: A',4,supsx(5),supsy(5),' 0 () ()'
      write(ifc,101) '%%+              A',3,supsx(4),supsy(4),' 0 () ()'
      write(ifc,101) '%%+              A',2,supsx(3),supsy(3),' 0 () ()'
      write(ifc,101) '%%+              A',1,supsx(2),supsy(2),' 0 () ()'
      write(ifc,101) '%%+              A',0,supsx(1),supsy(1),' 0 () ()'
      write(ifc,100) '%%PageOrder: Ascend'
      write(ifc,100) '%%Pages: (atend)'
      write(ifc,100) '%%Copyright: (C) 1986-2008, Patrick ROBERT,',
     &                             ' CNRS, All Rights Reserved'
      write(ifc,100) '%%EndComments'
      write(ifc,100)
      write(ifc,100) '%%BeginDefaults'
      write(ifc,100) '%%PageOrientation: Portrait'
      write(ifc,100) '%%PageMedia: A4'
      write(ifc,100) '%%EndDefaults'
      write(ifc,100)
      write(ifc,100) '% -----------------------------------------------'
      write(ifc,110) '% PostScript file created by ROGRALIB V',ver,
     &                        ' software'
      write(ifc,100) '% Copyright (c) 1986-2007, Patrick ROBERT, PatCie'
      write(ifc,100)
      write(ifc,100) '% Version initiale  depuis archives,     Fev 1986'
      write(ifc,100) '% Creation du driver PostScript,             1990'
      write(ifc,100) '% Refonte generale et nomage des modules,Mai 1993'
      write(ifc,100) '% Usage des polices PS standards,        Mar 1995'
      write(ifc,100) '% Nouveaux modules divers,               Dec 1995'
      write(ifc,100) '% Extension a 8 bits polices standards,  Dec 1996'
      write(ifc,100) '% Nouveaux modules de trace,             Mar 1998'
      write(ifc,100) '% Optimisation pour ecriture de texte,   Nov 1998'
      write(ifc,100) '% Gestion des polices proportionnelles,  Oct 1999'
      write(ifc,100) '% Refonte generale des common,           Nov 1999'
      write(ifc,100) '% Suppression de l"interface en pixels,  Nov 1999'
      write(ifc,100) '% Introduction des formats A3,A2,A1,A0,  Avr 2000'
      write(ifc,100) '% Corrections bugs avec Ghostview,       Dec 2001'
      write(ifc,100) '% Corrections bugs avec Ghostview PC     Mar 2003'
      write(ifc,100) '% Nouveaux modules divers (dash lines)   Oct 2007'
      write(ifc,100) '% Correction calcul Page Bounding Box    Nov 2007'
      write(ifc,100) '% fonct. x**n speciale pour portabilite  Nov 2007'
      write(ifc,100) '% cor. bug cfiggra_ + nb pages in driver May 2008'
      write(ifc,100) '% Intro calendrier, code unique SUN-PC   Jun 2008'
c
c *** prologue
c
      write(ifc,100) ' '
      write(ifc,100) '% -----------------------------------------------'
      write(ifc,100) '%%BeginProlog'
      write(ifc,100) ' '
      write(ifc,100) '%%BeginResource: new fonts for extra ascii ',
     &                                'characters (128-255)'
      write(ifc,100) '%                serial Patrick_sdfont'
      write(ifc,100) '%                P.Robert - Dec 1995 '
      write(ifc,100) ' '
      write(ifc,100) '%NewCodes '
      write(ifc,100) '/NewCodes 256 array def '
      write(ifc,100) 'NewCodes 0 '
      write(ifc,100) 'StandardEncoding '
      write(ifc,100) '0 128 getinterval '
      write(ifc,100) 'putinterval '
      write(ifc,100) ' '
      write(ifc,100) (carspe(i),i=1,135)
      write(ifc,100) ' '
      write(ifc,100) 'NewCodes 128 128 getinterval astore pop '
      write(ifc,100) ' '
      write(ifc,100) '%CopyDictionary '
      write(ifc,100) '/CopyDictionary { '
      write(ifc,100) '   dup maxlength dict '
      write(ifc,100) '   /NF exch def '
      write(ifc,100) '   {1 index /FID ne '
      write(ifc,100) '       {NF 3 1 roll put} '
      write(ifc,100) '       {pop pop} '
      write(ifc,100) '    ifelse '
      write(ifc,100) '    } forall '
      write(ifc,100) '    NF '
      write(ifc,100) '} def '
      write(ifc,100) ' '
      write(ifc,100) '%recode a font with new encoding vector '
      write(ifc,100) '/Recode { '
      write(ifc,100) '    dup cvn /NewName exch def '
      write(ifc,100) '    (Patrick_) anchorsearch '
      write(ifc,100) '        {pop '
      write(ifc,100) '        findfont CopyDictionary '
      write(ifc,100) '        dup /Encoding NewCodes put '
      write(ifc,100) '        NewName exch definefont '
      write(ifc,100) '    } if '
      write(ifc,100) '    pop '
      write(ifc,100) '} def '
      write(ifc,100) ' '
      write(ifc,100) '%RecodeFont - create newly recoded font '
      write(ifc,100) '/RecodeFont { '
      write(ifc,100) '    dup FontDirectory exch known '
      write(ifc,100) '        {pop} '
      write(ifc,100) '        {Recode} '
      write(ifc,100) '    ifelse '
      write(ifc,100) '} def '
      write(ifc,100) ' '
      write(ifc,100) '%NewFont ready to use '
c
      write(ifc,100) '  (Patrick_Courier) RecodeFont'
      write(ifc,100) '  (Patrick_Courier-Bold) RecodeFont'
      write(ifc,100) '% (Patrick_Courier-Oblique) RecodeFont'
      write(ifc,100) '% (Patrick_Courier-BoldOblique) RecodeFont'
      write(ifc,100) '  (Patrick_Times-Roman) RecodeFont'
      write(ifc,100) '  (Patrick_Times-Bold) RecodeFont'
      write(ifc,100) '  (Patrick_Times-Italic) RecodeFont'
      write(ifc,100) '  (Patrick_Times-BoldItalic) RecodeFont'
      write(ifc,100) '  (Patrick_Helvetica) RecodeFont'
      write(ifc,100) '  (Patrick_Helvetica-Bold) RecodeFont'
      write(ifc,100) '  (Patrick_Helvetica-Oblique) RecodeFont'
      write(ifc,100) '  (Patrick_Helvetica-BoldOblique) RecodeFont'
      write(ifc,100) '  (Symbol) RecodeFont'
c
c
      write(ifc,100) ' '
      write(ifc,100) '%%EndResource - 13 new ascii extended font',
     &                                ' ready to use '
      write(ifc,100) ' '
      write(ifc,100) '%%EndProlog'
      write(ifc,100) '% -----------------------------------------------'
c
c *** setup
c
      write(ifc,100) ' '
      write(ifc,100) '%%BeginSetup'
      write(ifc,100) ' '
      write(ifc,100) '% PSCM: conv. cm. en unite PS '
      write(ifc,100) ' /PSCM {gsave 28.3465 28.3465 scale grestore} def'
      write(ifc,100) ' '
      write(ifc,100) '% MTS: moveto and show '
      write(ifc,100) '% optimisation pour ecriture de texte, nov. 1998'
      write(ifc,100) ' /MTS {moveto show} bind def'
      write(ifc,100) ' '
      write(ifc,100) '% MTRS: moveto rotate and show '
      write(ifc,100) '% ecriture de texte incline, nov. 1998'
      write(ifc,100) ' /MTRS {moveto rotate show rotate} bind def'
      write(ifc,100) ' '
      write(ifc,100) '% STP=SnapToPixel fit vers le pixel le + proche '
      write(ifc,100) ' /STP {'
      write(ifc,100) '       transform'
      write(ifc,100) '       round .25 add'
      write(ifc,100) '       exch'
      write(ifc,100) '       round .25 add'
      write(ifc,100) '       exch'
      write(ifc,100) '       itransform'
      write(ifc,100) '     } bind def'
      write(ifc,100) ' '
c
c *** on initialise par defaut la page au format A4, avec des marges
c     de 1.2 cm tour autour de la feuille 21. x 29.7
c
      call sdr_dpagsiz(18.6,27.3,1.2,1.2)
c
      write(ifc,100) '%%EndSetup'
      write(ifc,100) '% -----------------------------------------------'
c
c
  100 format(5a)
  101 format(a,i1,2i5,a)
  110 format(a,f4.1,a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dpagnew(nupa)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_page_new and return page number
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
      common /sdrbbo/ xmip,xmap,ymip,ymap, xmimip,xmamap,ymimip,ymamap
c
      if(lc.eq.1) then
                  write(ifc,100) 'stroke'
                  write(ifc,100)
                  endif
c
      numpag=numpag+1
      nupa=numpag
c
c *** fin de la page precedente
c
c *   conversion en entier des Bounding Box (obligatoire)
c
c
      if(numpag.gt.1) then
                      ixmip=int(xmip)
                      iymip=int(ymip)
                      ixmap=int(xmap) +1
                      iymap=int(ymap) +1
c
                      write(ifc,300) '%%PageBoundingBox: ',
     &                                ixmip,iymip,ixmap,iymap
                      write(ifc,100) 'restore'
                      write(ifc,100) 'showpage'
                      write(ifc,100) '%%PageTrailer'
                      write(ifc,100)
                      endif
c
c *** nouvelle page
c
      write(ifc,100)
      write(ifc,200) '%%Page: ',numpag,numpag
      write(ifc,100) '%%PageOrientation: Portrait'
      write(ifc,100) '%%PageBoundingBox: (atend)'
      write(ifc,100) 'save'
      write(ifc,100)
c
c     la mise a 1 des 2 parametres suivants degrade le trace avec GS 8.0
c
      write(ifc,100) '0 setlinejoin'
      write(ifc,100) '0 setlinecap'
c
c *** remise a zero du BoundingBox page
c     attention: pas plus de 2**31-1 soit 2.e9 pour conversion en entier
c
      xmip=1.e9
      xmap=0.
      ymip=1.e9
      ymap=0.
c
c *** pas de stroke ulterieur
c
      lc=0
      is=0
c
  100 format(a)
  200 format(a,i4,1x,i4)
  300 format(a,4i8)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dpagppo(pox,poy)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, define_page_pen_position in cm
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
      
      character*32 forps
      character*4 fx,fy
c
      save forps,fx,fy
c
      if(lc.eq.1) then
                  write(ifc,100) 'stroke'
                  write(ifc,100)
                  endif
c
c *** conversion en ups
c
      call sdr_tcmiups(pox,poy,opsx,opsy)
c
c *** on ne deplace la plume sans trace (plume haute)
c     que si le chemin est ferme (is=0)
c     sinon, on fait un deplacement avec trace depuis la position
c     courante, sauf au premier appel qui definit le debut
c     du chemin total
c
c *   calcul du format pour le fichier PostScript
c
      call ucomfor_(opsx,opsy,fx,fy)
c
      forps='(' // fx // ',1x,' // fy //',1x,a)'
c
      if(is.eq.0) then
c                 * chemin ferme  
                  write(ifc,forps) opsx,opsy,'STP moveto'
                  else
c                 * chemin ouvert ou debut de nouveau chemin
                  if(is.eq.1) then
                              write(ifc,forps) opsx,opsy,'STP moveto'
                              else
                              write(ifc,forps) opsx,opsy,'STP lineto'
                              endif
                  is=is+1
                  endif
      lc=0
c
  100 format(a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_dpagsiz(spax,spay,smax,smay)
c
c     ---------------------------------------------------------------+--
c *   Object : system_drv, define_page_size and margin size, in cm.
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /sdrpag/ supsx,supsy, smarx,smary,ifor
c
      integer supsx(5), supsy(5)
c
      if(spax.le.1.) call uperror_('sdr_dpagsiz: spax <1cm')
      if(spay.le.1.) call uperror_('sdr_dpagsiz: spay <1cm')
c
      call sdr_wfilcom('begin dpagsiz_')
c
c
c *** calcul du format (de A4 a A0, toujours en format portrait)
c
      spama= spax+smax
c
      ifor=4
      if(spama.gt. 21.0) ifor=3
      if(spama.gt. 29.7) ifor=2
      if(spama.gt. 42.0) ifor=1
      if(spama.gt. 59.4) ifor=0
      if(spama.gt. 84.0) ifor=0
c
c *** calcul des marges en ups
c
      smarx= smax*72./2.54
      smary= smay*72./2.54
c
c *** directives de taille de page dans le fichier PostScript
c
      call sdr_wfilcom('end   dpagsiz_')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_gfontyp(fontyp,nbfon)
c
c     ---------------------------------------------------------------+--
c *   Object : system_drv, give_font_types from fontyp(13) as 'tital'
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) fontyp(13)
c
c
      fontyp( 1)='couri'
      fontyp( 2)='cbold'
      fontyp( 3)='cobli'
      fontyp( 4)='cbobl'
c
      fontyp( 5)='times'
      fontyp( 6)='tbold'
      fontyp( 7)='tital'
      fontyp( 8)='tbita'
c
      fontyp( 9)='helve'
      fontyp(10)='hbold'
      fontyp(11)='hobli'
      fontyp(12)='hbobl'
c
      fontyp(13)='symbo'
c
      nbfon=13
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_gfonwid(fonwid,nbfon)
c
c     ---------------------------------------------------------------+--
c *   Object : system_drv, give_font_width from fonwid(255,13) in cm.
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
c **  Les largeurs sont donnees en data  en UPS pour le corps 10;
c     Ils sont convertis en cm dans le tableau de retour fonwid.
c     Les caracteres imprimables vont de 33 a 255
c
      real wcouri(255), wcbold(255), wcobli(255),wcbobl(255)
      real wtimes(255), wtbold(255), wtital(255),wtbita(255)
      real whelve(255), whbold(255), whobli(255),whbobl(255)
c
      save wcouri, wcbold, wcobli,wcbobl
      save wtimes, wtbold, wtital,wtbita
      save whelve, whbold, whobli,whbobl
c
      real fonwid(255,13)
c                 achtung, fonwid(255,*) met des depassements memoire
c     ------------------------
c
c *** Courier (espacement fixes)
c
      data   wcouri /255*6.00/
      data   wcbold /255*6.00/
      data   wcobli /255*6.00/
      data   wcbobl /255*6.00/
c
c *** Times-Roman (espacement proportionnels)
c
      data   wtimes / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.50,
     &                3.33, 4.08, 5.00, 5.00, 8.33, 7.78, 3.33, 3.33,
     &                3.33, 5.00, 5.64, 2.50, 3.33, 2.50, 2.78, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00,
     &                5.00, 2.78, 2.78, 5.64, 5.64, 5.64, 4.44, 9.21,
     &                7.22, 6.67, 6.67, 7.22, 6.11, 5.56, 7.22, 7.22,
     &                3.33, 3.89, 7.22, 6.11, 8.89, 7.22, 7.22, 5.56,
     &                7.22, 6.67, 5.56, 6.11, 7.22, 7.22, 9.44, 7.22,
     &                7.22, 6.11, 3.33, 2.78, 3.33, 4.69, 5.00, 3.33,
     &                4.44, 5.00, 4.44, 5.00, 4.44, 3.33, 5.00, 5.00,
     &                2.78, 2.78, 5.00, 2.78, 7.78, 5.00, 5.00, 5.00,
     &                5.00, 3.33, 3.89, 2.78, 5.00, 5.00, 7.22, 5.00,
     &                5.00, 4.44, 4.80, 2.00, 4.80, 5.41, 5.00, 3.33,
     &                3.33, 3.33, 3.33, 3.33, 3.33, 2.78, 1.80, 3.33,
     &                2.00, 3.33, 5.00, 4.44,10.00, 5.00, 5.00, 3.33,
     &               10.00, 5.56, 3.33, 8.89, 3.33, 3.33, 4.44, 4.44,
     &                3.50, 5.00,10.00, 3.33, 9.80, 3.89, 3.33, 7.22,
     &                7.22, 2.50, 3.33, 5.00, 5.00, 2.00, 5.00, 3.33,
     &                7.60, 2.76, 5.00, 5.64, 3.33, 7.60, 3.33, 4.00,
     &                5.64, 3.00, 3.00, 3.33, 5.00, 4.53, 2.50, 3.33,
     &                3.00, 3.10, 5.00, 7.50, 7.50, 7.50, 4.44, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 7.22, 8.89, 6.67, 6.11,
     &                6.11, 6.11, 6.11, 3.33, 3.33, 3.33, 3.33, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 7.22, 7.22, 5.64, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 7.22, 5.56, 5.00, 4.44,
     &                4.44, 4.44, 4.44, 4.44, 4.44, 6.67, 4.44, 4.44,
     &                4.44, 4.44, 4.44, 2.78, 2.78, 2.78, 2.78, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.64, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00/
c
c *** Times-Bold
c
      data   wtbold / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.50,
     &                3.33, 5.55, 5.00, 5.00,10.00, 8.33, 3.33, 3.33,
     &                3.33, 5.00, 5.70, 2.50, 3.33, 2.50, 2.78, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00,
     &                5.00, 3.33, 3.33, 5.70, 5.70, 5.70, 5.00, 9.30,
     &                7.22, 6.67, 7.22, 7.22, 6.67, 6.11, 7.78, 7.78,
     &                3.89, 5.00, 7.78, 6.67, 9.44, 7.22, 7.78, 6.11,
     &                7.78, 7.22, 5.56, 6.67, 7.22, 7.22,10.00, 7.22,
     &                7.22, 6.67, 3.33, 2.78, 3.33, 5.81, 5.00, 3.33,
     &                5.00, 5.56, 4.44, 5.56, 4.44, 3.33, 5.00, 5.56,
     &                2.78, 3.33, 5.56, 2.78, 8.33, 5.56, 5.00, 5.56,
     &                5.56, 4.44, 3.89, 3.33, 5.56, 5.00, 7.22, 5.00,
     &                5.00, 4.44, 3.94, 2.20, 3.94, 5.20, 5.00, 3.33,
     &                3.33, 3.33, 3.33, 3.33, 3.33, 2.78, 2.78, 3.33,
     &                2.20, 3.33, 5.00, 5.00,10.00, 5.00, 5.00, 3.33,
     &               10.00, 5.56, 3.33,10.00, 3.33, 3.33, 5.00, 5.00,
     &                3.50, 5.00,10.00, 3.33,10.00, 3.89, 3.33, 7.22,
     &                7.22, 2.50, 3.33, 5.00, 5.00, 2.20, 5.00, 3.33,
     &                7.47, 3.00, 5.00, 5.70, 3.33, 7.47, 3.33, 4.00,
     &                5.70, 3.00, 3.00, 3.33, 5.56, 5.40, 2.50, 3.33,
     &                3.00, 3.30, 5.00, 7.50, 7.50, 7.50, 5.00, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 7.22,10.00, 7.22, 6.67,
     &                6.67, 6.67, 6.67, 3.89, 3.89, 3.89, 3.89, 7.22,
     &                7.22, 7.78, 7.78, 7.78, 7.78, 7.78, 5.70, 7.78,
     &                7.22, 7.22, 7.22, 7.22, 7.22, 6.11, 5.56, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 7.22, 4.44, 4.44,
     &                4.44, 4.44, 4.44, 2.78, 2.78, 2.78, 2.78, 5.00,
     &                5.56, 5.00, 5.00, 5.00, 5.00, 5.00, 5.70, 5.00,
     &                5.56, 5.56, 5.56, 5.56, 5.00, 5.56, 5.00/
c
c *** Times-Italic
c
      data   wtital / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.50,
     &                3.33, 4.20, 5.00, 5.00, 8.33, 7.78, 3.33, 3.33,
     &                3.33, 5.00, 6.75, 2.50, 3.33, 2.50, 2.78, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00,
     &                5.00, 3.33, 3.33, 6.75, 6.75, 6.75, 5.00, 9.20,
     &                6.11, 6.11, 6.67, 7.22, 6.11, 6.11, 7.22, 7.22,
     &                3.33, 4.44, 6.67, 5.56, 8.33, 6.67, 7.22, 6.11,
     &                7.22, 6.11, 5.00, 5.56, 7.22, 6.11, 8.33, 6.11,
     &                5.56, 5.56, 3.89, 2.78, 3.89, 4.22, 5.00, 3.33,
     &                5.00, 5.00, 4.44, 5.00, 4.44, 2.78, 5.00, 5.00,
     &                2.78, 2.78, 4.44, 2.78, 7.22, 5.00, 5.00, 5.00,
     &                5.00, 3.89, 3.89, 2.78, 5.00, 4.44, 6.67, 4.44,
     &                4.44, 3.89, 4.00, 2.75, 4.00, 5.41, 5.00, 3.33,
     &                3.33, 3.33, 3.33, 3.33, 3.33, 2.78, 2.14, 3.33,
     &                2.75, 3.33, 5.00, 5.56, 8.89, 5.00, 5.00, 3.33,
     &               10.00, 5.00, 3.33, 9.44, 3.33, 3.33, 5.56, 5.56,
     &                3.50, 5.00, 8.89, 3.33, 9.80, 3.89, 3.33, 6.67,
     &                5.56, 2.50, 3.89, 5.00, 5.00, 2.75, 5.00, 3.33,
     &                7.60, 2.76, 5.00, 6.75, 3.33, 7.60, 3.33, 4.00,
     &                6.75, 3.00, 3.00, 3.33, 5.00, 5.23, 2.50, 3.33,
     &                3.00, 3.10, 5.00, 7.50, 7.50, 7.50, 5.00, 6.11,
     &                6.11, 6.11, 6.11, 6.11, 6.11, 8.89, 6.67, 6.11,
     &                6.11, 6.11, 6.11, 3.33, 3.33, 3.33, 3.33, 7.22,
     &                6.67, 7.22, 7.22, 7.22, 7.22, 7.22, 6.75, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 5.56, 6.11, 5.00, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 6.67, 4.44, 4.44,
     &                4.44, 4.44, 4.44, 2.78, 2.78, 2.78, 2.78, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 6.75, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 4.44, 5.00, 4.44/
c
c *** Times-BoldItalic
c
      data   wtbita / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.50,
     &                3.89, 5.55, 5.00, 5.00, 8.33, 7.78, 3.33, 3.33,
     &                3.33, 5.00, 5.70, 2.50, 3.33, 2.50, 2.78, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00, 5.00,
     &                5.00, 3.33, 3.33, 5.70, 5.70, 5.70, 5.00, 8.32,
     &                6.67, 6.67, 6.67, 7.22, 6.67, 6.67, 7.22, 7.78,
     &                3.89, 5.00, 6.67, 6.11, 8.89, 7.22, 7.22, 6.11,
     &                7.22, 6.67, 5.56, 6.11, 7.22, 6.67, 8.89, 6.67,
     &                6.11, 6.11, 3.33, 2.78, 3.33, 5.70, 5.00, 3.33,
     &                5.00, 5.00, 4.44, 5.00, 4.44, 3.33, 5.00, 5.56,
     &                2.78, 2.78, 5.00, 2.78, 7.78, 5.56, 5.00, 5.00,
     &                5.00, 3.89, 3.89, 2.78, 5.56, 4.44, 6.67, 5.00,
     &                4.44, 3.89, 3.48, 2.20, 3.48, 5.70, 5.00, 3.33,
     &                3.33, 3.33, 3.33, 3.33, 3.33, 2.78, 2.78, 3.33,
     &                2.20, 3.33, 5.00, 5.00,10.00, 5.00, 5.00, 3.33,
     &               10.00, 5.56, 3.33, 9.44, 3.33, 3.33, 5.00, 5.00,
     &                3.50, 5.00,10.00, 3.33,10.00, 3.89, 3.33, 7.22,
     &                6.11, 2.50, 3.89, 5.00, 5.00, 2.20, 5.00, 3.33,
     &                7.47, 2.66, 5.00, 6.06, 3.33, 7.47, 3.33, 4.00,
     &                5.70, 3.00, 3.00, 3.33, 5.76, 5.00, 2.50, 3.33,
     &                3.00, 3.00, 5.00, 7.50, 7.50, 7.50, 5.00, 6.67,
     &                6.67, 6.67, 6.67, 6.67, 6.67, 9.44, 6.67, 6.67,
     &                6.67, 6.67, 6.67, 3.89, 3.89, 3.89, 3.89, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 7.22, 7.22, 5.70, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 6.11, 6.11, 5.00, 5.00,
     &                5.00, 5.00, 5.00, 5.00, 5.00, 7.22, 4.44, 4.44,
     &                4.44, 4.44, 4.44, 2.78, 2.78, 2.78, 2.78, 5.00,
     &                5.56, 5.00, 5.00, 5.00, 5.00, 5.00, 5.70, 5.00,
     &                5.56, 5.56, 5.56, 5.56, 4.44, 5.00, 4.44/
c
c *** Helvetica
c
      data   whelve / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.78,
     &                2.78, 3.55, 5.56, 5.56, 8.89, 6.67, 2.22, 3.33,
     &                3.33, 3.89, 5.84, 2.78, 3.33, 2.78, 2.78, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.56,
     &                5.56, 2.78, 2.78, 5.84, 5.84, 5.84, 5.56,10.15,
     &                6.67, 6.67, 7.22, 7.22, 6.67, 6.11, 7.78, 7.22,
     &                2.78, 5.00, 6.67, 5.56, 8.33, 7.22, 7.78, 6.67,
     &                7.78, 7.22, 6.67, 6.11, 7.22, 6.67, 9.44, 6.67,
     &                6.67, 6.11, 2.78, 2.78, 2.78, 4.69, 5.56, 2.22,
     &                5.56, 5.56, 5.00, 5.56, 5.56, 2.78, 5.56, 5.56,
     &                2.22, 2.22, 5.00, 2.22, 8.33, 5.56, 5.56, 5.56,
     &                5.56, 3.33, 5.00, 2.78, 5.56, 5.00, 7.22, 5.00,
     &                5.00, 5.00, 3.34, 2.60, 3.34, 5.84, 5.00, 3.33,
     &                3.33, 3.33, 3.33, 3.33, 3.33, 2.78, 1.91, 3.33,
     &                2.60, 2.22, 5.56, 3.33,10.00, 5.56, 5.56, 3.33,
     &               10.00, 6.67, 3.33,10.00, 2.22, 2.22, 3.33, 3.33,
     &                3.50, 5.56,10.00, 3.33,10.00, 5.00, 3.33, 9.44,
     &                6.67, 2.78, 3.33, 5.56, 5.56, 2.60, 5.56, 3.33,
     &                7.37, 3.70, 5.56, 5.84, 3.33, 7.37, 3.33, 4.00,
     &                5.84, 3.33, 3.33, 3.33, 5.56, 5.37, 2.78, 3.33,
     &                3.33, 3.65, 5.56, 8.34, 8.34, 8.34, 6.11, 6.67,
     &                6.67, 6.67, 6.67, 6.67, 6.67,10.00, 7.22, 6.67,
     &                6.67, 6.67, 6.67, 2.78, 2.78, 2.78, 2.78, 7.22,
     &                7.22, 7.78, 7.78, 7.78, 7.78, 7.78, 5.84, 7.78,
     &                7.22, 7.22, 7.22, 7.22, 6.67, 6.67, 6.11, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 8.89, 5.00, 5.56,
     &                5.56, 5.56, 5.56, 2.78, 2.78, 2.78, 2.78, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.84, 6.11,
     &                5.56, 5.56, 5.56, 5.56, 5.00, 5.56, 5.00/
c
c *** Helvetica-Bold
c
      data   whbold / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.78,
     &                3.33, 4.74, 5.56, 5.56, 8.89, 7.22, 2.78, 3.33,
     &                3.33, 3.89, 5.84, 2.78, 3.33, 2.78, 2.78, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.56,
     &                5.56, 3.33, 3.33, 5.84, 5.84, 5.84, 6.11, 9.75,
     &                7.22, 7.22, 7.22, 7.22, 6.67, 6.11, 7.78, 7.22,
     &                2.78, 5.56, 7.22, 6.11, 8.33, 7.22, 7.78, 6.67,
     &                7.78, 7.22, 6.67, 6.11, 7.22, 6.67, 9.44, 6.67,
     &                6.67, 6.11, 3.33, 2.78, 3.33, 5.84, 5.56, 2.78,
     &                5.56, 6.11, 5.56, 6.11, 5.56, 3.33, 6.11, 6.11,
     &                2.78, 2.78, 5.56, 2.78, 8.89, 6.11, 6.11, 6.11,
     &                6.11, 3.89, 5.56, 3.33, 6.11, 5.56, 7.78, 5.56,
     &                5.56, 5.00, 3.89, 2.80, 3.89, 5.84, 5.00, 3.33,
     &                3.33, 3.33, 3.33, 3.33, 3.33, 2.78, 2.38, 3.33,
     &                2.80, 2.78, 5.56, 5.00,10.00, 5.56, 5.56, 3.33,
     &               10.00, 6.67, 3.33,10.00, 2.78, 2.78, 5.00, 5.00,
     &                3.50, 5.56,10.00, 3.33,10.00, 5.56, 3.33, 9.44,
     &                6.67, 2.78, 3.33, 5.56, 5.56, 2.80, 5.56, 3.33,
     &                7.37, 3.70, 5.56, 5.84, 3.33, 7.37, 3.33, 4.00,
     &                5.84, 3.33, 3.33, 3.33, 6.11, 5.56, 2.78, 3.33,
     &                3.33, 3.65, 5.56, 8.34, 8.34, 8.34, 6.11, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 7.22,10.00, 7.22, 6.67,
     &                6.67, 6.67, 6.67, 2.78, 2.78, 2.78, 2.78, 7.22,
     &                7.22, 7.78, 7.78, 7.78, 7.78, 7.78, 5.84, 7.78,
     &                7.22, 7.22, 7.22, 7.22, 6.67, 6.67, 6.11, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 8.89, 5.56, 5.56,
     &                5.56, 5.56, 5.56, 2.78, 2.78, 2.78, 2.78, 6.11,
     &                6.11, 6.11, 6.11, 6.11, 6.11, 6.11, 5.84, 6.11,
     &                6.11, 6.11, 6.11, 6.11, 5.56, 6.11, 5.56/
c
c *** Helvetica-Oblique
c
      data   whobli / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.78,
     &                2.78, 3.55, 5.56, 5.56, 8.89, 6.67, 2.22, 3.33,
     &                3.33, 3.89, 5.84, 2.78, 3.33, 2.78, 2.78, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.56,
     &                5.56, 2.78, 2.78, 5.84, 5.84, 5.84, 5.56,10.15,
     &                6.67, 6.67, 7.22, 7.22, 6.67, 6.11, 7.78, 7.22,
     &                2.78, 5.00, 6.67, 5.56, 8.33, 7.22, 7.78, 6.67,
     &                7.78, 7.22, 6.67, 6.11, 7.22, 6.67, 9.44, 6.67,
     &                6.67, 6.11, 2.78, 2.78, 2.78, 4.69, 5.56, 2.22,
     &                5.56, 5.56, 5.00, 5.56, 5.56, 2.78, 5.56, 5.56,
     &                2.22, 2.22, 5.00, 2.22, 8.33, 5.56, 5.56, 5.56,
     &                5.56, 3.33, 5.00, 2.78, 5.56, 5.00, 7.22, 5.00,
     &                5.00, 5.00, 3.34, 2.60, 3.34, 5.84, 5.00, 3.33,
     &                3.33, 3.33, 3.33, 3.33, 3.33, 2.78, 1.91, 3.33,
     &                2.60, 2.22, 5.56, 3.33,10.00, 5.56, 5.56, 3.33,
     &               10.00, 6.67, 3.33,10.00, 2.22, 2.22, 3.33, 3.33,
     &                3.50, 5.56,10.00, 3.33,10.00, 5.00, 3.33, 9.44,
     &                6.67, 2.78, 3.33, 5.56, 5.56, 2.60, 5.56, 3.33,
     &                7.37, 3.70, 5.56, 5.84, 3.33, 7.37, 3.33, 4.00,
     &                5.84, 3.33, 3.33, 3.33, 5.56, 5.37, 2.78, 3.33,
     &                3.33, 3.65, 5.56, 8.34, 8.34, 8.34, 6.11, 6.67,
     &                6.67, 6.67, 6.67, 6.67, 6.67,10.00, 7.22, 6.67,
     &                6.67, 6.67, 6.67, 2.78, 2.78, 2.78, 2.78, 7.22,
     &                7.22, 7.78, 7.78, 7.78, 7.78, 7.78, 5.84, 7.78,
     &                7.22, 7.22, 7.22, 7.22, 6.67, 6.67, 6.11, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 8.89, 5.00, 5.56,
     &                5.56, 5.56, 5.56, 2.78, 2.78, 2.78, 2.78, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.84, 6.11,
     &                5.56, 5.56, 5.56, 5.56, 5.00, 5.56, 5.00/
c
c *** Helvetica-BoldOblique
c
      data   whbobl / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &                0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.78,
     &                3.33, 4.74, 5.56, 5.56, 8.89, 7.22, 2.78, 3.33,
     &                3.33, 3.89, 5.84, 2.78, 3.33, 2.78, 2.78, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.56, 5.56,
     &                5.56, 3.33, 3.33, 5.84, 5.84, 5.84, 6.11, 9.75,
     &                7.22, 7.22, 7.22, 7.22, 6.67, 6.11, 7.78, 7.22,
     &                2.78, 5.56, 7.22, 6.11, 8.33, 7.22, 7.78, 6.67,
     &                7.78, 7.22, 6.67, 6.11, 7.22, 6.67, 9.44, 6.67,
     &                6.67, 6.11, 3.33, 2.78, 3.33, 5.84, 5.56, 2.78,
     &                5.56, 6.11, 5.56, 6.11, 5.56, 3.33, 6.11, 6.11,
     &                2.78, 2.78, 5.56, 2.78, 8.89, 6.11, 6.11, 6.11,
     &                6.11, 3.89, 5.56, 3.33, 6.11, 5.56, 7.78, 5.56,
     &                5.56, 5.00, 3.89, 2.80, 3.89, 5.84, 5.00, 3.33,
     &                3.33, 3.33, 3.33, 3.33, 3.33, 2.78, 2.38, 3.33,
     &                2.80, 2.78, 5.56, 5.00,10.00, 5.56, 5.56, 3.33,
     &               10.00, 6.67, 3.33,10.00, 2.78, 2.78, 5.00, 5.00,
     &                3.50, 5.56,10.00, 3.33,10.00, 5.56, 3.33, 9.44,
     &                6.67, 2.78, 3.33, 5.56, 5.56, 2.80, 5.56, 3.33,
     &                7.37, 3.70, 5.56, 5.84, 3.33, 7.37, 3.33, 4.00,
     &                5.84, 3.33, 3.33, 3.33, 6.11, 5.56, 2.78, 3.33,
     &                3.33, 3.65, 5.56, 8.34, 8.34, 8.34, 6.11, 7.22,
     &                7.22, 7.22, 7.22, 7.22, 7.22,10.00, 7.22, 6.67,
     &                6.67, 6.67, 6.67, 2.78, 2.78, 2.78, 2.78, 7.22,
     &                7.22, 7.78, 7.78, 7.78, 7.78, 7.78, 5.84, 7.78,
     &                7.22, 7.22, 7.22, 7.22, 6.67, 6.67, 6.11, 5.56,
     &                5.56, 5.56, 5.56, 5.56, 5.56, 8.89, 5.56, 5.56,
     &                5.56, 5.56, 5.56, 2.78, 2.78, 2.78, 2.78, 6.11,
     &                6.11, 6.11, 6.11, 6.11, 6.11, 6.11, 5.84, 6.11,
     &                6.11, 6.11, 6.11, 6.11, 5.56, 6.11, 5.56/
c
c *** Symbol (a definir !)
c
clm*      data   wsymbo /255*6.00/
c
c
c *** mise en memoire des largeurs de caracteres
c     et conversion en cm
c
      do 10 i=1,255
c
      fonwid(i, 1)=wcouri(i)*2.54/72.
      fonwid(i, 2)=wcbold(i)*2.54/72.
      fonwid(i, 3)=wcobli(i)*2.54/72.
      fonwid(i, 4)=wcbobl(i)*2.54/72.
c
      fonwid(i, 5)=wtimes(i)*2.54/72.
      fonwid(i, 6)=wtbold(i)*2.54/72.
      fonwid(i, 7)=wtital(i)*2.54/72.
      fonwid(i, 8)=wtbita(i)*2.54/72.
c
      fonwid(i, 9)=whelve(i)*2.54/72.
      fonwid(i,10)=whbold(i)*2.54/72.
      fonwid(i,11)=whobli(i)*2.54/72.
      fonwid(i,12)=whbobl(i)*2.54/72.
c
c ***! on prends helvetica pour symbol en attendant mieux...
c
      fonwid(i,13)=whelve(i)*2.54/72.
c
   10 continue
c
      nbfon=13
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_pfilzon
c
c     ------------------------------------------------------------------
c *   Object : system_drv, plot_fill_zone of preceding plot
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
c
c
      write(ifc,100) 'closepath'
      write(ifc,100) 'fill'
      write(ifc,100)
c
      lc=0
c
c *** ferme aussi le chemin
      is=0
c
  100 format(a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_ppagcha(chast,pox,poy,angle)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, plot_character_string at bottom left corner
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
c
      character*(*) chast
      
      character*64 forps
      character*4 fx,fy
      character*255 ligne
      character*255 lignec
c
      save forps,fx,fy,ligne,lignec
c
c
      if(lc.eq.1) then
                  write(ifc,100) 'stroke'
                  write(ifc,100)
                  endif
c
c *** conversion en ups
c
      call sdr_tcmiups(pox,poy,opsx,opsy)
c
c *** traitement des parenthese et du backslash  en PostScript
c     (on ajoute \ devant les parenthese ou devant un \)
c
      ligne=chast
      lignec=ligne
      ic=0
c
      do 10 i=1,255
      ic=ic+1
      if(ic.gt.255) go to 20
c
      if(lignec(ic:ic).eq.'('.
     &or.lignec(ic:ic).eq.')'.
     &or.lignec(ic:ic).eq.char(92)) then
                                    lignec(1:ic-1)=ligne(1:ic-1)
                                    lignec(ic+1:255)=ligne(ic:254)
                                    lignec(ic:ic)=char(92)
                                    ic=ic+1
                                    ligne=lignec
                                    go to 10
                                    endif
   10 continue
   20 continue
c
      call cchalen_(lignec,ncu)
c
c *** trace de l'instruction dans le fichier PostScript
c
c *   calcul du format pour le fichier PostScript
c
      call ucomfor_(opsx,opsy,fx,fy)
c
      if(abs(angle).gt.0.1) then
            forps="(f8.2,1x,'(',a,') ',1x,f8.2,1x," // fx 
     &                                     // ',1x,' // fy // ',1x,a)'
            write(ifc,forps) -angle,lignec(1:ncu),angle,opsx,opsy,'MTRS'
                           else
            forps="('(',a,') '," // fx //',1x,' //fy // ',1x,a)'
            write(ifc,forps) lignec(1:ncu), opsx,opsy,'MTS'
                            endif
      lc=0
c
  100 format(a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_ppagima(pox,poy,sizx,sizy,angle,imag,nx,ny)
c
      common /sdrcom/ ifc,lc,numpag,is
c
c     ------------------------------------------------------------------
c *   Object : system_drv, plot_page_image
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      integer imag(nx,ny)
c
      character*2  hra(300000), hga(300000), hba(300000)
c
c
      if(lc.eq.1.and.is.ne.1) then
                              write(ifc,100) 'stroke'
                              write(ifc,100)
                              endif
c
      if(is.eq.2) then
                  write(ifc,100) 'clip'
                  else
                  write(ifc,100) 'gsave'
                  endif
c
c *** conversion en ups
c
      call sdr_tcmiups(pox,poy,opsx,opsy)
c
c *** tests
c
      if(opsx.lt.   0.) call uperror_('sps_ppagima: origine x negative')
      if(opsy.lt.   0.) call uperror_('sps_ppagima: origine y negative')
      if(opsx.gt.9999.) call uperror_('sps_ppagima: origine x too big')
      if(opsy.gt.9999.) call uperror_('sps_ppagima: origine y too big')
c
      ucm= 72./2.54
      scax=sizx*ucm
      scay=sizy*ucm
c
      if(scax.lt.   0.) call uperror_('sps_ppagima: scale x negative')
      if(scay.lt.   0.) call uperror_('sps_ppagima: scale y negative')
      if(scax.gt.9999.) call uperror_('sps_ppagima: scale x too big')
      if(scay.gt.9999.) call uperror_('sps_ppagima: scale y too big')
c
c *** chargement de l'image
c
      write(ifc,100) ' '
      write(ifc,200) ' /w ',nx,' def'
      write(ifc,200) ' /h ',ny,' def'
      write(ifc,100) ' /bpp 8 def'
      write(ifc,100) ' /chaine w 3 mul string def'
      write(ifc,100) ' /dump'
      write(ifc,100) ' {'
      write(ifc,100) ' w h bpp [w 0 0 h neg 0 h]'
      write(ifc,100) ' { currentfile chaine readhexstring pop } ',
     &                                     'false 3 colorimage'
      write(ifc,100) ' } def'
      write(ifc,100) '  '
c
      write(ifc,400) opsx,opsy, ' translate'
      if(abs(angle).gt.0.01) write(ifc,500) angle
      write(ifc,400) scax,scay, ' scale'
c
      write(ifc,100) '  dump'
c
      do 20 iy=1,ny
      ky=ny-iy+1
      do 30 ix=1,nx
      call cicorgb_(imag(ix,ky),ir,ig,ib)
      call cdechex_(ir,hra(ix))
      call cdechex_(ig,hga(ix))
      call cdechex_(ib,hba(ix))
   30 continue
      write(ifc,300) (hra(ix),hga(ix),hba(ix),ix=1,nx)
   20 continue
c
      write(ifc,100)
      if(abs(angle).gt.0.01) write(ifc,500) -angle
      write(ifc,100) 'grestore'
      write(ifc,100)
c
      lc=0
      is=0
c
c
  100 format(2a)
  200 format(a,i5,a)
  300 format(32(3a2))
  400 format(f8.2,1x,f8.2,a)
  500 format(f8.2,' rotate')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_ppagpmo(pox,poy)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, plot_pen_motion in cm
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
c
      character*32 forps
      character*4 fx,fy
c
      save forps,fx,fy
c
c
c *** conversion en ups
c
      call sdr_tcmiups(pox,poy,opsx,opsy)
c
c *** trace de l'instruction dans le fichier PostScript
c
c *   calcul du format pour le fichier PostScript
c
      call ucomfor_(opsx,opsy,fx,fy)
c
      forps='(' // fx // ',1x,' // fy //',1x,a)'  
c
      write(ifc,forps) opsx,opsy,'STP lineto'
c
c *** stroke ulterieur (seul subroutine autorisee a le faire)
c     seulement si on n'a pas ouvert de chemin par dfilzon_
c
      if(is.eq.0) then
                  lc=1
                  else
                  lc=0
                  endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_tcmiups(pox,poy,opsx,opsy)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, transform_cm_in_ups
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrpag/ supsx,supsy, smarx,smary,ifor
c
      integer supsx(5), supsy(5)
c
c *** conversion en ups
c
      ucm= 72./2.54
c
      opsx= smarx +pox*ucm
      opsy= smary +poy*ucm
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_updbbox
c
c     ------------------------------------------------------------------
c *   Object : system_drv, update bounding box values
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2007
c     ------------------------------------------------------------------
c
      common /boupag/ xminb,xmaxb,yminb,ymaxb
      common /sdrbbo/ xmip,xmap,ymip,ymap, xmimip,xmamap,ymimip,ymamap
c
c *** conversion en ups et chargement du common /sdrbbo/
c
      call sdr_tcmiups(xminb,yminb,xmip,ymip)
      call sdr_tcmiups(xmaxb,ymaxb,xmap,ymap)
c
      xmimip= min(xmimip,xmip)
      xmamap= max(xmamap,xmap)
      ymimip= min(ymimip,ymip)
      ymamap= max(ymamap,ymap)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sdr_wfilcom(com)
c
c     ------------------------------------------------------------------
c *   Object : system_drv, write_file_comment in .ps file
c *   Class  : system postscript driver modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      common /sdrcom/ ifc,lc,numpag,is
c
      character*(*) com
c
      if(com(1:5).eq.'begin') then
                              write(ifc,200) com
                              else
                              write(ifc,100) com
                              endif
c
  100 format(  '%ROGRALIB: ',a)
  200 format(/,'%ROGRALIB: ',a)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine sys_gdattim(imon,id,iy,ih,im,is)
c
c     ------------------------------------------------------------------
c
c *   Object : system_low:give_date_time at the call
c *   Class  : system compiler dependant modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c
c     input : none
c     output: all arguments
c
c     ------------------------------------------------------------------
c
      integer time 
c
      n=time()
c
      juld70= n/86400
      secotd= float(n -juld70*86400)
      milday= int(secotd*1000.)
c dbg print*, 'n,juld70,secotd,milday=',n,juld70,secotd,milday
c
      call cdatj70_(juld70,iy,imon,id)
      call ctimmil_(milday,ih,im,is,ims)
c dbg print*, 'iy,imon,id,ih,im,is,ims=',iy,imon,id,ih,im,is,ims
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine uboundi_(ix,ix1,ix2)
c
c     ---------------------------------------------------------------+--
c *   Object : u_bounds_integer ix as  ix1 <ix <ix2
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      if(ix.lt.ix1) ix=ix1
      if(ix.gt.ix2) ix=ix2
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ubounds_(x,x1,x2)
c
c     ---------------------------------------------------------------+--
c *   Object : u_bounds x as x1 <x <x2
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      if(x.lt.x1) x=x1
      if(x.gt.x2) x=x2
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ucgraste(dx,ggx,pgx)
c
c     ---------------------------------------------------------------+--
c *   Object : u_compute_graduations_steps from dx=x2-x1
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      data epsi  /1.e-35/
      save epsi
c
c
c *** calcule des intervalles de graduation pour dx donne
c                utilitaire de cgraste_
c
c
      if(dx.lt.0.)   call uperror_('ucgraste: dx negatif')
      if(dx.lt.epsi) call uperror_('ucgraste: dx trop petit')
c
      call cmanexp_(dx,rdx,ie)
      id=int(rdx*10.+0.5)
      if(id.lt.1) id=1
c
      go to (1,2,3,4,5,6,7,8,9,1),id
c
    1 ggx=dx/5.
      pgx=ggx/4.
      return
c
    2 ggx=dx/4.
      pgx=ggx/5.
      return
c
    3 ggx=dx/3.
clm      pgx=ggx/10.
      pgx=ggx/5.
      return
c
    4 ggx=dx/4.
clm      pgx=ggx/10.
      pgx=ggx/5.
      return
c
    5 ggx=dx/5.
clm      pgx=ggx/10.
      pgx=ggx/4.
      return
c
    6 ggx=dx/3.
      pgx=ggx/4.
      return
c
    7 ggx=dx*2./7.
      pgx=ggx/4.
      return
c
    8 ggx=dx/4.
      pgx=ggx/4.
      return
c
    9 ggx=dx*2./9.
      pgx=ggx/4.
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ucomfor_(xups,yups,fx,fy)
c
c     ---------------------------------------------------------------+--
c *   Object : u_compute_format for lineto/moveto of PS file
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 2008
c     ---------------------------------------------------------------+--
c
      character*4 fx,fy
c
c *** avoid '****' string in PostScript file in case of overlap format
c     Note:
c     limits of x,y in ups units should be, in A0 format:
c         0 < x < 2380
c         0 < y < 3368
c
c     limits taken:     [-9999.90, +9999.90]
c
c
c *   compute X format
c
      if(xups.gt.0.) then
                     fx='F4.2'
                     if(xups.gt.   9.9) fx='F5.2'
                     if(xups.gt.  99.9) fx='F6.2'
                     if(xups.gt. 999.9) fx='F7.2'
                     if(xups.gt.9999.9) xups= 9999.90
                     
                     else
                     fx='F5.2'
                     if(xups.lt.   -9.9) fx='F6.2'
                     if(xups.lt.  -99.9) fx='F7.2'
                     if(xups.lt. -999.9) fx='F8.2'
                     if(xups.lt. -9999.9) xups= -9999.90 
                     endif
c
c *   compute Y format
c
      if(yups.gt.0.) then
                     fy='F4.2'
                     if(yups.gt.   9.9) fy='F5.2'
                     if(yups.gt.  99.9) fy='F6.2'
                     if(yups.gt. 999.9) fy='F7.2'
                     if(yups.gt.9999.9) yups= 9999.90
                     
                     else
                     fy='F5.2'
                     if(yups.lt.   -9.9) fy='F6.2'
                     if(yups.lt.  -99.9) fy='F7.2'
                     if(yups.lt. -999.9) fy='F8.2'
                     if(yups.lt. -9999.9) yups= -9999.90
                     endif
c
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine udecfor_(format,ifg,n,nd)
c
c     ---------------------------------------------------------------+--
c *   Object : u_decode_format
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*)format
      character*1 s(8),ifg
      character*8 for8
c
c *** decode un format en fournissant ses caracteristiques
c
c
      for8=format
c
      read(for8,1) s
      ifg=s(2)
      if(ifg.ne.'i' .and. ifg.ne.'I') go to 10
      nd=0
      if(s(4).eq.')' .or. s(4).eq.'.') read(for8,2) n
      if(s(5).eq.')' .or. s(5).eq.'.') read(for8,3) n
      return
c
   10 continue
      if(s(4).ne.'.') go to 20
      read(for8,4) n,nd
      return
c
   20 continue
      if(s(6).eq.')') read(for8,4) n,nd
      if(s(7).eq.')') read(for8,5) n,nd
      if(s(8).eq.')') read(for8,6) n,nd
c
    1 format(8a1)
    2 format(2x,i1,5x)
    3 format(2x,i2,4x)
    4 format(2x,i1,1x,i1,3x)
    5 format(2x,i2,1x,i1,2x)
    6 format(2x,i2,1x,i2,1x)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine uencfor_(format,ifg,n,nd)
c
c     ---------------------------------------------------------------+--
c *   Object : u_encode_format
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) format
      character*1 ifg
c
c *** encode un format a partir de ses caracteristiques
c
c
      ll=len(format)
      if(ll.lt.8)
     &     call uperror_('uencfor_: format inferieur a 8 caracteres')
c
      if(ifg.ne.'i') go to 10
      if(n.le.9) write(format,1) n
      if(n.ge.10) write(format,2) n
      return
c
   10 continue
      if(n.gt.9) go to 20
      write(format,3) ifg,n,nd
      return
c
   20 continue
      if(nd.gt.9) go to 30
      write(format,4) ifg,n,nd
      return
c
   30 continue
      write(format,5) ifg,n,nd
c
    1 format('(i',i1,')',4x)
    2 format('(i',i2,')',3x)
    3 format('(',a1,i1,'.',i1,')',2x)
    4 format('(',a1,i2,'.',i1,')',1x)
    5 format('(',a1,i2,'.',i2,')')
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine ufigbou_(xcm,ycm)
c
c     ---------------------------------------------------------------+--
c *   Object : u_figure_boundaries force xcm, ycm inside the figure
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      common /figsiz/ rx,ry
      common /figori/ xz,yz
c
c *** limite xcm et ycm aux bornes en cm de la figure
c
      if(xcm.lt.xz) xcm=xz
      if(xcm.gt.xz+rx) xcm=xz+rx
c
      if(ycm.lt.yz) ycm=yz
      if(ycm.gt.yz+ry) ycm=yz+ry
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine uhuergb_(rm1,rm2,hue,rgb)
c
c     ---------------------------------------------------------------+--
c *   Object : utility_for_chsbrgb_
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      hh=hue
      if(hh.lt.0.) hh=hh+1.
      if(hh.gt.1.) hh=hh-1.
c
      if(hh.lt.1./6.) then
                      rgb= rm1 + (rm2-rm1)*hh*6.
                      return
                      endif
c
      if(hh.lt.1./2.) then
                      rgb= rm2
                      return
                      endif
c
      if(hh.lt.2./3.) then
                      rgb= rm1 + (rm2-rm1)*(2./3. -hh)*6.
                      return
                      endif
      rgb=rm1
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine upchael_(cara,x,y,tax,tay,angle)
c
c     ---------------------------------------------------------------+--
c *   Object : u_plot_character_element used by upchast_
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) cara
      character*1 car
c
c
c *** trace du texte par deplacement de plume
c
c
      integer cxga(5),cyga(5)
      integer cxgb(12),cygb(12)
      integer cxgc(8),cygc(8)
      integer cxgd(7),cygd(7)
      integer cxge(7),cyge(7)
      integer cxgf(6),cygf(6)
      integer cxgg(10),cygg(10)
      integer cxgh(6),cygh(6)
      integer cxgi(6),cygi(6)
      integer cxgj(5),cygj(5)
      integer cxgk(7),cygk(7)
      integer cxgl(4),cygl(4)
      integer cxgm(7),cygm(7)
      integer cxgn(6),cygn(6)
      integer cxgo(9),cygo(9)
      integer cxgp(7),cygp(7)
      integer cxgq(10),cygq(10)
      integer cxgr(10),cygr(10)
      integer cxgs(12),cygs(12)
      integer cxgt(7),cygt(7)
      integer cxgu(6),cygu(6)
      integer cxgv(3),cygv(3)
      integer cxgw(5),cygw(5)
      integer cxgx(6),cygx(6)
      integer cxgy(5),cygy(5)
      integer cxgz(4),cygz(4)
      integer cx1(5),cy1(5)
      integer cx2(9),cy2(9)
      integer cx3(13),cy3(13)
      integer cx4(8),cy4(8)
      integer cx5(9),cy5(9)
      integer cx6(12),cy6(12)
      integer cx7(7),cy7(7)
      integer cx8(16),cy8(16)
      integer cx9(12),cy9(12)
      integer cx0(9),cy0(9)
      integer cxplus(5),cyplus(5)
      integer cxmoin(2),cymoin(2)
      integer cxpoin(5),cypoin(5)
      integer cxslas(2),cyslas(2)
      integer cx2pn1(5),cy2pn1(5)
      integer cx2pn2(5),cy2pn2(5)
      integer cxpaou(4),cypaou(4)
      integer cxpafe(4),cypafe(4)
      integer cxpce1(2),cypce1(2)
      integer cxpce2(5),cypce2(5)
      integer cxpce3(5),cypce3(5)
      integer cxega1(2),cyega1(2)
      integer cxega2(2),cyega2(2)
      integer cxvirg(4),cyvirg(4)
      integer cxpvi1(4),cypvi1(4)
      integer cxpvi2(5),cypvi2(5)
c
      integer cxa(10),cya(10)
      integer cxb(8),cyb(8)
      integer cxc(8),cyc(8)
      integer cxd(7),cyd(7)
      integer cxe(10),cye(10)
      integer cxf(7),cyf(7)
      integer cxg(12),cyg(12)
      integer cxh(7),cyh(7)
      integer cxi1(5),cyi1(5)
      integer cxi2(5),cyi2(5)
      integer cxj1(5),cyj1(5)
      integer cxj2(5),cyj2(5)
      integer cxk(8),cyk(8)
      integer cxl(2),cyl(2)
      integer cxm(10),cym(10)
      integer cxn(7),cyn(7)
      integer cxo(9),cyo(9)
      integer cxp(9),cyp(9)
      integer cxq(9),cyq(9)
      integer cxr(6),cyr(6)
      integer cxs(10),cys(10)
      integer cxt(8),cyt(8)
      integer cxu(6),cyu(6)
      integer cxv(3),cyv(3)
      integer cxw(5),cyw(5)
      integer cxx(13),cyx(13)
      integer cxy(10),cyy(10)
      integer cxz(4),cyz(4)
c
c *** save for gfortran
c
      save cxga,cyga
      save cxgb,cygb
      save cxgc,cygc
      save cxgd,cygd
      save cxge,cyge
      save cxgf,cygf
      save cxgg,cygg
      save cxgh,cygh
      save cxgi,cygi
      save cxgj,cygj
      save cxgk,cygk
      save cxgl,cygl
      save cxgm,cygm
      save cxgn,cygn
      save cxgo,cygo
      save cxgp,cygp
      save cxgq,cygq
      save cxgr,cygr
      save cxgs,cygs
      save cxgt,cygt
      save cxgu,cygu
      save cxgv,cygv
      save cxgw,cygw
      save cxgx,cygx
      save cxgy,cygy
      save cxgz,cygz
      save cx1,cy1
      save cx2,cy2
      save cx3,cy3
      save cx4,cy4
      save cx5,cy5
      save cx6,cy6
      save cx7,cy7
      save cx8,cy8
      save cx9,cy9
      save cx0,cy0
      save cxplus,cyplus
      save cxmoin,cymoin
      save cxpoin,cypoin
      save cxslas,cyslas
      save cx2pn1,cy2pn1
      save cx2pn2,cy2pn2
      save cxpaou,cypaou
      save cxpafe,cypafe
      save cxpce1,cypce1
      save cxpce2,cypce2
      save cxpce3,cypce3
      save cxega1,cyega1
      save cxega2,cyega2
      save cxvirg,cyvirg
      save cxpvi1,cypvi1
      save cxpvi2,cypvi2
c
      save cxa,cya
      save cxb,cyb
      save cxc,cyc
      save cxd,cyd
      save cxe,cye
      save cxf,cyf
      save cxg,cyg
      save cxh,cyh
      save cxi1,cyi1
      save cxi2,cyi2
      save cxj1,cyj1
      save cxj2,cyj2
      save cxk,cyk
      save cxl,cyl
      save cxm,cym
      save cxn,cyn
      save cxo,cyo
      save cxp,cyp
      save cxq,cyq
      save cxr,cyr
      save cxs,cys
      save cxt,cyt
      save cxu,cyu
      save cxv,cyv
      save cxw,cyw
      save cxx,cyx
      save cxy,cyy
      save cxz,cyz
c
      data nga/5/
      data ngb/12/
      data ngc/8/
      data ngd/7/
      data nge/7/
      data ngf/6/
      data ngg/10/
      data ngh/6/
      data ngi/6/
      data ngj/5/
      data ngk/7/
      data ngl/4/
      data ngm/7/
      data ngn/6/
      data ngo/9/
      data ngp/7/
      data ngq/10/
      data ngr/10/
      data ngs/12/
      data ngt/7/
      data ngu/6/
      data ngv/3/
      data ngw/5/
      data ngx/6/
      data ngy/5/
      data ngz/4/
      data n1/5/
      data n2/9/
      data n3/13/
      data n4/8/
      data n5/9/
      data n6/12/
      data n7/7/
      data n8/16/
      data n9/12/
      data n0/9/
      data nplus/5/
      data nmoin/2/
      data npoin/5/
      data nslas/2/
      data n2pn1/5/
      data n2pn2/5/
      data npaou/4/
      data npafe/4/
      data npce1/2/
      data npce2/5/
      data npce3/5/
      data nega1/2/
      data nega2/2/
      data nvirg/4/
      data npvi1/4/
      data npvi2/5/
c
      data na/10/
      data nb/8/
      data nc/8/
      data nd/7/
      data ne/10/
      data nf/7/
      data ng/12/
      data nh/7/
      data ni1/5/
      data ni2/5/
      data nj1/5/
      data nj2/5/
      data nk/8/
      data nl/2/
      data nm/10/
      data nn/7/
      data no/9/
      data np/9/
      data nq/9/
      data nr/6/
      data ns/10/
      data nt/8/
      data nu/6/
      data nv/3/
      data nw/5/
      data nx/13/
      data ny/10/
      data nz/4/
c
c *** les coordonnees pour le trace de chaque caractere
c     sont dans une grille entiere 6 X 6
c
      data cxga/1,3,5,4,2/
      data cyga/0,6,0,3,3/
      data cxgb/1,1,4,5,5,4,1,4,5,5,4,1/
      data cygb/0,6,6,5,4,3,3,3,2,1,0,0/
      data cxgc/5,4,2,1,1,2,4,5/
      data cygc/1,0,0,1,5,6,6,5/
      data cxgd/1,4,5,5,4,1,1/
      data cygd/0,0,1,5,6,6,0/
      data cxge/5,1,1,4,1,1,5/
      data cyge/0,0,3,3,3,6,6/
      data cxgf/1,1,4,1,1,5/
      data cygf/0,3,3,3,6,6/
      data cxgg/3,5,5,4,2,1,1,2,4,5/
      data cygg/2,2,1,0,0,1,5,6,6,5/
      data cxgh/1,1,1,5,5,5/
      data cygh/6,0,3,3,6,0/
      data cxgi/2,4,3,3,2,4/
      data cygi/6,6,6,0,0,0/
      data cxgj/5,5,4,2,1/
      data cygj/6,1,0,0,1/
      data cxgk/1,1,1,3,5,3,5/
      data cygk/6,0,3,3,6,3,0/
      data cxgl/1,1,5,5/
      data cygl/6,0,0,1/
      data cxgm/1,1,2,3,4,5,5/
      data cygm/0,6,6,4,6,6,0/
      data cxgn/1,1,2,4,5,5/
      data cygn/0,6,6,0,0,6/
      data cxgo/1,1,2,4,5,5,4,2,1/
      data cygo/1,5,6,6,5,1,0,0,1/
      data cxgp/1,1,4,5,5,4,1/
      data cygp/0,6,6,5,4,3,3/
      data cxgq/4,2,1,1,2,4,5,5,4,3/
      data cygq/0,0,1,5,6,6,5,1,0,2/
      data cxgr/1,1,4,5,5,4,1,4,5,5/
      data cygr/0,6,6,5,4,3,3,3,2,0/
      data cxgs/1,2,4,5,5,4,2,1,1,2,4,5/
      data cygs/1,0,0,1,2,3,3,4,5,6,6,5/
      data cxgt/1,1,3,3,3,5,5/
      data cygt/5,6,6,0,6,6,5/
      data cxgu/1,1,2,4,5,5/
      data cygu/6,1,0,0,1,6/
      data cxgv/1,3,5/
      data cygv/6,0,6/
      data cxgw/1,2,3,4,5/
      data cygw/6,0,3,0,6/
      data cxgx/1,3,1,5,3,5/
      data cygx/0,3,6,0,3,6/
      data cxgy/1,3,5,3,3/
      data cygy/6,3,6,3,0/
      data cxgz/1,5,1,5/
      data cygz/6,6,0,0/
      data cx1/1,3,3,2,4/
      data cy1/5,6,0,0,0/
      data cx2/1,1,2,4,5,5,1,1,5/
      data cy2/4,5,6,6,5,4,1,0,0/
      data cx3/1,2,4,5,5,4,3,4,5,5,4,2,1/
      data cy3/5,6,6,5,4,3,3,3,2,1,0,0,1/
      data cx4/4,1,1,4,4,4,4,5/
      data cy4/6,3,2,2,3,0,2,2/
      data cx5/5,1,1,4,5,5,4,2,1/
      data cy5/6,6,3,3,2,1,0,0,1/
      data cx6/5,4,2,1,1,2,4,5,5,4,2,1/
      data cy6/5,6,6,5,1,0,0,1,2,3,3,2/
      data cx7/1,1,5,4,2,4,3/
      data cy7/5,6,6,3,3,3,0/
      data cx8/2,1,1,2,4,5,5,4,2,1,1,2,4,5,5,4/
      data cy8/3,4,5,6,6,5,4,3,3,2,1,0,0,1,2,3/
      data cx9/5,4,2,1,1,2,4,5,5,4,2,1/
      data cy9/4,3,3,4,5,6,6,5,1,0,0,1/
      data cx0/2,1,1,2,4,5,5,4,2/
      data cy0/6,4,2,0,0,2,4,6,6/
      data cxplus/3,3,3,1,5/
      data cyplus/5,1,3,3,3/
      data cxmoin/1,5/
      data cymoin/3,3/
      data cxpoin/2,2,3,3,2/
      data cypoin/0,1,1,0,0/
      data cxslas/1,5/
      data cyslas/0,6/
      data cx2pn1/2,2,3,3,2/
      data cy2pn1/1,2,2,1,1/
      data cx2pn2/2,2,3,3,2/
      data cy2pn2/4,5,5,4,4/
      data cxpaou/4,3,3,4/
      data cypaou/0,2,4,6/
      data cxpafe/2,3,3,2/
      data cypafe/0,2,4,6/
      data cxpce1/1,5/
      data cypce1/0,6/
      data cxpce2/4,4,5,5,4/
      data cypce2/1,2,2,1,1/
      data cxpce3/1,1,2,2,1/
      data cypce3/4,5,5,4,4/
      data cxega1/2,4/
      data cyega1/2,2/
      data cxega2/2,4/
      data cyega2/4,4/
      data cxvirg/2,3,4,2/
      data cyvirg/0,2,2,0/
      data cxpvi1/2,3,4,2/
      data cypvi1/0,2,2,0/
      data cxpvi2/3,3,4,4,3/
      data cypvi2/3,4,4,3,3/
c
c *** pour l'alphabet minuscule, le pave 6 X 6 est transforme
c     par un depassement de -3 en y pour la queue des lettres
c     (donc 6 X 9 en fait)
c
      data cxa/1,2,4,5,5,6,2,1,2,5/
      data cya/3,4,4,3,0,0,0,1,2,2/
      data cxb/1,1,4,5,5,4,2,1/
      data cyb/6,0,0,1,3,4,4,3/
      data cxc/5,4,2,1,1,2,4,5/
      data cyc/3,4,4,3,1,0,0,1/
      data cxd/5,5,2,1,1,2,5/
      data cyd/6,0,0,1,3,4,4/
      data cxe/1,5,5,4,2,1,1,2,4,5/
      data cye/2,2,3,4,4,3,1,0,0,1/
      data cxf/5,4,2,1,1,1,3/
      data cyf/5,6,6,5,0,3,3/
      data cxg/ 1, 2, 4, 5,5,4,2,1,1,2,4,5/
      data cyg/-2,-3,-3,-2,3,4,4,3,1,0,0,1/
      data cxh/1,1,1,2,4,5,5/
      data cyh/0,6,3,4,4,3,0/
      data cxi1/1,1,2,4,5/
      data cyi1/4,1,0,0,1/
      data cxi2/1,1,2,2,1/
      data cyi2/5,6,6,5,5/
      data cxj1/5, 5, 4, 2, 1/
      data cyj1/4,-2,-3,-3,-2/
      data cxj2/4,4,5,5,4/
      data cyj2/5,6,6,5,5/
      data cxk/1,1,1,3,5,3,2,4/
      data cyk/0,6,2,4,4,4,3,0/
      data cxl/3,3/
      data cyl/6,0/
      data cxm/5,5,4,3,3,3,2,1,1,1/
      data cym/0,4,4,3,0,4,4,3,0,4/
      data cxn/5,5,4,2,1,1,1/
      data cyn/0,3,4,4,3,0,4/
      data cxo/1,1,2,4,5,5,4,2,1/
      data cyo/3,1,0,0,1,3,4,4,3/
      data cxp/ 1,1,2,4,5,5,4,2,1/
      data cyp/-3,3,4,4,3,1,0,0,1/
      data cxq/ 5,5,4,2,1,1,2,4,5/
      data cyq/-3,3,4,4,3,1,0,0,1/
      data cxr/1,1,1,2,3,4/
      data cyr/4,0,3,4,4,3/
      data cxs/5,4,2,1,2,4,5,4,2,1/
      data cys/3,4,4,3,2,2,1,0,0,1/
      data cxt/1,1,3,1,1,2,4,5/
      data cyt/5,4,4,4,1,0,0,1/
      data cxu/1,1,2,4,5,5/
      data cyu/4,1,0,0,1,4/
      data cxv/1,3,5/
      data cyv/4,0,4/
      data cxw/1,2,3,4,5/
      data cyw/4,0,4,0,4/
      data cxx/1,2,3,4,5,4,3,4,5,4,3,2,1/
      data cyx/4,4,2,4,4,4,2,0,0,0,2,0,0/
      data cxy/1,1,2,4,5,5, 5, 4, 2, 1/
      data cyy/4,1,0,0,1,4,-2,-3,-3,-2/
      data cxz/1,4,1,4/
      data cyz/4,4,0,0/
c
c
      tx=tax/6.
      ty=tay/6.
      a=angle
      car=cara(1:1)
c
c
      if(car.eq.'A') call upcincm_(x,y,cxga  ,cyga  ,nga  ,tx,ty,a,*100)
      if(car.eq.'B') call upcincm_(x,y,cxgb  ,cygb  ,ngb  ,tx,ty,a,*100)
      if(car.eq.'C') call upcincm_(x,y,cxgc  ,cygc  ,ngc  ,tx,ty,a,*100)
      if(car.eq.'D') call upcincm_(x,y,cxgd  ,cygd  ,ngd  ,tx,ty,a,*100)
      if(car.eq.'E') call upcincm_(x,y,cxge  ,cyge  ,nge  ,tx,ty,a,*100)
      if(car.eq.'F') call upcincm_(x,y,cxgf  ,cygf  ,ngf  ,tx,ty,a,*100)
      if(car.eq.'G') call upcincm_(x,y,cxgg  ,cygg  ,ngg  ,tx,ty,a,*100)
      if(car.eq.'H') call upcincm_(x,y,cxgh  ,cygh  ,ngh  ,tx,ty,a,*100)
      if(car.eq.'I') call upcincm_(x,y,cxgi  ,cygi  ,ngi  ,tx,ty,a,*100)
      if(car.eq.'J') call upcincm_(x,y,cxgj  ,cygj  ,ngj  ,tx,ty,a,*100)
      if(car.eq.'K') call upcincm_(x,y,cxgk  ,cygk  ,ngk  ,tx,ty,a,*100)
      if(car.eq.'L') call upcincm_(x,y,cxgl  ,cygl  ,ngl  ,tx,ty,a,*100)
      if(car.eq.'M') call upcincm_(x,y,cxgm  ,cygm  ,ngm  ,tx,ty,a,*100)
      if(car.eq.'N') call upcincm_(x,y,cxgn  ,cygn  ,ngn  ,tx,ty,a,*100)
      if(car.eq.'O') call upcincm_(x,y,cxgo  ,cygo  ,ngo  ,tx,ty,a,*100)
      if(car.eq.'P') call upcincm_(x,y,cxgp  ,cygp  ,ngp  ,tx,ty,a,*100)
      if(car.eq.'Q') call upcincm_(x,y,cxgq  ,cygq  ,ngq  ,tx,ty,a,*100)
      if(car.eq.'R') call upcincm_(x,y,cxgr  ,cygr  ,ngr  ,tx,ty,a,*100)
      if(car.eq.'S') call upcincm_(x,y,cxgs  ,cygs  ,ngs  ,tx,ty,a,*100)
      if(car.eq.'T') call upcincm_(x,y,cxgt  ,cygt  ,ngt  ,tx,ty,a,*100)
      if(car.eq.'U') call upcincm_(x,y,cxgu  ,cygu  ,ngu  ,tx,ty,a,*100)
      if(car.eq.'V') call upcincm_(x,y,cxgv  ,cygv  ,ngv  ,tx,ty,a,*100)
      if(car.eq.'W') call upcincm_(x,y,cxgw  ,cygw  ,ngw  ,tx,ty,a,*100)
      if(car.eq.'X') call upcincm_(x,y,cxgx  ,cygx  ,ngx  ,tx,ty,a,*100)
      if(car.eq.'Y') call upcincm_(x,y,cxgy  ,cygy  ,ngy  ,tx,ty,a,*100)
      if(car.eq.'Z') call upcincm_(x,y,cxgz  ,cygz  ,ngz  ,tx,ty,a,*100)
      if(car.eq.'1') call upcincm_(x,y,cx1   ,cy1   ,n1   ,tx,ty,a,*100)
      if(car.eq.'2') call upcincm_(x,y,cx2   ,cy2   ,n2   ,tx,ty,a,*100)
      if(car.eq.'3') call upcincm_(x,y,cx3   ,cy3   ,n3   ,tx,ty,a,*100)
      if(car.eq.'4') call upcincm_(x,y,cx4   ,cy4   ,n4   ,tx,ty,a,*100)
      if(car.eq.'5') call upcincm_(x,y,cx5   ,cy5   ,n5   ,tx,ty,a,*100)
      if(car.eq.'6') call upcincm_(x,y,cx6   ,cy6   ,n6   ,tx,ty,a,*100)
      if(car.eq.'7') call upcincm_(x,y,cx7   ,cy7   ,n7   ,tx,ty,a,*100)
      if(car.eq.'8') call upcincm_(x,y,cx8   ,cy8   ,n8   ,tx,ty,a,*100)
      if(car.eq.'9') call upcincm_(x,y,cx9   ,cy9   ,n9   ,tx,ty,a,*100)
      if(car.eq.'0') call upcincm_(x,y,cx0   ,cy0   ,n0   ,tx,ty,a,*100)
      if(car.eq.'+') call upcincm_(x,y,cxplus,cyplus,nplus,tx,ty,a,*100)
      if(car.eq.'-') call upcincm_(x,y,cxmoin,cymoin,nmoin,tx,ty,a,*100)
      if(car.eq.'.') call upcincm_(x,y,cxpoin,cypoin,npoin,tx,ty,a,*100)
      if(car.eq.'/') call upcincm_(x,y,cxslas,cyslas,nslas,tx,ty,a,*100)
      if(car.eq.':') call upcincm_(x,y,cx2pn1,cy2pn1,n2pn1,tx,ty,a,*110)
  110 if(car.eq.':') call upcincm_(x,y,cx2pn2,cy2pn2,n2pn2,tx,ty,a,*100)
      if(car.eq.'(') call upcincm_(x,y,cxpaou,cypaou,npaou,tx,ty,a,*100)
      if(car.eq.')') call upcincm_(x,y,cxpafe,cypafe,npafe,tx,ty,a,*100)
      if(car.eq.'%') call upcincm_(x,y,cxpce1,cypce1,npce1,tx,ty,a,*120)
  120 if(car.eq.'%') call upcincm_(x,y,cxpce2,cypce2,npce2,tx,ty,a,*121)
  121 if(car.eq.'%') call upcincm_(x,y,cxpce3,cypce3,npce3,tx,ty,a,*100)
      if(car.eq.'=') call upcincm_(x,y,cxega1,cyega1,nega1,tx,ty,a,*130)
  130 if(car.eq.'=') call upcincm_(x,y,cxega2,cyega2,nega2,tx,ty,a,*100)
      if(car.eq.',') call upcincm_(x,y,cxvirg,cyvirg,nvirg,tx,ty,a,*100)
      if(car.eq.';') call upcincm_(x,y,cxpvi1,cypvi1,npvi1,tx,ty,a,*140)
  140 if(car.eq.';') call upcincm_(x,y,cxpvi2,cypvi2,npvi2,tx,ty,a,*100)
c
c
      if(car.eq.'a') call upcincm_(x,y,cxa ,cya ,na ,tx,ty,a,*100)
      if(car.eq.'b') call upcincm_(x,y,cxb ,cyb ,nb ,tx,ty,a,*100)
      if(car.eq.'c') call upcincm_(x,y,cxc ,cyc ,nc ,tx,ty,a,*100)
      if(car.eq.'d') call upcincm_(x,y,cxd ,cyd ,nd ,tx,ty,a,*100)
      if(car.eq.'e') call upcincm_(x,y,cxe ,cye ,ne ,tx,ty,a,*100)
      if(car.eq.'f') call upcincm_(x,y,cxf ,cyf ,nf ,tx,ty,a,*100)
      if(car.eq.'g') call upcincm_(x,y,cxg ,cyg ,ng ,tx,ty,a,*100)
      if(car.eq.'h') call upcincm_(x,y,cxh ,cyh ,nh ,tx,ty,a,*100)
      if(car.eq.'i') call upcincm_(x,y,cxi1,cyi1,ni1,tx,ty,a,*150)
  150 if(car.eq.'i') call upcincm_(x,y,cxi2,cyi2,ni2,tx,ty,a,*100)
      if(car.eq.'j') call upcincm_(x,y,cxj1,cyj1,nj1,tx,ty,a,*160)
  160 if(car.eq.'j') call upcincm_(x,y,cxj2,cyj2,nj2,tx,ty,a,*100)
      if(car.eq.'k') call upcincm_(x,y,cxk ,cyk ,nk, tx,ty,a,*100)
      if(car.eq.'l') call upcincm_(x,y,cxl ,cyl ,nl, tx,ty,a,*100)
      if(car.eq.'m') call upcincm_(x,y,cxm ,cym ,nm, tx,ty,a,*100)
      if(car.eq.'n') call upcincm_(x,y,cxn ,cyn ,nn, tx,ty,a,*100)
      if(car.eq.'o') call upcincm_(x,y,cxo ,cyo ,no, tx,ty,a,*100)
      if(car.eq.'p') call upcincm_(x,y,cxp ,cyp ,np, tx,ty,a,*100)
      if(car.eq.'q') call upcincm_(x,y,cxq ,cyq ,nq, tx,ty,a,*100)
      if(car.eq.'r') call upcincm_(x,y,cxr ,cyr ,nr, tx,ty,a,*100)
      if(car.eq.'s') call upcincm_(x,y,cxs ,cys ,ns, tx,ty,a,*100)
      if(car.eq.'t') call upcincm_(x,y,cxt ,cyt ,nt, tx,ty,a,*100)
      if(car.eq.'u') call upcincm_(x,y,cxu ,cyu ,nu, tx,ty,a,*100)
      if(car.eq.'v') call upcincm_(x,y,cxv ,cyv ,nv, tx,ty,a,*100)
      if(car.eq.'w') call upcincm_(x,y,cxw ,cyw ,nw, tx,ty,a,*100)
      if(car.eq.'x') call upcincm_(x,y,cxx ,cyx ,nx, tx,ty,a,*100)
      if(car.eq.'y') call upcincm_(x,y,cxy ,cyy ,ny, tx,ty,a,*100)
      if(car.eq.'z') call upcincm_(x,y,cxz ,cyz ,nz, tx,ty,a,*100)
c
c
  100 return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine upcincm_(x,y,ix,iy,in,rmx,rmy,a,*)
c
c     ---------------------------------------------------------------+--
c *   Object : u_plot_curve_in_cm. from x-y origin, used by upchael_
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      dimension ix(in),iy(in)
c
c *** trace une courbe en cm, origine x,y facteur ech rmx,rmy
c     avec rotation d'angle a et return sur une etiquette
c
c
      cx=x+float(ix(1))*rmx
      cy=y+float(iy(1))*rmy
c
      call cplarot_(x,y,a,cx,cy,gx,gy)
      call dpagppo_(gx,gy)
c
      do 20 i=2,in
      cx=x+float(ix(i))*rmx
      cy=y+float(iy(i))*rmy
      call cplarot_(x,y,a,cx,cy,gx,gy)
      call ppagpmo_(gx,gy)
   20 continue
c
      return 1
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine uperror_(com)
c
c     ---------------------------------------------------------------+--
c *   Object : u_print_error stop the run and print diagnostics
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) com
c
c
      print 100
      print 200
      print 100, 'ROGRALIB: ERROR !!!'
      print 100
      print 100, com
      print 100
      print 100, 'premature close of grafical file'
      print 100, 'premature end of main program'
      print 200
      print 100
c
      call sdr_dclogra
c
  100 format(1x,a)
  200 format(1x,78('*'))
c
      stop 'error ROGRALIB - see outpout'
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine upwarni_(com)
c
c     ---------------------------------------------------------------+--
c *   Object : u_print_warni  may be preceding uperror
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) com
c
c
      print 100
      print 100, 'ROGRALIB: *** WARNING ',com
c
  100 format(1x,2a)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine urinbel_
c
      character*1 bell
c
c     ------------------------------------------------------------------
c *   Object : u_ring_bell by printing 'OO7' character
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ------------------------------------------------------------------
c
      data bell/''/
      save bell
c
c     bell='007' en octal
c
      print *,bell
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine uverfor_(format,com)
c
c     ---------------------------------------------------------------+--
c *   Object : u_verify_format and stop run and print com if not valid
c *   Class  : utility modules of Rogralib Software
c *   Author : P. Robert, PatCie, 1992
c     ---------------------------------------------------------------+--
c
      character*(*) format,com
      character*80  com2
c
c *** verifi la validite d'un format
c
c
      call cchalen_(format,l)
      call cchalen_(com,ncom)
c
      if(l.lt.4) then
                 com2='uverfor_'//com(1:ncom)
     &                          //': format inferieur a 4 caracteres'
                 call uperror_(com2)
                 endif
c
      if(format(1:1).ne.'(') then
                 com2='uverfor_'//com(1:ncom)
     &                          //': le format ne commence pas par ('
                 call uperror_(com2)
                 endif
c
      if(format(l:l).ne.')') then
                 com2='uverfor_'//com(1:ncom)
     &                          //': le format ne se termine pas par )'
                 call uperror_(com2)
                 endif
c
      if(format(2:2).ne.'i'.and.
     &   format(2:2).ne.'I'.and.
     &   format(2:2).ne.'f'.and.
     &   format(2:2).ne.'F'.and.
     &   format(2:2).ne.'e'.and.
     &   format(2:2).ne.'E') then
                 com2='uverfor_'//com(1:ncom)
     &                      //': format type i,f,e ou I,F,E seulement'
                 call uperror_(com2)
                 endif
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
