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

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