home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l292 / 1.ddi / WORLDDR.FOR < prev   
Encoding:
Text File  |  1990-05-18  |  40.1 KB  |  1,524 lines
  1.  
  2.       INCLUDE 'FGRAPH.FI'
  3.  
  4.       SUBROUTINE RealToString (r, digits, wid, TheString)
  5.       REAL r, tempr
  6.       CHARACTER * 80 TheString, Result
  7.       INTEGER  exponent, digits, wid, num, position, behind, before
  8.       INTEGER delta, i,j, y, strLen, location
  9.       LOGICAL sign
  10.  
  11.       location = 1
  12.       CALL InitStr(TheString)
  13.       tempr = r * 1.000001
  14.       sign = .FALSE.
  15.       strLen = ABS(REAL(digits)) + 2    !!!  min. 2 characters sign, digit
  16.       IF (digits .NE. 0) strLen = strLen + 1
  17.       IF (digits .LT. 0) strLen = strLen + 4
  18.       IF (tempr .LT. 0)  sign = .TRUE.
  19.       tempr = ABS(tempr)
  20.  
  21.  
  22.       !!!  normalize downward, less than 10
  23.       exponent = 0
  24.       DO WHILE (tempr .GE. 10.0)
  25.        tempr=tempr/ 10.0
  26.         exponent = exponent + 1
  27.       END DO
  28.       IF (digits .GE. 0) THEN
  29.         before = exponent
  30.       ELSE
  31.         before = 0
  32.       END IF
  33.       behind = ABS(digits)
  34.  
  35.       !!!  scientific notation
  36.       IF (digits .LT. 0 .AND. tempr .NE. 0.0) THEN
  37.         DO WHILE (tempr .LT. 1.0 )  !!!  normalize upward, greater than 1
  38.          tempr=tempr* 10.0
  39.           exponent = exponent - 1
  40.         END DO
  41.         IF (tempr .GE. 10.0) THEN  !!!  normalize downward to less than 10
  42.          tempr=tempr/ 10.0
  43.           exponent = exponent + 1
  44.         END IF
  45.       END IF
  46.       !!!  sign
  47.       IF (sign) THEN
  48.         Result(1:1) = '-'
  49.         location = location + 1
  50.       END IF
  51.  
  52.       !!!  Write digits before the decimal-point
  53.       y = AINT(tempr)
  54.       Result(location:location) = CHAR(y+48)
  55.       location = location + 1
  56.       tempr= tempr - REAL(y)
  57.       DO WHILE (before .GT. 0)
  58.         tempr = tempr * 10.0
  59.         y = AINT(tempr)
  60.         Result(location:location) =  CHAR(y+48)
  61.         location = location + 1
  62.         tempr = tempr - y
  63.         before = before - 1
  64.       END DO
  65.       IF (behind .NE. 0) THEN
  66.         Result(location:location) = '.'
  67.         location = location + 1
  68.       END IF
  69.  
  70.       !!!  write digits after the decimal-point
  71.       DO WHILE (behind .GT. 0)
  72.         tempr = tempr * 10.0
  73.         y = AINT(tempr)
  74.         Result(location:location) = CHAR(y + 48)
  75.         location = location + 1
  76.         t = REAL(y)
  77.         tempr = tempr - REAL(y)
  78.         behind = behind - 1
  79.       END DO
  80.  
  81.       !!!  scientific notation: write exponent
  82.       IF (digits .LT. 0) THEN
  83.         Result(location:location) =  'E'
  84.         location = location + 1
  85.         IF (exponent .GE. 0) THEN
  86.           Result(location:location) =  '+'
  87.         ELSE
  88.           Result(location:location) =  '-'
  89.         END IF
  90.         location = location + 1
  91.         num = ABS(exponent)
  92.         IF (num .GE. 10) THEN
  93.           explen = 2
  94.         ELSE
  95.           explen = 1
  96.         END IF
  97.         position = location + explen - 1    !!!  start on the right
  98.  
  99.          DO WHILE (num .NE. 0)
  100.            i = MOD(num, 10)
  101.            Result(position:position) = CHAR(i+48)
  102.            position = position - 1
  103.            num = num / 10
  104.          END DO
  105.          DO WHILE (position .GE. location)
  106.            Result(position:position) = ' '
  107.            position = position - 1
  108.          END DO
  109.          location = location + explen
  110.        END IF
  111.  
  112.     !!!  leading blanks
  113.        location = location - 1
  114.        IF (wid .GT. location) THEN
  115.          delta = wid - location
  116.        ELSE
  117.          delta = 0
  118.        END IF
  119.        DO i = 1, location
  120.             j = i+delta
  121.             TheString(j:j) = Result(i:i)
  122.        END DO
  123.       END !SUBROUTINE
  124.  
  125.  
  126.       SUBROUTINE BarWorld (xx1, yy1, h, w, gc, gh)
  127.       REAL xx1, yy1, h, w
  128.       INCLUDE 'GRAFTYPE.FOR'
  129.       INTEGER gc, gh
  130.       RECORD /WorldRect/ Barrect
  131.  
  132.       CALL setfillstyleXX(gh, gc)
  133.  
  134.       Barrect.left = ConvertX1(xx1)
  135.       Barrect.bottom = ConvertY1(yy1)
  136.       Barrect.right = ConvertX1(xx1 + w)
  137.       Barrect.top = ConvertY1(yy1 + h)
  138.       CALL BarXX(Barrect.left, Barrect.bottom,
  139.      +           Barrect.right, Barrect.top)
  140.  
  141.       END !SUBROUTINE
  142.  
  143.  
  144.  
  145.       SUBROUTINE BarXX (x1, y1, x2, y2)
  146.       REAL x1,y1,x2,y2, vxAbs, vyAbs
  147.       INTEGER x1int, y1int, x2int, y2int, dummy, vx, vy, vh, vl
  148.       LOGICAL CRTGraphOnF, PlotterOnF
  149.       COMMON /PlotVals/ vxAbs, vyAbs
  150.       COMMON /ViewVals/ vx, vy, vh, vl
  151.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  152.  
  153.       INCLUDE 'FGRAPH.FD'
  154.  
  155.       IF (CRTGraphOnF) THEN
  156.           x1int = NINT(x1)
  157.           x2int = NINT(x2)
  158.           y1int = vh - NINT(y1)
  159.           y2int = vh - NINT(y2)
  160.       dummy = rectangle($GBORDER, x1int, y1int, x2int, y2int)
  161.       IF (y1int .NE. y2int )
  162.      +    dummy =  rectangle( $GFILLINTERIOR, x1int,y1int,x2int,y2int)
  163.       END IF
  164.       IF (PlotterOnF) THEN
  165.         CALL PBar(vxAbs + x1, vyAbs + y1, vxAbs + x2, vyAbs + y2)
  166.         CALL PRectangle(vxAbs + x1, vyAbs + y1, vxAbs + x2, vyAbs + y2)
  167.       END IF
  168.       END !SUBROUTINE
  169.  
  170.  
  171.  
  172.       SUBROUTINE BlackAndWhite(BWFlag)
  173.       INCLUDE 'FGRAPH.FD'
  174.       RECORD /videoconfig/ VC
  175.       LOGICAL BWFlag
  176.  
  177.       BWFlag = .FALSE.
  178.       CALL getvideoconfig(VC)
  179.       IF (VC.numcolors .LE. 2) BWFlag= .TRUE.
  180.       END !SUBROUTINE
  181.  
  182.  
  183.  
  184.       INTEGER FUNCTION CheckBit (i, Bit)
  185.       INTEGER i, Bit
  186.       INTEGER CheckBitResult
  187.       INTEGER BitMask(0:8)
  188.       COMMON BitMask
  189.  
  190.       IF ((i .AND. BitMask(Bit)) .EQ. BitMask(Bit)) THEN
  191.          checkBitResult =  1
  192.       ELSE
  193.          checkBitResult  =  0
  194.       END IF
  195.       CheckBit = checkBitResult
  196.  
  197.       END !FUNCTION
  198.  
  199.  
  200.  
  201.       REAL FUNCTION ClampReal (r, l, h)
  202.       REAL r, l, h
  203.       IF (r .LT. l) THEN
  204.          ClampReal = l
  205.       ELSE
  206.         IF (r .GT. h) THEN
  207.           ClampReal = h
  208.         ELSE
  209.           ClampReal = r
  210.         END IF
  211.       END IF
  212.       END !FUNCTION
  213.  
  214.  
  215.  
  216.  
  217.  
  218.       SUBROUTINE ClearViewportXX()
  219.       INCLUDE 'FGRAPH.FD'
  220.       LOGICAL CRTGraphOnF, PlotterOnF
  221.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  222.  
  223.       IF (CRTGraphOnF) CALL clearscreen($GVIEWPORT)
  224.       END !SUBROUTINE
  225.  
  226.  
  227.  
  228.  
  229.       SUBROUTINE ClipOff()
  230.       LOGICAL clipFlag
  231.       INTEGER TubeOn
  232.       COMMON /MiscOnOff/ clipFlag,TubeOn
  233.       clipFlag = .FALSE.
  234.       END !SUBROUTINE
  235.  
  236.  
  237.  
  238.       SUBROUTINE ClipOn()
  239.       LOGICAL clipFlag
  240.       INTEGER TubeOn
  241.       COMMON /MiscOnOff/ clipFlag,TubeOn
  242.       clipFlag = .TRUE.
  243.       END !SUBROUTINE
  244.  
  245.  
  246.  
  247.       SUBROUTINE CloseGraphics()
  248.       INCLUDE 'FGRAPH.FD'
  249.       LOGICAL CRTGraphOnF, PlotterOnF
  250.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  251.       INTEGER  dummy
  252.  
  253.       IF (CRTGraphOnF)  THEN
  254.        dummy =  setvideomode( $DEFAULTMODE )
  255.        CALL unregisterfonts()
  256.       END IF
  257.       IF (PlotterOnF) call SelectPen(0)
  258.       END !SUBROUTINE
  259.  
  260.  
  261.  
  262.  
  263.       SUBROUTINE Combine( outstr, s)
  264.       CHARACTER * (*) outstr, s
  265.       INTEGER LenO, LenS, i
  266.       LenO = LEN_TRIM(outstr) + 2
  267.       LenS = LEN_TRIM(s)
  268.  
  269.       DO i = 1, Lens
  270.         outstr(LenO:LenO) = s(i:i)
  271.         LenO = LenO + 1
  272.       END DO
  273.       END !SUBROUTINE
  274.  
  275.  
  276.       SUBROUTINE Catenate( outstr, s)
  277.       CHARACTER * (*) outstr, s
  278.       INTEGER LenO, LenS, i
  279.       LenO = LEN_TRIM(outstr) + 1
  280.       LenS = LEN_TRIM(s)
  281.  
  282.       DO i = 1, Lens
  283.         outstr(LenO:LenO) = s(i:i)
  284.         LenO = LenO + 1
  285.       END DO
  286.       END !SUBROUTINE
  287.  
  288.  
  289.  
  290.       FUNCTION ConvertX1 (xx1)
  291.       REAL xx1, temp
  292.       REAL wx, wy, wh, wl, tx, ty
  293.       INTEGER  vx, vy, vh, vl
  294.       COMMON /WorldVals/ wx, wy, wh, wl, tx, ty
  295.       COMMON /ViewVals/ vx, vy, vh, vl
  296.  
  297.       temp = (xx1 - wx) * tx + vx
  298.       ConvertX1 = ClampReal(temp, 0.0, 1000.0)
  299.       END !FUNCTION
  300.  
  301.  
  302.  
  303.       FUNCTION ConvertX2 (xx1)
  304.       REAL xx1, temp
  305.       REAL wx, wy, wh, wl, tx, ty
  306.       COMMON /WorldVals/ wx, wy, wh, wl, tx, ty
  307.  
  308.       temp = xx1 * tx
  309.       ConvertX2 = ClampReal(temp, -1000.0, 1000.0)
  310.       END !FUNCTION
  311.  
  312.  
  313.  
  314.  
  315.  
  316.       FUNCTION ConvertY1 (yy1)
  317.       REAL yy1, temp
  318.       REAL wx, wy, wh, wl, tx, ty
  319.       INTEGER  vx, vy, vh, vl
  320.       COMMON /WorldVals/ wx, wy, wh, wl, tx, ty
  321.       COMMON /ViewVals/ vx, vy, vh, vl
  322.  
  323.       temp = (yy1 - wy) * ty + vy
  324.       ConvertY1 = ClampReal(temp, 0.0, 1000.0)
  325.       END !FUNCTION
  326.  
  327.  
  328.  
  329.       FUNCTION ConvertY2 (yy1)
  330.       REAL yy1,  temp
  331.       REAL wx, wy, wh, wl, tx, ty
  332.       COMMON /WorldVals/ wx, wy, wh, wl, tx, ty
  333.  
  334.       temp = yy1 * ty
  335.       ConvertY2 = ClampReal(temp, -1000.0, 1000.0)
  336.       END !FUNCTION
  337.  
  338.  
  339.  
  340.       SUBROUTINE CRTGraphOff
  341.       LOGICAL CRTGraphOnF, PlotterOnF
  342.       LOGICAL clipFlag
  343.       INTEGER TubeOn
  344.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  345.       COMMON /MiscOnOff/ clipFlag,TubeOn
  346.       CRTGraphOnF = .FALSE.
  347.       TubeOn = 2
  348.       END !SUBROUTINE
  349.  
  350.  
  351.       SUBROUTINE CRTGraphOn
  352.       LOGICAL CRTGraphOnF, PlotterOn, ClipFlag
  353.       INTEGER TubeOn
  354.       COMMON /OnOff/ CRTGraphOnF, PlotterOn
  355.       COMMON /MiscOnOff/ ClipFlag, TubeOn
  356.       CRTGraphOnF = .TRUE.
  357.       TubeOn = 1
  358.       END !SUBROUTINE
  359.  
  360.  
  361.       SUBROUTINE ColorFillpoly (numdat, polyVector, fillstyle,
  362.      +                    fillcolor, outline)
  363.       INCLUDE 'STDHDR.FOR'
  364.       INCLUDE 'GRAFTYPE.FOR'
  365.       INCLUDE 'FGRAPH.FD'
  366.       INTEGER polyvector(0:maxv)
  367.       INTEGER numdat, fillstyle, fillcolor, outline
  368.       INTEGER gp, i, j, ii,  edge
  369.       INTEGER xmin, xmax, ymin, ymax
  370.       INTEGER startptX, startptY, endptX, endptY
  371.       INTEGER  vx, vy, vh, vl
  372.       COMMON /ViewVals/ vx, vy, vh, vl
  373.  
  374.       CALL SelectColor (15)
  375.       CALL MoveToXX(REAL(polyVector(0)),REAL(polyVector(1)))
  376.       CALL SetLineStyleXX(0, 1)
  377.       DO i = 1, numdat - 1
  378.         ii = 2 * i
  379.         CALL LineToXX(REAL(polyVector(ii)) , REAL(polyVector(ii+1)))
  380.       END DO
  381.       CALL PolyMinMax(polyVector, numdat, xmin, ymin, xmax, ymax)
  382.       CALL SetFillStyleXX(fillstyle, fillcolor)
  383.       CALL SelectColor (fillcolor)
  384.  
  385.       edge = 0
  386.       i = ymin
  387.  
  388.       DO WHILE (i .LE. ymax)
  389.         startptx = 0
  390.         startpty = 0
  391.         endptx = 0
  392.         endpty = 0
  393.         edge = 0
  394.         j = xmin - 1
  395.         DO WHILE (j .LE. xmax + 1)
  396.           gp  =  getpixel(j,vh-i)
  397.           IF (gp .EQ. 15) THEN
  398.             IF (edge .EQ. 0) THEN
  399.               edge = 1
  400.               startptx = j
  401.               startpty = i
  402.             ELSE
  403.               endptx = j
  404.               endpty = i
  405.               IF (endptx - startptx .GE. 2) THEN
  406.                 CALL MoveToXX(startptx + 1.0, REAL(startpty))
  407.                 CALL LineToXX(endptx - 1.0, REAL(endpty))
  408.                 j = xmax + 2
  409.               ELSE
  410.                startptx = endptx
  411.                startpty = endpty
  412.               END IF
  413.             END IF !!!  edge .NE. 0
  414.           END IF  !!! /* pixel = 15
  415.           j = j + 1
  416.         END DO  !!! while j
  417.         i = i + 1
  418.        END DO !!! while i
  419.  
  420.       CALL SelectColor (outline)
  421.       CALL MoveToXX(REAL(polyVector(0)), REAL(polyVector(1)))
  422.       CALL SetLineStyleXX(0, 1)
  423.       DO i = 1, numdat - 1
  424.         ii = 2 * i
  425.         CALL LineToXX(REAL(polyVector(ii)),REAL(polyVector(ii+ 1)))
  426.       END DO
  427.  
  428.  
  429.       END !SUBROUTINE
  430.  
  431.  
  432.       SUBROUTINE GetColXX(OldCol)
  433.       INCLUDE 'FGRAPH.FD'
  434.       LOGICAL CRTGraphOnF, PlotterOnF
  435.       INTEGER OldCol
  436.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  437.       IF (PlotterOnF)   CALL PGetColor (OldCol)
  438.       IF (CRTGraphOnF)  OldCol= getcolor()
  439.       END !FUNCTION
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.       SUBROUTINE GetMaxCoords (x, y)
  447.       INTEGER x, y
  448.       INCLUDE 'FGRAPH.FD'
  449.       LOGICAL CRTGraphOnF, PlotterOnF
  450.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  451.       RECORD /videoconfig/ VC
  452.  
  453.       IF (CRTGraphOnF) THEN
  454.         CALL getvideoconfig(VC)
  455.         x = VC.numxpixels-1
  456.         y = VC.numypixels-1
  457.       ELSE
  458.         x = 640
  459.         y = 485
  460.       END IF
  461.       END !SUBROUTINE
  462.  
  463.  
  464.  
  465.  
  466.       SUBROUTINE GetTextStyleXX (font, dir, Hsize, VSize)
  467.       INTEGER font, dir ,Hsize, VSize
  468.       INTEGER textFont, textdir, Htextsize, Vtextsize
  469.       COMMON /TextAttr/ textFont, textdir, Htextsize, Vtextsize
  470.  
  471.       font = textFont
  472.       dir = textdir
  473.       Hsize = HtextSize
  474.       VSize = VtextSize
  475.       END !SUBROUTINE
  476.  
  477.  
  478.  
  479.       SUBROUTINE GetViewportOrigin (left, top)
  480.       INTEGER  left, top
  481.       INCLUDE  'GRAFTYPE.FOR'
  482.       RECORD /Rect/ viewp
  483.       COMMON /Viewport/ viewp
  484.  
  485.       left = viewp.left
  486.       top = viewp.top
  487.       END !SUBROUTINE
  488.  
  489.  
  490.  
  491.  
  492.  
  493.       SUBROUTINE linerel( x, y)
  494.       INTEGER x, y
  495.       INCLUDE 'FGRAPH.FD'
  496.       RECORD /xycoord/ position
  497.       INTEGER dummy
  498.  
  499.       CALL getcurrentposition(position)
  500.       dummy = lineto(position.xcoord+x, position.ycoord+y)
  501.       END
  502.  
  503.  
  504.       SUBROUTINE LineRelXX (x, y)
  505.       REAL x, y
  506.       LOGICAL CRTGraphOnF, PlotterOnF
  507.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  508.  
  509.       IF (CRTGraphOnF)  CALL linerel( NINT(x), -NINT(y))
  510.       IF (PlotterOnF)   CALL PLineRel(x, y)
  511.       END !SUBROUTINE
  512.  
  513.  
  514.  
  515.  
  516.  
  517.       SUBROUTINE LineToXX (x, y)
  518.       REAL x, y
  519.       INTEGER  dummy
  520.       REAL vxAbs, vyAbs
  521.       INTEGER  vx, vy, vh, vl
  522.       LOGICAL CRTGraphOnF, PlotterOnF
  523.       COMMON /ViewVals/ vx, vy, vh, vl
  524.       COMMON /PlotVals/ vxAbs, vyAbs
  525.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  526.  
  527.       INCLUDE 'FGRAPH.FD'
  528.       IF (CRTGraphOnF)  dummy =  lineto( NINT(x), vh - NINT(y))
  529.       IF (PlotterOnF)   CALL PLineTo(vxAbs + x, vyAbs + y)
  530.       END !SUBROUTINE
  531.  
  532.  
  533.  
  534.       SUBROUTINE lineworldabs (xx1, yy1)
  535.       REAL xx1, yy1
  536.  
  537.       CALL LineToXX(ConvertX1(xx1), ConvertY1(yy1))
  538.       END !SUBROUTINE
  539.  
  540.  
  541.  
  542.       SUBROUTINE lineworldrel (xx1, yy1)
  543.       REAL xx1, yy1
  544.  
  545.       CALL LineRelXX(ConvertX2(xx1), ConvertY2(yy1))
  546.       END !SUBROUTINE
  547.  
  548.  
  549.  
  550.       SUBROUTINE moverel( x, y)
  551.       INTEGER x, y
  552.       INCLUDE 'FGRAPH.FD'
  553.       RECORD /xycoord/ position
  554.  
  555.       CALL getcurrentposition(position)
  556.       CALL moveto(position.xcoord+x, position.ycoord+y, position)
  557.       END
  558.  
  559.  
  560.       SUBROUTINE MoveRelXX (x, y)
  561.       REAL x,y
  562.       LOGICAL CRTGraphOnF, PlotterOnF
  563.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  564.  
  565.       IF (CRTGraphOnF)  CALL moverel( NINT(x), -NINT(y))
  566.     IF (PlotterOnF)   CALL PMoveRel(x, y)
  567.       END !SUBROUTINE
  568.  
  569.  
  570.  
  571.       SUBROUTINE MoveToXX (x, y)
  572.       INCLUDE 'FGRAPH.FD'
  573.       REAL x, y, vxAbs, vyAbs
  574.       RECORD /xycoord/ position
  575.       INTEGER  vx, vy, vh, vl
  576.       LOGICAL CRTGraphOnF, PlotterOnF
  577.       COMMON /ViewVals/ vx, vy, vh, vl
  578.       COMMON /PlotVals/ vxAbs, vyAbs
  579.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  580.  
  581.       IF (CRTGraphOnF)   CALL moveto(NINT(x), (vh - NINT(y)),position)
  582.       IF (PlotterOnF)  CALL PMoveTo(vxAbs + x, vyAbs + y)
  583.       END !SUBROUTINE
  584.  
  585.  
  586.  
  587.  
  588.       SUBROUTINE moveworldabs (xx1, yy1)
  589.       REAL xx1, yy1
  590.  
  591.       CALL MoveToXX(ConvertX1(xx1), ConvertY1(yy1))
  592.       END !SUBROUTINE
  593.  
  594.  
  595.  
  596.       SUBROUTINE moveworldrel (xx1, yy1)
  597.       REAL xx1, yy1
  598.  
  599.       CALL MoveRelXX(ConvertX2(xx1), ConvertY2(yy1))
  600.       END !SUBROUTINE
  601.  
  602.  
  603.       SUBROUTINE NoCursor()
  604.       INCLUDE 'FGRAPH.FD'
  605.       INTEGER dummy
  606.       dummy = displaycursor($GCURSOROFF)
  607.       END !SUBROUTINE
  608.  
  609.  
  610.       SUBROUTINE ShowCursor()
  611.       INCLUDE 'FGRAPH.FD'
  612.       INTEGER dummy
  613.       dummy = displaycursor($GCURSORON)
  614.       END !SUBROUTINE
  615.  
  616.       SUBROUTINE OneTimeInit (mode, fontpath )
  617.       INCLUDE 'FGRAPH.FD'
  618.       INCLUDE 'GRAFTYPE.FOR'
  619.       INTEGER mode,x,y, dummy
  620.       INTEGER vx, vy, vh, vl, horizdir, vertdir, TubeOn
  621.       CHARACTER * (*) fontpath
  622.       LOGICAL CRTGraphOnF, PlotterOnF, ClipFlag
  623.       COMMON /ViewVals/ vx, vy, vh, vl
  624.       COMMON /TextPos/ horizdir, vertdir
  625.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  626.       COMMON /MiscOnOff/ ClipFlag, TubeOn
  627.  
  628.       horizdir = 0
  629.       vertdir = 0
  630.       vx = 0
  631.       vy = 0
  632.       vl = 720
  633.       vh = 348
  634.  
  635.       IF (TubeOn .EQ. 0) CALL CRTGraphOn()
  636.       CALL ClipOn()
  637.  
  638.       IF (CRTGraphOnF) THEN
  639.         IF (registerfonts(fontpath) .LT. 0 .AND.
  640.      +    registerfonts('*.FON') .LT. 0)
  641.      +    STOP 'Error: incorrect pathname for font files.'
  642.          SELECT CASE (mode)
  643.            CASE (-1)
  644.                IF( setvideomode($MAXRESMODE) .EQ.  0)
  645.      +            STOP 'Error: cannot set graphics mode'
  646.            CASE (1)
  647.                dummy = setvideomode($MRES4COLOR)
  648.            CASE (2)
  649.                dummy = setvideomode($MRESNOCOLOR)
  650.            CASE (3)
  651.                dummy = setvideomode($HRESBW)
  652.            CASE (4)
  653.                dummy = setvideomode($MRES16COLOR)
  654.            CASE (5)
  655.                dummy = setvideomode($HRES16COLOR)
  656.            CASE (6)
  657.                dummy = setvideomode($ERESCOLOR)
  658.            CASE (7)
  659.                dummy = setvideomode($VRES2COLOR)
  660.            CASE (8)
  661.                dummy = setvideomode($VRES16COLOR)
  662.            CASE (9)
  663.                dummy = setvideomode($MRES256COLOR)
  664.            CASE (10)
  665.                dummy =  setvideomode($DEFAULTMODE)
  666.            CASE (11)
  667.                dummy = setvideomode($ERESNOCOLOR)
  668.            CASE (12)
  669.                dummy = setvideomode(8)
  670.            CASE DEFAULT
  671.               dummy = setvideomode(6)
  672.          END SELECT
  673.          CALL GetMaxCoords(x, y)
  674.       END IF
  675.       IF (PlotterOnF) THEN
  676.          CALL DefinePlotterFill
  677.          CALL SetPlotterViewport(1000, 500, 10000, 7500)
  678.          CALL GetMaxCoords(x, y)
  679.          CALL ScalePlotterViewport(0, 0, x, y)
  680.       END IF
  681.       CALL SetGraphViewport(0, 0, x, y)
  682.  
  683.       CALL SetTextJustifyXX(0, 1)
  684.       CALL SetTextStyleXX(0, 0, 10, 12)
  685.       CALL SelectColor(1)
  686.       END !SUBROUTINE
  687.  
  688.  
  689.  
  690.       SUBROUTINE outgraphstring (S, LengthS)
  691.       CHARACTER *(*) s
  692.       INCLUDE 'FGRAPH.FD'
  693.       INTEGER LengthS, i, x, y
  694.       INTEGER sizex, sizey
  695.       INTEGER horizdir, vertdir
  696.       INTEGER textdir, HtextSize, textFont, VTextSize
  697.       RECORD /xycoord/ position
  698.       COMMON /TextPos/ horizdir, vertdir
  699.       COMMON /TextAttr/ textFont, textdir, HtextSize, VtextSize
  700.  
  701.  
  702.       CALL getcurrentposition(position)
  703.       x = position.xcoord
  704.       y = position.ycoord
  705.       sizex = HtextSize
  706.       sizey = VtextSize
  707.  
  708.  
  709.       SELECT CASE (horizdir)
  710.          CASE (0)
  711.                    x = x + 0
  712.          CASE (1)
  713.           IF (textdir .EQ. 0) THEN
  714.            x = x - (sizex-1) * (LengthS / 2)
  715.           ELSE
  716.             x = x - sizex /2
  717.           END IF
  718.          CASE (2)
  719.           IF (textdir .EQ. 0) THEN
  720.              x = x - (sizex-1) * (LengthS)
  721.           ELSE
  722.               x = x - sizex
  723.           END IF
  724.          CASE DEFAULT
  725.           IF (textdir .EQ. 0) THEN
  726.              x = x - sizex * (LengthS / 2)
  727.           ELSE
  728.               x = x - sizex/2
  729.           END IF
  730.  
  731.              END SELECT
  732.  
  733.          SELECT CASE (vertdir)
  734.            CASE (0)
  735.            IF (textdir .EQ. 0) THEN
  736.               y = y - sizey
  737.            ELSE
  738.                y = y - sizey * LengthS
  739.            END IF
  740.            CASE (1)
  741.             IF (textdir .EQ. 0) THEN
  742.               y = y - sizey / 2
  743.            ELSE
  744.                y = y - (sizey) * (LengthS / 2)
  745.            END IF
  746.           CASE (2)
  747.  
  748.           CASE DEFAULT
  749.            IF (textdir .EQ. 0) THEN
  750.               y = y - sizey
  751.            ELSE
  752.                y = y - sizey * (LengthS / 2)
  753.            END IF
  754.           END SELECT
  755.  
  756.     CALL  moveto(x,y, position)
  757.     IF (textdir .EQ. 0) THEN
  758.       CALL outgtext(s)
  759.     ELSE
  760.       DO i = 1, LengthS
  761.         CALL outgtext(s(i:i))
  762.             y = sizey + y
  763.         CALL moveto(x, y, position)
  764.       END DO
  765.     END IF
  766.  
  767.       END !SUBROUTINE
  768.  
  769.  
  770.  
  771.       SUBROUTINE OutTextPie (x, y, S)
  772.       REAL x, y
  773.       CHARACTER * (*)  S
  774.       LOGICAL CRTGraphOnF, PlotterOnF
  775.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  776.       CALL MoveToXX(x, y)
  777.       IF (CRTGraphOnF)   CALL outgraphstring(S, LEN_TRIM(S))
  778.       IF (PlotterOnF)    CALL POutText(S)
  779.       END !SUBROUTINE
  780.  
  781.  
  782.  
  783.       SUBROUTINE OutTextXX (S)
  784.       CHARACTER * 80 S
  785.       LOGICAL CRTGraphOnF, PlotterOnF
  786.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  787.       IF (CRTGraphOnF) THEN
  788.         CALL outgraphstring(S, LEN_TRIM(S))
  789.        END IF
  790.       IF (PlotterOnF)    CALL POutText(S)
  791.       END !SUBROUTINE
  792.  
  793.  
  794.       SUBROUTINE OutRealXX (S)
  795.       CHARACTER * 80 S
  796.       LOGICAL CRTGraphOnF, PlotterOnF
  797.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  798.       IF (CRTGraphOnF) THEN
  799.         CALL outgraphstring(S, LEN_TRIM(S))
  800.        END IF
  801.       IF (PlotterOnF)    CALL POutText(S)
  802.       END !SUBROUTINE
  803.  
  804.  
  805.  
  806.  
  807.  
  808.       SUBROUTINE PieXX (x, y, stangle, endangle, radius, AspectR)
  809.       REAL x,y,stangle, endangle, radius, AspectR, TwoPi360,AsRad
  810.       REAL vxAbs, vyAbs
  811.       INTEGER x1, x2, x3,x4, y1, y2, y3, y4, dummy
  812.       INCLUDE 'FGRAPH.FD'
  813.  
  814.       INTEGER  vx, vy, vh, vl
  815.       LOGICAL CRTGraphOnF, PlotterOnF
  816.       COMMON /PlotVals/ vxAbs, vyAbs
  817.       COMMON /ViewVals/ vx, vy, vh, vl
  818.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  819.  
  820.  
  821.       PARAMETER ( TwoPi360 = 0.0174532)
  822.  
  823.       IF (PlotterOnF) AspectR = 1.0
  824.       AsRad = AspectR * radius
  825.       x3 = NINT(x + (radius*cos(twopi360*stangle)))
  826.       y3 = NINT(y + (Asrad*sin(stangle*twoPi360)))
  827.       x4 = NINT(x + (radius*cos(twopi360*endangle)))
  828.       y4 = NINT(y + (Asrad*sin(endangle*twopi360)))
  829.       x1 = NINT(x - radius)
  830.       x2 = NINT(x + radius)
  831.       y1 = NINT(y + Asrad)
  832.       y2 = NINT(y - Asrad)
  833.       IF (CRTGraphOnF) THEN
  834.          dummy =  pie( $GFILLINTERIOR, x1, vh-y1, x2, vh-y2,
  835.      +                 x3, vh-y3, x4, vh-y4)
  836.       END IF
  837.       IF (PlotterOnF)
  838.      +  CALL PShadeWedge(vxAbs + x, vyAbs + y, radius, NINT(stangle),
  839.      +              NINT(endangle-stangle))
  840.  
  841.       END !SUBROUTINE
  842.  
  843.  
  844.  
  845.       SUBROUTINE PlotterOff()
  846.       LOGICAL CRTGraphOnF, PlotterOnF
  847.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  848.       PlotterOnF = .FALSE.
  849.       END !SUBROUTINE
  850.  
  851.  
  852.  
  853.       SUBROUTINE PlotterOn()
  854.       LOGICAL CRTGraphOnF, PlotterOnF
  855.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  856.       PlotterOnF = .TRUE.
  857.       END !SUBROUTINE
  858.  
  859.  
  860.  
  861.  
  862.  
  863.  
  864.        SUBROUTINE ColorPolyFillWorldAbs (x, y, fillstyle,
  865.      +        fillcolor, numdat)
  866.        INCLUDE 'stdhdr.for'
  867.        REAL x(0:maxv), y(0:maxv)
  868.        INTEGER fillstyle, fillcolor, numdat
  869.        INTEGER outline, ii
  870.        INTEGER polyvector[ALLOCATABLE](:)
  871.        ALLOCATE(polyVector(0:maxv),STAT=iErr)
  872.  
  873.        CALL moveworldabs(x(0), y(0))
  874.        DO i = 0, numdat - 1
  875.          ii = 2 * i
  876.          polyVector(ii) = NINT(ConvertX1(x(i)))
  877.          polyVector(ii + 1) = NINT(ConvertY1(y(i)))
  878.        END DO
  879.        CALL GetColXX(outline)
  880.        CALL ColorFillpoly(numdat, polyVector,
  881.      +                    fillstyle, fillcolor, outline)
  882.        DEALLOCATE(polyVector,STAT=iErr)
  883.        END !SUBROUTINE
  884.  
  885.  
  886.  
  887.       SUBROUTINE polyLineWorldAbs (x, y, numdat)
  888.       INCLUDE 'stdhdr.for'
  889.       REAL x(0:maxv), y(0:maxv)
  890.       INTEGER  numdat
  891.  
  892.       CALL moveworldabs(x(0), y(0))
  893.       DO i = 1, numdat - 1
  894.         CALL lineworldabs(x(i), y(i))
  895.       END DO
  896.       END !SUBROUTINE
  897.  
  898.  
  899.  
  900.  
  901.       SUBROUTINE polyLineWorldRel (x, y, numdat)
  902.       INCLUDE 'STDHDR.FOR'
  903.       REAL x(0:maxv), y(0:maxv)
  904.       INTEGER  numdat
  905.  
  906.       CALL moveworldrel(x(0), y(0))
  907.       DO i = 1, numdat - 1
  908.           CALL lineworldRel(x(i), y(i))
  909.       END DO
  910.       END !SUBROUTINE
  911.  
  912.  
  913.  
  914.  
  915.  
  916.       SUBROUTINE PolyMinMax (polyVector, numdat, xmin, ymin, xmax, ymax)
  917.       INCLUDE 'STDHDR.FOR'
  918.       INTEGER polyVector(0:maxv)
  919.       INTEGER  numdat, xmin, ymin, xmax, ymax, i, ii
  920.  
  921.       xmin = polyVector(0)
  922.       xmax = polyVector(0)
  923.       ymin = polyVector(1)
  924.       ymax = polyVector(1)
  925.  
  926.       DO i = 1, numdat - 1
  927.         ii = 2 * i
  928.         IF (polyVector(ii) .LT. xmin)  xmin = polyVector(ii)
  929.         IF (polyVector(ii) .GT. xmax)  xmax = polyVector(ii)
  930.         IF (polyVector(ii+1) .LT. ymin)  ymin = polyVector(ii+1)
  931.         IF (polyVector(ii+1) .GT. ymax)  ymax = polyVector(ii+1)
  932.       END DO
  933.  
  934.       END !SUBROUTINE
  935.  
  936.  
  937.  
  938.       SUBROUTINE RectangleXX (x1, y1, x2, y2)
  939.       REAL x1,y1,x2,y2, vxAbs, vyAbs
  940.       INTEGER dummy
  941.       INCLUDE 'FGRAPH.FD'
  942.       LOGICAL CRTGraphOnF, PlotterOnF
  943.       COMMON /PlotVals/ vxAbs, vyAbs
  944.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  945.  
  946.       IF (CRTGraphOnF) THEN
  947.        dummy = rectangle($GBORDER, NINT(x1), NINT(y1),
  948.      +                   NINT(x2), NINT(y2))
  949.       END IF
  950.       IF (PlotterOnF)
  951.      +  CALL PRectangle(vxAbs+x1, vyAbs+y1, vxAbs+x2, vyAbs+y2)
  952.       END !SUBROUTINE
  953.  
  954.  
  955.       SUBROUTINE SelectColor (c)
  956.       INTEGER c,color,dummy
  957.       INCLUDE 'FGRAPH.FD'
  958.       LOGICAL CRTGraphOnF, PlotterOnF
  959.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  960.       color = 1
  961.       IF (CRTGraphOnF) THEN
  962.           color = NINT(AdjustCRT(c))
  963.          dummy =  setcolor(c)
  964.       END IF
  965.       IF (PlotterOnF)  CALL SelectPen(c)
  966.       END !SUBROUTINE
  967.  
  968.  
  969.  
  970.  
  971.       SUBROUTINE SetFillStyleXX (pat, c)
  972.       INTEGER pat, c
  973.       LOGICAL CRTGraphOnF, PlotterOnF
  974.       INTEGER * 1 fillmask(8,10)
  975.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  976.       DATA fillmask /#00, #00, #00, #00, #00, #00, #00, #00,
  977.      +   #FF, #FF, #FF, #FF, #FF, #FF, #FF, #FF,
  978.      +   #00, #FF, #00, #FF, #00, #FF, #00, #FF,
  979.      +   #11, #22, #44, #88, #11, #22, #44, #88,
  980.      +   #0F, #1E, #3C, #78, #F0, #E1, #C3, #87,
  981.      +   #87, #C3, #E1, #F0, #78, #3C, #1E, #0F,
  982.      +   #88, #44, #22, #11, #88, #44, #22, #11,
  983.      +   #81, #42, #24, #18, #18, #24, #42, #81,
  984.      +   #C3, #66, #42, #18, #42, #66, #C3, #81,
  985.      +   #88, #88, #88, #88, #88, #88, #88, #88 /
  986.  
  987.       CALL SelectColor(c)
  988.       IF (CRTGraphOnF) THEN
  989.         call setlinestyle(#FFFF)
  990.         CALL setfillmask(fillmask(1,pat))
  991.       END IF
  992.       IF (PlotterOnF)  CALL PSetFillStyle(pat, c)
  993.       END !SUBROUTINE
  994.  
  995.  
  996.  
  997.       SUBROUTINE SetGlobalView (c)
  998.       INTEGER c
  999.       INTEGER BackgroundColor
  1000.       BackgroundColor = NINT(AdjustCRT(c))
  1001.       END !SUBROUTINE
  1002.  
  1003.  
  1004.  
  1005.  
  1006.       SUBROUTINE SetGraphViewport (xx1, yy1, xx2, yy2)
  1007.       INCLUDE 'FGRAPH.FD'
  1008.       INCLUDE 'GRAFTYPE.FOR'
  1009.  
  1010.       INTEGER xx1,yy1, xx2, yy2, maxX,maxY
  1011.       INTEGER  vx, vy, vh, vl, horizdir, vertdir
  1012.       INTEGER PUx1, PUy1, PUx2, PUy2, TubeOn
  1013.       REAL x1, y1, x2, y2, vxAbs, vyAbs
  1014.       RECORD /Rect/ viewp
  1015.       LOGICAL CRTGraphOnF, PlotterOnF, ClipFlag
  1016.       COMMON /Viewport/ viewp
  1017.       COMMON /ViewVals/ vx, vy, vh, vl
  1018.       COMMON /PlotVals/ vxAbs, vyAbs
  1019.       COMMON /TextPos/ horizdir, vertdir
  1020.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  1021.       COMMON /MiscOnOff/ ClipFlag, TubeOn
  1022.  
  1023.       IF (CRTGraphOnF) THEN
  1024.          CALL setviewport  (xx1, yy1, xx2, yy2)
  1025.          IF (ClipFlag) CALL setcliprgn(xx1, yy1, xx2, yy2)
  1026.       END IF
  1027.       IF (PlotterOnF) THEN
  1028.     CALL GetMaxCoords(maxX, maxY)
  1029.     CALL GetPlotterViewport(pux1, puy1, pux2, puy2)
  1030.     IF (clipFlag) THEN
  1031.       x1 = pux1 + (pux2 - pux1) * REAL(xx1) / REAL(maxX)
  1032.       y1 = puy2 - (puy2 - puy1) * REAL(yy1) / REAL(maxY)
  1033.       x2 = pux1 + (pux2 - pux1) * REAL(xx2) / REAL(maxX)
  1034.       y2 = puy2 - (puy2 - puy1) * REAL(yy2) / REAL(maxY)
  1035.           CALL SetClippingWindow(x1,y2,x2,y1)
  1036.     END IF
  1037.       END IF
  1038.       vxAbs = xx1
  1039.       vyAbs = maxY - yy2
  1040.       vx = 0
  1041.       vy = 0
  1042.       vh = yy2 - yy1
  1043.       vl = xx2 - xx1
  1044.       viewp.left = xx1
  1045.       viewp.top = yy1
  1046.       viewp.right = xx2
  1047.       viewp.bottom = yy2
  1048.       END !SUBROUTINE
  1049.  
  1050.  
  1051.  
  1052.       SUBROUTINE SetLineStyleXX (ls, thick)
  1053.       INTEGER ls,  thick
  1054.       LOGICAL CRTGraphOnF, PlotterOnF
  1055.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  1056.       INTEGER *2 linemask(0:4)
  1057.       DATA linemask/ #FFFF, #5555, #6666, #BDBD,#FF00/
  1058.  
  1059.       IF (CRTGraphOnF) THEN
  1060.         LineStyle = ls
  1061.         CALL setlinestyle(linemask(ls))
  1062.       END IF
  1063.       IF (PlotterOnF)  CALL PSetLineStyle(ls, thick)
  1064.       END !SUBROUTINE
  1065.  
  1066.  
  1067.  
  1068.       SUBROUTINE SetTextJustifyXX (h, v)
  1069.       INTEGER h, v, horizdir, vertdir
  1070.       LOGICAL CRTGraphOnF, PlotterOnF
  1071.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  1072.       COMMON /TextPos/ horizdir, vertdir
  1073.  
  1074.       IF (CRTGraphOnF) THEN
  1075.          horizdir = h
  1076.          vertdir = v
  1077.       END IF
  1078.       IF (PlotterOnF)  CALL PSetTextJustify(h, v)
  1079.       END !SUBROUTINE
  1080.  
  1081.  
  1082.  
  1083.       SUBROUTINE SetTextStyleXX (font, dir, Hsize, Vsize)
  1084.       INCLUDE 'GRAFTYPE.FOR'
  1085.       INCLUDE 'FGRAPH.FD'
  1086.       INTEGER font, dir, Hsize, Vsize, textdir, dummy
  1087.       INTEGER HtextSize, textFont, VtextSize, psize
  1088.       CHARACTER * 30 list, hch, vch, attrib
  1089.       LOGICAL CRTGraphOnF, PlotterOnF
  1090.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  1091.       COMMON /TextAttr/ textFont, textdir, HtextSize, VtextSize
  1092.       CHARACTER* (10) option (NFONTS)/
  1093.      +     "t'courier'",    "t'helv'",
  1094.      +     "t'tms rmn'",    "t'modern'",
  1095.      +     "t'script'",     "t'roman'"/
  1096.  
  1097.       textdir = dir
  1098.       HtextSize = Hsize
  1099.       VtextSize = VSize
  1100.       textFont = font
  1101.       IF (CRTGraphOnF) THEN
  1102.         attrib = '              '
  1103.         hch = '              '
  1104.         vch = '              '
  1105.         list = '                 '
  1106.         CALL RealString(REAL(Hsize), 0, 1, hch)
  1107.         CALL RealString(REAL(Vsize), 0, 1, Vch)
  1108.         attrib = 'h'
  1109.         CALL catenate(attrib, hch)
  1110.         CALL catenate(attrib, 'w')
  1111.         CALL catenate(attrib, vch)
  1112.         CALL catenate(attrib, 'b')
  1113.         list = option(font+1)
  1114.         CALL combine(list, attrib )
  1115.         dummy = setfont(list)
  1116.       END IF
  1117.       IF (PlotterOnF)  THEN
  1118.         psize = (Vsize / 11) + 1
  1119.         CALL PSetTextStyle(0,0,1)
  1120.         CALL PSetTextStyle(font, dir, psize)
  1121.       END IF
  1122.       END !SUBROUTINE
  1123.  
  1124.       SUBROUTINE SetWorldCoordinates (wr)
  1125.       INCLUDE 'GRAFTYPE.FOR'
  1126.       RECORD /WorldRect/ wr
  1127.  
  1128.       REAL wx, wy, wh, wl, tx, ty
  1129.       INTEGER  vx, vy, vh, vl
  1130.       LOGICAL CRTGraphOnF, PlotterOnF
  1131.       COMMON /WorldVals/ wx, wy, wh, wl, tx, ty
  1132.       COMMON /ViewVals/ vx, vy, vh, vl
  1133.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  1134.  
  1135.       wx = wr.left
  1136.       wy = wr.bottom
  1137.       wh = wr.top - wr.bottom
  1138.       wl = wr.right - wr.left
  1139.  
  1140.       tx = REAL( vl) / wl
  1141.       ty = REAL( vh )/ wh
  1142.       END !SUBROUTINE
  1143.  
  1144.  
  1145.  
  1146.       SUBROUTINE SetWorldRect (Worldr, a, b, c, d)
  1147.       INCLUDE 'GRAFTYPE.FOR'
  1148.       RECORD /WorldRect/ Worldr
  1149.       REAL a,b,c,d
  1150.  
  1151.       Worldr.left = a
  1152.       Worldr.bottom = b
  1153.       Worldr.right = c
  1154.       Worldr.top = d
  1155.  
  1156.       END !SUBROUTINE
  1157.  
  1158.  
  1159.       SUBROUTINE WorldRectangle (wr)
  1160.       INCLUDE 'GRAFTYPE.FOR'
  1161.       RECORD /WorldRect/ wr, IntRect
  1162.     IntRect.left = ConvertX1(wr.left)
  1163.     IntRect.bottom = ConvertY1(wr.bottom)
  1164.     IntRect.right = ConvertX1(wr.right) + 1.0
  1165.     IntRect.top = ConvertY1(wr.top) - 1.0
  1166.     CALL RectangleXX(IntRect.left, IntRect.top,
  1167.      +                   IntRect.right, IntRect.bottom)
  1168.       END !SUBROUTINE
  1169.  
  1170.       FUNCTION AdjustCRT(c)
  1171.       INTEGER c
  1172.       REAL color
  1173.       INCLUDE 'FGRAPH.FD'
  1174.       RECORD /videoconfig/ VC
  1175.       LOGICAL CRTGraphOnF, PlotterOnF
  1176.       COMMON /OnOff/ CRTGraphOnF, PlotterOnF
  1177.  
  1178.       IF (CRTGraphOnF) THEN
  1179.         CALL getvideoconfig(VC)
  1180.         IF (VC.numcolors .EQ. 0) THEN
  1181.            IF (c  .GE. 1) then
  1182.              color = 1
  1183.            ELSE
  1184.              color = 0
  1185.            END IF
  1186.         ELSE
  1187.           IF (c .GT.  VC.numcolors-1) THEN
  1188.              color = VC.numcolors-1
  1189.           ELSE
  1190.              color = c
  1191.           END IF
  1192.         END IF
  1193.       END IF
  1194.       AdjustCRT = color
  1195.       END !FUNCTION
  1196.  
  1197.  
  1198.       SUBROUTINE QCKSRT
  1199.       !!  Based upon the non-recursive QuickSort algorithm presented in
  1200.       !!  Numerical Recipes, William T. Vetterling, Cambridge Press
  1201.       !!  1986
  1202.       INCLUDE 'GRAFTYPE.FOR'
  1203.       PARAMETER (M=7, NStack=1000, FA = 211.0,FC = 1663.0)
  1204.       PARAMETER (FM = 7875.0, FMI= 1.0/FM)
  1205.       INTEGER i, j, fspntr
  1206.       REAL IR
  1207.       RECORD /xyerec/ FillStack(0:1000),  A
  1208.       REAL IStack[ALLOCATABLE](:)
  1209.       COMMON /FSP/ fspntr
  1210.       COMMON /FStack/ FillStack
  1211.  
  1212.       ALLOCATE(IStack(NStack),STAT=iErr)
  1213.  
  1214.       n = fspntr
  1215.       JStack = 0
  1216.       L = 1
  1217.       IR = N
  1218.       FX = 0.0
  1219. 10    IF (IR-L .LT. M) THEN
  1220.         DO j = L + 1, IR
  1221.        A = FillStack(j-1)
  1222.            DO i = j-1, 1, -1
  1223.           IF ((FillStack(i-1).y .LT. A.y) .OR.
  1224.      +      ((FillStack(i-1).x .LE. A.x) .AND.
  1225.      +        (FillStack(i-1).y .EQ. A.y))) GO TO 12
  1226.         FillStack(i) = FillStack(i-1)
  1227.            END DO
  1228.            i = 0
  1229. 12         FillStack(i) = A
  1230.         END DO
  1231.     IF (JStack .EQ. 0) return
  1232.         IR =IStack(JStack)
  1233.         L = IStack(Jstack-1)
  1234.         JStack = JStack -2
  1235.       ELSE
  1236.         i = L
  1237.         J = IR
  1238.         IQ =  L + (IR-L)/2
  1239.     A = FillStack(IQ-1)
  1240.     FillStack(IQ-1) = FillStack(L-1)
  1241. 20        continue
  1242. 21      IF (j .GT. 0) THEN
  1243.       IF ((A.y .LT. FillStack(j-1).y) .OR.
  1244.      +      ((A.x .LE. FillStack(j-1).x ) .AND.
  1245.      +       (FillStack(j-1).y .EQ. A.y))) THEN
  1246.             J = J - 1
  1247.            GO TO 21
  1248.           END IF
  1249.         END IF
  1250.         IF (J .LE. i) THEN
  1251.       FillStack(i-1) = A
  1252.           GO TO 30
  1253.         END IF
  1254.     FillStack(i-1) = FillStack(j-1)
  1255.         i = i + 1
  1256. 22      IF (i .le. N) THEN
  1257.     IF ((A.y .GT. FillStack(i-1).y) .OR.
  1258.      +     ((A.x .GE. FillStack(i-1).x) .AND.
  1259.      +       (FillStack(i-1).y .EQ. A.y))) THEN
  1260.               i = i + 1
  1261.              GO TO 22
  1262.           END IF
  1263.         END IF
  1264.         IF (j .LE. i ) THEN
  1265.       FillStack(j-1) = A
  1266.           i = j
  1267.          GO TO 30
  1268.         END IF
  1269.     FillStack(j-1) = FillStack(i-1)
  1270.         j = j - 1
  1271.         GO TO 20
  1272. 30      JStack = JStack + 2
  1273.         IF (Jstack .GT. NStack) pause 'NStack must be made larger.'
  1274.         IF (IR- i .GE. i - L ) THEN
  1275.           istack(jstack) = IR
  1276.           istack(Jstack-1) = i +1
  1277.           IR = i -1
  1278.         ELSE
  1279.           istack(Jstack)= i - 1
  1280.           istack(Jstack-1) = L
  1281.           L = i + 1
  1282.         END IF
  1283.       END IF
  1284.       GO TO 10
  1285.       DEALLOCATE(IStack, STAT=IErr)
  1286.       END
  1287.  
  1288.       FUNCTION FSCompare (e1 , e2 )
  1289.       INCLUDE 'GRAFTYPE.FOR'
  1290.         RECORD /xyerec/ temp1, temp2, e1, e2
  1291.         temp1 = e1
  1292.         temp2 = e2
  1293.         IF ((temp1.y .GT. temp2.y) .OR. ((temp1.y .EQ. temp2.y) .AND.
  1294.      +      (temp1.x .GT. temp2.x))) THEN
  1295.            FSCompare = 1
  1296.         ELSE
  1297.           IF ((temp1.y .EQ. temp2.y) .AND.
  1298.      +        (temp1.x .EQ. temp2.x)) THEN
  1299.             FSCompare = 0
  1300.           ELSE
  1301.             FSCompare = -1
  1302.            END IF
  1303.          END IF
  1304.       END !FUNCTION
  1305.  
  1306.  
  1307.  
  1308.       SUBROUTINE MemDraw (x1, y1, x2, y2, edge, ep)
  1309.         INTEGER x1, y1, x2, y2, edge, ep
  1310.         INTEGER dx, dy, dxabs, dyabs
  1311.         INTEGER i, px, py,sdx, sdy, x, y
  1312.  
  1313.       ! Bresenham's algorithm for line drawing
  1314.       ! Based upon the line-drawing algorithm
  1315.       !   in Graphics Programming in C by Roger T. Stevens
  1316.  
  1317.         dx = (x2 - x1)
  1318.         dy = (y2 - y1)
  1319.         dxabs = ABS(dx)
  1320.         dyabs = ABS(dy)
  1321.         sdx = SignXX(dx)
  1322.         sdy = SignXX(dy)
  1323.         CALL MemPlot(x1, y1, edge)
  1324.         x = 0
  1325.         y = 0
  1326.         px = x1
  1327.         py = y1
  1328.         IF (dxabs .GE. dyabs) THEN
  1329.           DO i = 1, dxabs - 1
  1330.             y = y + dyabs
  1331.             IF (y .GE. dxabs) THEN
  1332.               y = y - dxabs
  1333.               py = py + sdy
  1334.             END IF
  1335.             px = px + sdx
  1336.             CALL MemPlot(px, py, edge)
  1337.           END DO
  1338.         ELSE
  1339.           DO i = 1, dyabs - 1
  1340.             x = x + dxabs
  1341.             IF (x .GE. dyabs) THEN
  1342.               x = x - dyabs
  1343.               px = px + sdx
  1344.             END IF
  1345.             py = py + sdy
  1346.             CALL MemPlot(px, py, edge)
  1347.           END DO
  1348.         END IF
  1349.         ! plot endpoint only IF ep flag set true
  1350.         IF (ep .EQ. 1)  CALL MemPlot(x2, y2, edge)
  1351.       END !SUBROUTINE
  1352.  
  1353.       SUBROUTINE MemPlot (xx, yy, ee)
  1354.       INCLUDE 'GRAFTYPE.FOR'
  1355.       INCLUDE 'FGRAPH.FD'
  1356.       INTEGER xx,yy,ee, fspntr
  1357.       RECORD /xyerec/ FillStack(0: 1000)
  1358.       COMMON /FStack/ FillStack
  1359.       COMMON /FSP/ fspntr
  1360.  
  1361.         FillStack(fspntr).x = xx
  1362.         FillStack(fspntr).y = yy
  1363.         FillStack(fspntr).edge = ee
  1364.         fspntr = fspntr + 1
  1365.       END !SUBROUTINE
  1366.  
  1367.       SUBROUTINE FillPoly (xy, n, fillcolor, outlinecolor)
  1368.       INCLUDE 'STDHDR.FOR'
  1369.       INCLUDE 'GRAFTYPE.FOR'
  1370.         INTEGER n, fillcolor, outlinecolor
  1371.         INTEGER i, j
  1372.         INTEGER plotit, ep, fspntr
  1373.         RECORD /xyrec/ xy(0:maxv)
  1374.         RECORD /xyerec/ FillStack(0: 1000)
  1375.         INTEGER EdgeTable[ALLOCATABLE](:)
  1376.         COMMON /FSP/ fspntr
  1377.         COMMON /FStack/ FillStack
  1378.  
  1379.         ALLOCATE (EdgeTable(0:1000),STAT=Ierr)
  1380.  
  1381.         ! Zero out edge table
  1382.         DO i = 0, 1000
  1383.           EdgeTable(i) = 0
  1384.         END DO
  1385.         fspntr = 0
  1386.  
  1387.  
  1388.         ! Check and make sure we are dealing  with a closed polygon
  1389.         IF ((xy(0).x .NE. xy(n - 1).x) .OR.
  1390.      +      (xy(0).y .NE. xy(n - 1).y)) THEN
  1391.           xy(n) = xy(0)
  1392.           n = n + 1
  1393.         END IF
  1394.         ! Create pixel list of polygon outline
  1395.         ! Plot endpoint IF line meets at in interior vertex
  1396.         DO i = 1, n - 1
  1397.           IF (i .EQ. (n - 1)) THEN
  1398.             IF (INT(SignXX(xy(i - 1).y - xy(i).y)) .NE.
  1399.      +            INT(SignXX(xy(0).y - xy(1).y))) THEN
  1400.               ep = 1
  1401.             ELSE
  1402.               ep = 0
  1403.             END IF
  1404.           ELSE
  1405.             IF  (ABS(INT(SignXX(xy(i-1).y - xy(i).y)) -
  1406.      +           INT(SignXX(xy(i).y - xy(i+1).y))) .EQ. 2) THEN
  1407.                ep = 1
  1408.              ELSE
  1409.                ep = 0
  1410.              END IF
  1411.           END IF
  1412.  
  1413.           IF (xy(i - 1).Y .NE. xy(i).y) THEN
  1414.             CALL MemDraw(xy(i - 1).x, xy(i - 1).y,
  1415.      +                   xy(i).x, xy(i).y, i, ep)
  1416.           END IF
  1417.         END DO
  1418.         ! Sort pixel list of polygon outline
  1419.         CALL QCKSRT
  1420.         plotit = 1
  1421.  
  1422.         ! set to fill color
  1423.         CALL Selectcolor (fillcolor)
  1424.  
  1425.         ! Initialze edge table for first edge
  1426.         EdgeTable(FillStack(0).edge) = 1
  1427.         DO i = 0, fspntr - 1
  1428.           ! check and make sure points are on the same scan line
  1429.           IF (FillStack(i).y .EQ. FillStack(i + 1).y) THEN
  1430.           ! check and make sure edges are different
  1431.             IF (FillStack(i).edge .NE. FillStack(i + 1).edge) THEN
  1432.           ! check and make sure edge has not be encountered before
  1433.               IF (EdgeTable(FillStack(i + 1).edge) .NE. 1) THEN
  1434.           ! IF polygon interior (plotit=1)  draw line between edges
  1435.                 IF (plotit .EQ. 1) THEN
  1436.                   CALL TLine(FillStack(i).x, FillStack(i).y,
  1437.      +                 FillStack(i + 1).x, FillStack(i).y)
  1438.                   plotit = 0  ! set plotit false
  1439.                 ELSE
  1440.                   plotit = 1  ! set plot it true
  1441.                 END IF
  1442.               END IF
  1443.               ! Enter edge into edge table
  1444.               EdgeTable(FillStack(i + 1).edge) = 1
  1445.             END IF
  1446.           ELSE
  1447.             ! y values different means scan line transition
  1448.             ! reset plotit to 1, and EdgeTable
  1449.             plotit = 1
  1450.              DO j = 0, 1000
  1451.                   EdgeTable(j) = 0
  1452.              END DO
  1453.             EdgeTable(FillStack(i + 1).edge) = 1
  1454.           END IF
  1455.         END DO
  1456.  
  1457.        ! set to outline color
  1458.          CALL Selectcolor (outlinecolor)
  1459.         ! draw outline of polygon
  1460.         DO i = 1, n - 1
  1461.            CALL Tline(xy(i - 1).x, xy(i - 1).y, xy(i).x,xy(i).y)
  1462.         END DO
  1463.       DEALLOCATE(EdgeTable, STAT=IErr)
  1464.       END !SUBROUTINE
  1465.  
  1466.       SUBROUTINE PolyFillWorldAbs (x, y, fillstyle,
  1467.      +                               fillcolor, numdat)
  1468.        INCLUDE 'GRAFTYPE.FOR'
  1469.        INCLUDE 'STDHDR.FOR'
  1470.        INTEGER outline, fillstyle, fillcolor, numdat
  1471.        INTEGER  vx, vy, vh, vl
  1472.        COMMON /ViewVals/ vx, vy, vh, vl
  1473.        REAL x(0:maxv), y(0:maxv)
  1474.        RECORD /xyrec/ polyvector[ALLOCATABLE](:)
  1475.        ALLOCATE(polyVector(0:maxv),STAT=iErr)
  1476.  
  1477.         DO i = 0, numdat - 1
  1478.           PolyVector(i).x = NINT(ConvertX1(x(i)))
  1479.           PolyVector(i).y = vh-NINT(ConvertY1(y(i)))
  1480.           ! added vh to line above to invert fill 5/18/90
  1481.         END DO
  1482.         CALL GetColXX(outline)
  1483.         CALL SetFillStyleXX(fillstyle, fillcolor)
  1484.         CALL FillPoly(PolyVector, numdat, fillcolor, outline)
  1485.         DEALLOCATE(polyVector, STAT=iErr)
  1486.       END !SUBROUTINE
  1487.  
  1488.  
  1489.       FUNCTION SignXX(i)
  1490.       INTEGER i, result
  1491.  
  1492.        IF (i .GT. 0) THEN
  1493.          result = 1
  1494.        ELSE
  1495.         IF (i .LT. 0) THEN
  1496.           result = -1
  1497.         ELSE
  1498.           result = 0
  1499.         END IF
  1500.        END IF
  1501.        SignXX = REAL(result)
  1502.       END !FUNCTION
  1503.  
  1504.       SUBROUTINE TLine (x1, y1, x2, y2)
  1505.         INCLUDE 'FGRAPH.FD'
  1506.         INTEGER x1, y1, x2, y2, dummy
  1507.         RECORD /xycoord/ position
  1508.  
  1509.           CALL moveto (x1, y1, position)
  1510.           dummy =  lineto( x2, y2)
  1511.       END !SUBROUTINE
  1512.  
  1513.  
  1514.  
  1515. !
  1516. ! 1/19/90 Changed settextstyleXX for Current Font Attributes
  1517. !          allows PlotterOn, CRTGraphOFF
  1518.  
  1519. ! Enhancement
  1520. ! 1/23/90 Added Polygon fill routines for monochrome display
  1521.  
  1522. ! 5/18/90 Change direction of polyfillworldabs routine by subtracting
  1523. !         calculated y value from viewport height vh
  1524. !