Télécharger la plaquette Cast3M


fr en

Télécharger prcoap.eso

Retour à la liste

Numérotation des lignes : 

prcoap

  1. C PRCOAP    SOURCE    GOUNAND   22/02/14    21:15:03     11281          
  2. C   CE SOUS PROGRAMME RETROUVE LE CONTOUR APPARENT (??) D'UN OBJET
  3. C   IL EST DERIVE DE PRCONT
  4. C
  5.       SUBROUTINE PRCOAP(IPT9,IPT2,ICPR,IVU,IRETNE)
  6. C
  7.       IMPLICIT INTEGER(I-N)
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC CCGEOME
  11. -INC SMELEME
  12. -INC SMCOORD
  13.       SEGMENT ICPR(nbpts)
  14.       SEGMENT IDCP(ITE)
  15.       SEGMENT NTSEG(0)
  16.       SEGMENT IVU(0)
  17.       SEGMENT KON(NBCON,NMAX)
  18. C
  19.       MELEME=IPT9
  20.       IPT8=MELEME
  21.       SEGACT MELEME
  22.       ITE=IVU(/1)
  23. C   ITE EST LE NOMBRE DE POINTS A CONSIDERER ICPR LE TABLEAU
  24. C   ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  25.       NBCON=7
  26.       NBCONR=NBCON-1
  27.       NMAX=(10*ITE)/NBCON
  28.       SEGINI KON
  29. C   MISE A ZERO DU TABLEAU KON
  30.       DO 10 I=1,NMAX
  31.         DO 11 J=1,NBCON
  32.            KON(J,I)=0
  33.  11     CONTINUE
  34.   10  CONTINUE
  35. C   FABRICATION DU TABLEAU DES CONNECTIONS
  36. C       POINT FINAL
  37.       ICHAIN=ITE
  38.       SEGACT MELEME
  39.       IPT1=MELEME
  40.       DO 100 IOB=1,MAX(1,LISOUS(/1))
  41.         IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB)
  42.         SEGACT IPT1
  43.         IF (KSURF(IPT1.ITYPEL).NE.0) THEN
  44.           NBELEM=IPT1.NUM(/2)
  45.           NBFAC=LTEL(1,IPT1.ITYPEL)
  46.           IAD=LTEL(2,IPT1.ITYPEL)-1
  47.           IF (NBFAC.NE.0) THEN
  48.             DO 101 IFAC=1,NBFAC
  49.               ITYP=LDEL(1,IAD+IFAC)
  50.               NPFAC=KDFAC(1,ITYP)
  51.               JAD=LDEL(2,IAD+IFAC)-1
  52.               IDEP=KDFAC(2,ITYP)
  53.               IFEP=IDEP+3*(KDFAC(3,ITYP)-1)
  54. * TRIANGLE ELEMENTAIRE
  55. * ON NE GARDE QUE CEUX QUI ONT LEURS TROIS NOEUDS VUS
  56.               DO 1011 ITRIAN=IDEP,IFEP,3
  57.                 IAFA=LFAC(JAD+KFAC(ITRIAN))
  58.                 IBFA=LFAC(JAD+KFAC(ITRIAN+1))
  59.                 ICFA=LFAC(JAD+KFAC(ITRIAN+2))
  60.                 DO 102 IEL=1,NBELEM
  61.                   IA=ICPR(IPT1.NUM(IAFA,IEL))
  62.                   IB=ICPR(IPT1.NUM(IBFA,IEL))
  63.                   IC=ICPR(IPT1.NUM(ICFA,IEL))
  64.                   IF (IVU(IA).GE.1.AND.IVU(IB).GE.1.AND.IVU(IC).GE.1)
  65.      *                                                              THEN
  66.                     DO 103 ICOT=1,3
  67.                       IF (ICOT.EQ.1) THEN
  68.                         N1=IA
  69.                         N2=IB
  70.                       ELSEIF (ICOT.EQ.2) THEN
  71.                         N1=IB
  72.                         N2=IC
  73.                       ELSEIF (ICOT.EQ.3) THEN
  74.                         N1=IC
  75.                         N2=IA
  76.                       ENDIF
  77.                       NI=N1
  78.                       NJ=N2
  79.                       IF (N1*N2.EQ.0) THEN
  80.                         CALL ERREUR(26)
  81.                         SEGSUP KON
  82.                         SEGDES MELEME
  83.                         RETURN
  84.                       ENDIF
  85.                       IPO=0
  86.   23                  CONTINUE
  87.   24                  CONTINUE
  88.                       DO 25 K=1,NBCONR
  89.                         IF (KON(K,NI).EQ.0) GOTO 26
  90.                         IF (KON(K,NI).EQ.NJ) GOTO 27
  91.   25                  CONTINUE
  92.                       IF (KON(NBCON,NI).EQ.0) GOTO 28
  93.                       NI=KON(NBCON,NI)
  94.                       GOTO 24
  95.   27                  CONTINUE
  96.                       KON(K,NI)=-1
  97.                       GOTO 29
  98.   26                  CONTINUE
  99.                       KON(K,NI)=NJ
  100.                       GOTO 29
  101.   28                  CONTINUE
  102.                       ICHAIN=ICHAIN+1
  103.                       IF (ICHAIN.GE.NMAX) THEN
  104. C   ON FAIT UN SEGADJ SUR LE TABLEAU DE CONNECTIONS
  105.                         NMAX=NMAX+1
  106.                         SEGADJ KON
  107.                         DO 70 J=1,NBCON
  108.                           KON(J,NMAX)=0
  109.   70                    CONTINUE
  110.                       ENDIF
  111.                       KON(NBCON,NI)=ICHAIN
  112.                       K=1
  113.                       NI=ICHAIN
  114.                       GOTO 26
  115.   29                  CONTINUE
  116.                       IF (IPO.NE.1) THEN
  117.                         NI=N2
  118.                         NJ=N1
  119.                         IPO=1
  120.                         GOTO 23
  121.                       ENDIF
  122.  103                CONTINUE
  123.                   ENDIF
  124.  102           CONTINUE
  125.  1011          CONTINUE
  126.  101        CONTINUE
  127.           ENDIF
  128.         ENDIF
  129.         IF (LISOUS(/1).NE.0) SEGDES IPT1
  130.   100 CONTINUE
  131.       SEGDES MELEME
  132.       IF (IIMPI.EQ.2)WRITE (IOIMP,1122)((KON(I,J),I=1,NBCON),J=1,NMAX)
  133.  1122 FORMAT(1X,14I5)
  134.       SEGDES MELEME
  135.       SEGINI IDCP
  136.       DO 40 I=1,ICPR(/1)
  137.         IF (ICPR(I).EQ.0) GOTO 40
  138.         IDCP(ICPR(I))=I
  139.   40  CONTINUE
  140. C  CREATION DE L'OBJET CONTOUR. ON COMMENCE PAR COMPTER LENOMBRE D'ELEME
  141.       NBSOUS=0
  142.       NBREF=0
  143.       NBELEM=0
  144.       DO 41 J=1,ITE
  145.         JJ=J
  146.   43    DO 42 I=1,NBCONR
  147.           IF (KON(I,JJ).LT.J) GOTO 42
  148.           NBELEM=NBELEM+1
  149.   42    CONTINUE
  150.         IF (KON(NBCON,JJ).EQ.0) GOTO 41
  151.         JJ=KON(NBCON,JJ)
  152.         GOTO 43
  153.   41  CONTINUE
  154.       IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM
  155.  1111 FORMAT(' NOMBRE D''ELEMENTS DU CONTOUR : ',I6)
  156.       IRETNE=NBELEM
  157.       NBNN=2
  158.       SEGINI MELEME
  159.       ITYPEL=2
  160.       IEL=0
  161.       KAUX=1
  162.   50  CONTINUE
  163.       K=KAUX
  164.       KAUXR=KAUX
  165.       if (k.gt.kon(/2)) then
  166.         write (6,*) ' anomalie dans le trace '
  167.         goto 63
  168.       endif
  169.   51  DO 52 KL=1,NBCONR
  170.         ITRA=KON(KL,K)
  171.         IF (ITRA.EQ.-1) GOTO 52
  172.         IF (ITRA.EQ.0) GOTO 53
  173.         GOTO 54
  174.   52  CONTINUE
  175.       K=KON(NBCON,K)
  176.       IF (K.NE.0) GOTO 51
  177.   53  CONTINUE
  178.       KAUX=KAUX+1
  179.       IF (KAUX.EQ.ITE+1) GOTO 63
  180.       GOTO 50
  181.   54  CONTINUE
  182.       KPRESS=KAUXR
  183.       GOTO 55
  184.   57  CONTINUE
  185.       KL=1
  186.   55  DO 56 L=KL,NBCONR
  187.         M=KON(L,K)
  188.         IF (M.EQ.0) GOTO 53
  189.         IF (M.EQ.-1) GOTO 56
  190.         GOTO 58
  191.   56  CONTINUE
  192.       K=KON(NBCON,K)
  193.       IF (K.EQ.0) GOTO 53
  194.       GOTO 57
  195.   58  CONTINUE
  196.       IEL=IEL+1
  197.       NUM(1,IEL)=IDCP(KPRESS)
  198.       NUM(2,IEL)=IDCP(M)
  199.       ICOLOR(IEL)=1
  200.       KON(L,K)=-1
  201.       M1=M
  202.   59  DO 60 L=1,NBCONR
  203.         IF (KON(L,M1).EQ.0) GOTO 62
  204.         IF (KON(L,M1).EQ.KPRESS) GOTO 61
  205.   60  CONTINUE
  206.       M1=KON(NBCON,M1)
  207.       IF (M1.EQ.0) GOTO 62
  208.       GOTO 59
  209.   61  CONTINUE
  210.       KON(L,M1)=-1
  211.   62  CONTINUE
  214.       GOTO 57
  215.   63  CONTINUE
  216. *  LE RESULTAT
  217.       IPT2=MELEME
  218.       IF (IIMPI.NE.0) THEN
  219.         WRITE (IOIMP,*) ' CONTOUR APPARENT DANS PRCOAP '
  220.         CALL ECROBJ('MAILLAGE',IPT2)
  221.         CALL PRLIST
  222.       ENDIF
  223.       SEGSUP KON,IDCP
  224. C
  225.       RETURN
  226.       END
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  

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