1      subroutine initps(i,hx,hy,angle,nomprog,longprog,nomps,lonps,icol)
2      INCLUDE 'Parametres.f'
3      real xpapier,ypapier
4ccc      parameter (ptcm=28.3464566929134,pi= 3.141592653589793)
5      parameter (ptcm=0.0283464566929134,pi= 3.141592653589793)
6c---------- taille du papier standart -------------
7      parameter (xpapier=21000.,ypapier=29700.)
8c--------------------------------------------------
9      integer llx,lly,urx,ury
10      real hx,hy,angle
11      character strng*255,kinfo*80,nomprog*80,nomps*80,bibi*80
12      character*3 cc
13      logical*4   la
14c
15    1 format(a)
16c
17      facteur_en_x_sauve = facteur_en_x
18      facteur_en_y_sauve = facteur_en_y
19      origine_x_sauve = origine_x
20      origine_y_sauve = origine_y
21      if (lonps.le.0) then
22        ilaser_file = i
23        if (icol.eq.0) then
24          lpr = longprog
25          strng(1:lpr) = nomprog(1:longprog)
26        else
27          lpr = longprog+3
28          if (nomprog(longprog-2:longprog).eq.'tex') then
29            strng(1:lpr) = nomprog(1:longprog-3)//'coltex'
30          else
31            strng(1:lpr) = nomprog(1:longprog)//'col'
32          endif
33        endif
34      elseif(lonps.eq.1.and.nomps(1:1).eq.'-') then
35        ilaser_file = 6
36      else
37        ilaser_file = i
38      endif
39      j = ilaser_file
40      if (j.eq.6) goto 200
41      ifich_laser = 1
42 100  if (lonps.le.0) then
43        if (ifich_laser.lt.100) then
44          write(cc,'(i2.2)') ifich_laser
45          ll = 2
46        else
47          write(cc,'(i3)') ifich_laser
48          ll = 3
49        endif
50        nomfichpost = strng(1:lpr)//cc(1:ll)//'.ps'
51        lonfichpost = lpr+ll+3
52      else
53        nomfichpost = nomps(1:lonps)
54        lonfichpost = lonps
55      endif
56      inquire(file=nomfichpost(1:lonfichpost),exist=la)
57      if (la) then
58        ifich_laser = ifich_laser+1
59        if (ifich_laser.ge.1000.or.lonps.gt.0) then
60          if (albion) then
61            print*,'*** Warning. File "'
62     &            //nomfichpost(1:lonfichpost)//'" will be deleted'
63          else
64            print*,'*** Attention, on �crase le fichier "'
65     &            //nomfichpost(1:lonfichpost)//'"'
66          endif
67          open(ilaser_file,file=nomfichpost(1:lonfichpost),iostat=ierr)
68          if (ierr.ne.0) then
69            call getenvc('PWD'//CHAR(0),strng,LEN(strng),IBID)
70            call enleve_tous_blancs(strng,l,255)
71            if (albion) then
72              print*,'***** ERROR ******'
73              print*,
74     &             '***** You have no permission to write on directory:'
75              print*,'***** '//strng(1:l)
76              print*,'***** PostScript generation cancelled'
77            else
78              print*,'***** ERREUR ******'
79              print*,
80     &             '***** Pas de droits en �criture sur le directory :'
81              print*,'***** '//strng(1:l)
82              print*,'***** Abandon de la sauvegarde PostScript'
83            endif
84            lonps = -1
85            return
86          endif
87        else
88          goto 100
89        endif
90      else
91        open (i,file=nomfichpost(1:lonfichpost),iostat=ierr)
92        if (ierr.ne.0) then
93          call getenvc('PWD'//CHAR(0),strng,LEN(strng),IBID)
94          call enleve_tous_blancs(strng,l,255)
95          if (albion) then
96            print*,'***** ERROR ******'
97            print*,'***** You have no permission to write on directory:'
98            print*,'***** '//strng(1:l)
99            print*,'***** PostScript generation cancelled'
100          else
101            print*,'***** ERREUR ******'
102            print*,'***** Pas de droits en �criture sur le directory :'
103            print*,'***** '//strng(1:l)
104            print*,'***** Abandon de la sauvegarde PostScript'
105          endif
106          lonps = -1
107          return
108        endif
109      endif
110      if (lonps.le.0) then
111        nomps = nomfichpost(1:lonfichpost)
112        lonps = lonfichpost
113      endif
114c
115CC_SA      write(j,1) '%!PS-Adobe-3.0 EPSF-3.0'
116 200  write(j,1) '%!PS-Adobe-2.0'
117      strng = ' '
118      strng = KINFO('UTILISATEUR')
119      write(j,1)'%%Creator: '//nomprogramme(1:lprog)//
120     &' (Francois.Jouve@polytechnique.fr)'
121CC     &' -- Francois JOUVE (Francois.Jouve@polytechnique.fr)'
122      call enleve_tous_blancs(strng,llll,80)
123      write(j,1)'%%For: ('//strng(1:llll)//')'
124      strng=' '
125      strng = KINFO('DATE')
126C
127C Y2K
128C
129      write(j,1)
130     &'%%CreationDate: 20'//strng(1:2)//':'//strng(3:4)//':'//strng(5:6)
131      write(j,1)'%%Pages: (atend)'
132      if (hx.gt.0.) then
133        xlx = (hx*abs(cos(angle*pi/180.)) + hy*abs(sin(angle*pi/180.)))
134        xly = (hx*abs(sin(angle*pi/180.)) + hy*abs(cos(angle*pi/180.)))
135        llx = nint(ptcm*(xpapier - xlx*1000.)*.5)
136        lly = nint(ptcm*(ypapier - xly*1000.)*.5)
137        urx = nint(ptcm*(xpapier + xlx*1000.)*.5)
138        ury = nint(ptcm*(ypapier + xly*1000.)*.5)
139        write(j,'(a,1x,4i8)') '%%BoundingBox:',llx,lly,urx,ury
140      endif
141      write(j,1) '%'
142      if (albion) then
143        write(j,1) '%% Misclaneous informations -----------------------'
144        write(j,1) '%> '//nomprogramme(1:lprog)//
145     &' (Francois.Jouve@polytechnique.fr)'
146        if (j.eq.6) then
147          write(j,1) '%> Initial file name      : <stdout>'
148        else
149          write(j,1) '%> Initial file name      : '//nomps(1:lonps)
150        endif
151      else
152        write(j,1) '%% Informations diverses --------------------------'
153        write(j,1) '%> '//nomprogramme(1:lprog)//
154     &' (Francois.Jouve@polytechnique.fr)'
155        if (j.eq.6) then
156          write(j,1) '%> Nom de fichier initial : <stdout>'
157        else
158          write(j,1) '%> Nom de fichier initial : '//nomps(1:lonps)
159        endif
160      endif
161      strng=' '
162      call getenvc('HOST'//CHAR(0),strng,LEN(strng),IBID)
163      call enleve_tous_blancs(strng,l,80)
164      bibi(1:l+2) = strng(1:l)//' ('
165      strng=' '
166      call getenvc('HOSTTYPE'//CHAR(0),strng,LEN(strng),IBID)
167      call enleve_tous_blancs(strng,ll,80)
168      bibi(l+3:l+ll+4) = strng(1:ll)//')'
169      if (albion) then
170        write(j,1) '%> Created on             : '//bibi(1:l+ll+4)
171      else
172        write(j,1) '%> Machine de creation    : '//bibi(1:l+ll+4)
173      endif
174      strng=' '
175      call getenvc('PWD'//CHAR(0),strng,LEN(strng),IBID)
176      call enleve_tous_blancs(strng,l,80)
177      write(j,1) '%> pwd = '//strng(1:l)
178      end
179