Télécharger monl.eso

Retour à la liste

Numérotation des lignes :

  1. C MONL SOURCE BP208322 16/11/18 21:19:28 9177
  2. C MODI NOMMER UN ELEMENT
  3. C
  4. SUBROUTINE MONL(XPROJ,IVU,ICPR,IPTZ)
  5. IMPLICIT INTEGER(I-N)
  6. -INC CCREEL
  7. -INC SMELEME
  8. -INC CCOPTIO
  9. -INC CCGEOME
  10. DIMENSION XTR(40),YTR(40),ztr(40)
  11. CHARACTER*8 ZONE
  12. CHARACTER*19 LEGEND(3)
  13. COMMON/CMODI/LIGMAX,XDEC,YDEC
  14. SEGMENT IVU(0)
  15. SEGMENT XPROJ(3,0)
  16. SEGMENT ICPR(0)
  17. SEGMENT ISOM(NBSO)
  18. do i=1,40
  19. ztr(i)=0
  20. enddo
  21. IPT1=IPTZ
  22. XDPR=XDEC**2
  23. 11 CONTINUE
  24. LEGEND(1)=' '
  25. LEGEND(2)='Element du maillage'
  26. LEGEND(3)='Element du contour'
  27. CALL MENU(LEGEND,3,19)
  28. CALL TRAFF(ICLE)
  29. IF (ICLE.NE.1.AND.ICLE.NE.2) GOTO 11
  30. IF (ICLE.EQ.2) THEN
  31. CALL ECROBJ('MAILLAGE',IPT1)
  32. CALL PRCONT
  33. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  34. IF (IERR.NE.0) RETURN
  35. * REACTIVONS LE MAILLAGE A TOUT HASARD
  36. SEGACT IPT1
  37. DO 101 I=1,IPT1.LISOUS(/1)
  38. IPT2=IPT1.LISOUS(I)
  39. SEGACT IPT2
  40. 101 CONTINUE
  41. SEGACT MELEME
  42. NBELEM=NUM(/2)
  43. NBNN=NUM(/1)
  44. CALL CHCOUL(1)
  45. ICOUR=0
  46. ITR=1
  47. DO 10 J=1,NBELEM
  48. DO 20 I=1,NBNN-1
  49. IP=ICPR(NUM(I,J))
  50. IP1=ICPR(NUM(I+1,J))
  51. IF (IVU(IP).NE.1) GOTO 20
  52. IF (IVU(IP1).NE.1) GOTO 20
  53. IF (ICOUR.NE.IP) THEN
  54. IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  55. ITR=1
  56. XTR(1)=XPROJ(1,IP)
  57. YTR(1)=XPROJ(2,IP)
  58. ENDIF
  59. ITR=ITR+1
  60. XTR(ITR)=XPROJ(1,IP1)
  61. YTR(ITR)=XPROJ(2,IP1)
  62. IF (ITR.EQ.40) THEN
  63. CALL POLRL(ITR,XTR,YTR,ZTR)
  64. XTR(1)=XTR(ITR)
  65. YTR(1)=YTR(ITR)
  66. ITR=1
  67. ENDIF
  68. ICOUR=IP1
  69. 20 CONTINUE
  70. 10 CONTINUE
  71. CALL POLRL(ITR,XTR,YTR,ZTR)
  72. ITR=1
  73. 40 CONTINUE
  74. CALL TRMESS('Pointez la premiere extremite')
  75. CALL MOPF3
  76. CALL TRDIG(X,Y,INCLE)
  77. IF (INCLE.EQ.3) RETURN
  78. DO 80 IL=1,NUM(/2)
  79. IPT=NUM(1,IL)
  80. IP=ICPR(IPT)
  81. IF (IVU(IP).NE.1) GOTO 80
  82. IF ((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LE.XDPR) GOTO 30
  83. 80 CONTINUE
  84. GOTO 40
  85. 30 IP1 = IPT
  86. 70 CONTINUE
  87. CALL TRMESS('Pointez la deuxieme extremite')
  88. CALL MOPF3
  89. CALL TRDIG(X,Y,INCLE)
  90. IF (INCLE.EQ.3) RETURN
  91. DO 50 IL=1,NUM(/2)
  92. IPT=NUM(1,IL)
  93. IP=ICPR(IPT)
  94. IF (IVU(IP).NE.1) GOTO 50
  95. IF ((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LE.XDPR) GOTO 60
  96. 50 CONTINUE
  97. GOTO 70
  98. 60 IP2=IPT
  99. CALL ECROBJ ('POINT ',IP2)
  100. CALL ECROBJ ('POINT ',IP1)
  101. CALL ECROBJ ('MAILLAGE',MELEME)
  102. CALL COMPRI
  103. CALL LIROBJ ( 'MAILLAGE',IPT2,1,IRETOU)
  104. IF(IERR.NE.0) RETURN
  105. SEGDES MELEME
  106. MELEME=IPT2
  107. SEGACT MELEME
  108. NBELEM=NUM(/2)
  109. NBNN=NUM(/1)
  110. CALL CHCOUL(6)
  111. ICOUR=0
  112. ITR=1
  113. DO 100 J=1,NBELEM
  114. DO 110 I=1,NBNN-1
  115. IP=ICPR(NUM(I,J))
  116. IP1=ICPR(NUM(I+1,J))
  117. IF (IVU(IP).NE.1) GOTO 110
  118. IF (IVU(IP1).NE.1) GOTO 110
  119. IF (ICOUR.NE.IP) THEN
  120. IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  121. ITR=1
  122. XTR(1)=XPROJ(1,IP)
  123. YTR(1)=XPROJ(2,IP)
  124. ENDIF
  125. ITR=ITR+1
  126. XTR(ITR)=XPROJ(1,IP1)
  127. YTR(ITR)=XPROJ(2,IP1)
  128. IF (ITR.EQ.40) THEN
  129. CALL POLRL(ITR,XTR,YTR,ZTR)
  130. XTR(1)=XTR(ITR)
  131. YTR(1)=YTR(ITR)
  132. ITR=1
  133. ENDIF
  134. ICOUR=IP1
  135. 110 CONTINUE
  136. 100 CONTINUE
  137. CALL POLRL(ITR,XTR,YTR,ZTR)
  138. ITR=1
  139. CALL TRGET('Donnez un nom si necessaire :',ZONE)
  140. IF (ZONE(1:1).EQ.' ') THEN
  141. SEGSUP MELEME
  142. RETURN
  143. ENDIF
  144. CALL NOMOBJ('MAILLAGE',ZONE,MELEME)
  145. RETURN
  146. ENDIF
  147. * RECHERCHE D'ELEMENT
  148. IPPT=0
  149. IEEL=0
  150. * ON CREE UN RESULTAT VIDE POUR RECEUILLIR LES ELEMENTS DESIGNES
  151. NBNN=0
  152. NBELEM=0
  153. NBSOUS=0
  154. NBREF=0
  155. SEGINI IPT8
  156. MELEME=IPT1
  157. CALL TRMESS('Pointez les elements a nommer. Pointez 2 fois le '
  158. # //'meme pour terminer')
  159. 400 CONTINUE
  160. CALL TRDIG(XP,YP,INCLE)
  161. IF (INCLE.EQ.3) GOTO 650
  162. IPT1=MELEME
  163. SEGACT IPT1
  164. DO 220 IO=1,MAX(1,LISOUS(/1))
  165. IF (LISOUS(/1).NE.0) THEN
  166. IPT1=LISOUS(IO)
  167. SEGACT IPT1
  168. ENDIF
  169. NBNN=IPT1.NUM(/1)
  170. IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 260
  171. * C'EST UNE LIGNE
  172. DO 240 J=1,IPT1.NUM(/2)
  173. IA=ICPR(IPT1.NUM(1,J))
  174. IB=ICPR(IPT1.NUM(NBNN,J))
  175. IF (IVU(IA).NE.1) GOTO 240
  176. IF (IVU(IB).NE.1) GOTO 240
  177. XA=XPROJ(1,IA)
  178. YA=XPROJ(2,IA)
  179. XB=XPROJ(1,IB)
  180. YB=XPROJ(2,IB)
  181. SCA=(XP-XA)*(XP-XB)+(YP-YA)*(YP-YB)
  182. IF (SCA.LE.0.) GOTO 500
  183. 240 CONTINUE
  184. GOTO 1000
  185. 260 IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 1000
  186. * C'EST UNE SURFACE
  187. NBSO = NBSOM(IPT1.ITYPEL)
  188. IF (NBSO.EQ.0) THEN
  189. C Polygone a N cotes
  190. NBSO = IPT1.NUM(/1)
  191. ENDIF
  192. SEGINI ISOM
  193. DO 261 I=1,ISOM(/1)
  194. ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I)
  195. 261 CONTINUE
  196. DO 262 J=1,IPT1.NUM(/2)
  197. I1=ICPR(IPT1.NUM(ISOM(1),J))
  198. I2=ICPR(IPT1.NUM(ISOM(2),J))
  199. I3=ICPR(IPT1.NUM(ISOM(3),J))
  200. IF (IVU(I1).NE.1) GOTO 262
  201. IF (IVU(I2).NE.1) GOTO 262
  202. IF (IVU(I3).NE.1) GOTO 262
  203. X1=XPROJ(1,I1)
  204. X2=XPROJ(1,I2)
  205. X3=XPROJ(1,I3)
  206. Y1=XPROJ(2,I1)
  207. Y2=XPROJ(2,I2)
  208. Y3=XPROJ(2,I3)
  209. Z1=0.
  210. Z2=0.
  211. Z3=0.
  212. XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3)
  213. YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3)
  214. ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3)
  215. DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2)
  216. XNORM=XNORM/DNORM
  217. YNORM=YNORM/DNORM
  218. ZNORM=ZNORM/DNORM
  219. ANG=0.
  220. I1=ICPR(IPT1.NUM(ISOM(ISOM(/1)),J))
  221. XV1=XPROJ(1,I1)-XP
  222. YV1=XPROJ(2,I1)-YP
  223. ZV1=0.
  224. DO 263 IS=1,ISOM(/1)
  225. I2=ICPR(IPT1.NUM(ISOM(IS),J))
  226. XV2=XPROJ(1,I2)-XP
  227. YV2=XPROJ(2,I2)-YP
  228. ZV2=0.
  229. XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+
  230. # ZNORM*(XV1*YV2-YV1*XV2)
  231. YATA=XV1*XV2+YV1*YV2+ZV1*ZV2
  232. IF (XATA.EQ.0..AND.YATA.EQ.0.) GOTO 500
  233. ANG=ANG+ATAN2(XATA,YATA)
  234. XV1=XV2
  235. YV1=YV2
  236. ZV1=ZV2
  237. 263 CONTINUE
  238. IF (ABS(ANG).GT.XPI) GOTO 500
  239. 262 CONTINUE
  240. SEGSUP ISOM
  241. 1000 CONTINUE
  242. 220 CONTINUE
  243. * ON N'A PAS TROUVE ON RECOMMENCE
  244. GOTO 400
  245. * ON A TROUVE ON DESSINE L'ELEMENT EN REDUIT ET EN ROSE
  246. 500 CONTINUE
  247. IEL=J
  248. IF (IPT1.EQ.IPPT.AND.IEL.EQ.IEEL) GOTO 650
  249. IPPT=IPT1
  250. IEEL=IEL
  251. XECLAT=0.8
  252. CALL CHCOUL(1)
  253. K=IPT1.ITYPEL
  254. IDEP=LPT(K)
  255. IFIN=IDEP+2*LPL(K)-2
  256. IFIN2=IFIN
  257. IF (LPL(K).EQ.0.AND.LPT(K).NE.0)THEN
  258. C Polygone
  259. IFIN =IDEP+2*IPT1.NUM(/1)-2
  260. IFIN2=IFIN -2
  261. ENDIF
  262. I=IEL
  263. XG=0.
  264. YG=0.
  265. N=IPT1.NUM(/1)
  266. DO 510 J=1,N
  267. XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I)))
  268. YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I)))
  269. 510 CONTINUE
  270. XG=XG/N
  271. YG=YG/N
  272. I3=0
  273. ITR=1
  274. DO 520 J=IDEP,IFIN,2
  275. IF (J.LE.IFIN2) THEN
  276. I1=ICPR(IPT1.NUM(KSEGM(J),I))
  277. I2=ICPR(IPT1.NUM(KSEGM(J+1),I))
  278. ELSE
  279. I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
  280. I2=ICPR(IPT1.NUM(KSEGM(1),I))
  281. ENDIF
  282. XR=XG+(XPROJ(1,I1)-XG)*XECLAT
  283. YR=YG+(XPROJ(2,I1)-YG)*XECLAT
  284. IF (I1.NE.I3) THEN
  285. IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  286. ITR=1
  287. XTR(ITR)=XR
  288. YTR(ITR)=YR
  289. ENDIF
  290. XR=XG+(XPROJ(1,I2)-XG)*XECLAT
  291. YR=YG+(XPROJ(2,I2)-YG)*XECLAT
  292. ITR=ITR+1
  293. XTR(ITR)=XR
  294. YTR(ITR)=YR
  295. I3=I2
  296. 520 CONTINUE
  297. IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  298. ITR=1
  299. * ON MET DANS LE RESULTAT
  300. ITYP=IPT1.ITYPEL
  301. 630 CONTINUE
  302. DO 600 IO=1,IPT8.LISOUS(/1)
  303. IPT2=IPT8.LISOUS(IO)
  304. IF (ITYP.NE.IPT2.ITYPEL) GOTO 600
  305. NBNN=IPT2.NUM(/1)
  306. NBSOUS=0
  307. NBREF=0
  308. NBELEM=IPT2.NUM(/2)+1
  309. SEGADJ IPT2
  310. DO 610 I=1,NBNN
  311. IPT2.NUM(I,NBELEM)=IPT1.NUM(I,IEL)
  312. 610 CONTINUE
  313. IPT2.ICOLOR(NBELEM)=IPT1.ICOLOR(NBELEM)
  314. GOTO 620
  315. 600 CONTINUE
  316. NBNN=IPT1.NUM(/1)
  317. NBELEM=0
  318. NBREF=0
  319. NBSOUS=0
  320. SEGINI IPT2
  321. IPT2.ITYPEL=IPT1.ITYPEL
  322. NBNN=0
  323. NBELEM=0
  324. NBREF=0
  325. NBSOUS=IPT8.LISOUS(/1)+1
  326. SEGADJ IPT8
  327. IPT8.LISOUS(NBSOUS)=IPT2
  328. GOTO 630
  329. * OK ON PEUT CONTINUER
  330. 620 CONTINUE
  331. GOTO 400
  332. 650 CONTINUE
  333. * SI UN SEUL SOUS-OBJET ON SIMPLIFIE LA STRUCTURE
  334. IF (IPT8.LISOUS(/1).EQ.1) THEN
  335. IPT7=IPT8
  336. IPT8=IPT7.LISOUS(1)
  337. SEGSUP IPT7
  338. ENDIF
  339. IF (IPT8.NUM(/2).EQ.0) THEN
  340. SEGSUP IPT8
  341. RETURN
  342. ENDIF
  343. * ON DEMANDE LE NOM
  344. CALL TRGET('Donnez un nom si necessaire:',ZONE)
  345. IF (ZONE(1:1).EQ.' ') THEN
  346. SEGSUP IPT8
  347. RETURN
  348. ENDIF
  349. CALL NOMOBJ('MAILLAGE',ZONE,IPT8)
  350. RETURN
  351. END
  352.  
  353.  
  354.  
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  
  366.  
  367.  
  368.  
  369.  

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