Télécharger mosu.eso

Retour à la liste

Numérotation des lignes :

  1. C MOSU SOURCE BP208322 16/11/18 21:19:29 9177
  2. C MODI SUPPRESSION D'UN ELEMENT
  3. C
  4. SUBROUTINE MOSU(XPROJ,IVU,ICPR,MELEME)
  5. IMPLICIT INTEGER(I-N)
  6. -INC CCREEL
  7. -INC SMELEME
  8. -INC CCGEOME
  9. COMMON/CMODI/LIGMAX,XDEC,YDEC
  10. DIMENSION XTR(10),YTR(10),ZTR(10)
  11. SEGMENT IVU(0)
  12. SEGMENT XPROJ(3,0)
  13. SEGMENT ICPR(0)
  14. SEGMENT ISOM(NBSO)
  15. do i=1,10
  16. ztr(i)=0
  17. enddo
  18. 5 CONTINUE
  19. CALL TRMESS('POINTEZ L''ELEMENT A SUPPRIMER')
  20. CALL MOPF3
  21. CALL TRDIG(XP,YP,INCLE)
  22. CALL TRMESS(' ')
  23. IF (INCLE.EQ.3) RETURN
  24. IPT1=MELEME
  25. SEGACT IPT1*MOD
  26. DO 20 IO=1,MAX(1,LISOUS(/1))
  27. IF (LISOUS(/1).NE.0) THEN
  28. IPT1=LISOUS(IO)
  29. SEGACT IPT1*MOD
  30. ENDIF
  31. NBNN=IPT1.NUM(/1)
  32. IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 60
  33. C C'EST UNE LIGNE
  34. DO 40 J=1,IPT1.NUM(/2)
  35. IA=ICPR(IPT1.NUM(1,J))
  36. IB=ICPR(IPT1.NUM(NBNN,J))
  37. IF (IVU(IA).NE.1) GOTO 40
  38. IF (IVU(IB).NE.1) GOTO 40
  39. XA=XPROJ(1,IA)
  40. YA=XPROJ(2,IA)
  41. XB=XPROJ(1,IB)
  42. YB=XPROJ(2,IB)
  43. SCA=(XP-XA)*(XP-XB)+(YP-YA)*(YP-YB)
  44. IF (SCA.LE.0.) GOTO 500
  45. 40 CONTINUE
  46. GOTO 100
  47. 60 IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 100
  48. C C'EST UNE SURFACE
  49. NBSO = NBSOM(IPT1.ITYPEL)
  50. IF (NBSO.EQ.0) THEN
  51. C Polygone a N cotes
  52. NBSO = IPT1.NUM(/1)
  53. ENDIF
  54. SEGINI ISOM
  55. DO 61 I=1,ISOM(/1)
  56. ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I)
  57. 61 CONTINUE
  58. DO 62 J=1,IPT1.NUM(/2)
  59. I1=ICPR(IPT1.NUM(ISOM(1),J))
  60. I2=ICPR(IPT1.NUM(ISOM(2),J))
  61. I3=ICPR(IPT1.NUM(ISOM(3),J))
  62. IF (IVU(I1).NE.1) GOTO 62
  63. IF (IVU(I2).NE.1) GOTO 62
  64. IF (IVU(I3).NE.1) GOTO 62
  65. X1=XPROJ(1,I1)
  66. X2=XPROJ(1,I2)
  67. X3=XPROJ(1,I3)
  68. Y1=XPROJ(2,I1)
  69. Y2=XPROJ(2,I2)
  70. Y3=XPROJ(2,I3)
  71. Z1=0.
  72. Z2=0.
  73. Z3=0.
  74. XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3)
  75. YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3)
  76. ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3)
  77. DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2)
  78. XNORM=XNORM/DNORM
  79. YNORM=YNORM/DNORM
  80. ZNORM=ZNORM/DNORM
  81. ANG=0.
  82. I1=ICPR(IPT1.NUM(ISOM(ISOM(/1)),J))
  83. XV1=XPROJ(1,I1)-XP
  84. YV1=XPROJ(2,I1)-YP
  85. ZV1=0.
  86. DO 63 IS=1,ISOM(/1)
  87. I2=ICPR(IPT1.NUM(ISOM(IS),J))
  88. XV2=XPROJ(1,I2)-XP
  89. YV2=XPROJ(2,I2)-YP
  90. ZV2=0.
  91. XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+
  92. # ZNORM*(XV1*YV2-YV1*XV2)
  93. YATA=XV1*XV2+YV1*YV2+ZV1*ZV2
  94. IF (XATA.EQ.0..AND.YATA.EQ.0.) GOTO 500
  95. ANG=ANG+ATAN2(XATA,YATA)
  96. XV1=XV2
  97. YV1=YV2
  98. ZV1=ZV2
  99. 63 CONTINUE
  100. IF (ABS(ANG).GT.XPI) GOTO 500
  101. 62 CONTINUE
  102. SEGSUP ISOM
  103. 100 CONTINUE
  104. 20 CONTINUE
  105. * ON N'A PAS TROUVE ON RECOMMENCE
  106. GOTO 5
  107. * ON A TROUVE ON DESSINE L'ELEMENT EN REDUIT ET EN ROSE
  108. 500 CONTINUE
  109. call insegt(3,iresu)
  110. ITR=1
  111. XECLAT=0.8
  112. IEL=J
  113. CALL CHCOUL(3)
  114. K=IPT1.ITYPEL
  115. IDEP=LPT(K)
  116. IFIN=IDEP+2*LPL(K)-2
  117. IFIN2=IFIN
  118. IF (LPL(K).EQ.0.AND.LPT(K).NE.0)THEN
  119. C Polygone
  120. IFIN =IDEP+2*IPT1.NUM(/1)-2
  121. IFIN2=IFIN -2
  122. ENDIF
  123. I=IEL
  124. XG=0.
  125. YG=0.
  126. N=IPT1.NUM(/1)
  127. DO 510 J=1,N
  128. XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I)))
  129. YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I)))
  130. 510 CONTINUE
  131. XG=XG/N
  132. YG=YG/N
  133. I3=0
  134. DO 520 J=IDEP,IFIN,2
  135. IF (J.LE.IFIN2) THEN
  136. I1=ICPR(IPT1.NUM(KSEGM(J),I))
  137. I2=ICPR(IPT1.NUM(KSEGM(J+1),I))
  138. ELSE
  139. I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
  140. I2=ICPR(IPT1.NUM(KSEGM(1),I))
  141. ENDIF
  142. XR=XG+(XPROJ(1,I1)-XG)*XECLAT
  143. YR=YG+(XPROJ(2,I1)-YG)*XECLAT
  144. IF (I1.NE.I3) THEN
  145. IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  146. ITR=1
  147. XTR(ITR)=XR
  148. YTR(ITR)=YR
  149. ENDIF
  150. XR=XG+(XPROJ(1,I2)-XG)*XECLAT
  151. YR=YG+(XPROJ(2,I2)-YG)*XECLAT
  152. ITR=ITR+1
  153. XTR(ITR)=XR
  154. YTR(ITR)=YR
  155. I3=I2
  156. 520 CONTINUE
  157. IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  158. * DEFINITIF
  159. IPTSUP=IPT1
  160. IPT1=MELEME
  161. DO 610 IO=1,MAX(1,LISOUS(/1))
  162. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  163. IF (IPT1.NE.IPTSUP) GOTO 620
  164. DO 630 IL=IEL,IPT1.NUM(/2)-1
  165. DO 640 IN=1,IPT1.NUM(/1)
  166. IPT1.NUM(IN,IL)=IPT1.NUM(IN,IL+1)
  167. 640 CONTINUE
  168. IPT1.ICOLOR(IL)=IPT1.ICOLOR(IL+1)
  169. 630 CONTINUE
  170. NBNN=IPT1.NUM(/1)
  171. NBELEM=IPT1.NUM(/2)-1
  172. NBREF=0
  173. NBSOUS=0
  174. SEGADJ IPT1
  175. 620 CONTINUE
  176. 610 CONTINUE
  177. * SUPPRIMER LES SOUS-OBJETS VIDES
  178. IF (LISOUS(/1).EQ.0) RETURN
  179. IO1=0
  180. DO 700 IO=1,LISOUS(/1)
  181. IPT1=LISOUS(IO)
  182. IF (IPT1.NUM(/2).EQ.0) THEN
  183. SEGSUP IPT1
  184. GOTO 700
  185. ENDIF
  186. IO1=IO1+1
  187. LISOUS(IO1)=LISOUS(IO)
  188. 700 CONTINUE
  189. NBELEM=0
  190. NBNN=0
  191. NBREF=0
  192. NBSOUS=IO1
  193. IF (NBSOUS.NE.LISOUS(/1)) SEGADJ MELEME
  194. * SI UNE SEULE REFERENCE SUPPRIMER LE CHAPEAU
  195. IF (LISOUS(/1).EQ.1) THEN
  196. IPT1=LISOUS(1)
  197. NBELEM=IPT1.NUM(/2)
  198. NBNN=IPT1.NUM(/1)
  199. NBSOUS=0
  200. NBREF=0
  201. SEGADJ MELEME
  202. ITYPEL=IPT1.ITYPEL
  203. DO 731 J=1,NBELEM
  204. DO 730 I=1,NBNN
  205. NUM(I,J)=IPT1.NUM(I,J)
  206. 730 CONTINUE
  207. ICOLOR(J)=IPT1.ICOLOR(J)
  208. 731 CONTINUE
  209. SEGSUP IPT1
  210. ENDIF
  211. END
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales