C CHEMIN SOURCE PASCAL 22/02/24 21:15:02 11298 SUBROUTINE CHEMIN(MELEME,IP1,IP2,IPT1) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCOORD SEGMENT ICPR(nbpts) SEGMENT IPRI(nbpts) SEGMENT INEG(nbpts) SEGMENT KON(MAXVOI,NPO) SEGMENT IVOI(MAXVOI,NPO) SEGMENT ILKON(NPO) SEGMENT ICHEM INTEGER NIVE(NPO+2) INTEGER INOE(NPO) INTEGER IPERE(nbpts) ENDSEGMENT SEGINI ICPR NPOIN=0 I1=1 I2=2 SEGACT MELEME NBELEM=NUM(/2) IF(ITYPEL.NE.2.AND.ITYPEL.NE.3) THEN CALL ERREUR(16) SEGDES MELEME RETURN ENDIF IF(ITYPEL.EQ.3) I2=3 * * en entree MELEME est suppose ne contenir que des elements de meme * type. Soit des seg2 soit des seg3. ICPR(I)=J l'ancien Ieme noeud * est le Jeme local * * comptage des voisins * DO 1 I=1,NUM(/2) IJ= NUM(I1,I) ICPR(IJ)=ICPR(IJ)+1 IJ= NUM(I2,I) ICPR(IJ)=ICPR(IJ)+1 1 CONTINUE IF(ICPR(IP1).EQ.0.OR.ICPR(IP2).EQ.0) THEN CALL ERREUR(866) RETURN ENDIF MAXVOI=0 NPO=0 DO 2 I=1,ICPR(/1) IF(ICPR(I).NE.0) THEN MAXVOI=MAX(MAXVOI,ICPR(I)) NPO=NPO+1 ICPR(I)=NPO ENDIF 2 CONTINUE * * fabrication du tableau KON(I,J)=k le iémé noeud connecté au noeud * J est le Keme noeud SEGINI KON,ILKON,IVOI DO 3 I=1,NUM(/2) IA=NUM(I1,I) IB=NUM(I2,I) IACP=ICPR(IA) IBCP=ICPR(IB) ILKON(IACP)=ILKON(IACP)+1 ILKON(IBCP)=ILKON(IBCP)+1 KON(ILKON(IACP),IACP)=IB KON(ILKON(IBCP),IBCP)=IA IVOI(ILKON(IACP),IACP)=I IVOI(ILKON(IBCP),IBCP)=I 3 CONTINUE * * on demarre l'arbre en partant du point IP2 * SEGINI ICHEM,IPRI,INEG IDEP=IP2 IPLA=1 INUM=1 NIVE(1)=1 NIVE(2)=2 INOE(IPLA)=IP2 IPRI(IP2)=1 IPERE(IP2)=0 IDER=0 IAV=0 100 CONTINUE IF(IDER.EQ.1) GO TO 101 IF(IPLA.EQ.IAV) GO TO 101 IAV=IPLA IF(IPLA.GE.NPO) IDER=1 IDEB=NIVE(INUM) IFIN=NIVE(INUM+1)-1 DO 104 I=IDEB,IFIN IA=INOE(I) IC=IPERE(IA) DO 105 J=1,ILKON(ICPR(IA)) IB=KON(J,ICPR(IA)) IF(IB.EQ.IC) GO TO 105 if (ib.eq.0) goto 105 IF(IPRI(IB).EQ.0) THEN IPLA=IPLA+1 INOE(IPLA)=IB IPRI(IB)=INUM+1 IPERE(IB)=IA ELSE * * on remonte le long des deux branches pour trouver la partie commune * J1=IA J2=IB L1=IPRI(IA) L2=IPRI(IB) IF(L1.LT.L2) THEN J2=IPERE(J2) L2=IPRI(J2) ENDIF IF(L1.GT.L2) THEN J1=IPERE(J1) L1=IPRI(J1) ENDIF 106 CONTINUE IF(J2.NE.J1) THEN J1=IPERE(J1) J2=IPERE(J2) GO TO 106 ELSE INEG(J2)=1 ENDIF ENDIF 105 CONTINUE 104 CONTINUE INUM=INUM+1 NIVE(INUM+1)=IPLA+1 GO TO 100 101 CONTINUE IF(IPRI(IP1).EQ.0) THEN CALL ERREUR(868) SEGDES MELEME SEGSUP ICHEM,ILKON,KON,ICPR,IPRI,INEG,IVOI RETURN ENDIF IF(INEG(IP2).EQ.1) THEN CALL ERREUR(867) SEGDES MELEME SEGSUP ICHEM,ILKON,KON,ICPR,IPRI,INEG,IVOI RETURN ENDIF * * on recommence l'arbre mais on met en negatif toutes les cycles * DO 199 I=1,IPRI(/1) IPRI(I)=0 199 CONTINUE IPLA=1 INUM=1 NIVE(1)=1 NIVE(2)=2 INOE(IPLA)=IP2 IPRI(IP2)=1 IPERE(IP2)=0 IAV=0 200 CONTINUE IF(IPLA.GE.NPO) GO TO 201 IF(IPLA.EQ.IAV) GO TO 201 IAV=IPLA IDEB=NIVE(INUM) IFIN=NIVE(INUM+1)-1 DO 204 I=IDEB,IFIN IA=INOE(I) IC=IPERE(IA) ID=INEG(IA) DO 205 J=1,ILKON(ICPR(IA)) IB=KON(J,ICPR(IA)) IF(IB.EQ.IC) GO TO 205 IF(IB.EQ.0) GO TO 205 IF(IPRI(IB).EQ.0) THEN IPLA=IPLA+1 INOE(IPLA)=IB IPRI(IB)=INUM+1 IPERE(IB)=IA IF(ID.GT.0) INEG(IB)=1 ENDIF 205 CONTINUE 204 CONTINUE INUM=INUM+1 NIVE(INUM+1)=IPLA+1 GO TO 200 201 CONTINUE * * si ineg(IP1)=0 la tache est possible sinon retour * IF(INEG(IP1).EQ.1)THEN CALL ERREUR(867) SEGDES MELEME SEGSUP ICHEM,ILKON,KON,ICPR,IPRI,INEG,IVOI RETURN ENDIF NBELEM=IPRI(IP1)-1 NBNN = NUM(/1) NBSOUS=0 NBREF=0 SEGINI IPT1 IPT1.NUM(1,1)=IP1 IPA=IP1 IPO=1 302 CONTINUE IB=IPERE(IPA) DO 303 I=1,ILKON(ICPR(IPA)) IF(IB.NE.KON(I,ICPR(IPA))) GO TO 303 IV=IVOI (I,ICPR(IPA)) IF(NBNN.EQ.3) IPT1.NUM(2,IPO)=NUM(2,IV) IPT1.ICOLOR(IPO)=ICOLOR(IV) IPT1.NUM(I2,IPO)=IB IF(IB.NE.IP2) THEN IPA=IB IPO=IPO+1 IPT1.NUM(1,IPO)=IB GO TO 302 ENDIF GO TO 304 303 CONTINUE CALL ERREUR(21) RETURN 304 CONTINUE IPT1.ITYPEL=I2 SEGDES IPT1,MELEME SEGSUP ICHEM,ILKON,KON,ICPR,IPRI,INEG,IVOI RETURN END