Numérotation des lignes :

chanlg
C CHANLG    SOURCE    FANDEUR   21/04/26    21:15:07     10979          C   CE SOUS PROGRAMME FABRIQUE L'ENSEMBLE DES ARETES D'UN MAILLAGEC   IL FONCTIONNE SUIVANT UN PRINCIPE DERIVE DES TRACESC      SUBROUTINE CHANLG      IMPLICIT INTEGER(I-N) -INC PPARAM-INC CCOPTIO-INC CCGEOME-INC SMELEME-INC SMCOORD      SEGMENT ICPR(nbpts)      SEGMENT IDCP(ITE)      SEGMENT NTSEG(0)      SEGMENT KON(NBCON,NMAX,3)       ICPR = 0      ICDP = 0      KON = 0       CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)      IF (IERR.NE.0) RETURN       SEGINI ICPR      ITE=0      NELTOT=0      idegre=0       SEGACT MELEME      IPT8 = MELEMEc on peut faire un ACTOBJ !      NBSOU8 = meleme.LISOUS(/1)      IPT1=MELEME      DO 3 I=1,MAX(1,NBSOU8)         IF (NBSOU8.NE.0) THEN            IPT1 = meleme.LISOUS(I)            SEGACT IPT1         ENDIF         NBNOE1=IPT1.NUM(/1)         NBELT1=IPT1.NUM(/2)         NELTOT=NELTOT+NBELT1         K=IPT1.ITYPEL         idegre=KDEGRE(K)         IDEP=NSPOS(K)         if (idep.eq.0) goto 8         IF (NBSOM(K).GT.0) THEN            IFEP=IDEP+NBSOM(K)-1         ELSEC            Cas du polygone            IFEP=IDEP+NBNOE1-1         ENDIF         DO 4 JJ=IDEP,IFEP            J=IBSOM(JJ)            DO 41 K=1,NBELT1               IPOIT=IPT1.NUM(J,K)               IF (ICPR(IPOIT).NE.0) GOTO 41               ITE=ITE+1               ICPR(IPOIT)=ITE 41         CONTINUE 4       CONTINUE 8       CONTINUE         IF (NBSOU8.NE.0) SEGDES IPT1 3    CONTINUE      SEGDES MELEME*      IF (ITE.NE.0) GOTO 6      SEGSUP,ICPR* sg 2016/11/29 gestion maillage vide      IF (NELTOT.EQ.0) THEN* Par défaut SEG2, sinon en fonction du dernier KDEGRE lu.         ity=2         IF (idegre.ge.1.and.idegre.le.3) ity=idegre         CALL melvid(ity,meleme)         CALL ECROBJ('MAILLAGE',MELEME)      ELSE*  16 2*Type d'élément incorrect         CALL ERREUR(16)      ENDIF      RETURN 6    CONTINUE C   ITE EST LE NOMBRE DE POINTS A CONSIDERER  ICPR LE TABLEAUC   ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS      NBCON=7      NBCONR=NBCON-1      NMAX= 10*ITE      SEGINI KONC   FABRICATION DU TABLEAU DES CONNECTIONSC    1  POINT FINALC    2  POINT INTERMEDIAIRE EVENTUEL ET SENS      ICHAIN=ITE      SEGACT MELEME      IOO=0      IA=0      IPT1=MELEME      DO 30 IO=1,MAX(1,NBSOU8)         IF (NBSOU8.NE.0) IPT1=LISOUS(IO)         SEGACT IPT1         K=IPT1.ITYPEL         If ((K.eq.22).or.(K.eq.48)) then            segdes ipt1            goto 30         endif         NBNN=KDEGRE(K)c k=32 et nbnn=2         IF (IA.EQ.0)  IA=NBNN         IF (NBNN.NE.IA) THEN*           PRINT *,'*MAILLAGE IMPOSSIBLE'*           PRINT *,'*EXISTENCE D''ELEMENTS DONNANT'*           PRINT *,'*DES SEG2 ET DES SEG3'            CALL ERREUR(26)            GOTO 64         ENDIF         IPAS=NBNN-1         KKK=LTEL(1,K)c IPAS = 1 & KKK = 1* Cas des segments         IF (KKK.EQ.0) THEN            DO 122 I=1,IPT1.NUM(/2)               NMIL=1               N1=ICPR(IPT1.NUM(1,I))               JSUIV=1+IPAS               N2=ICPR(IPT1.NUM(JSUIV,I))               IF (N1*N2.EQ.0) THEN                 CALL ERREUR(26)                 GOTO 64               ENDIF               IF (IPAS.EQ.2) NMIL=IPT1.NUM(1+1,I)               NI=N1               NJ=N2               KSCOL=IPT1.ICOLOR(I)*                           PRINT *,'*KSCOL',KSCOL               IPO=0 123           CONTINUE               DO 125 IK=1,NBCONR                  IF (KON(IK,NI,1).EQ.0) GOTO 126                  IF (KON(IK,NI,1).EQ.NJ) GOTO 129 125           CONTINUE               IF (KON(NBCON,NI,1).EQ.0) GOTO 128               NI=KON(NBCON,NI,1)               GOTO 123 126           CONTINUE               KON(IK,NI,1)=NJ               KON(IK,NI,2)=NMIL               KON(IK,NI,3)=KSCOL               GOTO 129 128           ICHAIN=ICHAIN+1               IF (ICHAIN.GE.NMAX) THEN                 CALL ERREUR(26)                 GOTO 64               ENDIF               KON(NBCON,NI,1)=ICHAIN               IK=1               NI=ICHAIN               GOTO 126 129           CONTINUE               IF (IPO.EQ.1) GOTO 122               NMIL=-NMIL               NI=N2               NJ=N1               IPO=1               GOTO 123 122        CONTINUE         ELSE            IOO=1            KK=LTEL(2,K)-1c KKK = 1 && KK = 49            DO 300 III=1,KKKC ****BOUCLE PERMETTANT D'ALLER RECHERCHER TOUTES LES FACES               KK=KK+1               ITYP=LDEL(1,KK)               IDEP=LDEL(2,KK)               IF (K.EQ.32) ITYP = 0               IF (ITYP.GT.0) THEN                  IFEP=IDEP+KDFAC(1,ITYP)-1*     SG 20160711 pour les faces TRI7 et QUA9, on ignore le dernier*     point (centre de la face)                  IF (ITYP.EQ.7.OR.ITYP.EQ.8) IFEP=IFEP-1               ELSEC                    Cas du polygone                  IFEP= IDEP+IPT1.NUM(/1)-1               ENDIF               DO 22 I=1,IPT1.NUM(/2)                  KSCOL=IPT1.ICOLOR(I)                  DO 221 J=IDEP,IFEP,IPAS                     NMIL=1                     N1=ICPR(IPT1.NUM(LFAC(J),I))                     JSUIV=J+IPAS                     IF (JSUIV.GT.IFEP) JSUIV=IDEP                     N2=ICPR(IPT1.NUM(LFAC(JSUIV),I))                     IF (IPAS.EQ.2) NMIL=IPT1.NUM(LFAC(J+1),I)                     NI=N1                     NJ=N2                     IF (N1*N2.EQ.0) THEN                       CALL ERREUR(26)                       GOTO 64                     ENDIF                     IPO=0 23                  CONTINUE                     DO 25 IK=1,NBCONR                        IF (KON(IK,NI,1).EQ.0) GOTO 26                        IF (KON(IK,NI,1).EQ.NJ) GOTO 29 25                  CONTINUE                     IF (KON(NBCON,NI,1).EQ.0) GOTO 28                     NI=KON(NBCON,NI,1)                     GOTO 23 26                  KON(IK,NI,1)=NJ                     KON(IK,NI,2)=NMIL                     KON(IK,NI,3)=KSCOL                     GOTO 29 28                  ICHAIN=ICHAIN+1                     IF (ICHAIN.GE.NMAX) THEN                       CALL ERREUR(26)                       GOTO 64                     ENDIF                     KON(NBCON,NI,1)=ICHAIN                     IK=1                     NI=ICHAIN                     GOTO 26 29                  IF (IPO.EQ.1) GOTO 221                     NMIL=-NMIL                     NI=N2                     NJ=N1                     IPO=1                     GOTO 23 221              CONTINUE 22            CONTINUE 300        CONTINUE         ENDIF         IF (NBSOU8.NE.0) SEGDES IPT1 30   CONTINUE       IF (IIMPI.EQ.2)WRITE (IOIMP,1122) (((KON(I,J,K),K=1     \$     ,2),I=1,NBCON),J=1,NMAX) 1122 FORMAT(1X,14I5)       SEGDES MELEME       SEGINI IDCP       DO 40 I=1,ICPR(/1)         IF (ICPR(I).EQ.0) GOTO 40         IDCP(ICPR(I))=I 40   CONTINUE *************************************************************************  CREATION DE L'OBJET MAILLAGE      NBSOUS=0      NBREF=0      NBELEM=0 C ****ON COMPTE LE NOMBRE D'ELEMENTS POUR ACTIVER LE SEGMENT       DO 170 J=1,ITE         JJ=J  179     CONTINUE         DO 180 I=1,NBCONR            M=KON(I,JJ,1)            IF(M.LT.J) GOTO 180            NBELEM=NBELEM+1 180     CONTINUE          IF (KON(NBCON,JJ,1) .EQ. 0) GOTO 170         JJ=KON(NBCON,JJ,1)         GOTO 179 170  CONTINUE ** TEST VERIFIANT SI AU DEPART ON A DEJA DES POINTS,SEG2 OU SEG3      IF (IOO.EQ.0) THEN*        LE MAILLAGE EXISTE DEJA*        PRINT *,'*LE MAILLAGE EXISTE DEJA'         CALL ECROBJ('MAILLAGE',IPT1)         GOTO 64      ENDIF       IF (NBELEM.EQ.0) THEN        CALL ERREUR(26)        GOTO 64      ENDIF C****ETABLISSEMENT DU MAILLAGEC****CONSTRUCTION DU TABLEAU NUM      SEGINI,MELEME      ITYPEL=NBNN      IEL=0      DO 100 J=1,ITE         JJ=J 109     CONTINUE         DO 110 I=1,NBCONR            M=KON(I,JJ,1)            IF (M.LT.J) GOTO 110            IEL=IEL+1            NUM(1,IEL)=IDCP(J)            NUM(NBNN,IEL)=IDCP(M)            ICOLOR(IEL)=KON(I,JJ,3)            IF (NBNN.EQ.3) NUM(2,IEL)=ABS(KON(I,JJ,2)) 110     CONTINUE          IF (KON(NBCON,JJ,1).EQ.0) GOTO 100         JJ=KON(NBCON,JJ,1)         GOTO 109 100  CONTINUE       SEGDES MELEME      CALL ECROBJ('MAILLAGE',MELEME) *  ON INSCRIT LE MAILLAGE  DANS LE MAILLAGE INITIAL*      SEGACT,IPT8*MOD*      IF (IPT8.LISREF(/1).EQ.0) THEN*          NBREF=1*          NBNN=IPT8.NUM(/1)*          NBELEM=IPT8.NUM(/2)*          NBSOUS=IPT8.LISOUS(/1)*          SEGADJ IPT8*          IPT8.LISREF(1)=MELEME*      ENDIF*      SEGDES IPT8  64   CONTINUE      IF (KON.GT.0)  SEGSUP,KON      IF (IDCP.GT.0) SEGSUP,IDCP      IF (ICPR.GT.0) SEGSUP,ICPRc      CALL ACTOBJ pour meleme=ipt8      SEGDES,IPT8       RETURN      END   

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