subroutine initps(i,hx,hy,angle,nomprog,longprog,nomps,lonps,icol)
      INCLUDE 'Parametres.f'
      real xpapier,ypapier
ccc      parameter (ptcm=28.3464566929134,pi= 3.141592653589793)
      parameter (ptcm=0.0283464566929134,pi= 3.141592653589793)
c---------- taille du papier standart ------------- 
      parameter (xpapier=21000.,ypapier=29700.)
c--------------------------------------------------
      integer llx,lly,urx,ury
      real hx,hy,angle
      character strng*255,kinfo*80,nomprog*80,nomps*80,bibi*80
      character*3 cc
      logical*4   la
c
    1 format(a)
c
      facteur_en_x_sauve = facteur_en_x
      facteur_en_y_sauve = facteur_en_y
      origine_x_sauve = origine_x
      origine_y_sauve = origine_y
      if (lonps.le.0) then
        ilaser_file = i
        if (icol.eq.0) then
          lpr = longprog
          strng(1:lpr) = nomprog(1:longprog)
        else
          lpr = longprog+3
          if (nomprog(longprog-2:longprog).eq.'tex') then
            strng(1:lpr) = nomprog(1:longprog-3)//'coltex'
          else
            strng(1:lpr) = nomprog(1:longprog)//'col'
          endif
        endif
      elseif(lonps.eq.1.and.nomps(1:1).eq.'-') then
        ilaser_file = 6
      else
        ilaser_file = i
      endif
      j = ilaser_file
      if (j.eq.6) goto 200
      ifich_laser = 1
 100  if (lonps.le.0) then
        if (ifich_laser.lt.100) then
          write(cc,'(i2.2)') ifich_laser
          ll = 2
        else
          write(cc,'(i3)') ifich_laser
          ll = 3
        endif
        nomfichpost = strng(1:lpr)//cc(1:ll)//'.ps'
        lonfichpost = lpr+ll+3
      else
        nomfichpost = nomps(1:lonps)
        lonfichpost = lonps
      endif
      inquire(file=nomfichpost(1:lonfichpost),exist=la)
      if (la) then
        ifich_laser = ifich_laser+1
        if (ifich_laser.ge.1000.or.lonps.gt.0) then
          if (albion) then
            print*,'*** Warning. File "'
     &            //nomfichpost(1:lonfichpost)//'" will be deleted'
          else
            print*,'*** Attention, on écrase le fichier "'
     &            //nomfichpost(1:lonfichpost)//'"'
          endif
          open(ilaser_file,file=nomfichpost(1:lonfichpost),iostat=ierr)
          if (ierr.ne.0) then
            call getenvc('PWD'//CHAR(0),strng,LEN(strng),IBID)
            call enleve_tous_blancs(strng,l,255)
            if (albion) then
              print*,'***** ERROR ******'
              print*,
     &             '***** You have no permission to write on directory:'
              print*,'***** '//strng(1:l)
              print*,'***** PostScript generation cancelled'
            else
              print*,'***** ERREUR ******'
              print*,
     &             '***** Pas de droits en écriture sur le directory :'
              print*,'***** '//strng(1:l)
              print*,'***** Abandon de la sauvegarde PostScript'
            endif
            lonps = -1
            return
          endif
        else
          goto 100
        endif
      else
        open (i,file=nomfichpost(1:lonfichpost),iostat=ierr)
        if (ierr.ne.0) then
          call getenvc('PWD'//CHAR(0),strng,LEN(strng),IBID)
          call enleve_tous_blancs(strng,l,255)
          if (albion) then
            print*,'***** ERROR ******'
            print*,'***** You have no permission to write on directory:'
            print*,'***** '//strng(1:l)
            print*,'***** PostScript generation cancelled'
          else
            print*,'***** ERREUR ******'
            print*,'***** Pas de droits en écriture sur le directory :'
            print*,'***** '//strng(1:l)
            print*,'***** Abandon de la sauvegarde PostScript'
          endif
          lonps = -1
          return
        endif
      endif
      if (lonps.le.0) then
        nomps = nomfichpost(1:lonfichpost)
        lonps = lonfichpost
      endif
c
CC_SA      write(j,1) '%!PS-Adobe-3.0 EPSF-3.0'
 200  write(j,1) '%!PS-Adobe-2.0'
      strng = ' '
      strng = KINFO('UTILISATEUR')
      write(j,1)'%%Creator: '//nomprogramme(1:lprog)//
     &' (Francois.Jouve@polytechnique.fr)'
CC     &' -- Francois JOUVE (Francois.Jouve@polytechnique.fr)'
      call enleve_tous_blancs(strng,llll,80)
      write(j,1)'%%For: ('//strng(1:llll)//')'
      strng=' '
      strng = KINFO('DATE')
C
C Y2K
C
      write(j,1)
     &'%%CreationDate: 20'//strng(1:2)//':'//strng(3:4)//':'//strng(5:6)
      write(j,1)'%%Pages: (atend)'
      if (hx.gt.0.) then
        xlx = (hx*abs(cos(angle*pi/180.)) + hy*abs(sin(angle*pi/180.)))
        xly = (hx*abs(sin(angle*pi/180.)) + hy*abs(cos(angle*pi/180.)))
        llx = nint(ptcm*(xpapier - xlx*1000.)*.5)
        lly = nint(ptcm*(ypapier - xly*1000.)*.5)
        urx = nint(ptcm*(xpapier + xlx*1000.)*.5)
        ury = nint(ptcm*(ypapier + xly*1000.)*.5)
        write(j,'(a,1x,4i8)') '%%BoundingBox:',llx,lly,urx,ury
      endif
      write(j,1) '%'
      if (albion) then
        write(j,1) '%% Misclaneous informations -----------------------'
        write(j,1) '%> '//nomprogramme(1:lprog)//
     &' (Francois.Jouve@polytechnique.fr)'
        if (j.eq.6) then
          write(j,1) '%> Initial file name      : <stdout>'
        else
          write(j,1) '%> Initial file name      : '//nomps(1:lonps)
        endif
      else
        write(j,1) '%% Informations diverses --------------------------'
        write(j,1) '%> '//nomprogramme(1:lprog)//
     &' (Francois.Jouve@polytechnique.fr)'
        if (j.eq.6) then
          write(j,1) '%> Nom de fichier initial : <stdout>'
        else
          write(j,1) '%> Nom de fichier initial : '//nomps(1:lonps)
        endif
      endif
      strng=' '
      call getenvc('HOST'//CHAR(0),strng,LEN(strng),IBID)
      call enleve_tous_blancs(strng,l,80)
      bibi(1:l+2) = strng(1:l)//' ('
      strng=' '
      call getenvc('HOSTTYPE'//CHAR(0),strng,LEN(strng),IBID)
      call enleve_tous_blancs(strng,ll,80)
      bibi(l+3:l+ll+4) = strng(1:ll)//')'
      if (albion) then
        write(j,1) '%> Created on             : '//bibi(1:l+ll+4)
      else
        write(j,1) '%> Machine de creation    : '//bibi(1:l+ll+4)
      endif
      strng=' '
      call getenvc('PWD'//CHAR(0),strng,LEN(strng),IBID)
      call enleve_tous_blancs(strng,l,80)
      write(j,1) '%> pwd = '//strng(1:l)
      end