C CHANLG SOURCE PV 12/04/13 21:15:19 7351 C CE SOUS PROGRAMME FABRIQUE L'ENSEMBLE DES ARETES D'UN MAILLAGE C IL FONCTIONNE SUIVANT UN PRINCIPE DERIVE DES TRACES C SUBROUTINE CHANLG IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC CCGEOME -INC SMELEME -INC SMCOORD SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) SEGMENT IDCP(ITE) SEGMENT NTSEG(0) SEGMENT KON(NBCON,NMAX,3) CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) IF (IERR.NE.0) RETURN IPT8=MELEME SEGACT MELEME SEGINI ICPR DO 1 I=1,ICPR(/1) ICPR(I)=0 1 CONTINUE ITE=0 IPT1=MELEME DO 3 I=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(I) SEGACT IPT1 ENDIF K=IPT1.ITYPEL IDEP=NSPOS(K) if (idep.eq.0) goto 8 IF (NBSOM(K).GT.0) THEN IFEP=IDEP+NBSOM(K)-1 ELSE C Cas du polygone IFEP=IDEP+IPT1.NUM(/1)-1 ENDIF IF (IFEP.LT.IDEP) GOTO 8 DO 4 JJ=IDEP,IFEP J=IBSOM(JJ) DO 4 K=1,IPT1.NUM(/2) IPOIT=IPT1.NUM(J,K) IF (ICPR(IPOIT).NE.0) GOTO 7 ITE=ITE+1 ICPR(IPOIT)=ITE 7 CONTINUE 4 CONTINUE 8 CONTINUE IF (LISOUS(/1).NE.0) SEGDES IPT1 3 CONTINUE SEGDES MELEME IF (ITE.NE.0) GOTO 6 SEGSUP ICPR CALL ERREUR(16) RETURN 6 CONTINUE C ITE EST LE NOMBRE DE POINTS A CONSIDERER ICPR LE TABLEAU C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS NBCON=7 NBCONR=NBCON-1 NMAX=(10*ITE) SEGINI KON C MISE A ZERO DU TABLEAU KON DO 10 K=1,3 DO 10 I=1,NMAX DO 10 J=1,NBCON 10 KON(J,I,K)=0 C FABRICATION DU TABLEAU DES CONNECTIONS C 1 POINT FINAL C 2 POINT INTERMEDIAIRE EVENTUEL ET SENS ICHAIN=ITE SEGACT MELEME IPT1=MELEME IOO=0 IA=0 DO 30 IO=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) SEGACT IPT1 K=IPT1.ITYPEL If( K.eq.22) then segdes ipt1 goto 30 endif NBNN=KDEGRE(K) 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' SEGSUP KON,ICPR SEGDES MELEME RETURN ENDIF IPAS=NBNN-1 KKK=LTEL(1,K) 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 (IPAS.EQ.2) NMIL=IPT1.NUM(1+1,I) NI=N1 NJ=N2 IF (N1*N2.EQ.0) GOTO 32 KSCOL=IPT1.ICOLOR(I) * PRINT *,'*KSCOL',KSCOL IPO=0 123 CONTINUE 124 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 124 126 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) GOTO 32 KON(NBCON,NI,1)=ICHAIN IK=1 NI=ICHAIN GOTO 126 129 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)-1 DO 300 III=1,KKK C ****BOUCLE PERMETTANT D'ALLER RECHERCHER TOUTES LES FACES KK=KK+1 ITYP=LDEL(1,KK) IDEP=LDEL(2,KK) IF (ITYP.GT.0) THEN IFEP=IDEP+KDFAC(1,ITYP)-1 ELSE C Cas du polygone IFEP= IDEP+IPT1.NUM(/1)-1 ENDIF DO 22 I=1,IPT1.NUM(/2) DO 22 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) GOTO 32 KSCOL=IPT1.ICOLOR(I) IPO=0 23 CONTINUE 24 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 24 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) GOTO 32 KON(NBCON,NI,1)=ICHAIN IK=1 NI=ICHAIN GOTO 26 29 IF (IPO.EQ.1) GOTO 22 NMIL=-NMIL NI=N2 NJ=N1 IPO=1 GOTO 23 22 CONTINUE 21 CONTINUE 300 CONTINUE ENDIF IF (LISOUS(/1).NE.0) SEGDES IPT1 30 CONTINUE GOTO 31 32 CALL ERREUR(26) SEGSUP KON,ICPR SEGDES MELEME RETURN 31 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 SEGSUP ICPR ************************************************************************ * CREATION DE L'OBJET MAILLAGE IEL=0 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 * IF (M.EQ.0) GOTO 170 NBELEM=NBELEM+1 180 CONTINUE * IF (I.EQ.0) GOTO 170 * IF (KON(NBCON-1,JJ,1).EQ.0) GOTO 170 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) SEGDES MELEME RETURN ENDIF IF (NBELEM .EQ. 0) CALL ERREUR(26) IF (IERR .NE. 0) GOTO 64 SEGINI MELEME ITYPEL=NBNN IEL=0 C****ETABLISSEMENT DU MAILLAGE C****CONSTRUCTION DU TABLEAU NUM DO 100 J=1,ITE JJ=J 109 CONTINUE DO 110 I=1,NBCONR M=KON(I,JJ,1) * IF (M.EQ.0) GOTO 100 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 (I.EQ.0) GOTO 170 * IF (KON(NBCON-1,JJ,1).EQ.0) GOTO 100 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 CONTOUR DANS LE MAILLAGE INITIAL * SEGACT IPT8 * 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 SEGSUP KON,IDCP RETURN END