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