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