Télécharger la plaquette Cast3M


fr en

Télécharger compri.eso

Retour à la liste

Numérotation des lignes : 

compri

  1. C COMPRI    SOURCE    CB215821  26/08/24    21:15:40     12622          
  2. C   CET OPERATEUR EXTRAIT D'UNE LIGNE LA PARTIE COMPRISE ENTRE 2 PTS
  3. C
  4.       SUBROUTINE COMPRI
  5.       IMPLICIT INTEGER(I-N)
  6.  
  7. -INC PPARAM
  8. -INC CCOPTIO
  9. -INC SMELEME
  10. -INC SMCOORD
  11.       SEGMENT ICPR(nbpts)
  12.       SEGMENT IDCP(ITE)
  13.       SEGMENT KON(NBCON,NMAX,3)
  14.       CHARACTER*(8) ITPOIN,ITMAIL
  15.       DATA ITPOIN,ITMAIL/'POINT   ','MAILLAGE'/
  16.       ipt1=0
  17.       CALL LIROBJ(ITMAIL,MELEME,1,IRETOU)
  18.       CALL LIROBJ(ITPOIN,IP1,1,IRETOU)
  19.       CALL LIROBJ(ITPOIN,IP2,1,IRETOU)
  20.       IPA1=IP1
  21.       IPA2=IP2
  22.       IF (IERR.NE.0) RETURN
  23.       SEGACT MELEME
  24.       NBNN=ITYPEL
  25.       IF (NBNN.NE.2.AND.NBNN.NE.3) CALL ERREUR(16)
  26.       IF (IERR.EQ.0) GOTO 1
  27.       SEGDES MELEME
  28.       RETURN
  29.    1  CONTINUE
  30.       SEGINI ICPR
  31.       DO 2 I=1,ICPR(/1)
  32.       ICPR(I)=0
  33.     2 CONTINUE
  34. C  REMPLISSAGE DE ICPR
  35.       ITE=0
  36.       NBELEM=NUM(/2)
  37.       NBNN=NUM(/1)
  38.       DO 101 J=1,NBNN
  39.       DO 3 K=1,NBELEM
  40.       IPOIT=NUM(J,K)
  41.       IF (ICPR(IPOIT).NE.0) GOTO 3
  42.       ITE=ITE+1
  43.       ICPR(IPOIT)=ITE
  44.    3  CONTINUE
  45.   101 CONTINUE
  46. C  TABLEAU INVERSE
  47.       SEGINI IDCP
  48.       ILO=nbpts
  49.       DO 4 I=1,ILO
  50.       J=ICPR(I)
  51.       IF (J.EQ.0) GOTO 4
  52.       IDCP(J)=I
  53.    4  CONTINUE
  54. C   ITE EST LE NOMBRE DE POINTS A TRACER  ICPR LE TABLEAU
  55. C   ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  56.       NBCON=3
  57.       NBCONR=NBCON-1
  58.       NMAX=(5*ITE)/NBCON
  59.       SEGINI KON
  60. C   MISE A ZERO DU TABLEAU KON
  61.       DO 103 K=1,3
  62.       DO 102 I=1,NMAX
  63.       DO 10 J=1,NBCON
  64.       KON(J,I,K)=0
  65.    10 CONTINUE
  66.   102 CONTINUE
  67.   103 CONTINUE
  68. C   FABRICATION DU TABLEAU DES CONNECTIONS
  69.       ICHAIN=ITE
  70.       DO 20 I=1,NBELEM
  71.       NMIL=1
  72.       N1=ICPR(NUM(1,I))
  73.       N2=ICPR(NUM(NBNN,I))
  74.       IF (NBNN.EQ.3) NMIL=NUM(2,I)
  75.       IF (N1.EQ.N2) GOTO 20
  76.       NI=N1
  77.       NJ=N2
  78.       KSCOL=ICOLOR(I)
  79.   21  CONTINUE
  80.   22  DO 23 K=1,NBCONR
  81.       IF (KON(K,NI,1).EQ.0) GOTO 25
  82.   23  CONTINUE
  83.       IF (KON(NBCON,NI,1).EQ.0) GOTO 24
  84.       NI=KON(NBCON,NI,1)
  85.       GOTO 22
  86.   24  ICHAIN=ICHAIN+1
  87.       IF (ICHAIN.EQ.NMAX) GOTO 30
  88.       KON(NBCON,NI,1)=ICHAIN
  89.       K=1
  90.       NI=ICHAIN
  91.   25  KON(K,NI,1)=NJ
  92.       KON(K,NI,2)=NMIL
  93.       KON(K,NI,3)=KSCOL
  94.       IF (NMIL.LE.0) GOTO 20
  95.       NI=N2
  96.       NJ=N1
  97.       NMIL=-NMIL
  98.       GOTO 21
  99.   30  CALL ERREUR(23)
  100.       RETURN
  101.   20  CONTINUE
  102.       SEGDES MELEME
  103. C  EXTRACTION DE LA SOUS-PARTIE
  104.       NBSOUS=0
  105.       NBREF=0
  106. *     write (6,*) ' ipt1 nbelem nbnn   ',nbelem nbnn
  107.       SEGINI IPT1
  108.       IP1=ICPR(IP1)
  109.       IP2=ICPR(IP2)
  110.       IF (IP1*IP2.EQ.0) CALL ERREUR(18)
  111.       IF (IERR.EQ.0) GOTO 31
  112.       SEGSUP KON
  113.       RETURN
  114.   31  CONTINUE
  115.       if (ipt1.eq.0) call erreur(5)
  116.       IEL=0
  117.       KAUX=IP1
  118.       K=KAUX
  119.       KPRESS=KAUX
  120.   41  DO 40 KL=1,NBCONR
  121.       M=KON(KL,K,1)
  122.       IF (M.EQ.0) GOTO 100
  123.       IF (KON(KL,K,2).LE.0) GOTO 40
  124.       GOTO 45
  125.   40  CONTINUE
  126.       K=KON(NBCON,K,1)
  127.       IF (K.EQ.0) GOTO 100
  128.       GOTO 41
  129.   46  KL=1
  130.   45  DO 47 L=KL,NBCONR
  131.       M=KON(L,K,1)
  132.       IF (M.EQ.-1) GOTO 47
  133.       IF (M.EQ.0) GOTO 100
  134.       GOTO 48
  135.   47  CONTINUE
  136.       K=KON(NBCON,K,1)
  137.       IF (K.EQ.0) GOTO 100
  138.       GOTO 46
  139.   48  IEL=IEL+1
  140.       IPT1.NUM(1,IEL)=IDCP(KPRESS)
  141.       IPT1.NUM(NBNN,IEL)=IDCP(M)
  142.       IPT1.ICOLOR(IEL)=KON(L,K,3)
  143.       IF (NBNN.EQ.3) IPT1.NUM(2,IEL)=ABS(KON(L,K,2))
  144.       IF (M.EQ.IP2) GOTO 52
  145.       KON(L,K,1)=-1
  146.       M1=M
  147.   49  DO 50 L=1,NBCONR
  148.       IF (KON(L,M1,1).EQ.0) GOTO 53
  149.       IF (KON(L,M1,1).EQ.-1) GOTO 50
  150.       IF (KON(L,M1,1).EQ.KPRESS) GOTO 51
  151.   50  CONTINUE
  152.       M1=KON(NBCON,M1,1)
  153.       GOTO 49
  154.   51  KON(L,M1,1)=-1
  155.   53  KPRESS=M
  157.       GOTO 46
  158.  100  CONTINUE
  159. * on essaye de voir si un seul chemin
  160.       SEGSUP KON,IPT1,ICPR,IDCP
  161.       CALL CHEMIN(MELEME,IPA1,IPA2,IPT1)
  162.       IF(IERR.EQ.0)CALL ECROBJ(ITMAIL,IPT1)
  163.       RETURN
  164.   52  CONTINUE
  165.       SEGSUP KON,ICPR,IDCP
  166. C  ON A FINI IL NE RESTE PLUS QU'A COMPACTER LE SEGMENT
  167.       NBELEM=IEL
  168.       SEGINI MELEME
  169.       ITYPEL=NBNN
  170.       DO 104 I=1,NBNN
  171.       DO 60 J=1,NBELEM
  172.       NUM(I,J)=IPT1.NUM(I,J)
  173.   60  CONTINUE
  174.   104 CONTINUE
  175.       DO 61 I=1,NBELEM
  176.       ICOLOR(I)=IPT1.ICOLOR(I)
  177.    61 CONTINUE
  178.       SEGSUP IPT1
  179.       SEGDES MELEME
  180.       CALL ECROBJ(ITMAIL,MELEME)
  181.       RETURN
  182.       END
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  

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