1 : C CCON1 SOURCE CHAT 05/01/12 21:50:20 5004 2 : SUBROUTINE CCON1(MELEME,IRETO) 3 : IMPLICIT INTEGER(I-N) 4 : -INC SMCOORD 5 : -INC SMELEME 6 : -INC CCOPTIO 7 : -INC SMLENTI 8 : REAL*8 XDE 9 : CHARACTER*1 CHE 10 : LOGICAL LOGE 11 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 12 : SEGMENT INUINV(XCOOR(/1)/(IDIM+1)) 13 : SEGMENT JMEM(NODES) 14 : SEGMENT MEMJT(NKON) 15 : SEGMENT IPOME(NODES+1) 16 : SEGMENT ICONC(NODES) 17 : SEGMENT IDEJ(NODES) 18 : SEGMENT IPRI(NODES) 19 : *** SEGACT MELEME 20 : * 21 : * LOGIQUE : ON PREND UN POINT PUIS TOUS LES ELEMENTS TOUCHANT 22 : * POINT PUIS ON DIT LE S NOEUDS VOISINS ET ON BOUCLE SUR LES NOEUDS 23 : * CONCERNEES NON DEJA TRAITES 24 : * 25 : * ON REGARDE L'ENSEMBLE DES NOEUDS DES NOEUDS DE MELEME ET ON CONSTRUIT 26 : * LE TABLEAU DONNANT LES ELEMENTS TOUCHANT CHAQUE NOEUD 27 : * 28 : SEGINI ICPR,INUINV 29 : SEGACT MELEME*MOD 30 : IPT1=MELEME 31 : IRETO=0 32 : IKOU=0 33 : DO 202 IO=1,MAX(1,LISOUS(/1)) 34 : IF (LISOUS(/1).NE.0) THEN 35 : IPT1=LISOUS(IO) 36 : SEGACT IPT1*MOD 37 : ENDIF 38 : DO 203 I=1,IPT1.NUM(/1) 39 : DO 203 J=1,IPT1.NUM(/2) 40 : IJ=IPT1.NUM(I,J) 41 : IF (ICPR(IJ).NE.0) GOTO 203 42 : IKOU=IKOU+1 43 : ICPR(IJ)=IKOU 44 : INUINV(IKOU)=IJ 45 : 203 CONTINUE 46 : 202 CONTINUE 47 : NODES=IKOU 48 : SEGINI JMEM ,IPOME 49 : IPT1=MELEME 50 : NGRAND=0 51 : NMAX=0 52 : DO 3 IO=1,MAX(1,LISOUS(/1)) 53 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) 54 : DO 4 I=1,IPT1.NUM(/1) 55 : DO 4 J=1,IPT1.NUM(/2) 56 : JMEM(ICPR(IPT1.NUM(I,J)))=JMEM(ICPR(IPT1.NUM(I,J)))+1 57 : 4 CONTINUE 58 : NGRAND=MAX(NGRAND,IPT1.NUM(/2)) 59 : NMAX=NMAX+IPT1.NUM(/2) 60 : 3 CONTINUE 61 : NGRAND=NGRAND+1 62 : IPOME(1)=0 63 : DO 6 I=1,NODES 64 : IPOME(I+1)=IPOME (I) + JMEM(I) 65 : 6 CONTINUE 66 : DO 7 I=1,NODES 67 : JMEM(I)=0 68 : 7 CONTINUE 69 : NKON=IPOME(NODES+1) 70 : SEGINI MEMJT 71 : IPT1=MELEME 72 : DO 101 IO=1,MAX(1,LISOUS(/1)) 73 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) 74 : DO 100 I=1,IPT1.NUM(/2) 75 : DO 100 J=1,IPT1.NUM(/1) 76 : IND=ICPR(IPT1.NUM(J,I)) 77 : JMEM(IND)=JMEM(IND)+1 78 : MEMJT(IPOME(IND)+JMEM(IND))=I+NGRAND*IO 79 : 100 CONTINUE 80 : 101 CONTINUE 81 : * 82 : * quelques initialisations 83 : * 84 : * WRITE(6,FMT='('' NODES '' ,I5)') NODES 85 : SEGINI IDEJ,ICONC,IPRI 86 : INDE=0 87 : * 88 : * debut de tourner en rond. 89 : * 90 : 50 CONTINUE 91 : DO 51 I=1,NODES 92 : ICONC(I)=0 93 : IPRI(I)=0 94 : 51 CONTINUE 95 : DO 52 I=1,NODES 96 : IF(IDEJ(I).EQ.0) GO TO 54 97 : 52 CONTINUE 98 : GO TO 59 99 : 54 CONTINUE 100 : IDEP=I 101 : * WRITE(6,FMT='('' POINT DE DEPART '',I5)') IDEP 102 : INC=1 103 : INA=1 104 : ICONC(INC)=IDEP 105 : IPRI(IDEP)=1 106 : 55 CONTINUE 107 : INO=INC 108 : DO 57 I=INA,INO 109 : INU=ICONC(I) 110 : IF(IDEJ(INU).NE.0) THEN 110 : CALL ERREUR (5) 111 : ELSE 112 : IDEJ(INU)=1 113 : ENDIF 114 : K4=JMEM(INU) 115 : JSUB=IPOME(INU) 116 : * WRITE(6,FMT='('' NOEUD NBVOIS DDEB'',3I5)')INUINV(INU), 117 : * $ K4,JSUB 118 : DO 40 JJ=1,K4 119 : IND=JSUB+JJ 120 : K6=MEMJT(IND) 121 : IAIA= K6/NGRAND 122 : IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA) 123 : SEGACT IPT1*MOD 124 : K6=MOD(K6,NGRAND) 125 : IF(IPT1.NUM(1,K6).LE.0) GO TO 40 126 : IPT1.NUM(1,K6)=-IPT1.NUM(1,K6) 127 : * WRITE(6,FMT='('' ELEMENT NUMERO '',I5)') K6 128 : DO 85 L=1,IPT1.NUM(/1) 129 : K5=ICPR(ABS(IPT1.NUM(L,K6))) 130 : IF (IPRI(K5).GT.0) GO TO 85 131 : INC=INC+1 132 : ICONC(INC)=K5 133 : IPRI(K5)=1 134 : * WRITE(6,FMT= '('' NOEUD NUMERO '',I5)') INUINV(K5) 135 : 85 CONTINUE 136 : 40 CONTINUE 137 : 57 CONTINUE 138 : IF(INO.NE.INC) THEN 139 : * WRITE(6,FMT='('' ON BOUCLE INA INO INC'',3I5)') INA,INO,INC 140 : INA=INO+1 141 : GO TO 55 142 : ENDIF 143 : * 144 : * on vient de trouver une composante connexe 145 : * 146 : 59 CONTINUE 147 : * WRITE(6,FMT=' ('' UNE COMPOSANTE CONNEXES TROUVEE '')') 148 : * 149 : * on cree une table si pas deja fait puis remise de meleme en positif 150 : * 151 : IF(IRETO.EQ.0) THEN 152 : JG=1 153 : SEGINI MLENTI 154 : IRETO=MLENTI 155 : ELSE 156 : SEGACT MLENTI 157 : JG=JG+1 158 : SEGADJ MLENTI 159 : ENDIF 160 : DO 71 K=1,MAX(1,LISOUS(/1)) 161 : IF(LISOUS(/1).NE.0) IPT1=LISOUS(K) 162 : DO 73 KI=1,IPT1.NUM(/2) 163 : IPT1.NUM(1,KI)=ABS(IPT1.NUM(1,KI)) 164 : 73 CONTINUE 165 : 71 CONTINUE 166 : NBNN=1 167 : NBELEM=INO 168 : NBSOUS=0 169 : NBREF=0 170 : SEGINI IPT2 171 : DO 70 I=1,INO 172 : IPT2.NUM(1,I)=INUINV(ICONC(I)) 173 : 70 CONTINUE 174 : IPT2.ITYPEL=1 175 : SEGDES IPT2 175 : CALL ECRCHA('APPUYER') 175 : CALL ECROBJ('MAILLAGE',IPT2) 175 : CALL ECROBJ('MAILLAGE',MELEME) 175 : CALL EXTREL (IRR,1,LIEL) 176 : SEGSUP IPT2 176 : CALL LIROBJ('MAILLAGE',IPT,1,IRETAY) 177 : IF(IERR.NE.0) THEN 177 : CALL ERREUR(5) 178 : RETURN 179 : ENDIF 180 : SEGACT MELEME*MOD 181 : DO 2020 IO=1,MAX(1,LISOUS(/1)) 182 : IF (LISOUS(/1).NE.0) THEN 183 : IPT1=LISOUS(IO) 184 : SEGACT IPT1*MOD 185 : ENDIF 186 : 2020 CONTINUE 187 : LECT(JG)=IPT 188 : INDE=INDE+INO 189 : IF(INDE.NE.NODES) GO TO 50 190 : 1000 CONTINUE 191 : SEGDES MLENTI 192 : IF(LISOUS(/1).NE.0) THEN 193 : DO 74 K=1,LISOUS(/1) 194 : IPT1=LISOUS(K) 195 : SEGDES IPT1 196 : 74 CONTINUE 197 : ENDIF 198 : SEGDES MELEME 199 : SEGSUP ICPR,ICONC,IDEJ,IPRI,MEMJT,JMEM,INUINV,IPOME 200 : RETURN 201 : END 202 : 203 : 204 :
© Cast3M 2003 - All rights reserved.
Disclaimer