1 : C COMPRI SOURCE PV 09/07/16 21:15:05 6446 2 : C CET OPERATEUR EXTRAIT D'UNE LIGNE LA PARTIE COMPRISE ENTRE 2 PTS 3 : C 4 : SUBROUTINE COMPRI 5 : IMPLICIT INTEGER(I-N) 6 : -INC CCOPTIO 7 : -INC SMELEME 8 : -INC SMCOORD 9 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 10 : SEGMENT IDCP(ITE) 11 : SEGMENT KON(NBCON,NMAX,3) 12 : CHARACTER*(8) ITPOIN,ITMAIL 13 : DATA ITPOIN,ITMAIL/'POINT ','MAILLAGE'/ 14 : ipt1=0 14 : CALL LIROBJ(ITMAIL,MELEME,1,IRETOU) 14 : CALL LIROBJ(ITPOIN,IP1,1,IRETOU) 14 : CALL LIROBJ(ITPOIN,IP2,1,IRETOU) 15 : IPA1=IP1 16 : IPA2=IP2 17 : IF (IERR.NE.0) RETURN 18 : SEGACT MELEME 19 : NBNN=ITYPEL 19 : IF (NBNN.NE.2.AND.NBNN.NE.3) CALL ERREUR(16) 20 : IF (IERR.EQ.0) GOTO 1 21 : SEGDES MELEME 22 : RETURN 23 : 1 CONTINUE 24 : SEGINI ICPR 25 : DO 2 I=1,ICPR(/1) 26 : 2 ICPR(I)=0 27 : C REMPLISSAGE DE ICPR 28 : ITE=0 29 : NBELEM=NUM(/2) 30 : NBNN=NUM(/1) 31 : DO 3 J=1,NBNN 32 : DO 3 K=1,NBELEM 33 : IPOIT=NUM(J,K) 34 : IF (ICPR(IPOIT).NE.0) GOTO 3 35 : ITE=ITE+1 36 : ICPR(IPOIT)=ITE 37 : 3 CONTINUE 38 : C TABLEAU INVERSE 39 : SEGINI IDCP 40 : ILO=XCOOR(/1)/(IDIM+1) 41 : DO 4 I=1,ILO 42 : J=ICPR(I) 43 : IF (J.EQ.0) GOTO 4 44 : IDCP(J)=I 45 : 4 CONTINUE 46 : C ITE EST LE NOMBRE DE POINTS A TRACER ICPR LE TABLEAU 47 : C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS 48 : NBCON=3 49 : NBCONR=NBCON-1 50 : NMAX=(5*ITE)/NBCON 51 : SEGINI KON 52 : C MISE A ZERO DU TABLEAU KON 53 : DO 10 K=1,3 54 : DO 10 I=1,NMAX 55 : DO 10 J=1,NBCON 56 : 10 KON(J,I,K)=0 57 : C FABRICATION DU TABLEAU DES CONNECTIONS 58 : ICHAIN=ITE 59 : DO 20 I=1,NBELEM 60 : NMIL=1 61 : N1=ICPR(NUM(1,I)) 62 : N2=ICPR(NUM(NBNN,I)) 63 : IF (NBNN.EQ.3) NMIL=NUM(2,I) 64 : IF (N1.EQ.N2) GOTO 20 65 : NI=N1 66 : NJ=N2 67 : KSCOL=ICOLOR(I) 68 : 21 CONTINUE 69 : 22 DO 23 K=1,NBCONR 70 : IF (KON(K,NI,1).EQ.0) GOTO 25 71 : 23 CONTINUE 72 : IF (KON(NBCON,NI,1).EQ.0) GOTO 24 73 : NI=KON(NBCON,NI,1) 74 : GOTO 22 75 : 24 ICHAIN=ICHAIN+1 76 : IF (ICHAIN.EQ.NMAX) GOTO 30 77 : KON(NBCON,NI,1)=ICHAIN 78 : K=1 79 : NI=ICHAIN 80 : 25 KON(K,NI,1)=NJ 81 : KON(K,NI,2)=NMIL 82 : KON(K,NI,3)=KSCOL 83 : IF (NMIL.LE.0) GOTO 20 84 : NI=N2 85 : NJ=N1 86 : NMIL=-NMIL 87 : GOTO 21 87 : 30 CALL ERREUR(23) 88 : RETURN 89 : 20 CONTINUE 90 : SEGDES MELEME 91 : C EXTRACTION DE LA SOUS-PARTIE 92 : NBSOUS=0 93 : NBREF=0 94 : * write (6,*) ' ipt1 nbelem nbnn ',nbelem nbnn 95 : SEGINI IPT1 96 : IP1=ICPR(IP1) 97 : IP2=ICPR(IP2) 97 : IF (IP1*IP2.EQ.0) CALL ERREUR(18) 98 : IF (IERR.EQ.0) GOTO 31 99 : SEGSUP KON 100 : RETURN 101 : 31 CONTINUE 101 : if (ipt1.eq.0) call erreur(5) 102 : IEL=0 103 : KAUX=IP1 104 : K=KAUX 105 : KPRESS=KAUX 106 : 41 DO 40 KL=1,NBCONR 107 : M=KON(KL,K,1) 108 : IF (M.EQ.0) GOTO 100 109 : IF (KON(KL,K,2).LE.0) GOTO 40 110 : GOTO 45 111 : 40 CONTINUE 112 : K=KON(NBCON,K,1) 113 : IF (K.EQ.0) GOTO 100 114 : GOTO 41 115 : 46 KL=1 116 : 45 DO 47 L=KL,NBCONR 117 : M=KON(L,K,1) 118 : IF (M.EQ.-1) GOTO 47 119 : IF (M.EQ.0) GOTO 100 120 : GOTO 48 121 : 47 CONTINUE 122 : K=KON(NBCON,K,1) 123 : IF (K.EQ.0) GOTO 100 124 : GOTO 46 125 : 48 IEL=IEL+1 126 : IPT1.NUM(1,IEL)=IDCP(KPRESS) 127 : IPT1.NUM(NBNN,IEL)=IDCP(M) 128 : IPT1.ICOLOR(IEL)=KON(L,K,3) 129 : IF (NBNN.EQ.3) IPT1.NUM(2,IEL)=ABS(KON(L,K,2)) 130 : IF (M.EQ.IP2) GOTO 52 131 : KON(L,K,1)=-1 132 : M1=M 133 : 49 DO 50 L=1,NBCONR 134 : IF (KON(L,M1,1).EQ.0) GOTO 53 135 : IF (KON(L,M1,1).EQ.-1) GOTO 50 136 : IF (KON(L,M1,1).EQ.KPRESS) GOTO 51 137 : 50 CONTINUE 138 : M1=KON(NBCON,M1,1) 139 : GOTO 49 140 : 51 KON(L,M1,1)=-1 141 : 53 KPRESS=M 142 : K=KPRESS 143 : GOTO 46 144 : 100 CONTINUE 145 : * on essaye de voir si un seul chemin 146 : SEGSUP KON,IPT1,ICPR,IDCP 146 : CALL CHEMIN(MELEME,IPA1,IPA2,IPT1) 146 : IF(IERR.EQ.0)CALL ECROBJ(ITMAIL,IPT1) 147 : RETURN 148 : 52 CONTINUE 149 : SEGSUP KON,ICPR,IDCP 150 : C ON A FINI IL NE RESTE PLUS QU'A COMPACTER LE SEGMENT 151 : NBELEM=IEL 152 : SEGINI MELEME 153 : ITYPEL=NBNN 154 : DO 60 I=1,NBNN 155 : DO 60 J=1,NBELEM 156 : NUM(I,J)=IPT1.NUM(I,J) 157 : 60 CONTINUE 158 : DO 61 I=1,NBELEM 159 : 61 ICOLOR(I)=IPT1.ICOLOR(I) 160 : SEGSUP IPT1 161 : SEGDES MELEME 161 : CALL ECROBJ(ITMAIL,MELEME) 162 : RETURN 163 : END 164 : 165 : 166 :
© Cast3M 2003 - All rights reserved.
Disclaimer