Télécharger coutur.eso

Retour à la liste

Numérotation des lignes :

  1. C COUTUR SOURCE BP208322 16/11/18 21:15:59 9177
  2. C CE SOUS PROGRAMME EFFECTUE LA COUTURE ENTRE DEUX LIGNES
  3. C REPRIS DE COCO
  4. C
  5. SUBROUTINE COUTUR
  6. IMPLICIT INTEGER(I-N)
  7. implicit real*8 (a-h,o-z)
  8. -INC CCGEOME
  9. -INC CCOPTIO
  10. -INC SMELEME
  11. -INC SMCOORD
  12. c ITEST(0:NBCOUL-1)
  13. DIMENSION ITPOIN(2),ITEST(0:30)
  14. CHARACTER*(8) ITMAIL
  15. DATA ITMAIL/'MAILLAGE'/
  16. DISTA(A,B,C,D,E,F)=SQRT((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F))
  17. DO 10 I=0,NBCOUL-1
  18. 10 ITEST(I)=0
  19. CALL LIROBJ(ITMAIL,IPT1,1,IRETOU)
  20. CALL LIROBJ(ITMAIL,IPT2,0,ILIG2)
  21. IF (ILIG2.EQ.0) CALL LIROBJ('POINT ',IPO2,1,IRETOU)
  22. IF (IERR.NE.0) RETURN
  23. SEGACT IPT1
  24. IF (IPT1.LISOUS(/1).NE.0) CALL ERREUR(25)
  25. IF (IERR.NE.0) RETURN
  26. IF (KSURF(IPT1.ITYPEL).EQ.0) THEN
  27. DO 21 I=1,IPT1.NUM(/2)
  28. ITEST(IPT1.ICOLOR(I))=1
  29. 21 CONTINUE
  30. GOTO 1
  31. ENDIF
  32. NBREF=IPT1.LISREF(/1)
  33. IF (NBREF.EQ.0) CALL ERREUR(24)
  34. IF (NBREF.NE.4) CALL ERREUR(26)
  35. IF (IERR.NE.0) RETURN
  36. IPT3=IPT1.LISREF(1)
  37. SEGDES IPT1
  38. CALL INVERS(IPT3,IPT1)
  39. DO 11 I=1,IPT3.NUM(/2)
  40. ITEST(IPT3.ICOLOR(I))=1
  41. 11 CONTINUE
  42. SEGDES IPT3
  43. 1 CONTINUE
  44. IF (ILIG2.EQ.0) GOTO 3
  45. SEGACT IPT2
  46. IF (IPT2.LISOUS(/1).NE.0) CALL ERREUR(25)
  47. IF (IERR.NE.0) RETURN
  48. IF (KSURF(IPT2.ITYPEL).EQ.0) THEN
  49. DO 22 I=1,IPT2.NUM(/2)
  50. ITEST(IPT2.ICOLOR(I))=1
  51. 22 CONTINUE
  52. GOTO 2
  53. ENDIF
  54. NBREF=IPT2.LISREF(/1)
  55. IF (NBREF.EQ.0) CALL ERREUR(24)
  56. IF (NBREF.NE.4) CALL ERREUR(26)
  57. IF (IERR.NE.0) RETURN
  58. IPT3=IPT2.LISREF(1)
  59. SEGDES IPT2
  60. DO 12 I=1,IPT3.NUM(/2)
  61. ITEST(IPT3.ICOLOR(I))=1
  62. 12 CONTINUE
  63. IPT2=IPT3
  64. 2 CONTINUE
  65. C IPT1 ET IPT2 SONT LES DEUX LIGNES A COUDRE ELLES SONT DECRITES
  66. C DANS LE MEME SENS
  67. C ON VERIFIE D'ABORD LA COHERENCE DES TYPES D'ELEMENTS
  68. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) CALL ERREUR(16)
  69. IF (IERR.NE.0) RETURN
  70. C ON CREE IPT3 QUI CONTIENT LE RESULTAT
  71. 3 CONTINUE
  72. ICHCOL=-1
  73. DO 13 I=0,NBCOUL-1
  74. IF (ITEST(I).EQ.1) THEN
  75. IF (ICHCOL.EQ.-1) THEN
  76. ICHCOL=I
  77. ELSE
  78. ICHCOL=ITABM(ICHCOL,I)
  79. ENDIF
  80. ENDIF
  81. 13 CONTINUE
  82. NBELE1=IPT1.NUM(/2)
  83. NBELE2=0
  84. NBREF=3
  85. IF (ILIG2.EQ.0) GOTO 4
  86. NBREF=4
  87. NBELE2=IPT2.NUM(/2)
  88. 4 CONTINUE
  89. NBELEM=NBELE1+NBELE2
  90. NBNN=3
  91. NBSOUS=0
  92. SEGINI IPT3
  93. IPT3.ITYPEL=4
  94. IPT3.LISREF(1)=IPT1
  95. IF (ILIG2.EQ.0) GOTO 5
  96. CALL INVERS(IPT2,IPT4)
  97. IPT3.LISREF(3)=IPT4
  98. SEGDES IPT4
  99. C IL FAUR CREER LES BORDS LATERAUX
  100. 5 CONTINUE
  101. NBNN=2
  102. NBELEM=1
  103. NBSOUS=0
  104. NBREF=0
  105. SEGINI IPT4
  106. IPT4.ITYPEL=2
  107. IPT3.LISREF(2)=IPT4
  108. IPT4.NUM(1,1)=IPT1.NUM(IPT1.NUM(/1),NBELE1)
  109. IF (ILIG2.NE.0) IPT4.NUM(2,1)=IPT2.NUM(IPT2.NUM(/1),NBELE2)
  110. IF (ILIG2.EQ.0) IPT4.NUM(2,1)=IPO2
  111. SEGDES IPT4
  112. NBNN=2
  113. NBELEM=1
  114. NBSOUS=0
  115. NBREF=0
  116. SEGINI IPT4
  117. IPT4.ITYPEL=2
  118. IPT4.NUM(2,1)=IPT1.NUM(1,1)
  119. IF (ILIG2.EQ.0) GOTO 6
  120. IPT4.NUM(1,1)=IPT2.NUM(1,1)
  121. IPT3.LISREF(4)=IPT4
  122. GOTO 7
  123. 6 IPT4.NUM(1,1)=IPO2
  124. IPT3.LISREF(3)=IPT4
  125. 7 SEGDES IPT4
  126. LNUMEL=1
  127. NBNN=IPT1.NUM(/1)
  128. IF (ILIG2.EQ.0) GOTO 800
  129. CC
  130. C COUTURE AVEC DES TRIANGLES A 3 NOEUDS
  131. C IMAX = NUMERO DU DERNIER ELEMENT DU COTE 1
  132. C JMAX = NUMERO DU DERNIER ELEMENT DE LA COUTURE
  133. C
  134. SEGACT MCOORD
  135. IMAX = NBELE1
  136. JMAX = NBELE2
  137. NUMELG=0
  138. IEL1=1
  139. IEL2=1
  140. 100 I1=IPT1.NUM(1,IEL1)
  141. I2=IPT1.NUM(NBNN,IEL1)
  142. J1=IPT2.NUM(1,IEL2)
  143. J2=IPT2.NUM(NBNN,IEL2)
  144. 101 CONTINUE
  145. IREF1=(I1-1)*(IDIM+1)
  146. IREF2=(I2-1)*(IDIM+1)
  147. JREF1=(J1-1)*(IDIM+1)
  148. JREF2=(J2-1)*(IDIM+1)
  149. XI1=XCOOR(IREF1+1)
  150. YI1=XCOOR(IREF1+2)
  151. ZI1=XCOOR(IREF1+3)
  152. XI2=XCOOR(IREF2+1)
  153. YI2=XCOOR(IREF2+2)
  154. ZI2=XCOOR(IREF2+3)
  155. XJ1=XCOOR(JREF1+1)
  156. YJ1=XCOOR(JREF1+2)
  157. ZJ1=XCOOR(JREF1+3)
  158. XJ2=XCOOR(JREF2+1)
  159. YJ2=XCOOR(JREF2+2)
  160. ZJ2=XCOOR(JREF2+3)
  161. IF (IDIM.EQ.3) GOTO 200
  162. ZI1=0
  163. ZI2=0
  164. ZJ1=0.
  165. ZJ2=0.
  166. 200 CONTINUE
  167. A=DISTA(XI1,YI1,ZI1,XJ2,YJ2,ZJ2)
  168. B=DISTA(XJ1,YJ1,ZJ1,XI2,YI2,ZI2)
  169. IF(A.LE.B) GO TO 102
  170. CC
  171. C DIST(J1,I2) < DIST(I1,J2)
  172. C ON CREE LE TRIANGLE I1,I2,J1
  173. C
  174. NUMELG = NUMELG + 1
  175. IPT3.NUM(1,NUMELG) = I1
  176. IPT3.NUM(2,NUMELG) = I2
  177. IPT3.NUM(3,NUMELG) = J1
  178. INTERR(1)=NUMELG
  179. IF (I1.EQ.I2.OR.I1.EQ.J1.OR.I2.EQ.J1) CALL ERREUR(101)
  180. IF(IEL1.EQ.IMAX) GO TO 103
  181. IEL1=IEL1+1
  182. GO TO 100
  183. CC
  184. C PLUS DE POINT SUR LE COTE 1 = ON RELIE I2 AUX POINTS RESTANTS
  185. C DE LA COUTURE
  186. C
  187. 103 NUMELG = NUMELG + 1
  188. IPT3.NUM(1,NUMELG) = I2
  189. IPT3.NUM(2,NUMELG) = J2
  190. IPT3.NUM(3,NUMELG) = J1
  191. INTERR(1)=NUMELG
  192. IF (I2.EQ.J2.OR.I2.EQ.J1.OR.J2.EQ.J1) CALL ERREUR(101)
  193. IF(IEL2.EQ.JMAX) GO TO 150
  194. IEL2=IEL2+1
  195. J1=IPT2.NUM(1,IEL2)
  196. J2=IPT2.NUM(NBNN,IEL2)
  197. GO TO 103
  198. CC
  199. C DIST(J1,I2) > DIST(I1,J2)
  200. C ON CREE LE TRIANGLE I1,J2,J1
  201. C
  202. 102 NUMELG = NUMELG + 1
  203. IPT3.NUM(1,NUMELG) = I1
  204. IPT3.NUM(2,NUMELG) = J2
  205. IPT3.NUM(3,NUMELG) = J1
  206. INTERR(1)=NUMELG
  207. IF (I1.EQ.J2.OR.I1.EQ.J1.OR.J2.EQ.J1) CALL ERREUR(101)
  208. IF(IEL2.EQ.JMAX) GO TO 105
  209. IEL2=IEL2+1
  210. GOTO 100
  211. CC
  212. C PLUS DE POINT SUR LA COUTURE = ON RELIE J2 AUX POINTS RESTANTS
  213. C DU COTE 1
  214. C
  215. 105 NUMELG = NUMELG + 1
  216. IPT3.NUM(1,NUMELG) = I1
  217. IPT3.NUM(2,NUMELG) = I2
  218. IPT3.NUM(3,NUMELG) = J2
  219. INTERR(1)=NUMELG
  220. IF (I1.EQ.I2.OR.I1.EQ.J2.OR.I2.EQ.J2) CALL ERREUR(101)
  221. IF(IEL1.EQ.IMAX) GO TO 150
  222. IEL1=IEL1+1
  223. I1=IPT1.NUM(1,IEL1)
  224. I2=IPT1.NUM(NBNN,IEL1)
  225. GO TO 105
  226. 800 CONTINUE
  227. C ON EST DANS LE CAS FACILE OU ON RELIE IPT1 AVEC UN SEUL POINT
  228. DO 801 I=1,NBELE1
  229. IPT3.NUM(1,I)=IPT1.NUM(1,I)
  230. IPT3.NUM(2,I)=IPT1.NUM(NBNN,I)
  231. IPT3.NUM(3,I)=IPO2
  232. 801 CONTINUE
  233. 150 CONTINUE
  234. C OK C'EST FAIT EVENTUELLEMENT CONVERTIR LE TYPE D'ELEMENT
  235. IF (NBNN.EQ.2) ITY=4
  236. IF (NBNN.EQ.3) ITY=6
  237. CALL CHANGE(IPT3,ITY)
  238. SEGDES IPT1
  239. IF (ILIG2.NE.0) SEGDES IPT2
  240. IF (IERR.NE.0) RETURN
  241. SEGACT IPT3*MOD
  242. DO 14 I=1,IPT3.NUM(/2)
  243. 14 IPT3.ICOLOR(I)=ICHCOL
  244. SEGDES IPT3
  245. CALL ECROBJ(ITMAIL,IPT3)
  246. RETURN
  247. END
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  

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