Télécharger chemin.eso

Retour à la liste

Numérotation des lignes :

  1. C CHEMIN SOURCE PV 09/07/16 21:15:01 6446
  2. SUBROUTINE CHEMIN(MELEME,IP1,IP2,IPT1)
  3. IMPLICIT INTEGER(I-N)
  4. -INC CCOPTIO
  5. -INC SMELEME
  6. -INC SMCOORD
  7. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  8. SEGMENT IPRI(XCOOR(/1)/(IDIM+1))
  9. SEGMENT INEG(XCOOR(/1)/(IDIM+1))
  10. SEGMENT KON(MAXVOI,NPO)
  11. SEGMENT IVOI(MAXVOI,NPO)
  12. SEGMENT ILKON(NPO)
  13. SEGMENT ICHEM
  14. INTEGER NIVE(NPO+2)
  15. INTEGER INOE(NPO)
  16. INTEGER IPERE(XCOOR(/1)/(IDIM+1))
  17. ENDSEGMENT
  18. SEGINI ICPR
  19. NPOIN=0
  20. I1=1
  21. I2=2
  22. SEGACT MELEME
  23. NBELEM=NUM(/2)
  24. IF(ITYPEL.NE.2.AND.ITYPEL.NE.3) THEN
  25. CALL ERREUR(16)
  26. SEGDES MELEME
  27. RETURN
  28. ENDIF
  29. IF(ITYPEL.EQ.3) I2=3
  30. *
  31. * en entree MELEME est suppose ne contenir que des elements de meme
  32. * type. Soit des seg2 soit des seg3. ICPR(I)=J l'ancien Ieme noeud
  33. * est le Jeme local
  34. *
  35. * comptage des voisins
  36. *
  37. DO 1 I=1,NUM(/2)
  38. IJ= NUM(I1,I)
  39. ICPR(IJ)=ICPR(IJ)+1
  40. IJ= NUM(I2,I)
  41. ICPR(IJ)=ICPR(IJ)+1
  42. 1 CONTINUE
  43. IF(ICPR(IP1).EQ.0.OR.ICPR(IP2).EQ.0) THEN
  44. CALL ERREUR(866)
  45. RETURN
  46. ENDIF
  47. MAXVOI=0
  48. NPO=0
  49. DO 2 I=1,ICPR(/1)
  50. IF(ICPR(I).NE.0) THEN
  51. MAXVOI=MAX(MAXVOI,ICPR(I))
  52. NPO=NPO+1
  53. ICPR(I)=NPO
  54. ENDIF
  55. 2 CONTINUE
  56. *
  57. * fabrication du tableau KON(I,J)=k le iémé noeud connecté au noeud
  58. * J est le Keme noeud
  59. SEGINI KON,ILKON,IVOI
  60. DO 3 I=1,NUM(/2)
  61. IA=NUM(I1,I)
  62. IB=NUM(I2,I)
  63. IACP=ICPR(IA)
  64. IBCP=ICPR(IB)
  65. ILKON(IACP)=ILKON(IACP)+1
  66. ILKON(IBCP)=ILKON(IBCP)+1
  67. KON(ILKON(IACP),IACP)=IB
  68. KON(ILKON(IBCP),IBCP)=IA
  69. IVOI(ILKON(IACP),IACP)=I
  70. IVOI(ILKON(IBCP),IBCP)=I
  71. 3 CONTINUE
  72. *
  73. * on demarre l'arbre en partant du point IP2
  74. *
  75. SEGINI ICHEM,IPRI,INEG
  76. IDEP=IP2
  77. IPLA=1
  78. INUM=1
  79. NIVE(1)=1
  80. NIVE(2)=2
  81. INOE(IPLA)=IP2
  82. IPRI(IP2)=1
  83. IPERE(IP2)=0
  84. IDER=0
  85. IAV=0
  86. 100 CONTINUE
  87. IF(IDER.EQ.1) GO TO 101
  88. IF(IPLA.EQ.IAV) GO TO 101
  89. IAV=IPLA
  90. IF(IPLA.GE.NPO) IDER=1
  91. IDEB=NIVE(INUM)
  92. IFIN=NIVE(INUM+1)-1
  93. DO 104 I=IDEB,IFIN
  94. IA=INOE(I)
  95. IC=IPERE(IA)
  96. DO 105 J=1,ILKON(ICPR(IA))
  97. IB=KON(J,ICPR(IA))
  98. IF(IB.EQ.IC) GO TO 105
  99. if (ib.eq.0) goto 105
  100. IF(IPRI(IB).EQ.0) THEN
  101. IPLA=IPLA+1
  102. INOE(IPLA)=IB
  103. IPRI(IB)=INUM+1
  104. IPERE(IB)=IA
  105. ELSE
  106. *
  107. * on remonte le long des deux branches pour trouver la partie commune
  108. *
  109. J1=IA
  110. J2=IB
  111. L1=IPRI(IA)
  112. L2=IPRI(IB)
  113. IF(L1.LT.L2) THEN
  114. J2=IPERE(J2)
  115. L2=IPRI(J2)
  116. ENDIF
  117. IF(L1.GT.L2) THEN
  118. J1=IPERE(J1)
  119. L1=IPRI(J1)
  120. ENDIF
  121. 106 CONTINUE
  122. IF(J2.NE.J1) THEN
  123. J1=IPERE(J1)
  124. J2=IPERE(J2)
  125. GO TO 106
  126. ELSE
  127. INEG(J2)=1
  128. ENDIF
  129. ENDIF
  130. 105 CONTINUE
  131. 104 CONTINUE
  132. INUM=INUM+1
  133. NIVE(INUM+1)=IPLA+1
  134. GO TO 100
  135. 101 CONTINUE
  136. IF(IPRI(IP1).EQ.0) THEN
  137. CALL ERREUR(868)
  138. SEGDES MELEME
  139. SEGSUP ICHEM,ILKON,KON,ICPR,IPRI,INEG,IVOI
  140. RETURN
  141. ENDIF
  142. IF(INEG(IP2).EQ.1) THEN
  143. CALL ERREUR(867)
  144. SEGDES MELEME
  145. SEGSUP ICHEM,ILKON,KON,ICPR,IPRI,INEG,IVOI
  146. RETURN
  147. ENDIF
  148. *
  149. * on recommence l'arbre mais on met en negatif toutes les cycles
  150. *
  151. DO 199 I=1,IPRI(/1)
  152. IPRI(I)=0
  153. 199 CONTINUE
  154. IPLA=1
  155. INUM=1
  156. NIVE(1)=1
  157. NIVE(2)=2
  158. INOE(IPLA)=IP2
  159. IPRI(IP2)=1
  160. IPERE(IP2)=0
  161. IAV=0
  162. 200 CONTINUE
  163. IF(IPLA.GE.NPO) GO TO 201
  164. IF(IPLA.EQ.IAV) GO TO 201
  165. IAV=IPLA
  166. IDEB=NIVE(INUM)
  167. IFIN=NIVE(INUM+1)-1
  168. DO 204 I=IDEB,IFIN
  169. IA=INOE(I)
  170. IC=IPERE(IA)
  171. ID=INEG(IA)
  172. DO 205 J=1,ILKON(ICPR(IA))
  173. IB=KON(J,ICPR(IA))
  174. IF(IB.EQ.IC) GO TO 205
  175. IF(IB.EQ.0) GO TO 205
  176. IF(IPRI(IB).EQ.0) THEN
  177. IPLA=IPLA+1
  178. INOE(IPLA)=IB
  179. IPRI(IB)=INUM+1
  180. IPERE(IB)=IA
  181. IF(ID.GT.0) INEG(IB)=1
  182. ENDIF
  183. 205 CONTINUE
  184. 204 CONTINUE
  185. INUM=INUM+1
  186. NIVE(INUM+1)=IPLA+1
  187. GO TO 200
  188. 201 CONTINUE
  189. *
  190. * si ineg(IP1)=0 la tache est possible sinon retour
  191. *
  192. IF(INEG(IP1).EQ.1)THEN
  193. CALL ERREUR(867)
  194. SEGDES MELEME
  195. SEGSUP ICHEM,ILKON,KON,ICPR,IPRI,INEG,IVOI
  196. RETURN
  197. ENDIF
  198. NBELEM=IPRI(IP1)-1
  199. NBNN = NUM(/1)
  200. NBSOUS=0
  201. NBREF=0
  202. SEGINI IPT1
  203. IPT1.NUM(1,1)=IP1
  204. IPA=IP1
  205. IPO=1
  206. 302 CONTINUE
  207. IB=IPERE(IPA)
  208. DO 303 I=1,ILKON(ICPR(IPA))
  209. IF(IB.NE.KON(I,ICPR(IPA))) GO TO 303
  210. IV=IVOI (I,ICPR(IPA))
  211. IF(NBNN.EQ.3) IPT1.NUM(2,IPO)=NUM(2,IV)
  212. IPT1.ICOLOR(IPO)=ICOLOR(IV)
  213. IPT1.NUM(I2,IPO)=IB
  214. IF(IB.NE.IP2) THEN
  215. IPA=IB
  216. IPO=IPO+1
  217. IPT1.NUM(1,IPO)=IB
  218. GO TO 302
  219. ENDIF
  220. GO TO 304
  221. 303 CONTINUE
  222. CALL ERREUR(5)
  223. RETURN
  224. 304 CONTINUE
  225. IPT1.ITYPEL=I2
  226. SEGDES IPT1,MELEME
  227. SEGSUP ICHEM,ILKON,KON,ICPR,IPRI,INEG,IVOI
  228. RETURN
  229. END
  230.  
  231.  
  232.  
  233.  

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