Télécharger mocr.eso

Retour à la liste

Numérotation des lignes :

  1. C MOCR SOURCE BP208322 16/11/18 21:19:16 9177
  2. C MODI CREATION D'ELEMENT
  3. C
  4. SUBROUTINE MOCR(XPROJ,IVU,IDCP,MELEME,ICPR,ITE,IMILL,TMIN,IBOUJ)
  5. IMPLICIT INTEGER(I-N)
  6. COMMON/CMODI/LIGMAX,XDEC,YDEC
  7. -INC SMELEME
  8. -INC CCOPTIO
  9. -INC CCGEOME
  10. -INC SMCOORD
  11. DIMENSION XTR(10),YTR(10),ZTR(10)
  12. SEGMENT XPROJ(3,ITE)
  13. SEGMENT IVU(ITE)
  14. SEGMENT IDCP(ITE)
  15. SEGMENT ICPR(0)
  16. SEGMENT IMILL(ITE)
  17. SEGMENT IBOUJ(0)
  18. CHARACTER*4 LEGEND(11)
  19. CHARACTER*8 ZONE
  20. do i=1,10
  21. ztr(i)=0
  22. enddo
  23. XPR=XDEC**2
  24. TTEMP=TMIN
  25. 10 CONTINUE
  26. CALL TRMESS('Choisissez le type d''element')
  27. LEGEND(1)=' '
  28. LEGEND(2)='POI1'
  29. LEGEND(3)='SEG2'
  30. LEGEND(4)='SEG3'
  31. LEGEND(5)='TRI3'
  32. LEGEND(6)=' '
  33. LEGEND(7)='TRI6'
  34. LEGEND(8)=' '
  35. LEGEND(9)='QUA4'
  36. LEGEND(10)=' '
  37. LEGEND(11)='QUA8'
  38. CALL MENU(LEGEND,11,4)
  39. CALL TRAFF(ICLE)
  40. IF (ICLE.NE.2.AND.ICLE.NE.3.AND.ICLE.NE.4.AND.ICLE.NE.6
  41. # .AND.ICLE.NE.8.AND.ICLE.NE.10.AND.ICLE.NE.1) THEN
  42. GOTO 10
  43. ENDIF
  44. IF (KDEGRE(ICLE).EQ.3) THEN
  45. * IL FAUT INDIQUER OU SONT LES POINTS MILIEUX
  46. call insegt(3,iresu)
  47. CALL CHCOUL(IDNOIR)
  48. IPT1=MELEME
  49. DO 30 IO=1,MAX(1,LISOUS(/1))
  50. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  51. IF (KDEGRE(IPT1.ITYPEL).NE.3) GOTO 40
  52. DO 50 I=1,IPT1.NUM(/1)
  53. DO 50 J=1,IPT1.NUM(/2)
  54. IP=ICPR(IPT1.NUM(I,J))
  55. IF (IMILL(IP).NE.0) GOTO 50
  56. XTR(1)=XPROJ(1,IP)
  57. YTR(1)=XPROJ(2,IP)
  58. XTR(2)=XPROJ(1,IP)
  59. YTR(2)=XPROJ(2,IP)
  60. CALL POLRL(2,XTR,YTR,ZTR)
  61. IMILL(IP)=1
  62. 50 CONTINUE
  63. 40 CONTINUE
  64. 30 CONTINUE
  65. ENDIF
  66. NBELEM=0
  67. NBSOUS=0
  68. NBREF=0
  69. NBNN=NBNNE(ICLE)
  70. SEGINI IPT8
  71. IPT8.ITYPEL=ICLE
  72. 100 CONTINUE
  73. CALL TRMESS('Pointez les points de l''element')
  74. NBELEM=NBELEM+1
  75. SEGADJ IPT8
  76. CALL CHCOUL(5)
  77. DO 110 I=1,NBNN
  78. CALL TRDIG(X,Y,INCLE)
  79. IF (INCLE.EQ.3) GOTO 141
  80. DO 120 IP=1,ITE
  81. IF (IVU(IP).NE.1) GOTO 120
  82. IF((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LT.XPR) GOTO 130
  83. 120 CONTINUE
  84. ITE=ITE+1
  85. SEGADJ XPROJ
  86. XPROJ(1,ITE)=X
  87. XPROJ(2,ITE)=Y
  88. XPROJ(3,ITE)=TTEMP
  89. XCOOR(**)=X
  90. XCOOR(**)=Y
  91. IF (IDIM.EQ.3) XCOOR(**)=TTEMP
  92. XCOOR(**)=DENSIT
  93. IP=ITE
  94. ICPR(**)=ITE
  95. III=ICPR(/1)
  96. IDCP(**)=III
  97. IVU(**)=1
  98. IMILL(**)=0
  99. CALL PROMOD(ICPR,XPROJ,III,4,IBOUJ)
  100. 130 CONTINUE
  101. call insegt(3,iresu)
  102. TTEMP=XPROJ(3,IP)
  103. XTR(I)=XPROJ(1,IP)
  104. YTR(I)=XPROJ(2,IP)
  105. IF (I.NE.1) CALL POLRL(2,XTR(I-1),YTR(I-1),ZTR)
  106. IF (I.EQ.NBNN.AND.IPT8.ITYPEL.GT.3) THEN
  107. XTR(2)=XTR(I)
  108. YTR(2)=YTR(I)
  109. CALL POLRL(2,XTR,YTR,ZTR)
  110. ENDIF
  111. IPT8.NUM(I,NBELEM)=IDCP(IP)
  112. 110 CONTINUE
  113. IPT8.ICOLOR(NBELEM)=IDCOUL
  114. CALL CHCOUL(IDNOIR)
  115. DO 140 I=1,NBNN
  116. IPR=ICPR(IPT8.NUM(I,NBELEM))
  117. XTR(1)=XPROJ(1,IPR)
  118. YTR(1)=XPROJ(2,IPR)
  119. XTR(2)=XPROJ(1,IPR)
  120. YTR(2)=XPROJ(2,IPR)
  121. CALL POLRL(2,XTR,YTR,ZTR)
  122. IMILL(IPR)=1
  123. 140 CONTINUE
  124. 141 CONTINUE
  125. LEGEND(1)=' '
  126. LEGEND(2)='Fin'
  127. LEGEND(3)='Cont'
  128. CALL MENU(LEGEND,3,4)
  129. CALL TRMESS('Fin pour arreter la definition d''elements')
  130. CALL TRAFF(IREP)
  131. IF (IREP.NE.1) GOTO 100
  132. CALL TRGET
  133. * ('Donnez si necessaire un nom aux elements crees :',ZONE)
  134. IF (ZONE(1:1).NE.' ') THEN
  135. CALL NOMOBJ('MAILLAGE',ZONE,IPT8)
  136. ENDIF
  137. LEGEND(1)=' '
  138. LEGEND(2)='Ajou'
  139. LEGEND(3)='Cont'
  140. CALL MENU(LEGEND,3,4)
  141. CALL TRMESS('Ajou pour ajouter le maillage au maillage courant')
  142. CALL TRAFF(IREP)
  143. IF (IREP.NE.1) THEN
  144. SEGDES IPT8
  145. RETURN
  146. ENDIF
  147. IF (LISOUS(/1).EQ.0) THEN
  148. IF (ITYPEL.EQ.IPT8.ITYPEL) THEN
  149. NBELE0=NUM(/2)
  150. NBELE8=IPT8.NUM(/2)
  151. NBELEM=NBELE0+NBELE8
  152. NBNN=NUM(/1)
  153. NBREF=0
  154. NBSOUS=0
  155. SEGADJ MELEME
  156. DO 800 I=NBELE0+1,NBELEM
  157. ICOLOR(I)=IPT8.ICOLOR(I-NBELE0)
  158. DO 800 J=1,NBNN
  159. NUM(J,I)=IPT8.NUM(J,I-NBELE0)
  160. 800 CONTINUE
  161. SEGDES IPT8
  162. RETURN
  163. ENDIF
  164. SEGINI,IPT2=MELEME
  165. NBSOUS=2
  166. NBREF=0
  167. NBNN=0
  168. NBELEM=0
  169. SEGADJ MELEME
  170. ITYPEL=0
  171. LISOUS(1)=IPT2
  172. LISOUS(2)=IPT8
  173. RETURN
  174. ENDIF
  175. DO 810 IO=1,LISOUS(/1)
  176. IPT1=LISOUS(IO)
  177. IF (IPT1.ITYPEL.NE.IPT8.ITYPEL) GOTO 810
  178. NBELE1=IPT1.NUM(/2)
  179. NBELE8=IPT8.NUM(/2)
  180. NBELEM=NBELE1+NBELE8
  181. NBNN=IPT1.NUM(/1)
  182. NBREF=0
  183. NBSOUS=0
  184. SEGADJ IPT1
  185. DO 820 I=NBELE1+1,NBELEM
  186. IPT1.ICOLOR(I)=IPT8.ICOLOR(I-NBELE1)
  187. DO 820 J=1,NBNN
  188. IPT1.NUM(J,I)=IPT8.NUM(J,I-NBELE1)
  189. 820 CONTINUE
  190. SEGDES IPT8
  191. RETURN
  192. 810 CONTINUE
  193. NBELEM=0
  194. NBREF=0
  195. NBSOUS=LISOUS(/1)+1
  196. NBNN=0
  197. SEGADJ MELEME
  198. LISOUS(NBSOUS)=IPT8
  199. END
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  

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