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

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