1 : C RACCOR SOURCE CHAT 12/04/06 21:15:23 7345 2 : C FABRIQUE LES ELEMENTS RACCORD ENTRE DEUX LIGNES 3 : C EXTRAIT DE COCO 4 : C 5 : SUBROUTINE RACCOR(IPT1,IPT2,MELEME,PREC) 6 : 7 : IMPLICIT INTEGER(I-N) 8 : IMPLICIT REAL*8(A-H,O-Z) 9 : -INC CCOPTIO 10 : -INC CCGEOME 11 : -INC CCREEL 12 : *- 13 : -INC SMELEME 14 : -INC SMCOORD 15 : SEGMENT MTRAV 16 : REAL*8 TA(NBELEM) 17 : INTEGER NP1(NBELE1),NP2(NBELE1) 18 : ENDSEGMENT 19 : C* DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME 20 : DIMENSION ITEST(0:15) 21 : 22 : SEGACT,MCOORD 23 : IDIMP1 = IDIM+1 24 : 25 : PREC3=3.*PREC 26 : TMAX=-XGRAND 27 : TMIN= XGRAND 28 : 29 : NB1=IPT1.NUM(/2) 30 : NB2=IPT2.NUM(/2) 31 : NBMAX=MIN(NB1,NB2) 32 : NBNN=IPT1.NUM(/1) 33 : IF (NBNN.NE.IPT2.NUM(/1)) THEN 33 : CALL ERREUR(16) 34 : RETURN 35 : ENDIF 36 : DO 40 I=0,NBCOUL-1 37 : 40 ITEST(I)=0 38 : DO 41 I=1,NB1 39 : ITEST(IPT1.ICOLOR(I))=1 40 : 41 CONTINUE 41 : DO 42 I=1,NB2 42 : ITEST(IPT2.ICOLOR(I))=1 43 : 42 CONTINUE 44 : ICHCOL=-1 45 : DO 43 I=0,NBCOUL-1 46 : IF (ITEST(I).EQ.1) THEN 47 : IF (ICHCOL.EQ.-1) THEN 48 : ICHCOL=I 49 : ELSE 50 : ICHCOL=ITABM(ICHCOL,I) 51 : ENDIF 52 : ENDIF 53 : 43 CONTINUE 54 : NBELEM=NB2 55 : NBELE1=NBELEM+1 56 : SEGINI MTRAV 57 : DO 11 I=1,NB2 58 : Z=0. 59 : DO 12 J=1,NBNN 60 : IREF=IPT2.NUM(J,I)*IDIMP1-IDIM 61 : Z=Z+ABS(XCOOR(IREF))+ABS(XCOOR(IREF+1)) 62 : IF (IDIM.NE.2) Z=Z+ABS(XCOOR(IREF+2)) 63 : 12 CONTINUE 64 : Z=Z/NBNN 65 : TA(I)=Z 66 : IF(Z.GT.TMAX) TMAX=Z 67 : IF(Z.LT.TMIN) TMIN=Z 68 : 11 CONTINUE 69 : C 70 : C CLASSEMENT APPROXIMATIF PAR ' DISTANCE ' 71 : C 72 : IF ((ABS(TMAX).GE.XPETIT).AND.(TMAX-TMIN)/TMAX.GE.1E-6) GOTO 6 73 : TMAX=TMAX+1. 74 : TMIN=TMIN-1. 75 : 6 CONTINUE 76 : TDEC=(TMAX-TMIN)/NBELEM*1.0001 77 : N =int( PREC/TDEC) + 1 78 : C* Boucle 3 redeondante avec SEGINI MTRAV 79 : C* DO 3 I=1,NBELE1 80 : C* 3 NP1(I)=0 81 : DO 4 I=1,NBELEM 82 : IPLA=int((TA(I)-TMIN)/TDEC)+1 83 : 4 NP1(IPLA)=NP1(IPLA)+1 84 : DO 400 I=2,NBELE1 85 : 400 NP1(I)=NP1(I-1)+NP1(I) 86 : DO 5 I=1,NBELEM 87 : IPLA=int((TA(I)-TMIN)/TDEC)+1 88 : IPLB=NP1(IPLA) 89 : NP1(IPLA)=NP1(IPLA)-1 90 : NP2(IPLB)=I 91 : 5 CONTINUE 92 : C 93 : C DANS NP1 ADDRESSE DU DEBUT DE ZONE 94 : C DANS NP2 NUMERO DES ELEMENTS EN NUMEROTATION LOCALE 95 : C DANS TA DISTANCE DES ELEMENTS 96 : C 97 : C IL FAUT PREPARER LE SEGMENT TAMPON OU METTRE LES ELEMS CREES. 98 : NBREF=0 99 : NBSOUS=0 100 : NBNNOR=NBNN 101 : NBNN=2*NBNN 102 : NBELEM=NB1+NB2 103 : SEGINI MELEME 104 : IPT4=MELEME 105 : NBT=NBELEM 106 : NBELEM=NB2 107 : NUMELG=0 108 : C 109 : C BOUCLE SUR TOUS LES ELEMENTS POUR CONNAITRE LEUR FACES ET REGARDER SI 110 : C LE CENTRE DE GRAVITE EST CONFONDU A PREC PRES DE CELUI D'UN ELEMENT 111 : C COQUE 112 : DO 20 I=1,NB1 113 : ZAA=0. 114 : DO 21 J=1,NBNNOR 115 : IREF=IPT1.NUM(J,I)*IDIMP1-IDIM 116 : ZAA=ZAA+ABS(XCOOR(IREF))+ABS(XCOOR(IREF+1)) 117 : IF (IDIM.NE.2) ZAA=ZAA+ABS(XCOOR(IREF+2)) 118 : 21 CONTINUE 119 : ZAA=ZAA/NBNNOR 120 : IZO=int((ZAA-TMIN)/TDEC)+1 121 : IZO1=IZO-N 122 : IZO2=IZO+N 123 : IF(IZO1.LT.1) IZO1=1 124 : IF(IZO2.GT.NBELEM) IZO2=NBELEM 125 : IF (IZO.LT.0.OR.IZO.GT.NBELE1) GOTO 20 126 : DO 28 IZO=IZO1,IZO2 127 : IDEP=NP1(IZO)+1 128 : IFIN=NP1(IZO+1) 129 : IF(IFIN.LT.IDEP) GO TO 28 130 : DO 23 JFA=IDEP,IFIN 131 : IB=NP2(JFA) 132 : IF(ABS(TA(IB)-ZAA).GT.PREC3) GO TO 23 133 : C ON VIENT D'IDENTIFIER UN ELEMENT DE RACCOR ON VA LE CREER 134 : IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM 135 : DO 24 IK=1,NBNNOR 136 : IREFB=IPT2.NUM(IK,IB)*IDIMP1-IDIM 137 : IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 24 138 : IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 24 139 : IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2) GOTO 140 : # 24 141 : ISTA=IK 142 : GO TO 26 143 : 24 CONTINUE 144 : GO TO 23 145 : 26 CONTINUE 146 : ISENS=1 147 : ISTA1=ISTA+1 148 : ISTAA=ISTA 149 : IF (ISTA1.GT.NBNNOR) ISTA1=1 150 : IREFA=IPT1.NUM(2,I)*IDIMP1-IDIM 151 : IREFB=IPT2.NUM(ISTA1,IB)*IDIMP1-IDIM 152 : Z=XCOOR(IREFA)-XCOOR(IREFB) 153 : IF(ABS(Z).GT.PREC) ISENS=-1 154 : Z=XCOOR(IREFA+1)-XCOOR(IREFB+1) 155 : IF(ABS(Z).GT.PREC) ISENS=-1 156 : IF (IDIM.NE.2) THEN 157 : Z=XCOOR(IREFA+2)-XCOOR(IREFB+2) 158 : IF (ABS(Z).GT.PREC) ISENS=-1 159 : ENDIF 160 : DO 30 IJ=2,NBNNOR 161 : IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM 162 : ISTAA=ISTAA+ISENS 163 : IF (ISTAA.EQ.0) ISTAA=NBNNOR 164 : IF (ISTAA.GT.NBNNOR) ISTAA=1 165 : IREFB=IPT2.NUM(ISTAA,IB)*IDIMP1-IDIM 166 : DO 32 KLP=1,IDIM 167 : Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1) 168 : IF(ABS(Z).GT.PREC) GO TO 23 169 : 32 CONTINUE 170 : 30 CONTINUE 171 : C CREATION D'UN ELEM RACCORD 172 : NUMELG=NUMELG+1 172 : IF (NUMELG.GT.NBMAX) CALL ERREUR(31) 173 : IF (IERR.NE.0) GOTO 101 174 : DO 27 IK=1,NBNNOR 175 : IP1=IPT1.NUM(IK,I) 176 : IP2=IPT2.NUM(ISTA,IB) 177 : NUM(IK,NUMELG)=IP1 178 : NUM(NBNN-IK+1,NUMELG)=IP2 179 : ISTA=ISTA+ISENS 180 : IF (ISTA.EQ.0) ISTA=NBNNOR 181 : IF (ISTA.GT.NBNNOR) ISTA=1 182 : IF (IP1.NE.IP2) GOTO 27 183 : INTERR(1)=NUMELG 183 : CALL ERREUR(101) 184 : 27 CONTINUE 185 : 23 CONTINUE 186 : 28 CONTINUE 187 : 20 CONTINUE 188 : WRITE(IOIMP,29) NUMELG 189 : 29 FORMAT(//,' NOMBRE D''ELEMENTS DE RACCORD CREES : ',I5) 190 : NBELEM=NUMELG 191 : MELEME = 0 192 : IF (NBELEM.EQ.0) THEN 192 : CALL ERREUR(26) 193 : GOTO 101 194 : ENDIF 195 : SEGINI MELEME 196 : IF (NBNN.EQ.4) ITYPEL=12 197 : IF (NBNN.EQ.6) ITYPEL=13 198 : DO 100 J=1,NBELEM 199 : ICOLOR(J)=ICHCOL 200 : DO 100 I=1,NBNN 201 : NUM(I,J)=IPT4.NUM(I,J) 202 : 100 CONTINUE 203 : 101 SEGSUP IPT4 204 : SEGSUP MTRAV 205 : 206 : RETURN 207 : END 208 : 209 : 210 :
© Cast3M 2003 - All rights reserved.
Disclaimer