File: r3dtops.f

package info (click to toggle)
raster3d 3.0-3-2
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 4,916 kB
  • ctags: 1,557
  • sloc: fortran: 9,536; ansic: 1,060; makefile: 318; sh: 250; csh: 15
file content (621 lines) | stat: -rw-r--r-- 20,009 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
*******************************************************************************
*               Support routines for PostScript labels                        *
*******************************************************************************
*     Version 3.0
*
* EAM Dec 1996	- Initial version (called labels3d, later changed)
* EAM May 1999	- Updated to match V 2.4j as stand-alone program
* EAM Nov 1999	- V2.5 called from render.f as part of normal processing
* EAM Feb 2000	- iso-8859-1 encodings for �
*		  TeX-like syntax for greek, superscript, subscript
*		  sub- and super- scripts use 0.8 * current font size
* EAM Sep 2000	- tweak RED values in work-around for ImageMagick bug
* EAM Jun 2001	- Tru64 f90 compiler barfs on '\\' as meaning a single \
*		  re-work pathway through ghostscript + ImageMagick 5.3.2
* EAM Apr 2006	- Tweak for gfortran compatibility
* EAM Dec 2010	- Label support is moving to libgd, with default lflag = TRUE
*******************************************************************************
*
* These routines are called from render.f to handle object types 10, 11 and 12.
* The PostScript file describes a canvas with the same dimension in pixels as
* the image created by render.  The PostScript canvas can be composited on top
* of the rendered image to produce a labeled figure.
*
*	Object types 10 and 11 are used for specifying labels.
*	Label object types are
*	  - type 10: Font_Name size alignment
*	  - type 11: XYZ RGB on first line
*		     label (ascii characters enclosed in quotes) on second line
*	Object type 12 is reserved to go with this, as I have a nagging
*	suspicion more information may turn out to be necessary.
*
*******************************************************************************
      SUBROUTINE LOPEN( FILENAME )
*
      IMPLICIT NONE
      REAL     PSCALE
      REAL     BKGND(3)
      CHARACTER*132 FILENAME
      CHARACTER*80 TITLE
*
      INCLUDE 'VERSION.incl'
*
      INTEGER  I, J, LEN, IBEG
      INTEGER  INPUT, INTYPE, KEEP
      LOGICAL  MATCOL
      REAL     RGBMAT(3)
      CHARACTER*1 BACKSLASH
*
*     Input transformation
      COMMON /MATRICES/ XCENT, YCENT, SCALE, EYEPOS, SXCENT, SYCENT,
     &                  TMAT, TINV, TINVT, SROT, SRTINV, SRTINVT
      REAL   XCENT, YCENT, SCALE, SXCENT, SYCENT
*     Transformation matrix, inverse, and transposed inverse
      REAL   TMAT(4,4), TINV(4,4), TINVT(4,4)
*     Shortest rotation from light source to +z axis
      REAL   SROT(4,4), SRTINV(4,4), SRTINVT(4,4)
*     Distance (in +z) of viewing eye
      REAL   EYEPOS
*
      EXTERNAL PERSP
      REAL     PERSP, PFAC
*
      COMMON /NICETIES/ TRULIM,      ZLIM,    FRONTCLIP, BACKCLIP
     &                , ISOLATION
      REAL              TRULIM(3,2), ZLIM(2), FRONTCLIP, BACKCLIP
      INTEGER           ISOLATION
*
*     Command line options
      COMMON /OPTIONS/ FONTSCALE, GAMMA, ZOOM, NSCHEME, SHADOWFLAG, XBG,
     &                 NAX, NAY, OTMODE, QUALITY, INVERT, LFLAG
      REAL             FONTSCALE, GAMMA, ZOOM
      INTEGER          NSCHEME, SHADOWFLAG, XBG
      INTEGER*4        NAX, NAY, OTMODE, QUALITY
      LOGICAL*2        INVERT, LFLAG
*
*     Stuff for labels
      COMMON /LABELS/ LB
      INTEGER         LB

      CHARACTER*80  FONTNAME, FONTALIGN
      CHARACTER*128 LABELSTRING
      INTEGER       MAXLABLEN
      PARAMETER    (MAXLABLEN = 128)
      CHARACTER*1   LTEX,TEXSTRING
      EXTERNAL      LTEX
      INTEGER      LEVEL
      REAL         SSSIZE
      INTEGER      IALIGN
      SAVE         IALIGN
      INTEGER      FONT, LABEL
      PARAMETER   (FONT = 10, LABEL = 11)
      REAL         XA, YA, ZA, RED, GRN, BLU
      REAL         FONTSIZE
      SAVE         FONTSIZE
      REAL         PSSCALE
      SAVE         PSSCALE
*
*     Copy of NOISE for ASSERT to see
      COMMON /ASSCOM/ NOISE, VERBOSE
      INTEGER NOISE
      LOGICAL VERBOSE
*
*     Initial entry
*     Open file for PostScript output
*
      LEN = LEN_TRIM(FILENAME)
      OPEN( UNIT=LB, FILE=FILENAME(1:LEN), STATUS='UNKNOWN', ERR=99)
      WRITE (NOISE,*) 'Writing PostScript labels to file ',
     &                FILENAME(1:LEN),' with scale',FONTSCALE
      RETURN
   99 CONTINUE
      WRITE (NOISE,100) FILENAME(1:LEN)
  100 FORMAT('>>> Cannot open ',A,' for writing labels')
      CALL EXIT(-1)
*
*     Don't write PostScript header until we've read R3D header
*
      ENTRY LSETUP( PSCALE, BKGND, TITLE )
	PSSCALE = PSCALE
*     The libgd-based label code calls lsetup() regardless of LFLAG
	if (.NOT.LFLAG) RETURN
*     For some reason ImageMagick messes up image composition if the
*     background is pure white or pure black. 
*     Work-around is to tweak the background. (Abandoned this idea for 2.6)
COLD	if (bkgnd(1).eq.1.0) bkgnd(1) = 0.9900
COLD	if (bkgnd(1).eq.0.0) bkgnd(1) = 0.0001
	RED = sqrt( bkgnd(1) )
	GRN = sqrt( bkgnd(2) )
	BLU = sqrt( bkgnd(3) )
*
c
c     Write out PostScript prolog records
c	To be minimally-conforming, there should also be a 
c	%%DocumentFonts: (atend)
c	record and record-keeping of all fonts used.
c
6     FORMAT(A,1X,A)
600   FORMAT(A,1X,A,1X,A)
601   FORMAT(A,I6,A)
602   FORMAT(A,2I6,A)
603   FORMAT(A,F6.3,A)
604   FORMAT(3F6.3,A)
605   FORMAT('/',A,' findfont',F6.2,' FontScale setfont')
606   FORMAT('/CurrentFont /',A,' def /CurrentSize ',F6.2,' def ',A)
607   FORMAT((A))

      WRITE(LB,600) '%!PS-Adobe-3.0 EPSF-3.0'
      WRITE(LB,600) '%%Creator: Raster3D',VERSION,'rendering program'
      WRITE(LB,600) '%%Title:',TITLE
      WRITE(LB,600) '%%Pages: 1'
      WRITE(LB,602) '%%BoundingBox: 0 0',nax,nay
      WRITE(LB,600) '%%DocumentFonts: (atend)'
      WRITE(LB,600) '%%EndComments'
      WRITE(LB,600) '%%BeginProlog'
      WRITE(LB,600) '% These are the only control parameters'
      WRITE(LB,603) '/FontSize ',FONTSCALE,' def'
      WRITE(LB,601) '/UnitHeight ',nay/2,' def'
      WRITE(LB,601) '/UnitWidth  ',nax/2,' def'
      WRITE(LB,607) '% ',
     & '% This should be dynamic, but how???',
     & '/FontHeight 30 def',
     & '/FontWidth  30 def',
     & '% ',
     & '/FontScale { FontSize mul scalefont } bind def',
     & '/Center {',
     & ' dup stringwidth exch -2 div exch -2 div rmoveto',
     & ' } bind def',
     & '/Right {',
     & ' dup stringwidth exch -1 mul exch -1 mul rmoveto',
     & ' } bind def',
     & '/Skip { stringwidth 1.1 mul rmoveto } bind def',
     & '/ShrinkFont {',
     & '  CurrentFont findfont CurrentSize 0.8 mul FontScale setfont',
     & ' } bind def',
     & '/RestoreFont {',
     & '  CurrentFont findfont CurrentSize FontScale setfont',
     & ' } bind def',
     & '/XYZmove { pop moveto } bind def',
     & '/XYZrmove { pop rmoveto } bind def'
      WRITE(LB,607) '/SetBackground { '
      WRITE (LB,604) RED,GRN,BLU,' setrgbcolor'
      WRITE(LB,607) ' } bind def'

c
c This is one way to do it
c
c     WRITE(LB,607)
c    &      '%',
c    &      '% Add Angstrom sign to commonly used fonts',
c    &      '% using iso-8859-1 encoding (� = 197,  305 octal)',
c    &      '%',
c    &      '/reencsmalldict 12 dict def',
c    &      '/ReEncodeSmall',
c    &      '  { reencsmalldict begin',
c    &      '    /newcodesandnames exch def ',
c    &      '    /newfontname exch def',
c    &      '    /basefontname exch def ',
c    &      '    /basefontdict basefontname findfont def',
c    &      '    /newfont basefontdict maxlength dict def',
c    &      '    basefontdict',
c    &      '      { exch dup /FID ne',
c    &      '	{ dup /Encoding eq',
c    &      '	  { exch dup length array copy newfont 3 1 roll put }',
c    &      '	  { exch newfont 3 1 roll put }',
c    &      '	  ifelse',
c    &      '        }',
c    &      '        { pop pop }',
c    &      '        ifelse',
c    &      '      } forall',
c    &      '    newfont /FontName newfontname put',
c    &      '    newcodesandnames aload pop',
c    &      '    newcodesandnames length 2 idiv',
c    &      '      { newfont /Encoding get 3 1 roll put }',
c    &      '      repeat',
c    &      '    newfontname newfont definefont pop',
c    &      '    end',
c    &      '  } def',
c    &      '/symbvec [',
c    &      '  8#305 /Aring',
c    &      '  ] def',
c    &      '/AddSymbs { dup symbvec ReEncodeSmall } def',
c    &      '/Times-Roman AddSymbs',
c    &      '/Times-Bold AddSymbs',
c    &      '/Times-Italic AddSymbs',
c    &      '/Times-BoldItalic AddSymbs',
c    &      '/Helvetica AddSymbs',
c    &      '/Helvetica-Bold AddSymbs',
c    &      '/Helvetica-Narrow AddSymbs',
c    &      '/Helvetica-Narrow-Bold AddSymbs',
c    &      '% End re-encoding'
c
c This is another way to do it
c
      WRITE(LB,607)
     &      '%',
     &      '% Switch common fonts to iso-8859-1 encoding',
     &      '%',
     &      '/Latin1 {',
     &      '  findfont dup length dict begin',
     &      '    {1 index /FID ne {def} {pop pop} ifelse} forall',
     &      '    /Encoding ISOLatin1Encoding def',
     &      '    currentdict',
     &      '  end',
     &      '} def',
     &      '/Times-Roman           dup Latin1 definefont pop',
     &      '/Times-Bold            dup Latin1 definefont pop',
     &      '/Times-Italic          dup Latin1 definefont pop',
     &      '/Times-BoldItalic      dup Latin1 definefont pop',
     &      '/Helvetica             dup Latin1 definefont pop',
     &      '/Helvetica-Bold        dup Latin1 definefont pop',
     &      '/Helvetica-Narrow      dup Latin1 definefont pop',
     &      '/Helvetica-Narrow-Bold dup Latin1 definefont pop',
     &      '/Helvetica-Oblique     dup Latin1 definefont pop',
     &      '/Helvetica-BoldOblique dup Latin1 definefont pop',
     &      '% End Re-encoding','%'
c
c
      WRITE(LB,600) '%%EndProlog'
      WRITE(LB,600) '%%BeginSetup'
      WRITE(LB,600) 'gsave'
      WRITE(LB,600) 'UnitWidth UnitHeight translate'
      WRITE(LB,600) 'SetBackground'
      WRITE(LB,600) 
     &	'UnitWidth -1 mul dup UnitHeight -1 mul newpath moveto'
      WRITE(LB,600)
     &	'UnitWidth UnitHeight -1 mul lineto UnitWidth UnitHeight lineto'
      WRITE(LB,600) 'UnitHeight lineto closepath fill'
      WRITE(LB,606) 'Times-Bold',10.,'RestoreFont'
      WRITE(LB,600) '/LabelStart gstate def'
      WRITE(LB,600) '%%Endsetup'
      WRITE(LB,600) '%%Page: 1 1'
     
      RETURN


      ENTRY LINP( INPUT, INTYPE, MATCOL, RGBMAT )
c
c     Read in next object
      IF (INTYPE .EQ. FONT) THEN
	READ (INPUT,*,END=50) FONTNAME, FONTSIZE, FONTALIGN
	IF (FONTALIGN(1:1).EQ.'C') THEN
	    IALIGN=1
	ELSE IF (FONTALIGN(1:1).EQ.'R') THEN
	    IALIGN=2
	ELSE IF (FONTALIGN(1:1).EQ.'O') THEN
	    IALIGN=3
	ELSE
	    IALIGN=0
	ENDIF
c
c	Here is where Perl would shine
c
	len = len_trim(fontname)
	WRITE (LB,606) FONTNAME(1:len), FONTSIZE, 'RestoreFont'

      ELSE IF (INTYPE .EQ. LABEL ) THEN
	READ (INPUT,*,END=50) XA, YA, ZA, RED, GRN, BLU
	IF (MATCOL) THEN
	    RED = RGBMAT(1)
	    GRN = RGBMAT(2)
	    BLU = RGBMAT(3)
	ENDIF
c
c	Here is where Perl would shine
c
	READ (INPUT,'(A)',END=50) LABELSTRING
	do j= MAXLABLEN,1,-1
	    len = j
	    if (LABELSTRING(len:len).ne.' ') goto 702
	enddo
702	continue
c
c       Isolated objects not transformed by TMAT, but still subject to inversion.
c       Then again, PostScript y-axis convention is upside-down from screen coords.
        IF (ISOLATION.GT.0) THEN
          IF (.not.INVERT) YA = -YA
	  if (isolation.eq.2) then
	    if (xcent.gt.ycent) xa = xa * xcent / ycent
	    if (xcent.lt.ycent) ya = ya * ycent / xcent
	  endif
        ELSE
c         modify the input, as it were
	  IF (IALIGN.NE.3) THEN
	    CALL TRANSF (XA,YA,ZA, TMAT)
            YA = -YA
	  ENDIF
        ENDIF
c       perspective
        IF (EYEPOS.GT.0) THEN
	    PFAC = PERSP(ZA)
	ELSE
	    PFAC = 1.0
	ENDIF
c
	XA = XA * PFAC * PSSCALE
	YA = YA * PFAC * PSSCALE
	ZA = ZA * PFAC * PSSCALE
c
	IF  (ZA * (SCALE/PSSCALE) .LT. BACKCLIP 
     &  .OR. ZA * (SCALE/PSSCALE) .GT. FRONTCLIP) RETURN
c
	CALL CHKRGB( RED, GRN, BLU, 'invalid label color')
	RED = SQRT(RED)
	GRN = SQRT(GRN)
	BLU = SQRT(BLU)
c
	IF (IALIGN.EQ.3) THEN
	    WRITE (LB,802) RED,GRN,BLU,XA,YA,ZA
	ELSE
	    WRITE (LB,801) RED,GRN,BLU,XA,YA,ZA
	ENDIF
801	FORMAT(3f6.3,' setrgbcolor',3(1x,f10.4),' XYZmove')
802	FORMAT(3f6.3,' setrgbcolor',3(1x,f10.4),' XYZrmove')
c
c	At this point I should loop over string looking for
c	escape sequences, control characters, etc.
c
	WRITE (LB,600) 'LabelStart currentgstate pop'
	LEVEL  = 0
	IBEG = 1
  81	CONTINUE
  	I = IBEG
	IF (I.GT.LEN) RETURN
  82	CONTINUE
c	
c	27-Feb-2000
c	TeX-like escape sequence processing
c	Unfortunately this is not easily made compatible with anything other
c	that Left-Align.
c	Possibly these problems can be fixed by additional PostScript code?
c
	  backslash = '\\'
	  if (labelstring(i:i) .eq. backslash) then
	    j = i
   83	    j = j + 1
   	    if (labelstring(j:j).ge.'A' .and. labelstring(j:j).le.'Z')
     &         goto 83
   	    if (labelstring(j:j).ge.'a' .and. labelstring(j:j).le.'z')
     &         goto 83
	    if (j.gt.i+2 .and. j.le.len+1) then
	      texstring = ltex( labelstring(i+1:j-1) )
	      if (texstring.eq.char(0)) goto 90 
	      if (ibeg.lt.i) 
     &           write(LB,804) labelstring(ibeg:i-1),'show'
     	      sssize = FONTSIZE
	      if (level.ne.0) sssize = sssize * 0.8
	      write(LB,605) 'Symbol',sssize
	      write(LB,804) texstring,'show RestoreFont'
	      if (level.ne.0) write(LB,600)'ShrinkFont'
	      if (labelstring(j:j).eq.' ') j = j + 1
	      ibeg = j
	      goto 81
	    endif
	  endif

	  if (labelstring(i:i) .eq. '_') then
	    if (ibeg.lt.i) 
     &         write(LB,804) labelstring(ibeg:i-1),'show'
	    write(LB,600) '0 FontHeight -0.3 mul rmoveto'
	    write(LB,600) 'ShrinkFont'
	    i = i + 1
	    if (labelstring(i:i) .eq. '{') then
	      level = -1
	      ibeg = i + 1
	      goto 81
	    else
	      if (labelstring(i:i).eq.backslash) labelstring(i:i)='^'
	      write(LB,804) labelstring(i:i),'show'
	      write(LB,600) 'RestoreFont'
	      write(LB,600) '0 FontHeight 0.3 mul rmoveto'
	      ibeg = i + 1
	      goto 81
	    endif
	  endif

	  if (labelstring(i:i) .eq. '^') then
	    if (ibeg.lt.i) 
     &         write(LB,804) labelstring(ibeg:i-1),'show'
	    write(LB,600) '0 FontHeight 0.3 mul rmoveto'
	    write(LB,600) 'ShrinkFont'
	    i = i + 1
	    if (labelstring(i:i) .eq. '{') then
	      level = 1
	      ibeg = i + 1
	      goto 81
	    else
	      if (labelstring(i:i).eq.backslash) labelstring(i:i)='^'
	      write(LB,804) labelstring(i:i),'show'
	      write(LB,600) 'RestoreFont'
	      write(LB,600) '0 FontHeight -0.3 mul rmoveto'
	      ibeg = i + 1
	      goto 81
	    endif
	  endif

	  if (labelstring(i:i) .eq. '}') then
	    if (ibeg.lt.i)
     &         write(LB,804) labelstring(ibeg:i-1),'show'
	    write(LB,600) 'RestoreFont'
	    write(LB,603) '0 FontHeight ',-0.3*level,'  mul rmoveto'
	    level = 0
	    ibeg = i + 1
	    goto 81
	  endif
c
c	End of TeX-like escape processing
c
   90	CONTINUE
	  IF  ( LABELSTRING(I:I)    .EQ.backslash
     &    .AND. LABELSTRING(I+1:I+1).EQ.'n') THEN
	    IF (IBEG.LT.I) THEN
	      IF (IALIGN.EQ.1) THEN
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),'Center'
	      ELSE IF (IALIGN.EQ.2) THEN
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),'Right'
	      ELSE
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),' '
	      ENDIF
	    ENDIF
	    WRITE(LB,600) 'LabelStart setgstate',
     &                    '0 FontHeight -1 mul rmoveto',
     &	                  'LabelStart currentgstate pop'
	    IBEG = I+2
	    GOTO 81
	  ENDIF
	  IF  ( LABELSTRING(I:I)    .EQ.backslash
     &    .AND. LABELSTRING(I+1:I+1).EQ.'v') THEN
	    IF (IBEG.LT.I) THEN
	      IF (IALIGN.EQ.1) THEN
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),'Center'
	      ELSE IF (IALIGN.EQ.2) THEN
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),'Right'
	      ELSE
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),' '
	      ENDIF
	    ENDIF
	    WRITE(LB,600) '0 FontHeight 0.5 mul rmoveto'
	    IBEG = I+2
	    GOTO 81
	  ENDIF
	  IF  ( LABELSTRING(I:I)    .EQ.backslash
     &    .AND. LABELSTRING(I+1:I+1).EQ.'b') THEN
	    IF (IBEG.LT.I) THEN
	      IF (IALIGN.EQ.1) THEN
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),'Center'
	      ELSE IF (IALIGN.EQ.2) THEN
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),'Right'
	      ELSE
	        WRITE (LB,803) LABELSTRING(IBEG:I-1),' '
	      ENDIF
	    ENDIF
	    WRITE(LB,600) 'FontWidth -0.5 mul 0 rmoveto'
	    IBEG = I+2
	    GOTO 81
	  ENDIF
	  IF  ( LABELSTRING(I:I)    .EQ.backslash
     &    .AND. LABELSTRING(I+1:I+1).EQ.'A') THEN
     	    LABELSTRING(I+1:I+1) = CHAR(197)
     	  ENDIF
	I = I + 1
	IF (I.LE.LEN) GOTO 82
c
c	End proposed escape interpretation loop
c
	IF (IALIGN.EQ.1) THEN
	    WRITE (LB,803) LABELSTRING(IBEG:LEN),'Center'
	ELSE IF (IALIGN.EQ.2) THEN
	    WRITE (LB,803) LABELSTRING(IBEG:LEN),'Right'
	ELSE
	    WRITE (LB,803) LABELSTRING(IBEG:LEN),' '
	ENDIF
803	FORMAT('(',A,') ',A6,'  show')
804	FORMAT('(',A,') ',A)
      ENDIF
      
      RETURN

c
c Error handling
c
 50	WRITE (NOISE,*) '>>> Unrecognized label command'
 	RETURN



c
c All done, finish off PostScript file and report success
c
      ENTRY LCLOSE( KEEP )
c
c     Make 100% sure that pixel[0,0] is background color so that
c     it can be used for auto-definition of matte
      WRITE (LB,600) '%Force pixel [0,0] to background color'
      WRITE (LB,600) 'SetBackground'
      WRITE (LB,600) 'newpath UnitWidth -1 mul UnitHeight moveto'
      WRITE (LB,600) '1 0 rlineto 0 -1 rlineto -1 0 rlineto',
     &               'closepath fill'
c
c     Finish off PostScript output
      WRITE (LB,600) '%'
      WRITE (LB,600) 'showpage'
      WRITE (LB,600) '%%Trailer'
      WRITE (LB,600) '%%DocumentFonts: Times-Bold'
      WRITE (LB,600) '%%EOF'

      IF (KEEP.GT.0) THEN
          CLOSE (UNIT=LB)
      ELSE
          CLOSE (UNIT=LB,STATUS='DELETE')
      ENDIF
*
      end

C
C     Map TeX escape sequences to the corresponding character in the
C     standard PostScript SYmbol font.
C     Most greek letters map to their own first letter, so we don't
C     need to explicitly search for them.
C     We explicitly map \nu to distinguish it from \n = newline,
C     and \beta to distinguish it from \b = backspace. 
C
      function ltex( symbolstring )
      character*1 ltex
      character*(*) symbolstring
      ltex = symbolstring(1:1)
c
      if (ltex.eq.'b') ltex = char(0)
      if (ltex.eq.'n') ltex = char(0)
      if (ltex.eq.'v') ltex = char(0)
c
      if (symbolstring.eq.'beta') then 
          ltex = 'b'
      else if (symbolstring.eq.'eta') then
          ltex = 'h'
      else if (symbolstring.eq.'nu') then
          ltex = 'n'
      else if (symbolstring.eq.'theta') then
          ltex = 'q'
      else if (symbolstring.eq.'phi') then
          ltex = 'j'
      else if (symbolstring.eq.'psi') then
          ltex = 'y'
      else if (symbolstring.eq.'omega') then
          ltex = 'w'
      else if (symbolstring.eq.'Eta') then 
          ltex = 'H'
      else if (symbolstring.eq.'Theta') then
          ltex = 'Q'
      else if (symbolstring.eq.'Phi') then
          ltex = 'F'
      else if (symbolstring.eq.'Psi') then
          ltex = 'Y'
      else if (symbolstring.eq.'Omega') then
          ltex = 'W'
      else if (symbolstring.eq.'infty') then
          ltex = char(165)
C         ltex = '�'
      else if (symbolstring.eq.'nabla') then
          ltex = char(165)
C         ltex = '�'
      else if (symbolstring.eq.'ellipses') then
          ltex = char(188)
C         ltex = '�'
      else if (symbolstring.eq.'partial') then
          ltex = char(182)
C         ltex = '�'
      else if (symbolstring.eq.'degree') then
          ltex = char(176)
C         ltex = '�'
      else if (symbolstring.eq.'func') then
          ltex = char(166)
C         ltex = '�'
      else if (symbolstring.eq.'sqrt') then
          ltex = char(214)
C         ltex = '�'
      else if (symbolstring.eq.'aleph') then
          ltex = char(192)
C         ltex = '�'
      endif
      return
      end