Télécharger la plaquette Cast3M


fr en

Télécharger chanlg.eso

Retour à la liste

Numérotation des lignes : 

chanlg

  1. C CHANLG    SOURCE    FANDEUR   21/04/26    21:15:07     10979          
  2. C   CE SOUS PROGRAMME FABRIQUE L'ENSEMBLE DES ARETES D'UN MAILLAGE
  3. C   IL FONCTIONNE SUIVANT UN PRINCIPE DERIVE DES TRACES
  4. C
  5.       SUBROUTINE CHANLG
  6.       IMPLICIT INTEGER(I-N)
  7.  
  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 KON(NBCON,NMAX,3)
  17.  
  18.       ICPR = 0
  19.       ICDP = 0
  20.       KON = 0
  21.  
  22.       CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  23.       IF (IERR.NE.0) RETURN
  24.  
  25.       SEGINI ICPR
  26.       ITE=0
  27.       NELTOT=0
  28.       idegre=0
  29.  
  30.       SEGACT MELEME
  31.       IPT8 = MELEME
  32. c on peut faire un ACTOBJ !
  33.       NBSOU8 = meleme.LISOUS(/1)
  34.       IPT1=MELEME
  35.       DO 3 I=1,MAX(1,NBSOU8)
  36.          IF (NBSOU8.NE.0) THEN
  37.             IPT1 = meleme.LISOUS(I)
  38.             SEGACT IPT1
  39.          ENDIF
  40.          NBNOE1=IPT1.NUM(/1)
  41.          NBELT1=IPT1.NUM(/2)
  42.          NELTOT=NELTOT+NBELT1
  43.          K=IPT1.ITYPEL
  44.          idegre=KDEGRE(K)
  45.          IDEP=NSPOS(K)
  46.          if (idep.eq.0) goto 8
  47.          IF (NBSOM(K).GT.0) THEN
  48.             IFEP=IDEP+NBSOM(K)-1
  49.          ELSE
  50. C            Cas du polygone
  51.             IFEP=IDEP+NBNOE1-1
  52.          ENDIF
  53.          DO 4 JJ=IDEP,IFEP
  54.             J=IBSOM(JJ)
  55.             DO 41 K=1,NBELT1
  56.                IPOIT=IPT1.NUM(J,K)
  57.                IF (ICPR(IPOIT).NE.0) GOTO 41
  58.                ITE=ITE+1
  59.                ICPR(IPOIT)=ITE
  60.  41         CONTINUE
  61.  4       CONTINUE
  62.  8       CONTINUE
  63.          IF (NBSOU8.NE.0) SEGDES IPT1
  64.  3    CONTINUE
  65.       SEGDES MELEME
  66. *
  67.       IF (ITE.NE.0) GOTO 6
  68.       SEGSUP,ICPR
  69. * sg 2016/11/29 gestion maillage vide
  70.       IF (NELTOT.EQ.0) THEN
  71. * Par défaut SEG2, sinon en fonction du dernier KDEGRE lu.
  72.          ity=2
  73.          IF (idegre.ge.1.and.idegre.le.3) ity=idegre
  74.          CALL melvid(ity,meleme)
  75.          CALL ECROBJ('MAILLAGE',MELEME)
  76.       ELSE
  77. *  16 2
  78. *Type d'élément incorrect
  79.          CALL ERREUR(16)
  80.       ENDIF
  81.       RETURN
  82.  6    CONTINUE
  83.  
  84. C   ITE EST LE NOMBRE DE POINTS A CONSIDERER  ICPR LE TABLEAU
  85. C   ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  86.       NBCON=7
  87.       NBCONR=NBCON-1
  88.       NMAX= 10*ITE
  89.       SEGINI KON
  90. C   FABRICATION DU TABLEAU DES CONNECTIONS
  91. C    1  POINT FINAL
  92. C    2  POINT INTERMEDIAIRE EVENTUEL ET SENS
  93.       ICHAIN=ITE
  94.       SEGACT MELEME
  95.       IOO=0
  96.       IA=0
  97.       IPT1=MELEME
  98.       DO 30 IO=1,MAX(1,NBSOU8)
  99.          IF (NBSOU8.NE.0) IPT1=LISOUS(IO)
  100.          SEGACT IPT1
  101.          K=IPT1.ITYPEL
  102.          If ((K.eq.22).or.(K.eq.48)) then
  103.             segdes ipt1
  104.             goto 30
  105.          endif
  106.          NBNN=KDEGRE(K)
  107. c k=32 et nbnn=2
  108.          IF (IA.EQ.0)  IA=NBNN
  109.          IF (NBNN.NE.IA) THEN
  110. *           PRINT *,'*MAILLAGE IMPOSSIBLE'
  111. *           PRINT *,'*EXISTENCE D''ELEMENTS DONNANT'
  112. *           PRINT *,'*DES SEG2 ET DES SEG3'
  113.             CALL ERREUR(26)
  114.             GOTO 64
  115.          ENDIF
  116.          IPAS=NBNN-1
  117.          KKK=LTEL(1,K)
  118. c IPAS = 1 & KKK = 1
  119. * Cas des segments
  120.          IF (KKK.EQ.0) THEN
  121.             DO 122 I=1,IPT1.NUM(/2)
  122.                NMIL=1
  123.                N1=ICPR(IPT1.NUM(1,I))
  124.                JSUIV=1+IPAS
  125.                N2=ICPR(IPT1.NUM(JSUIV,I))
  126.                IF (N1*N2.EQ.0) THEN
  127.                  CALL ERREUR(26)
  128.                  GOTO 64
  129.                ENDIF
  130.                IF (IPAS.EQ.2) NMIL=IPT1.NUM(1+1,I)
  131.                NI=N1
  132.                NJ=N2
  133.                KSCOL=IPT1.ICOLOR(I)
  134. *                           PRINT *,'*KSCOL',KSCOL
  135.                IPO=0
  136.  123           CONTINUE
  137.                DO 125 IK=1,NBCONR
  138.                   IF (KON(IK,NI,1).EQ.0) GOTO 126
  139.                   IF (KON(IK,NI,1).EQ.NJ) GOTO 129
  140.  125           CONTINUE
  141.                IF (KON(NBCON,NI,1).EQ.0) GOTO 128
  142.                NI=KON(NBCON,NI,1)
  143.                GOTO 123
  144.  126           CONTINUE
  145.                KON(IK,NI,1)=NJ
  146.                KON(IK,NI,2)=NMIL
  147.                KON(IK,NI,3)=KSCOL
  148.                GOTO 129
  149.  128           ICHAIN=ICHAIN+1
  150.                IF (ICHAIN.GE.NMAX) THEN
  151.                  CALL ERREUR(26)
  152.                  GOTO 64
  153.                ENDIF
  154.                KON(NBCON,NI,1)=ICHAIN
  155.                IK=1
  156.                NI=ICHAIN
  157.                GOTO 126
  158.  129           CONTINUE
  159.                IF (IPO.EQ.1) GOTO 122
  160.                NMIL=-NMIL
  161.                NI=N2
  162.                NJ=N1
  163.                IPO=1
  164.                GOTO 123
  165.  122        CONTINUE
  166.          ELSE
  167.             IOO=1
  168.             KK=LTEL(2,K)-1
  169. c KKK = 1 && KK = 49
  170.             DO 300 III=1,KKK
  171. C ****BOUCLE PERMETTANT D'ALLER RECHERCHER TOUTES LES FACES
  172.                KK=KK+1
  173.                ITYP=LDEL(1,KK)
  174.                IDEP=LDEL(2,KK)
  175.                IF (K.EQ.32) ITYP = 0
  176.                IF (ITYP.GT.0) THEN
  177.                   IFEP=IDEP+KDFAC(1,ITYP)-1
  178. *     SG 20160711 pour les faces TRI7 et QUA9, on ignore le dernier
  179. *     point (centre de la face)
  180.                   IF (ITYP.EQ.7.OR.ITYP.EQ.8) IFEP=IFEP-1
  181.                ELSE
  182. C                    Cas du polygone
  183.                   IFEP= IDEP+IPT1.NUM(/1)-1
  184.                ENDIF
  185.                DO 22 I=1,IPT1.NUM(/2)
  186.                   KSCOL=IPT1.ICOLOR(I)
  187.                   DO 221 J=IDEP,IFEP,IPAS
  188.                      NMIL=1
  189.                      N1=ICPR(IPT1.NUM(LFAC(J),I))
  190.                      JSUIV=J+IPAS
  191.                      IF (JSUIV.GT.IFEP) JSUIV=IDEP
  192.                      N2=ICPR(IPT1.NUM(LFAC(JSUIV),I))
  193.                      IF (IPAS.EQ.2) NMIL=IPT1.NUM(LFAC(J+1),I)
  194.                      NI=N1
  195.                      NJ=N2
  196.                      IF (N1*N2.EQ.0) THEN
  197.                        CALL ERREUR(26)
  198.                        GOTO 64
  199.                      ENDIF
  200.                      IPO=0
  201.  23                  CONTINUE
  202.                      DO 25 IK=1,NBCONR
  203.                         IF (KON(IK,NI,1).EQ.0) GOTO 26
  204.                         IF (KON(IK,NI,1).EQ.NJ) GOTO 29
  205.  25                  CONTINUE
  206.                      IF (KON(NBCON,NI,1).EQ.0) GOTO 28
  207.                      NI=KON(NBCON,NI,1)
  208.                      GOTO 23
  209.  26                  KON(IK,NI,1)=NJ
  210.                      KON(IK,NI,2)=NMIL
  211.                      KON(IK,NI,3)=KSCOL
  212.                      GOTO 29
  213.  28                  ICHAIN=ICHAIN+1
  214.                      IF (ICHAIN.GE.NMAX) THEN
  215.                        CALL ERREUR(26)
  216.                        GOTO 64
  217.                      ENDIF
  218.                      KON(NBCON,NI,1)=ICHAIN
  219.                      IK=1
  220.                      NI=ICHAIN
  221.                      GOTO 26
  222.  29                  IF (IPO.EQ.1) GOTO 221
  223.                      NMIL=-NMIL
  224.                      NI=N2
  225.                      NJ=N1
  226.                      IPO=1
  227.                      GOTO 23
  228.  221              CONTINUE
  229.  22            CONTINUE
  230.  300        CONTINUE
  231.          ENDIF
  232.          IF (NBSOU8.NE.0) SEGDES IPT1
  233.  30   CONTINUE
  234.  
  235.       IF (IIMPI.EQ.2)WRITE (IOIMP,1122) (((KON(I,J,K),K=1
  236.      $     ,2),I=1,NBCON),J=1,NMAX)
  237.  1122 FORMAT(1X,14I5)
  238.  
  239.       SEGDES MELEME
  240.  
  241.       SEGINI IDCP
  242.  
  243.       DO 40 I=1,ICPR(/1)
  244.          IF (ICPR(I).EQ.0) GOTO 40
  245.          IDCP(ICPR(I))=I
  246.  40   CONTINUE
  247.  
  248. ************************************************************************
  249. *  CREATION DE L'OBJET MAILLAGE
  250.       NBSOUS=0
  251.       NBREF=0
  252.       NBELEM=0
  253.  
  254. C ****ON COMPTE LE NOMBRE D'ELEMENTS POUR ACTIVER LE SEGMENT
  255.  
  256.       DO 170 J=1,ITE
  257.          JJ=J
  258.  
  259.  179     CONTINUE
  260.          DO 180 I=1,NBCONR
  261.             M=KON(I,JJ,1)
  262.             IF(M.LT.J) GOTO 180
  263.             NBELEM=NBELEM+1
  264.  180     CONTINUE
  265.  
  266.          IF (KON(NBCON,JJ,1) .EQ. 0) GOTO 170
  267.          JJ=KON(NBCON,JJ,1)
  268.          GOTO 179
  269.  170  CONTINUE
  270.  
  271. ** TEST VERIFIANT SI AU DEPART ON A DEJA DES POINTS,SEG2 OU SEG3
  272.       IF (IOO.EQ.0) THEN
  273. *        LE MAILLAGE EXISTE DEJA
  274. *        PRINT *,'*LE MAILLAGE EXISTE DEJA'
  275.          CALL ECROBJ('MAILLAGE',IPT1)
  276.          GOTO 64
  277.       ENDIF
  278.  
  279.       IF (NBELEM.EQ.0) THEN
  280.         CALL ERREUR(26)
  281.         GOTO 64
  282.       ENDIF
  283.  
  284. C****ETABLISSEMENT DU MAILLAGE
  285. C****CONSTRUCTION DU TABLEAU NUM
  286.       SEGINI,MELEME
  287.       ITYPEL=NBNN
  288.       IEL=0
  289.       DO 100 J=1,ITE
  290.          JJ=J
  291.  109     CONTINUE
  292.          DO 110 I=1,NBCONR
  293.             M=KON(I,JJ,1)
  294.             IF (M.LT.J) GOTO 110
  295.             IEL=IEL+1
  296.             NUM(1,IEL)=IDCP(J)
  297.             NUM(NBNN,IEL)=IDCP(M)
  298.             ICOLOR(IEL)=KON(I,JJ,3)
  299.             IF (NBNN.EQ.3) NUM(2,IEL)=ABS(KON(I,JJ,2))
  300.  110     CONTINUE
  301.  
  302.          IF (KON(NBCON,JJ,1).EQ.0) GOTO 100
  303.          JJ=KON(NBCON,JJ,1)
  304.          GOTO 109
  305.  100  CONTINUE
  306.  
  307.       SEGDES MELEME
  308.       CALL ECROBJ('MAILLAGE',MELEME)
  309.  
  310. *  ON INSCRIT LE MAILLAGE  DANS LE MAILLAGE INITIAL
  311. *      SEGACT,IPT8*MOD
  312. *      IF (IPT8.LISREF(/1).EQ.0) THEN
  313. *          NBREF=1
  314. *          NBNN=IPT8.NUM(/1)
  315. *          NBELEM=IPT8.NUM(/2)
  316. *          NBSOUS=IPT8.LISOUS(/1)
  317. *          SEGADJ IPT8
  318. *          IPT8.LISREF(1)=MELEME
  319. *      ENDIF
  320. *      SEGDES IPT8
  321.  
  322.  64   CONTINUE
  323.       IF (KON.GT.0)  SEGSUP,KON
  324.       IF (IDCP.GT.0) SEGSUP,IDCP
  325.       IF (ICPR.GT.0) SEGSUP,ICPR
  326. c      CALL ACTOBJ pour meleme=ipt8
  327.       SEGDES,IPT8
  328.  
  329.       RETURN
  330.       END
  331.  
  332.  
  333.  

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