Programming samples by Robert Elton Maas <rem@BTR.Com>
Fortran


This the whole file UG370F.FOR:

C Given reference parameter to segment in PSL or elsewhere,
C  establish common variable /PTRS/ PSEG pointing at it.
C Warning, if the segment moves, such as by a garbage collect,
C  this pointer won't be updated, therefore it should be established
C  immediately before its intended use and discarded via CLRSEG
C  immediately afterward rather than left around for awhile.
      SUBROUTINE SETSEG(SEG)
      INTEGER*4 SEG(*)
      COMMON /PTRS/ PSEG,PCOLOR,LCOLOR
      INTEGER*4 PSEG,PCOLOR,LCOLOR
      CALL F4ADR(SEG,PSEG)
      END
C
C Inactivate (clear) the pointer established by SETSEG so that
C  any attempt to use it will generate an error report.
      SUBROUTINE CLRSEG()
      COMMON /PTRS/ PSEG,PCOLOR,LCOLOR
      INTEGER*4 PSEG,PCOLOR,LCOLOR
      PSEG = 0
      END
C
C Given reference parameter to color&option string in PSL or elsewhere,
C  establish common variable /PTRS/ PCOLOR pointing at it and
C  /PTRS/ LCOLOR giving its length (number of characters).
C Warning, if the string moves, such as by a garbage collect,
C  this pointer won't be updated, therefore it should be established
C  immediately before its intended use and discarded via CLRCOL
C  immediately afterward rather than left around for awhile.
      SUBROUTINE SETCOL(COLOR)
      CHARACTER*(*) COLOR
      COMMON /PTRS/ PSEG,PCOLOR,LCOLOR
      INTEGER*4 PSEG,PCOLOR,LCOLOR
      CALL F4ADRL(COLOR,PCOLOR,LCOLOR)
      IF (LCOLOR) 7734,7734,99
   99 RETURN
 7734 CALL UGRERR(3,'SETCOL  ',7734)
      END
C
C Inactivate (clear) the pointer established by SETCOL so that
C  any attempt to use it will generate an error report.
      SUBROUTINE CLRCOL()
      COMMON /PTRS/ PSEG,PCOLOR,LCOLOR
      INTEGER*4 PSEG,PCOLOR,LCOLOR
      PCOLOR = 0
      LCOLOR = 0
      END
C
C COLLIN subroutine used as UGSCIN subroutine argument,
C  i.e. routine to draw teeny segment from old point to
C  current point when BBIT is on.
C This subroutine has different parameters if GENTAN
C  option is used.  This format assumes GENTAN is not used.
C
      SUBROUTINE COLLIN(X,Y,BBIT)
      REAL X,Y
      INTEGER BBIT
C     COMMON /GSEG/ SEG
C     INTEGER*4 SEG(2048)
      COMMON /PTRS/ PSEG,PCOLOR,LCOLOR
      INTEGER*4 PSEG,PCOLOR,LCOLOR
C      pointers to psl-allocated graphics-segment and color-string
      IF (PSEG) 7734,7734,91
   91 IF (PCOLOR) 7734,7734,92
   92 IF (LCOLOR) 7734,7734,93
   93 CALL CCSLIN(X,Y,BBIT,PCOLOR,LCOLOR,PSEG)
      RETURN
 7734 CALL UGRERR(3,'COLLIN  ',7734)
      END
C
C Returns the distance between points (X1,Y1) and (X2,Y2).
C Note if world coords are used you get mathematical distance,
C  whereas if screen coords are used you get screen distance.
      FUNCTION DIST(X1,Y1,X2,Y2)
      REAL X1,X2,Y1,Y2
      REAL DIST
      DIST = SQRT((X1 - X2)**2 + (Y1 - Y2)**2)
      END
C
C W is 2*2 matrix similar to (usually identical to) the WINDOW parameter
C  to UGWDOW, identifying low/hi ranges for X and Y in world coords.
C Plot X axis (Y=0), and Y axis (X=0), scaled correctly to screen.
      SUBROUTINE AXIS(COLOR,W,SEG)
      CHARACTER*(*) COLOR
      REAL*4 W(2,2)
      REAL*4 SEG(2048)
      EXTERNAL COLLIN
      EXTERNAL NULTXT
      REAL*4 LOW,HIGH
      INTEGER I
      CALL SETSEG(SEG)
      CALL SETCOL(COLOR)
C
C Plot the horizontal i.e. X axis first...
C
      I = W(1,1)
      LOW = I
      I = W(1,2)
      HIGH = I
      I =  DIST(W(1,1),0.0,W(1,2),0.0)
      I = I + 1
      CALL UGLNAX(' ',COLLIN,NULTXT,0,LOW,0.0,HIGH,0.0,
     X            LOW,HIGH,I)
C
C Now plot the vertical i.e. Y axis...
C
      I = W(2,1)
      LOW = I
      I = W(2,2)
      HIGH = I
      I =  DIST(0.0,W(2,1),0.0,W(2,2))
      I = I + 1
      CALL UGLNAX(' ',COLLIN,NULTXT,0,0.0,LOW,0.0,HIGH,
     X            LOW,HIGH,I)
C
      CALL CLRSEG()
      CALL CLRCOL()
      RETURN
      END
C
C
C Dummy routine (do nothing) for sake of passing to UGLNAX.
C Setting FLG to 1 is merely to avoid diagnostic compiler message.
      SUBROUTINE NULTXT(X,Y,VAL,FLG)
      REAL X,Y,VAL
      INTEGER FLG
C
      FLG = 1
      RETURN
      END
C
C Subroutine to outline a window. queries UGS for the current size of thOUT00020
C window, so it will work on a window of any size without the necessity OUT00030
C of the calling program knowing the window size.
C
      SUBROUTINE OUTLIN(COLOR,SEG)
      CHARACTER*(*) COLOR
      DIMENSION SEG(*)
      DIMENSION VIEW(2,2),WINDOW(2,2)
      EQUIVALENCE (MINX,WINDOW(1,1)),(MINY,WINDOW(2,1))
      EQUIVALENCE (MAXX,WINDOW(1,2)),(MAXY,WINDOW(2,2))
C
C Get the window size from ugs...
C
      CALL UGWDOW('GET',VIEW,WINDOW)
C
C MOVE TO THE FIRST POINT WITH NO DRAWING, then mark&draw around box... OUT00160
C
      CALL UGLINE(' ',MINX,MINY,0,SEG)
      CALL UGLINE(COLOR,MINX,MAXY,1,SEG)
      CALL UGLINE(COLOR,MAXX,MAXY,1,SEG)
      CALL UGLINE(COLOR,MAXX,MINY,1,SEG)
      CALL UGLINE(COLOR,MINX,MINY,1,SEG)
      END