home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l292 / 1.ddi / PLOT3D.FOR < prev    next >
Encoding:
Text File  |  1990-01-22  |  8.0 KB  |  349 lines
  1.  
  2.       SUBROUTINE Close3DGraphics
  3.       CALL CloseGraphics
  4.       END !SUBROUTINE
  5.  
  6.       SUBROUTINE Concat2 (a, b, c)
  7.       REAL a(0:8), b(0:8), c(0:8)
  8.       INTEGER  i3
  9.       DO i = 0 , 2
  10.         i3 = i * 3
  11.         DO j = 0 , 2
  12.            c(i3 + j) = a(i3 + 0) * b(j) + a(i3 + 1) * b(3 + j) +
  13.      +                 a(i3 + 2) * b(6 + j)
  14.         END DO
  15.       END DO
  16.       END !SUBROUTINE
  17.  
  18.       SUBROUTINE Concat3 (a, b, c)
  19.       REAL a(0:15), b(0:15), c(0:15)
  20.       INTEGER i,j, i4
  21.  
  22.       DO i = 0 , 3
  23.         i4 = i * 4
  24.         DO j = 0 , 3
  25.           c(i4 + j) = a(i4 + 0) * b(j) + a(i4 + 1) *
  26.      +        b(4 + j) + a(i4 + 2) *
  27.      +        b(8 + j) + a(i4 + 3) * b(12 + j)
  28.         END DO
  29.        END DO
  30.  
  31.       END !SUBROUTINE
  32.  
  33.  
  34.  
  35.       SUBROUTINE Draw3DAxes (x, y, z)
  36.       CALL Move3Abs(0.0, 0.0, 0.0)
  37.       CALL Line3Abs(x, 0.0, 0.0)
  38.       CALL Move3Abs(0.0, 0.0, 0.0)
  39.       CALL Line3Abs(0.0, y, 0.0)
  40.       CALL Move3Abs(0.0, 0.0, 0.0)
  41.       CALL Line3Abs(0.0, 0.0, z)
  42.       END !SUBROUTINE
  43.  
  44.       SUBROUTINE IdArg (a)
  45.       REAL a(0:8)
  46.       INTEGER i, j, i3
  47.  
  48.       DO i = 0 , 2
  49.         i3 = i * 3
  50.         DO j = 0 , 2
  51.           a(i3 + j) = 0.0
  52.         END DO
  53.         a(i3 + i) = 1.0
  54.       END DO
  55.       END !SUBROUTINE
  56.  
  57.       SUBROUTINE IdArg3 (a)
  58.       REAL a(0:15)
  59.       INTEGER i,j, i4
  60.       DO i = 0 , 3
  61.         i4  = i * 4
  62.         DO j = 0 , 3
  63.            a(i4 + j) = 0.0
  64.         END DO
  65.         a(i4 + i) = 1.0
  66.       END DO
  67.       END !SUBROUTINE
  68.  
  69.  
  70.  
  71.       SUBROUTINE Ident (a)
  72.       REAL a(0:8)
  73.       CALL IdArg(a)
  74.       END !SUBROUTINE
  75.  
  76.  
  77.  
  78.       SUBROUTINE Ident3 (a)
  79.       REAL a(0:15)
  80.  
  81.       CALL IdArg3(a)
  82.       END !SUBROUTINE
  83.  
  84.  
  85.  
  86.  
  87.       SUBROUTINE Init3D (mode, pathname)
  88.       INTEGER mode
  89.       CHARACTER * 80 pathname
  90.       CALL OneTimeInit(mode, pathname)
  91.       END !SUBROUTINE
  92.  
  93.       SUBROUTINE Label3D (s)
  94.       CHARACTER * (*) s
  95.       CHARACTER * 80 outstring
  96.       INTEGER i
  97.       DO i = 1, 80
  98.        outstring(i:i) = ' '
  99.       END DO
  100.       outstring = s
  101.       CALL OutTextXX (outstring)
  102.       END !SUBROUTINE
  103.  
  104.       SUBROUTINE Line2Abs (x, y)
  105.       REAL x,y, xt, yt
  106.  
  107.       CALL Xfrm2P(x, y, xt, yt)
  108.       CALL lineworldabs(xt, yt)
  109.       END !SUBROUTINE
  110.  
  111.  
  112.  
  113.       SUBROUTINE Line2Rel (x, y)
  114.       REAL x,y, xt, yt
  115.  
  116.       CALL Xfrm2P(x, y, xt, yt)
  117.       CALL lineworldRel(xt, yt)
  118.       END !SUBROUTINE
  119.  
  120.  
  121.  
  122.       SUBROUTINE Line3Abs (x, y, z)
  123.       REAL x, y, z, xt, yt, zt, wt
  124.  
  125.       CALL Xfrm3P(x, y, z, 1.0, xt, yt, zt, wt)
  126.       xt = xt / wt
  127.       yt = yt / wt
  128.       CALL lineworldabs(xt, yt)
  129.       END !SUBROUTINE
  130.  
  131.  
  132.  
  133.       SUBROUTINE Line3Rel (x, y, z)
  134.       REAL x, y, z, xt, yt, zt, wt
  135.  
  136.       CALL Xfrm3P(x, y, z, 1.0, xt, yt, zt, wt)
  137.       xt = xt / wt
  138.       yt = yt / wt
  139.       CALL lineworldRel(xt, yt)
  140.       END !SUBROUTINE
  141.  
  142.  
  143.       SUBROUTINE Move2Abs (x, y)
  144.       REAL x, y, xt, yt
  145.  
  146.       CALL Xfrm2P(x, y, xt, yt)
  147.       CALL moveworldabs(xt, yt)
  148.       END !SUBROUTINE
  149.  
  150.       SUBROUTINE Move2Rel (x, y)
  151.       REAL xt, yt
  152.  
  153.       CALL Xfrm2P(x, y, xt, yt)
  154.       CALL moveworldrel(xt, yt)
  155.       END !SUBROUTINE
  156.  
  157.       SUBROUTINE Move3Abs (x, y, z)
  158.       REAL x, y, z, xt, yt, zt, wt
  159.  
  160.       CALL Xfrm3P(x, y, z, 1.0, xt, yt, zt, wt)
  161.       xt = xt / wt
  162.       yt = yt / wt
  163.       CALL moveworldabs(xt, yt)
  164.       END !SUBROUTINE
  165.  
  166.       SUBROUTINE Move3Rel (x, y, z)
  167.       REAL x, y, z, xt, yt, zt, wt
  168.  
  169.       CALL Xfrm3P(x, y, z, 1.0, xt, yt, zt, wt)
  170.       xt = xt / wt
  171.       yt = yt / wt
  172.       CALL moveworldrel(xt, yt)
  173.       END !SUBROUTINE
  174.  
  175.       SUBROUTINE Persp (dist)
  176.       REAL tmp3Mat(0 :15), t3Curnt(0:15), dist
  177.       COMMON /mat3D/ t3Curnt
  178.  
  179.       CALL IdArg3(tmp3Mat)
  180.       tmp3Mat(0) = -dist
  181.       tmp3Mat(5) = -dist
  182.       tmp3Mat(11) = 1.0
  183.       tmp3Mat(15) = -dist
  184.       CALL Concat3(t3Curnt, tmp3Mat, t3Curnt)
  185.       END !SUBROUTINE
  186.  
  187.       SUBROUTINE PolyFill3D (p, fillstyle, fillcolor, numdat)
  188.       INCLUDE 'GRAFTYPE.FOR'
  189.       INCLUDE 'STDHDR.FOR'
  190.       RECORD /point3D/  p(0:maxv)
  191.       INTEGER  fillstyle, fillcolor, numdat
  192.       REAL xt, yt, zt, wt
  193.       REAL x(0 :maxv)
  194.       REAL y(0 :maxv)
  195.       LOGICAL Bw
  196.  
  197.       DO i = 0 , numdat - 1
  198.         CALL Xfrm3P(p(i).x, p(i).y, p(i).z, 1.0, xt, yt, zt, wt)
  199.         x(i) = xt / wt
  200.         y(i) = yt / wt
  201.       END DO
  202.       CALL BlackAndWhite(Bw)
  203.       IF ( Bw) THEN
  204.         CALL PolyFillWorldAbs(x,y, fillstyle, fillcolor, numdat)
  205.       ELSE
  206.         CALL ColorPolyFillWorldAbs(x, y, fillstyle, fillcolor, numdat)
  207.       END IF
  208.       END !SUBROUTINE
  209.  
  210.  
  211.       SUBROUTINE tInit
  212.       REAL tCurnt(0:8)
  213.       COMMON /mat2d/ tCurnt
  214.       CALL Ident(tCurnt)
  215.       END !SUBROUTINE
  216.  
  217.  
  218.  
  219.       SUBROUTINE tInit3
  220.       REAL t3Curnt(0:15)
  221.       COMMON /mat3d/ t3Curnt
  222.  
  223.       CALL Ident3(t3Curnt)
  224.       END !SUBROUTINE
  225.  
  226.       SUBROUTINE WorldRotate2 (degree)
  227.       REAL tmpMat(0 :8),radian, degree
  228.       REAL tCurnt(0:8)
  229.       COMMON /mat2d/ tCurnt
  230.  
  231.       CALL IdArg(tmpMat)
  232.       radian = degree * 3.1415 / 180.0
  233.       tmpMat(0) = COS(radian)
  234.       tmpMat(1) = SIN(radian)
  235.       tmpMat(3) = -SIN(radian)
  236.       tmpMat(4) = COS(radian)
  237.       CALL Concat2(tCurnt, tmpMat, tCurnt)
  238.       END !SUBROUTINE
  239.  
  240.       SUBROUTINE WorldRotate3 (degree, iAxis)
  241.       REAL tmp3Mat(0 :15), sign, radian,degree
  242.       INTEGER i1, i2, iAxis, i14, i24
  243.       REAL t3Curnt(0:15)
  244.       COMMON /mat3d/ t3Curnt
  245.  
  246.       SELECT CASE (iAxis)
  247.        CASE (0)
  248.          i1 = 1
  249.          i2 = 2
  250.          sign = 1.0
  251.        CASE (1)
  252.          i1 = 0
  253.          i2 = 2
  254.          sign = -1.0
  255.        CASE (2)
  256.          i1 = 0
  257.          i2 = 1
  258.          sign = 1.0
  259.        CASE DEFAULT
  260.          i1 = 1
  261.          i2 = 2
  262.        END SELECT
  263.       CALL IdArg3(tmp3Mat)
  264.       radian = degree * 3.1415 / 180.0
  265.       i14 = i1 * 4
  266.       i24 = i2 * 4
  267.       tmp3Mat(i14 + i1) = COS(radian)
  268.       tmp3Mat(i24 + i2) = tmp3Mat(i14 + i1)
  269.       tmp3Mat(i14 + i2) = sign * SIN(radian)
  270.       tmp3Mat(i24 + i1) = -tmp3Mat(i14 + i2)
  271.       CALL Concat3(t3Curnt, tmp3Mat, t3Curnt)
  272.       END !SUBROUTINE
  273.  
  274.       SUBROUTINE WorldScale2 (x, y)
  275.       REAL tmpMat(0 :8), x, y
  276.       REAL tCurnt(0:8)
  277.       COMMON /mat2d/ tCurnt
  278.  
  279.       CALL IdArg(tmpMat)
  280.       tmpMat(0) = x
  281.       tmpMat(4) = y
  282.       CALL Concat2(tCurnt, tmpMat, tCurnt)
  283.       END !SUBROUTINE
  284.  
  285.       SUBROUTINE WorldScale3 (x, y, z)
  286.       REAL tmp3Mat(0 :15), x, y
  287.       REAL t3Curnt(0:15)
  288.       COMMON /mat3d/ t3Curnt
  289.  
  290.       CALL IdArg3(tmp3Mat)
  291.       tmp3Mat(0) = x
  292.       tmp3Mat(5) = y
  293.       tmp3Mat(10) = z
  294.       CALL Concat3(t3Curnt, tmp3Mat, t3Curnt)
  295.       END !SUBROUTINE
  296.  
  297.  
  298.  
  299.       SUBROUTINE WorldTran2 (x, y)
  300.       REAL tmpMat(0 :8), x, y
  301.       REAL tCurnt(0:8)
  302.       COMMON /mat2d/ tCurnt
  303.  
  304.       CALL IdArg(tmpMat)
  305.       tmpMat(6) = x
  306.       tmpMat(7) = y
  307.       CALL Concat2(tCurnt, tmpMat, tCurnt)
  308.       END !SUBROUTINE
  309.  
  310.  
  311.  
  312.       SUBROUTINE WorldTran3 (x, y, z)
  313.       REAL tmp3Mat(0 :15), x, y, z
  314.       REAL t3Curnt(0:15)
  315.       COMMON /mat3d/ t3Curnt
  316.  
  317.       CALL IdArg3(tmp3Mat)
  318.       tmp3Mat(12) = x
  319.       tmp3Mat(13) = y
  320.       tmp3Mat(14) = z
  321.       CALL Concat3(t3Curnt, tmp3Mat, t3Curnt)
  322.       END !SUBROUTINE
  323.  
  324.  
  325.       SUBROUTINE Xfrm2P (x, y, xt, yt)
  326.       REAL x, y, xt, yt
  327.       REAL tCurnt(0:8)
  328.       COMMON /mat2d/ tCurnt
  329.       xt = x * tCurnt(0) + y * tCurnt(3) + tCurnt(6)
  330.       yt = x * tCurnt(1) + y * tCurnt(4) + tCurnt(7)
  331.       xt = xt / tCurnt(8)
  332.       yt = yt / tCurnt(8)
  333.       END !SUBROUTINE
  334.  
  335.       SUBROUTINE Xfrm3P (x, y, z, w, xt, yt, zt, wt)
  336.       REAL x, y, z, w, xt, yt, zt, wt
  337.       REAL t3Curnt(0:15)
  338.       COMMON /mat3d/ t3Curnt
  339.       xt = x * t3Curnt(0) + y * t3Curnt(4) + z *
  340.      +          t3Curnt(8) + w * t3Curnt(12)
  341.       yt = x * t3Curnt(1) + y * t3Curnt(5) + z *
  342.      +          t3Curnt(9) + w * t3Curnt(13)
  343.       zt = x * t3Curnt(2) + y * t3Curnt(6) + z *
  344.      +          t3Curnt(10) + w * t3Curnt(14)
  345.       wt = x * t3Curnt(3) + y * t3Curnt(7) + z *
  346.      +          t3Curnt(11) + w * t3Curnt(15)
  347.       END !SUBROUTINE
  348.  
  349.