home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e003 / 13.ddi / PO2.FOR < prev    next >
Encoding:
Text File  |  1987-10-29  |  23.2 KB  |  839 lines
  1.       SUBROUTINE ELTPLT(NLCP,NDF,MAXL,NGPT,NELT,NCP,LCP,X,Y,Z,DNX,DNY,
  2.      1DNZ,LCDX,LCDY,IBC,IWTYP,NEXT)
  3.       LOGICAL RGET,IGET
  4.       COMMON/CALCOM/ICAL,XSIZE,YSIZE
  5.       COMMON/UNIT/II11,II22
  6.       COMMON/IGL100/IGLKEY
  7.       DIMENSION NCP(NELT),LCP(NLCP),X(NGPT),Y(NGPT),Z(NGPT)
  8.      1,LCDX(NGPT),LCDY(NGPT),IBC(NGPT)
  9.      2,DNX(NDF),DNY(NDF),DNZ(NDF),IWTYP(NELT)
  10.       COMMON /MES/L(10),V(10),I,IS,IERR
  11.       COMMON/LFIRST/IFIRST
  12.       COMMON/HP21/IHP21
  13.       COMMON /PT/NU,NS,VC(3)
  14.       COMMON/IWINDO/IWIND,XM1,XM2,YM1,YM2
  15.       COMMON /PLT/IPN,IEN,ILN,XB,YB,SC,SCL,SCD,SCFL,SCFD,ISR,INR,LABL
  16.      1,TYPEU,TYPED,WHAT,LNTYPD,LNTYPU,SCALE,IBCS,IPOINT,ILOAD
  17.       COMMON /BX/BM(3),BL(6),BLS(6)
  18.       COMMON/LAB/ILAB
  19.       COMMON /ANG/H,SX,SY,CX,CY,IDC(3)
  20.       DATA UUU/1HU/,DDD/1HD/,BBB/1HB/
  21. 11    IF(NEXT.EQ.0)CALL INITM(NGPT,NELT,X,Y,Z)
  22.       NEXT=0
  23. 21    CALL COMM
  24.       IF(I.EQ.17.OR.I.EQ.30)GO TO 200
  25.       IF(I.EQ.26)GO TO 61
  26.       GO TO (31,41,51,54,61,71,81,11,91,101,111,121,131),I
  27. 31    IPN=-IPN
  28.       GO TO 21
  29. 41    IEN=-IEN
  30.       GO TO 21
  31. 51    ILN=-ILN
  32.       GO TO 21
  33. 54    IPOINT=-IPOINT
  34.       GO TO 21
  35. 61    CALL ANGS
  36.       IF(IHP21.EQ.1)IHP21=-3
  37.       CALL SCALEM
  38. 62    CALL ERASE
  39. 63    CALL AXESPT
  40.       IF(IHP21.EQ.-3)IHP21=1
  41.       GO TO 21
  42. 71    CALL BOX
  43.       GO TO 21
  44. 81    H=V(1)
  45.       GO TO 21
  46. 91    CALL SCALEM
  47.       ZERO=0.0
  48.       IZERO=0
  49.       IF(ICAL.EQ.1)WRITE(*,93)
  50.       IF(ICAL.EQ.1)WRITE(10,95)IZERO,XSIZE,YSIZE
  51. 95    FORMAT(I10,2F10.3)
  52.       CALL PLOTM(NLCP,NDF,NGPT,NELT,NCP,LCP,X,Y,Z,DNX,DNY,DNZ,MAXL
  53.      1,LCDX,LCDY,IBC,IWTYP)
  54. 93    FORMAT(' START CREATING PLOT FILE FOR CALCOMP PLOTTER')
  55.       IF(ICAL.EQ.1)WRITE(10,95)IZERO,ZERO,ZERO
  56.       IF(ICAL.EQ.1)WRITE(*,96)
  57. 96    FORMAT(' CALCOMP FILE IS CREATED')
  58. 94    FORMAT(I10)
  59.       CALL DWINDO(XM1,XM2,YM1,YM2)
  60.       GO TO 21
  61. 101   RETURN
  62. 111   LABL=-LABL
  63.       GO TO 21
  64. 121   SCALE=V(1)
  65.       GO TO 21
  66. 131   IBCS=-IBCS
  67.       GO TO 21
  68. 200   WRITE(*,201)
  69. 201   FORMAT(' INPUT NODE NUMBER ,0 TERMINATE')
  70. 202   WRITE(*,203)
  71. 203   FORMAT(2H ?)
  72. 210   CALL GETNL(GET001)
  73.       IF(IGET(NONO))GO TO 210
  74.       IF(NONO.LE.0)GO TO 21
  75.       IF(IFIRST.NE.0)NONO=NONO-IFIRST+1
  76.       IF(NONO.GT.NGPT)GO TO 230
  77.       IF(I.EQ.30)GO TO 710
  78.       WRITE(*,228)
  79. 228   FORMAT(' --- UNDEFORMED SHAPE ---')
  80.       WRITE(*,220)NONO,X(NONO),Y(NONO),Z(NONO)
  81. 220   FORMAT('  NODE =',I5,'  X= ',E12.5,'  Y= ',E12.5,'  Z= ',E12.5)
  82.       IF(WHAT.EQ.UUU)GO TO 202
  83.       WRITE(*,240)
  84. 240   FORMAT(' +++ DISPLACEMENTS +++')
  85.       WRITE(*,220)NONO,DNX(NONO),DNY(NONO),DNZ(NONO)
  86.       GO TO 202
  87. 230   WRITE(*,231)NONO
  88. 231   FORMAT(' NODE =',I5,' DOES NOT EXIST ')
  89.       GO TO 202
  90. 710   WRITE(*,711)NONO,X(NONO),Y(NONO),Z(NONO)
  91. 711   FORMAT(10X,' NODE NUMBER =',I5,' PRESENT COORDINATES'
  92.      1,/,20X,'X = ',F15.5,1X,' Y = ',F15.5,1X,' Z = ',F15.5)
  93. 713   WRITE(*,712)
  94. 712   FORMAT(16X,'NEW X =')
  95.       CALL GETNL(GET001)
  96.       IF(RGET(XDUM))GO TO 714
  97.       X(NONO)=XDUM
  98. 714   WRITE(*,715)
  99. 715   FORMAT(16X,'NEW Y = ')
  100.       CALL GETNL(GET001)
  101.       IF(RGET(YDUM))GO TO 716
  102.       Y(NONO)=YDUM
  103. 716   WRITE(*,717)
  104. 717   FORMAT(16X,'NEW Z = ')
  105.       CALL GETNL(GET001)
  106.       IF(RGET(ZDUM))GO TO 200
  107.       Z(NONO)=ZDUM
  108.       GO TO 200
  109.       END
  110.       SUBROUTINE ENF(V,T)
  111.       DIMENSION T(3)
  112.       KK=LENSTR(T,V)
  113.       RETURN
  114.       END
  115.       SUBROUTINE ENF1(I,M)
  116.       DIMENSION M(1)
  117.       XX=FLOAT(I)
  118.       KK=LENSTR(M,XX)
  119.       RETURN
  120.       END
  121.       SUBROUTINE ERROR(I)
  122.       COMMON/UNIT/II11,II22
  123.       J=IABS(I)
  124.       WRITE(*,10)J
  125. 10    FORMAT(' ***** INCREASE THE MTOT IN POST PROGRAM BY =',I6)
  126.       RETURN
  127.       END
  128.       SUBROUTINE FINODE(K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  129.       COMMON/MES/L(10)
  130.       COMMON/HIDDEN/I123,J123,NHID1(3000)
  131.       COMMON/PLT/I01,I02,I03,XBB,YBB,SCC
  132.       COMMON/KAMY/MXNDNM,NUMNP,NEL,VX,VY,VZ,
  133.      $IPOINT,S,F,D,
  134.      $ID(20),RESULT,XKS(4),YKS(4),ZKS(4),ZSS
  135.       COMMON/ELRANG/IRANG
  136.       DIMENSION VCC(3)
  137.       DIMENSION XE(K0),YE(K0),ZE(K0),XS(K0),YS(K0),ZS(K0),NODE(K0)
  138.      1,X(K0),Y(K0),Z(K0)
  139.       DIMENSION WORD(13)
  140.       D1=-L(1)
  141.       D2=-L(2)
  142.       D3=-L(3)
  143.       S=0.0
  144.       F=0.0
  145.       D=20000.0
  146.       DO 555 IGOG=1,K0
  147.       XS(IGOG)=0.0
  148.       YS(IGOG)=0.0
  149.       ZS(IGOG)=0.0
  150.       NHID1(IGOG)=0
  151.       NODE(IGOG)=0
  152. 555   CONTINUE
  153.       REWIND 31
  154.       READ(31,20)WORD
  155. 20    FORMAT(13A4)
  156.       READ(31,21)IDUM
  157.       IF(IDUM.GT.0)NUMNP=IDUM
  158.       IF(IDUM.GT.0)GO TO 19
  159. 21    FORMAT(5X,I5)
  160.       READ(31,21)NUMNP
  161. 19    MXNDNM=0
  162.       DIMAX=0.
  163. 50    READ(31,21)IPOINT
  164.       IF(IPOINT.GT.MXNDNM)MXNDNM=IPOINT
  165.       IF(IPOINT.EQ.0)GO TO 30
  166.       READ(31,22)AO,BO,CO
  167. 22    FORMAT(3E12.5)
  168.       X(IPOINT)=AO
  169.       Y(IPOINT)=BO
  170.       Z(IPOINT)=CO
  171.       IF(AO.GT.DIMAX)DIMAX=AO
  172.       IF(BO.GT.DIMAX)DIMAX=BO
  173.       IF(CO.GT.DIMAX)DIMAX=CO
  174.       NODE(IPOINT)=IPOINT
  175.       GO TO 50
  176.  
  177.  
  178. 30    VX=D1*DIMAX*11.
  179.       VY=D2*DIMAX*11.
  180.       VZ=D3*DIMAX*11.
  181.  
  182.  
  183.       DO 284 IRR=1,MXNDNM
  184.       IF(NODE(IRR).EQ.0)GO TO 284
  185.       F1=X(IRR)
  186.       F2=Y(IRR)
  187.       F3=Z(IRR)
  188.       CALL EYE(F1,F2,F3,IRR,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  189. 284   CONTINUE
  190.       DO 285 IPOT=1,MXNDNM
  191.       IF(NODE(IPOT).EQ.0)GO TO 285
  192.       VCC(1)=X(IPOT)
  193.       VCC(2)=Y(IPOT)
  194.       VCC(3)=Z(IPOT)
  195.       CALL SCNCD(VCC,EX0,VY0)
  196.       XS(IPOT)=(EX0-XBB)*SCC+400.
  197.       YS(IPOT)=(VY0-YBB)*SCC+400.
  198.       ZS(IPOT)=(F*(ZE(IPOT)-D))/(ZE(IPOT)*(F-D))
  199. 285   CONTINUE
  200.  
  201.       REWIND 11
  202.       READ(31,21)NUMEL
  203.       NEL=0
  204. 35    READ(31,21)MTYP
  205.       IF(MTYP.EQ.0)GO TO 100
  206.       IF(MTYP.EQ.10)MTYP=5
  207.       IF(MTYP.EQ.11.OR.MTYP.EQ.12.OR.MTYP.EQ.13)MTYP=4
  208.       READ(31,24)ILN,(ID(J),J=1,8)
  209.       IF(IRANG.NE.1)GO TO 210
  210.       CALL SEELM1(ILN,IKOB)
  211.       IF(IKOB.NE.1)GO TO 35
  212. 210   CONTINUE
  213. 24    FORMAT(5X,15(I5))
  214.  
  215.  
  216.       GO TO (1,2,3,4,5,6,7,8,9),MTYP
  217. 1     GO TO 35
  218. 2     GO TO 35
  219. 3     NEL=NEL+1
  220.       IF(ID(4).EQ.0)WRITE(11)NEL,ID(1),ID(2),ID(3),ID(3)
  221.       IF(ID(4).NE.0)WRITE(11)NEL,(ID(K),K=1,4)
  222.       GO TO 35
  223. 4     GO TO 3
  224. 5     IF(ID(7).EQ.0)GO TO 61
  225.       NEL=NEL+1
  226.       WRITE(11)NEL,ID(1),ID(2),ID(6),ID(5)
  227.       NEL=NEL+1
  228.       WRITE(11)NEL,ID(3),ID(4),ID(8),ID(7)
  229.       NEL=NEL+1
  230.       WRITE(11)NEL,ID(2),ID(3),ID(7),ID(6)
  231.       NEL=NEL+1
  232.       WRITE(11)NEL,ID(1),ID(4),ID(8),ID(5)
  233.       NEL=NEL+1
  234.       WRITE(11)NEL,ID(5),ID(6),ID(7),ID(8)
  235.       NEL=NEL+1
  236.       WRITE(11)NEL,(ID(K),K=1,4)
  237.       GO TO 35
  238. 61    NEL=NEL+1
  239.       WRITE(11)NEL,ID(1),ID(2),ID(5),ID(4)
  240.       NEL=NEL+1
  241.       WRITE(11)NEL,ID(2),ID(3),ID(6),ID(5)
  242.       NEL=NEL+1
  243.       WRITE(11)NEL,ID(1),ID(3),ID(6),ID(4)
  244.       NEL=NEL+1
  245.       WRITE(11)NEL,ID(1),ID(2),ID(3),ID(3)
  246.       NEL=NEL+1
  247.       WRITE(11)NEL,ID(4),ID(5),ID(6),ID(6)
  248.       GO TO 35
  249. 6     GO TO 3
  250. 7     GO TO 35
  251. 8     GO TO 3
  252. 9     GO TO 35
  253.  
  254.  
  255. 10    READ(31,32)ILN,(ID(J),J=1,20)
  256.       IF(IRANG.NE.1)GO TO 220
  257.       CALL SEELM1(ILN,IKOB)
  258.       IF(IKOB.NE.1)GO TO 35
  259. 220   CONTINUE
  260. 32    FORMAT(5X,20(I5))
  261.       TEST=0.
  262.       DO 110 I=9,20
  263.       IF(ID(I).EQ.0)GO TO 110
  264.       ITEST=1
  265. 110   CONTINUE
  266.       IF(ITEST.EQ.0)GO TO 5
  267.  
  268.  
  269.       MXNDNM=NUMNP
  270.       IF(ID(9).EQ.0)CALL INTERS(ID(1),ID(2),9,K0,XE,YE,ZE,XS,YS,ZS,NODE
  271.      1,X,Y,Z)
  272.       IF(ID(10).EQ.0)CALL INTERS(ID(2),ID(3),10,K0,XE,YE,ZE,XS,YS,ZS,NODE
  273.      1,X,Y,Z)
  274.       IF(ID(11).EQ.0)CALL INTERS(ID(3),ID(4),11,K0,XE,YE,ZE,XS,YS,ZS,NODE
  275.      1,X,Y,Z)
  276.       IF(ID(12).EQ.0)CALL INTERS(ID(4),ID(1),12,K0,XE,YE,ZE,XS,YS,ZS,NODE
  277.      1,X,Y,Z)
  278.       IF(ID(13).EQ.0)CALL INTERS(ID(5),ID(6),13,K0,XE,YE,ZE,XS,YS,ZS,NODE
  279.      1,X,Y,Z)
  280.       IF(ID(14).EQ.0)CALL INTERS(ID(6),ID(7),14,K0,XE,YE,ZE,XS,YS,ZS,NODE
  281.      1,X,Y,Z)
  282.       IF(ID(15).EQ.0)CALL INTERS(ID(7),ID(8),15,K0,XE,YE,ZE,XS,YS,ZS,NODE
  283.      1,X,Y,Z)
  284.       IF(ID(16).EQ.0)CALL INTERS(ID(8),ID(5),16,K0,XE,YE,ZE,XS,YS,ZS,NODE
  285.      1,X,Y,Z)
  286.       IF(ID(17).EQ.0)CALL INTERS(ID(1),ID(5),17,K0,XE,YE,ZE,XS,YS,ZS,NODE
  287.      1,X,Y,Z)
  288.       IF(ID(18).EQ.0)CALL INTERS(ID(2),ID(6),18,K0,XE,YE,ZE,XS,YS,ZS,NODE
  289.      1,X,Y,Z)
  290.       IF(ID(19).EQ.0)CALL INTERS(ID(3),ID(7),19,K0,XE,YE,ZE,XS,YS,ZS,NODE
  291.      1,X,Y,Z)
  292.       IF(ID(20).EQ.0)CALL INTERS(ID(4),ID(8),20,K0,XE,YE,ZE,XS,YS,ZS,NODE
  293.      1,X,Y,Z)
  294.  
  295.  
  296.       NO1=ID(9)
  297.       NO2=ID(11)
  298.       NO3=ID(10)
  299.       NO4=ID(12)
  300.       MXNDNM=MXNDNM+1
  301.       CALL IMAGIN(NO1,NO2,NO3,NO4,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  302.       NEL=NEL+1
  303.       WRITE(11)NEL,ID(1),NO1,MXNDNM,NO4
  304.       NEL=NEL+1
  305.       WRITE(11)NEL,ID(2),NO3,MXNDNM,NO1
  306.       NEL=NEL+1
  307.       WRITE(11)NEL,NO3,ID(3),NO2,MXNDNM
  308.       NEL=NEL+1
  309.       WRITE(11)NEL,MXNDNM,NO2,ID(4),NO4
  310.       NO1=ID(11)
  311.       NO2=ID(15)
  312.       NO3=ID(19)
  313.       NO4=ID(20)
  314.       MXNDNM=MXNDNM+1
  315.       CALL IMAGIN(NO1,NO2,NO3,NO4,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  316.       NEL=NEL+1
  317.       WRITE(11)NEL,ID(3),NO3,MXNDNM,NO1
  318.       NEL=NEL+1
  319.       WRITE(11)NEL,NO3,ID(7),NO2,MXNDNM
  320.       NEL=NEL+1
  321.       WRITE(11)NEL,MXNDNM,NO2,ID(8),NO4
  322.       NEL=NEL+1
  323.       WRITE(11)NEL,NO1,MXNDNM,NO4,ID(4)
  324.       NO1=ID(15)
  325.       NO2=ID(13)
  326.       NO3=ID(14)
  327.       NO4=ID(16)
  328.       MXNDNM=MXNDNM+1
  329.       CALL IMAGIN(NO1,NO2,NO3,NO4,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  330.       NEL=NEL+1
  331.       WRITE(11)NEL,ID(7),NO3,MXNDNM,NO1
  332.       NEL=NEL+1
  333.       WRITE(11)NEL,NO1,MXNDNM,NO4,ID(8)
  334.       NEL=NEL+1
  335.       NEL=NEL+1
  336.       WRITE(11)NEL,NO3,ID(6),NO2,MXNDNM
  337.       NEL=NEL+1
  338.       WRITE(11)NEL,MXNDNM,NO2,ID(5),NO4
  339.       NO1=ID(13)
  340.       NO2=ID(9)
  341.       NO3=ID(18)
  342.       NO4=ID(17)
  343.       MXNDNM=MXNDNM+1
  344.       CALL IMAGIN(NO1,NO2,NO3,NO4,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  345.       NEL=NEL+1
  346.       WRITE(11)NEL,ID(6),NO3,MXNDNM,NO1
  347.       NEL=NEL+1
  348.       WRITE(11)NEL,NO1,MXNDNM,NO4,ID(5)
  349.       NEL=NEL+1
  350.       WRITE(11)NEL,NO3,ID(2),NO2,MXNDNM
  351.       NEL=NEL+1
  352.       WRITE(11)NEL,MXNDNM,NO2,ID(1),NO4
  353.       NO1=ID(10)
  354.       NO2=ID(14)
  355.       NO3=ID(18)
  356.       NO4=ID(19)
  357.       MXNDNM=MXNDNM+1
  358.       CALL IMAGIN(NO1,NO2,NO3,NO4,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  359.       NEL=NEL+1
  360.       WRITE(11)NEL,ID(2),NO3,MXNDNM,NO1
  361.       NEL=NEL+1
  362.       WRITE(11)NEL,NO1,MXNDNM,NO4,ID(3)
  363.       NEL=NEL+1
  364.       WRITE(11)NEL,NO3,ID(6),NO2,MXNDNM
  365.       NEL=NEL+1
  366.       WRITE(11)NEL,MXNDNM,NO2,ID(7),NO4
  367.       NO1=ID(12)
  368.       NO2=ID(16)
  369.       NO3=ID(17)
  370.       NO4=ID(20)
  371.       MXNDNM=MXNDNM+1
  372.       CALL IMAGIN(NO1,NO2,NO3,NO4,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  373.       NEL=NEL+1
  374.       WRITE(11)NEL,NO1,ID(1),NO3,MXNDNM,NO1
  375.       NEL=NEL+1
  376.       WRITE(11)NEL,NO1,MXNDNM,NO4,ID(4)
  377.       NEL=NEL+1
  378.       WRITE(11)NEL,NO3,ID(5),NO2,MXNDNM
  379.       NEL=NEL+1
  380.       WRITE(11)NEL,MXNDNM,NO2,ID(8),NO4
  381.       GO TO 35
  382.  
  383.  
  384. 11    READ(31,24)ILN,(ID(J),J=1,8)
  385.       IF(IRANG.NE.1)GO TO 230
  386.       CALL SEELM1(ILN,IKOB)
  387.       IF(IKOB.NE.1)GO TO 35
  388. 230   CONTINUE
  389.       ITEST=0
  390.       DO 116 I=5,8
  391.       IF(ID(I).EQ.0)GO TO 116
  392.       ITEST=1
  393. 116   CONTINUE
  394.       IF(ITEST.EQ.0)GO TO 3
  395.       MXNDNM=NUMNP
  396.       IF(ID(5).EQ.0)CALL INTERS(ID(1),ID(2),5,K0,XE,YE,ZE,XS,YS,ZS,NODE
  397.      1,X,Y,Z)
  398.       IF(ID(6).EQ.0)CALL INTERS(ID(2),ID(3),6,K0,XE,YE,ZE,XS,YS,ZS,NODE
  399.      1,X,Y,Z)
  400.       IF(ID(7).EQ.0)CALL INTERS(ID(3),ID(4),7,K0,XE,YE,ZE,XS,YS,ZS,NODE
  401.      1,X,Y,Z)
  402.       IF(ID(8).EQ.0)CALL INTERS(ID(4),ID(1),8,K0,XE,YE,ZE,XS,YS,ZS,NODE
  403.      1,X,Y,Z)
  404.       NO1=ID(5)
  405.       NO2=ID(7)
  406.       NO3=ID(8)
  407.       NO4=ID(6)
  408.       MXNDNM=MXNDNM+1
  409.       CALL IMAGIN(NO1,NO2,NO3,NO4,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  410.       NEL=NEL+1
  411.       WRITE(11)NEL,ID(1),ID(5),MXNDNM,ID(8)
  412.       NEL=NEL+1
  413.       WRITE(11)NEL,ID(8),MXNDNM,ID(7),ID(4)
  414.       NEL=NEL+1
  415.       WRITE(11)NEL,ID(5),ID(2),ID(6),MXNDNM
  416.       NEL=NEL+1
  417.       WRITE(11)NEL,MXNDNM,ID(6),ID(3),ID(7)
  418.       GO TO 35
  419.  
  420.  
  421. 100   CALL SUBHID(K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  422. 200   RETURN
  423.       END
  424.       SUBROUTINE SUBHID(K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  425.       REAL*8 ZSM8,ZSS8
  426.       COMMON/HIDDEN/I123,NH,NHID1(3000)
  427.       COMMON/KAMY/MXNDNM,NUMNP,NEL,VX,VY,VZ,
  428.      $IPOINT,S,F,D,
  429.      $ID(20),RESULT,XKS(4),YKS(4),ZKS(4),ZSS
  430.       DIMENSION IPLNOD(4)
  431.       DIMENSION XK(4),YK(4),ZK(4)
  432.       DIMENSION XE(K0),YE(K0),ZE(K0),XS(K0),YS(K0),ZS(K0),NODE(K0)
  433.      1,X(K0),Y(K0),Z(K0)
  434.       ERROR=0.0001
  435.       NH=0
  436.       REWIND 11
  437.       DO 4 J=1,NEL
  438.       READ(11)IPLANE,(IPLNOD(JJ),JJ=1,4)
  439.       DO 3 M=1,NUMNP
  440.       IF(NODE(M).LE.0)GO TO 3
  441.       DO 5 K=1,4
  442.       IF(NODE(M).EQ.IPLNOD(K))GO TO 3
  443.       LL=IPLNOD(K)
  444.       XK(K)=XS(LL)
  445.       XKS(K)=XS(LL)
  446.       YK(K)=YS(LL)
  447.       YKS(K)=YS(LL)
  448.       ZK(K)=ZS(LL)
  449.       ZKS(K)=ZS(LL)
  450. 5     CONTINUE
  451.       IF(ABS(XK(1)-XK(2)).LT.ERROR.AND.ABS(XK(2)-XK(3)).LT.ERROR.
  452.      $AND.ABS(XK(3)-XK(4)).LT.ERROR)GO TO 4
  453.       IF(ABS(YK(1)-YK(2)).LT.ERROR.AND.ABS(YK(2)-YK(3)).LT.ERROR.
  454.      $AND.ABS(YK(3)-YK(4)).LT.ERROR)GO TO 4
  455.       IF(ABS(XS(M)-XK(1)).LT.ERROR.AND.ABS(YS(M)-YK(1)).LT.
  456.      $ERROR)GO TO 19
  457.       IF(ABS(XS(M)-XK(2)).LT.ERROR.AND.ABS(YS(M)-YK(2)).LT.
  458.      $ERROR)GO TO 19
  459.       IF(ABS(XS(M)-XK(3)).LT.ERROR.AND.ABS(YS(M)-YK(3)).LT.
  460.      $ERROR)GO TO 19
  461.       IF(ABS(XS(M)-XK(4)).LT.ERROR.AND.ABS(YS(M)-YK(4)).LT.
  462.      $ERROR)GO TO 19
  463.       XMIN=XK(1)
  464.       YMIN=YK(1)
  465.       XMAX=XK(1)
  466.       YMAX=YK(1)
  467.       DO 7 MN=2,4
  468.       IF(XK(MN).LT.XMIN)XMIN=XK(MN)
  469.       IF(XK(MN).GT.XMAX)XMAX=XK(MN)
  470.       IF(YK(MN).LT.YMIN)YMIN=YK(MN)
  471.       IF(YK(MN).GT.YMAX)YMAX=YK(MN)
  472. 7     CONTINUE
  473.       IF(ABS(XS(M)).LT.ABS(XMIN).OR.ABS(XS(M)).GT.ABS(XMAX))GO TO 3
  474.       IF(ABS(YS(M)).LT.ABS(YMIN).OR.ABS(YS(M)).GT.ABS(YMAX))GO TO 3
  475.       CALL FINAL(XS(M),YS(M),K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  476.       IF(RESULT.EQ.1.0)GO TO 3
  477. 19    CALL DEPTH(XS(M),YS(M),K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  478.       ZSM8=ZS(M)
  479.       ZSS8=ZSS
  480.       IF(ZSM8.LT.ZSS8)GO TO 3
  481.       IF(DABS(ZSM8-ZSS8).LE.0.000001D0)GO TO 3
  482. 20    NH=NH+1
  483.       NHID1(NH)=M
  484.       NODE(M)=-M
  485. 3     CONTINUE
  486. 4     CONTINUE
  487.       RETURN
  488.       END
  489.       SUBROUTINE EYE(XOO,YOO,ZOO,IPOT,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  490.       COMMON/KAMY/MXNDNM,NUMNP,NEL,VX,VY,VZ,
  491.      $IPOINT,S,F,D,
  492.      $ID(20),RESULT,XKS(4),YKS(4),ZKS(4),ZSS
  493.       DIMENSION XE(K0),YE(K0),ZE(K0),XS(K0),YS(K0),ZS(K0),NODE(K0)
  494.      1,X(K0),Y(K0),Z(K0)
  495.       X1=XOO-VX
  496.       Y1=YOO-VY
  497.       Z1=ZOO-VZ
  498.       PI=4.*ATAN(1.)
  499.       ROT=90.*PI/180.
  500.       X2=X1
  501.       Y2=Y1*COS(ROT)+Z1*SIN(ROT)
  502.       Z2=-Y1*SIN(ROT)+Z1*COS(ROT)
  503.       IF(VX.EQ.0..AND.VY.EQ.0.)GO TO 43
  504.       TETA1=PI+ACOS(VY/(SQRT(VX**2+VY**2)))
  505.       GO TO 45
  506. 43    TETA1=PI
  507. 45    X3=X2*COS(-TETA1)-Z2*SIN(-TETA1)
  508.       Y3=Y2
  509.       Z3=X2*SIN(-TETA1)+Z2*COS(-TETA1)
  510.       TETA2=ACOS(SQRT(VX**2+VY**2)/SQRT(VX**2+VY**2+VZ**2))
  511.       X4=X3
  512.       Y4=Y3*COS(-TETA2)+Z3*SIN(-TETA2)
  513.       Z4=-Y3*SIN(-TETA2)+Z3*COS(-TETA2)
  514.       XE(IPOT)=X4
  515.       YE(IPOT)=Y4
  516.       ZE(IPOT)=-Z4
  517.       IF(ABS(XE(IPOT)).GT.S)S=XE(IPOT)
  518.       IF(ABS(YE(IPOT)).GT.S)S=YE(IPOT)
  519.       IF(ABS(ZE(IPOT)).GT.F)F=ZE(IPOT)
  520.       RETURN
  521.       END
  522.       SUBROUTINE DEPTH(SX,SY,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  523.       REAL*8 ONE,TWO,THREE,FOUR,FIVE
  524.       COMMON/KAMY/MXNDNM,NUMNP,NEL,VX,VY,VZ,
  525.      $IPOINT,S,F,D,
  526.      $ID(20),RESULT,XKS(4),YKS(4),ZKS(4),ZSS
  527.       ONE=XKS(1)*YKS(2)-XKS(2)*YKS(1)
  528.       TWO=XKS(1)*ZKS(2)-XKS(2)*ZKS(1)
  529.       THREE=XKS(1)-XKS(2)
  530.       FOUR=XKS(1)*YKS(3)-XKS(3)*YKS(1)
  531.       FIVE=XKS(1)*ZKS(3)-XKS(3)*ZKS(1)
  532.       SIX=XKS(1)-XKS(3)
  533.       IF((TWO*FOUR-FIVE*ONE).EQ.0.)GO TO 10
  534.       CC=(ONE*SIX-FOUR*THREE)/(TWO*FOUR-FIVE*ONE)
  535.       IF(ONE.EQ.0.)GO TO 10
  536.       BB=-(THREE+CC*TWO)/ONE
  537.       IF(XKS(1).EQ.0.)GO TO 10
  538.       AA=-(BB*YKS(1)+CC*ZKS(1)+1.)/XKS(1)
  539.       IF(CC.EQ.0.)GO TO 10
  540.       ZSS=-(1.+AA*SX+BB*SY)/CC
  541.       GO TO 20
  542. 10    ZSS=100.
  543. 20    RETURN
  544.       END
  545.       SUBROUTINE FINAL(CPX,CPY,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  546.       COMMON/KAMY/MXNDNM,NUMNP,NEL,VX,VY,VZ,
  547.      $IPOINT,S,F,D,
  548.      $ID(20),RESULT,XKS(4),YKS(4),ZKS(4),ZSS
  549.       DIMENSION GOY(4)
  550.       NI=0
  551.       ERROR=0.0001
  552.       DO 100 II=1,4
  553.       IP=II+1
  554.       IF(II.EQ.4)IP=1
  555.       IF(XKS(IP).EQ.XKS(II))GO TO 100
  556.       SMALLX=XKS(II)
  557.       IF(XKS(IP).LT.SMALLX)GO TO 150
  558.       BIGX=XKS(IP)
  559.       GO TO 200
  560. 150   SMALLX=XKS(IP)
  561.       BIGX=XKS(II)
  562. 200   IF(CPX.LT.SMALLX.OR.CPX.GT.BIGX)GO TO 100
  563.       YINT=(((CPX-XKS(II))*(YKS(IP)-YKS(II)))/
  564.      1(XKS(IP)-XKS(II)))+YKS(II)
  565.       NI=NI+1
  566.       GOY(NI)=YINT
  567. 100   CONTINUE
  568.       YLARGE=GOY(1)
  569.       YSMALL=GOY(1)
  570.       DO 300 NOK=2,NI
  571.       IF(GOY(NOK).LT.YSMALL)YSMALL=GOY(NOK)
  572.       IF(GOY(NOK).GT.YLARGE)YLARGE=GOY(NOK)
  573. 300   CONTINUE
  574.       RESULT=0.0
  575.       IF(CPY.LT.YSMALL.OR.CPY.GT.YLARGE)RESULT=1.0
  576.       RETURN
  577. 400   RESULT=0.0
  578.       RETURN
  579.       END
  580.       SUBROUTINE IMAGIN(NO1,NO2,NO3,NO4,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  581.       COMMON/KAMY/MXNDNM,NUMNP,NEL,VX,VY,VZ,
  582.      $IPOINT,S,F,D,
  583.      $ID(20),RESULT,XKS(4),YKS(4),ZKS(4),ZSS
  584.       DIMENSION XE(K0),YE(K0),ZE(K0),XS(K0),YS(K0),ZS(K0),NODE(K0)
  585.      1,X(K0),Y(K0),Z(K0)
  586.       A=X(NO2)-X(NO1)
  587.       B=Y(NO2)-Y(NO1)
  588.       C=X(NO4)-X(NO3)
  589.       D=Y(NO4)-Y(NO3)
  590.       E=Z(NO2)-Z(NO1)
  591.       X(MXNDNM)=(D*X(NO3)-C*Y(NO3)-(B*C*X(NO1))/A+C*Y(NO1))/(D-C*B/A)
  592.       WX=X(MXNDNM)
  593.       Y(MXNDNM)=(MX*B-B*X(NO1)+A*Y(NO1))/A
  594.       WY=Y(MXNDNM)
  595.       Z(MXNDNM)=((MY-Y(NO1))*E+B*Z(NO1))/B
  596.       WZ=Z(MXNDNM)
  597.       CALL EYE(WX,WY,WZ,MXNDNM,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  598.       RETURN
  599.       END
  600.       SUBROUTINE INTERS(ME1,ME2,KK,K0,XE,YE,ZE,XS,YS,ZS,NODE,X,Y,Z)
  601.       COMMON/KAMY/MXNDNM,NUMNP,NEL,VX,VY,VZ,
  602.      $IPOINT,S,F,D,
  603.      $ID(20),RESULT,XKS(4),YKS(4),ZKS(4),ZSS
  604.       DIMENSION XE(K0),YE(K0),ZE(K0),XS(K0),YS(K0),ZS(K0),NODE(K0)
  605.      1,X(K0),Y(K0),Z(K0)
  606.       MXNDNM=MXNDNM+1
  607.       ID(KK)=MXNDNM
  608.       X(MXNDNM)=(X(ME1)+X(ME2))/2.
  609.       Y(MXNDNM)=(Y(ME1)+Y(ME2))/2.
  610.       Z(MXNDNM)=(Z(ME1)+Z(ME2))/2.
  611.       RETURN
  612.       END
  613.       FUNCTION DECIMA(ERROR)
  614.       LOGICAL LEXP,AFTER,MINUS,ERROR
  615.       DOUBLE PRECISION MANT,DECIMA
  616.       INTEGER EXP
  617.       COMMON/FRECNM/MULTIP
  618.       LEXP    = .FALSE.
  619.       MINUS   = .FALSE.
  620.       AFTER   = .FALSE.
  621.       IOFF    = 1
  622.       MANT    = 0.0
  623.       EXP     = 0
  624.       X       = 0.0
  625.       DO 100  IPOSIT=1,20
  626.       N = IDIGFG(IPOSIT)
  627.       GO TO (5,5,5,5,5,5,5,5,5,5,100,12,13,14,14,16,17,18),N
  628. 5     IF (AFTER) GO TO 6
  629.       X = X*10.0 + N - 1.0
  630.       GO TO 100
  631. 6     Y = N - 1
  632.       X = X + Y/10.0**IOFF
  633.       IOFF = IOFF + 1
  634.       GO TO 100
  635. 12    MINUS = .TRUE.
  636.       GO TO 100
  637. 13    AFTER = .TRUE.
  638.       IOFF = 1
  639.       GO TO 100
  640. 14    MANT = X
  641.       IF (MINUS) MANT = -X
  642.       MINUS = .FALSE.
  643.       AFTER = .FALSE.
  644.       LEXP  = .TRUE.
  645.       X     = 0.0
  646.       GO TO 100
  647. 17    MULTIP=X
  648.       GO TO 100
  649. 100   CONTINUE
  650. 18    ERROR = .TRUE.
  651. 16    IF (LEXP) EXP = X
  652.       IF (LEXP.AND.MINUS) EXP = -X
  653.       IF (.NOT.LEXP) MANT = X
  654.       IF (.NOT.LEXP.AND.MINUS) MANT = -X
  655.       DECIMA = MANT*10.0**EXP
  656.       RETURN
  657.       END
  658.       FUNCTION ERR1(ERR001)
  659.       INTEGER SECT,POINT,BEGIN,GETSEC,EPOINT,BLANK,AGET,AGETW
  660.       LOGICAL EOL,EOS,EOF,ERROR,INDEX,GETWRD,IGET,RGET,ERR1
  661.       COMMON  /FRECNT/ LINE(80),SECT,EOL,EOS,EOF,
  662.      1ERROR,BLANK,ICOMMA,POINT,BEGIN,LENGTH,
  663.      2EPOINT,NSECT,LINENM,MAXSTR,KUNIT,JUNIT,IUNIT
  664.       ERR1=ERROR
  665.       RETURN
  666.       END
  667.       SUBROUTINE GETNL(GET001)
  668.       INTEGER SECT,POINT,BEGIN,GETSEC,EPOINT,BLANK,AGET,AGETW
  669.       LOGICAL EOL,EOS,EOF,ERROR,INDEX,GETWRD,IGET,RGET,ERR1
  670.       COMMON/UNIT/II1,II2,II3,II4,II5,ITER
  671.       COMMON/FRECNM/MULTIP
  672.       COMMON  /FRECNT/ LINE(80),SECT,EOL,EOS,EOF,
  673.      1ERROR,BLANK,ICOMMA,POINT,BEGIN,LENGTH,
  674.      2EPOINT,NSECT,LINENM,MAXSTR,KUNIT,JUNIT,IUNIT
  675.       DATA    IZER/1H0/,ININE/1H9/,ICOM/1H*/,IDOL/1H$/
  676.       MULTIP=0
  677.       IF (.NOT.ERROR) GO TO 100
  678. 9800  WRITE (*,9801)
  679. 9801  FORMAT (' SYNTAX ERROR , INPUT AGAIN')
  680.       WRITE(*,101)LINE
  681.       ERROR = .FALSE.
  682.       EPOINT = 1
  683. 100   READ (*,101,ERR=9800,END=910) (LINE(JJ),JJ=1,71)
  684. 101   FORMAT (71A1)
  685.       LINENM = LINENM + 1
  686. 210   CONTINUE
  687.       POINT = 1
  688.       EOL   = .FALSE.
  689.       EOS   = .FALSE.
  690.       RETURN
  691. 910   EOF = .TRUE.
  692.       RETURN
  693.       END
  694.       FUNCTION GETWRD(GET001)
  695.       INTEGER SECT,POINT,BEGIN,GETSEC,EPOINT,BLANK,AGET,AGETW
  696.       LOGICAL EOL,EOS,EOF,ERROR,INDEX,GETWRD,IGET,RGET,ERR1
  697.       COMMON  /FRECNT/ LINE(80),SECT,EOL,EOS,EOF,
  698.      1ERROR,BLANK,ICOMMA,POINT,BEGIN,LENGTH,
  699.      2EPOINT,NSECT,LINENM,MAXSTR,KUNIT,JUNIT,IUNIT
  700.       GETWRD = .FALSE.
  701.       LENGTH = 0
  702.       IF (EOL) RETURN
  703.       DO 100 BEGIN = POINT,80
  704.       IF (LINE(BEGIN).NE.BLANK) GO TO 110
  705. 100   CONTINUE
  706.       EOL = .TRUE.
  707.       POINT = 80
  708.       RETURN
  709. 110   DO 170 POINT = BEGIN,80
  710.       IF (LINE(POINT).EQ.BLANK.OR.LINE(POINT).EQ.ICOMMA)
  711.      1GO TO 180
  712.       LENGTH = POINT - BEGIN + 1
  713.       MAXSTR = LENGTH
  714. 170   CONTINUE
  715.       GETWRD = .TRUE.
  716.       EOL = .TRUE.
  717.       RETURN
  718. 180   IP = POINT
  719.       DO 200 POINT = POINT,80
  720.       IF (LINE(POINT).EQ.ICOMMA) GO TO 210
  721.       IF (LINE(POINT).NE.BLANK) GO TO 190
  722. 200   CONTINUE
  723.       GETWRD = .TRUE.
  724.       EOL =.TRUE.
  725.       RETURN
  726. 190   POINT = IP
  727.       GETWRD = .TRUE.
  728.       RETURN
  729. 210   POINT = POINT + 1
  730.       GETWRD = .TRUE.
  731.       RETURN
  732.       END
  733.       FUNCTION IDIGFG(IPOSIT)
  734.       INTEGER AGET
  735.       DIMENSION IVALID(17)
  736.       DATA IVALID/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H+,
  737.      11H-,1H.,1HE,1HD,1H ,1H*/
  738.       DO 100 IDIGFG=1,17
  739.       IF (AGET(IPOSIT).EQ.IVALID(IDIGFG)) GO TO 110
  740. 100   CONTINUE
  741.       IDIGFG = 18
  742. 110   RETURN
  743.       END
  744.       SUBROUTINE INITM(NGPT,NELT,X,Y,Z)
  745.       REAL*8 FNM
  746.       COMMON/HP21/IHP21,PAT21,HI21
  747.       COMMON/HIDDEN/IHIDE
  748.       COMMON/MSTREE/S100,S101,KALOR,NCOL
  749.       COMMON/SENOD1/ISEND
  750.       COMMON/SHLOAD/LOAD6
  751.       COMMON/IGL100/IGLKEY,IBAUD,IDEV,IOPT,PXSIZE,PYSIZE
  752.       COMMON/TEKPLT/KEYTEK
  753.       COMMON/RAMTEK/MTEK1
  754.       COMMON/VS11VA/IVS11,IMOVE
  755.       COMMON/CALCOM/ICAL
  756.       COMMON/SHRINK/ISHR1
  757.       COMMON/SHOWAX/ISHOW1
  758.       COMMON/GROUP/IGR1
  759.       DIMENSION X(NGPT),Y(NGPT),Z(NGPT)
  760.       DIMENSION FN(15),LN(2,15)
  761.       COMMON /MES/L(10),V(10),I,IS,IERR
  762.       COMMON /PLT/IPN,IEN,ILN,XB,YB,SC,SCL,SCD,SCFL,SCFD,ISR,INR,LABL
  763.      1,TYPEU,TYPED,WHAT,LNTYPD,LNTYPU,SCALE,IBCS,IPOINT,ILOAD
  764.       COMMON /BX/BM(3),BL(6),BLS(6)
  765.       COMMON/ROTAT/IROT
  766.       COMMON/WATYPE/KSTYPE
  767.       COMMON/STRESS/IFLOK,IST1
  768.       COMMON/IWINDO/IWIND,XM1,XM2,YM1,YM2,WINLEN
  769.       COMMON/ELRANG/IRANG
  770.       COMMON /ANG/H,SX,SY,CX,CY,IDC(3)
  771.       COMMON /PT/NU,NS,VC(3)
  772.       COMMON/LAB/ILAB
  773.       EQUIVALENCE (LM,FN),(LS,LN),(XJOB,FNM)
  774.       DATA BLNK/1H /,UUUU/1HU/,SSSS/1HS/
  775.       IF(I.EQ.8)GO TO 31
  776. 10    I300=30
  777.       CALL INITT(I300)
  778. 20    DO 11 I=1,5,2
  779.       BLS(I)=1.E20
  780. 11    BLS(I+1)=-1.E20
  781.       DO 21 I=1,NGPT
  782.       VC(1)=X(I)
  783.       VC(2)=Y(I)
  784.       VC(3)=Z(I)
  785.       DO 21 J=1,3
  786.       J2=2*J
  787.       IF (VC(J) .LT. BLS(J2-1)) BLS(J2-1)=VC(J)
  788.       IF (VC(J) .GT. BLS(J2)) BLS(J2)=VC(J)
  789. 21    CONTINUE
  790. 31    LABL=-1
  791.       WHAT=UUUU
  792.       TYPEU=SSSS
  793.       LNTYPD=3434
  794.       LNTYPU=0
  795.       ILN=1
  796.       IWIND=-1
  797.       XM1=0.0
  798.       XM2=800.0
  799.       YM1=0.0
  800.       YM2=800.0
  801.       WINLEN=800.
  802.       IHP21=-1
  803.       IHIDE=-1
  804.       NCOL=7
  805.       MTEK1=-1
  806.       IGLKEY=0
  807.       IMOVE=-1
  808.       ISHOW1=-1
  809.       ICAL=-1
  810.       ISHR1=-1
  811.       ISEND=-1
  812.       LOAD6=-1
  813.       IROT=-1
  814.       KSTYPE=-1
  815.       IGR1=-1
  816.       PAT21=10.0
  817.       IRANG=-1
  818.       HI21=12.0
  819.       ILOAD=-1
  820.       IBCS=-1
  821.       IPOINT=-1
  822.       IPN=-1
  823.       IEN=-1
  824.       IST1=-1
  825.       H=1.E20
  826.       SX=0.
  827.       SY=0.
  828.       CX=1.
  829.       CY=1.
  830.       IDC(1)=0
  831.       IDC(2)=0
  832.       IDC(3)=1
  833.       DO 41 I=1,6
  834. 41    BL(I)=BLS(I)
  835.       DO 51 I=1,3
  836. 51    BM(I)=.5*(BL(2*I)+BL(2*I-1))
  837.       RETURN
  838.       END
  839.