Télécharger la plaquette Cast3M


fr en

Télécharger chemin.eso

Retour à la liste

Numérotation des lignes : 

chemin

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

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