Télécharger genjo2.eso

Retour à la liste

Numérotation des lignes :

  1. C GENJO2 SOURCE BP208322 16/11/18 21:17:20 9177
  2. SUBROUTINE GENJO2
  3. C--------------------------------------------------------------------
  4. C
  5. C MAIL1 = GENJ MAIL2 FLOT1;
  6. C
  7. C MAIL1 : MAILLAGE DE JOI2
  8. C MAIL2 : MAILLAGE DE QUA4 ET/OU DE TRI3
  9. C FLOT1 : TOLERANCE
  10. C
  11. C Pierre Pegon/JRC Ispra
  12. C + modif PP 8/98 pour accelerer la recherche des contours
  13. C--------------------------------------------------------------------
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8 (A-H,O-Z)
  16. C
  17. -INC CCOPTIO
  18. -INC SMELEME
  19. -INC SMCOORD
  20. -INC CCGEOME
  21. -INC SMLENTI
  22. C
  23. SEGMENT,JOIGEN
  24. INTEGER P1(NCOTE),P2(NCOTE),SZONE(NCOTE),NELMT(NCOTE)
  25. INTEGER FLAG(NCOTE)
  26. ENDSEGMENT
  27. POINTEUR JOIGE1.JOIGEN
  28. C
  29. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  30. IF(IERR.NE.0) RETURN
  31. CALL LIRREE(XTOL,1,IRETOU)
  32. IF(IERR.NE.0) RETURN
  33. C
  34. C VERIFICATION DE LA DIMENSION
  35. C
  36. IF (IDIM.NE.2)THEN
  37. WRITE(IOIMP,*)'GENJO2: on n"est pas en 2D'
  38. RETURN
  39. ENDIF
  40. C
  41. C VERIFICATION DES TYPES D'ELEMENT (POUR LE MOMENT QUA4 ET TRI3)
  42. C ET CALCUL DU NOMBRE DE COTES
  43. C
  44. NCOTE=0
  45. SEGACT,IPT1
  46. NBSOUS=IPT1.LISOUS(/1)
  47. DO IE1=1,MAX(NBSOUS,1)
  48. IF(NBSOUS.EQ.0)THEN
  49. MELEME=IPT1
  50. ELSE
  51. MELEME=IPT1.LISOUS(IE1)
  52. SEGACT,MELEME
  53. ENDIF
  54. ILC=ITYPEL
  55. IF(ILC.NE.4.AND.ILC.NE.8)THEN
  56. WRITE(IOIMP,*)'GENJO2: type d"element incorrect'
  57. SEGDES,MELEME*NOMOD
  58. RETURN
  59. ELSE
  60. NCOTE=NCOTE+((ILC/4)+2)*ICOLOR(/1)
  61. ENDIF
  62. SEGDES,MELEME*NOMOD
  63. ENDDO
  64. C
  65. C REMPLISSAGE DU SEGMENT DES COTES
  66. C
  67. SEGACT,IPT1
  68. SEGINI,JOIGEN
  69. IJOI=0
  70. DO IE1=1,MAX(NBSOUS,1)
  71. IF(NBSOUS.EQ.0)THEN
  72. MELEME=IPT1
  73. ELSE
  74. MELEME=IPT1.LISOUS(IE1)
  75. SEGACT,MELEME
  76. ENDIF
  77. NC=(ITYPEL/4)+2
  78. NBEL=ICOLOR(/1)
  79. DO IE2=1,NBEL
  80. DO IE3=1,NC
  81. IJOI=IJOI+1
  82. P1(IJOI) =NUM(IE3,IE2)
  83. P2(IJOI) =NUM(MOD(IE3,NC)+1,IE2)
  84. SZONE(IJOI)=MIN(NBSOUS,IE1)
  85. NELMT(IJOI)=IE2
  86. FLAG(IJOI) =P1(IJOI)+P2(IJOI)
  87. ENDDO
  88. ENDDO
  89. ENDDO
  90. C
  91. C ELIMINATION DES DOUBLONS A NOEUDS IDENTIQUES
  92. C
  93. C NOUVELLE STRATEGIE AVEC TRI PREALABLE COMME DANS GENJO3 (8/98)
  94. C
  95. JG=NCOTE
  96. SEGINI,MLENTI,MLENT1
  97. DO IE1=1,NCOTE
  98. LECT(IE1)=IE1
  99. MLENT1.LECT(IE1)=FLAG(IE1)
  100. ENDDO
  101. CALL GENOR2(MLENT1.LECT,LECT,NCOTE)
  102. IFI=MLENT1.LECT(1)
  103. DO IE1=2,NCOTE
  104. IFF=MLENT1.LECT(IE1)
  105. IF(IFI.EQ.IFF)THEN
  106. JE1=LECT(IE1-1)
  107. IF(FLAG(JE1).NE.0)THEN
  108. DO IE2=IE1,NCOTE
  109. IFFF=MLENT1.LECT(IE2)
  110. IF(IFI.NE.IFFF)GOTO 10
  111. JE2=LECT(IE2)
  112. IF(FLAG(JE2).NE.0)THEN
  113. IF((P1(JE1).EQ.P1(JE2).AND.P2(JE1).EQ.P2(JE2)).OR.
  114. > (P1(JE1).EQ.P2(JE2).AND.P2(JE1).EQ.P1(JE2)))THEN
  115. FLAG(JE1)=0
  116. FLAG(JE2)=0
  117. GOTO 10
  118. ENDIF
  119. ENDIF
  120. ENDDO
  121. ENDIF
  122. ENDIF
  123. 10 IFI=IFF
  124. ENDDO
  125. SEGSUP,MLENTI,MLENT1
  126. C
  127. C CONCATENATION DE LA LISTE
  128. C
  129. NNCOTE=NCOTE
  130. NCOTE=0
  131. DO IE1=1,NNCOTE
  132. IF(FLAG(IE1).NE.0)NCOTE=NCOTE+1
  133. ENDDO
  134. SEGINI,JOIGE1
  135. IE2=0
  136. DO IE1=1,NNCOTE
  137. IF(FLAG(IE1).NE.0)THEN
  138. IE2=IE2+1
  139. JOIGE1.P1(IE2)=P1(IE1)
  140. JOIGE1.P2(IE2)=P2(IE1)
  141. JOIGE1.SZONE(IE2)=SZONE(IE1)
  142. JOIGE1.NELMT(IE2)=NELMT(IE1)
  143. JOIGE1.FLAG(IE2)=0
  144. ENDIF
  145. ENDDO
  146. SEGSUP,JOIGEN
  147. JOIGEN=JOIGE1
  148. C
  149. C DETERMINATION DES SEGMENTS AVEC VIS-A-VIS
  150. C
  151. DO IE1=1,NCOTE-1
  152. IF(FLAG(IE1).EQ.0)THEN
  153. IPR1 = (IDIM+1)*(P1(IE1)-1)
  154. XP1 = XCOOR(IPR1+1)
  155. YP1 = XCOOR(IPR1+2)
  156. IPR2 = (IDIM+1)*(P2(IE1)-1)
  157. XP2 = XCOOR(IPR2+1)
  158. YP2 = XCOOR(IPR2+2)
  159. DO IE2=IE1+1,NCOTE
  160. IF(FLAG(IE2).EQ.0)THEN
  161. IPPR1= (IDIM+1)*(P1(IE2)-1)
  162. XPP1 = XCOOR(IPPR1+1)
  163. YPP1 = XCOOR(IPPR1+2)
  164. IPPR2= (IDIM+1)*(P2(IE2)-1)
  165. XPP2 = XCOOR(IPPR2+1)
  166. YPP2 = XCOOR(IPPR2+2)
  167. DIST1=SQRT((XP1-XPP1)**2+(YP1-YPP1)**2)
  168. > +SQRT((XP2-XPP2)**2+(YP2-YPP2)**2)
  169. DIST2=SQRT((XP1-XPP2)**2+(YP1-YPP2)**2)
  170. > +SQRT((XP2-XPP1)**2+(YP2-YPP1)**2)
  171. C PP 2001 IF(DIST1.LT.XTOL.OR.DIST2.LT.XTOL)THEN
  172. IF(DIST1.LT.2*XTOL.OR.DIST2.LT.2*XTOL)THEN
  173. FLAG(IE1)=IE2
  174. FLAG(IE2)=IE1
  175. C PP 2001 IF(DIST2.LT.XTOL)THEN
  176. IF(DIST2.LT.2*XTOL)THEN
  177. IPDUM=P1(IE2)
  178. P1(IE2)=P2(IE2)
  179. P2(IE2)=IPDUM
  180. ENDIF
  181. GOTO 20
  182. ENDIF
  183. ENDIF
  184. ENDDO
  185. ENDIF
  186. 20 CONTINUE
  187. ENDDO
  188. C
  189. C CREATION DU MAILLAGE DE JOINT
  190. C
  191. NBNN=4
  192. NBREF=0
  193. NBSOUS=0
  194. NBELEM=0
  195. DO IE1=1,NCOTE
  196. IF(FLAG(IE1).NE.0)NBELEM=NBELEM+1
  197. ENDDO
  198. NBELEM=NBELEM/2
  199. SEGINI,IPT2
  200. IPT2.ITYPEL=12
  201. DO IE1=1,NBELEM
  202. IPT2.ICOLOR(IE1)=0
  203. ENDDO
  204. C
  205. C GENERATION DU MAILLAGE DE JOINT
  206. C
  207. IELEM=0
  208. DO IE1=1,NCOTE
  209. IF(FLAG(IE1).NE.0)THEN
  210. IELEM=IELEM+1
  211. *
  212. * premier barycentre
  213. *
  214. XG=0.D0
  215. YG=0.D0
  216. IF(SZONE(IE1).EQ.0)THEN
  217. MELEME=IPT1
  218. ELSE
  219. MELEME=IPT1.LISOUS(SZONE(IE1))
  220. ENDIF
  221. DO IE3=1,NUM(/1)
  222. IPDUM=(IDIM+1)*(NUM(IE3,NELMT(IE1))-1)
  223. XG=XG+XCOOR(IPDUM+1)
  224. YG=YG+XCOOR(IPDUM+2)
  225. ENDDO
  226. XG=XG/NUM(/1)
  227. YG=YG/NUM(/1)
  228. *
  229. * 2 points le long du joint
  230. *
  231. IPR1 = (IDIM+1)*(P1(IE1)-1)
  232. XP1 = XCOOR(IPR1+1)
  233. YP1 = XCOOR(IPR1+2)
  234. IPR2 = (IDIM+1)*(P2(IE1)-1)
  235. XP2 = XCOOR(IPR2+1)
  236. YP2 = XCOOR(IPR2+2)
  237. *
  238. * second barycentre
  239. *
  240. IE2=FLAG(IE1)
  241. XGG=0.D0
  242. YGG=0.D0
  243. IF(SZONE(IE2).EQ.0)THEN
  244. MELEME=IPT1
  245. ELSE
  246. MELEME=IPT1.LISOUS(SZONE(IE2))
  247. ENDIF
  248. DO IE3=1,NUM(/1)
  249. IPDUM=(IDIM+1)*(NUM(IE3,NELMT(IE2))-1)
  250. XGG=XGG+XCOOR(IPDUM+1)
  251. YGG=YGG+XCOOR(IPDUM+2)
  252. ENDDO
  253. XGG=XGG/NUM(/1)
  254. YGG=YGG/NUM(/1)
  255. *
  256. * produit vectoriel, et selon son signe...
  257. *
  258. XVECT=(XP2-XP1)*(YGG-YG)-(YP2-YP1)*(XGG-XG)
  259. * PPj IF(XVECT.GT.0)THEN
  260. IF(XVECT.LT.0)THEN
  261. IPT2.NUM(1,IELEM)=P1(IE1)
  262. IPT2.NUM(2,IELEM)=P2(IE1)
  263. IPT2.NUM(3,IELEM)=P2(IE2)
  264. IPT2.NUM(4,IELEM)=P1(IE2)
  265. ELSE
  266. IPT2.NUM(1,IELEM)=P2(IE1)
  267. IPT2.NUM(2,IELEM)=P1(IE1)
  268. IPT2.NUM(3,IELEM)=P1(IE2)
  269. IPT2.NUM(4,IELEM)=P2(IE2)
  270. ENDIF
  271. *
  272. * on efface les 2 cotes
  273. *
  274. FLAG(IE1)=0
  275. FLAG(IE2)=0
  276. ENDIF
  277. ENDDO
  278. C
  279. C DESTRUCTION, DESACTIVATION ET RETOUR A GIBIANE
  280. C
  281. SEGSUP,JOIGEN
  282. NBSOUS=IPT1.LISOUS(/1)
  283. DO IE1=1,MAX(NBSOUS,1)
  284. IF(NBSOUS.EQ.0)THEN
  285. MELEME=IPT1
  286. ELSE
  287. MELEME=IPT1.LISOUS(IE1)
  288. ENDIF
  289. SEGDES,MELEME*NOMOD
  290. ENDDO
  291. SEGDES,IPT2
  292. CALL ECROBJ('MAILLAGE',IPT2)
  293. C
  294. RETURN
  295. END
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304.  

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