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

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