1 : C RACPOR SOURCE FANDEUR 10/08/30 21:15:42 6732 2 : C 3 : C FABRIQUE LES ELEMENTS RACCORD POUR LES ELEMENTS JOINT POREUX (BALD). 4 : C CES ELEMENTS JOINTS SONT COMPOSES PAR TROIS LIGNES: LES LIGNES TOP 5 : C ET BOT SONT MAILLEES AVEC DES ELEMENTS SEG3, LA LIGNE AU MILIEU AVEC 6 : C DES SEG2. L'ELEMENT RACCORD CREE A 8 NOEUDS. 7 : C 8 : SUBROUTINE RACPOR(IPT1,IPT2,IPT3,MELEME,PREC) 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8(A-H,O-Z) 11 : -INC CCOPTIO 12 : -INC CCGEOME 13 : -INC CCREEL 14 : -INC SMELEME 15 : -INC SMCOORD 16 : SEGMENT MTRAV 17 : REAL*8 TA(NBELEM) 18 : INTEGER NP1(NBELE1),NP2(NBELE1) 19 : ENDSEGMENT 20 : C* DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME 21 : DIMENSION ITEST(0:15) 22 : 23 : IDIMP1 = IDIM+1 24 : SEGACT MCOORD 25 : PREC3=3.*PREC 26 : TMAX=-XGRAND 27 : TMIN= XGRAND 28 : NB1=IPT1.NUM(/2) 29 : NB2=IPT2.NUM(/2) 30 : NB3=IPT3.NUM(/2) 31 : NBMAX=MIN(NB1,NB2,NB3) 32 : NBNN=IPT1.NUM(/1) 33 : NBNM=IPT3.NUM(/1) 34 : IF ((NBNN.NE.IPT2.NUM(/1)).OR.(NBNN.EQ.NBNM).OR. 35 : . (NBSOM(IPT1.ITYPEL).NE.NBSOM(IPT3.ITYPEL))) THEN 35 : CALL ERREUR(16) 36 : RETURN 37 : ENDIF 38 : DO 40 I=0,(NBCOUL-1) 39 : ITEST(I)=0 40 : 40 CONTINUE 41 : DO 41 I=1,NB1 42 : ITEST(IPT1.ICOLOR(I))=1 43 : 41 CONTINUE 44 : DO 42 I=1,NB2 45 : ITEST(IPT2.ICOLOR(I))=1 46 : 42 CONTINUE 47 : DO 43 I=1,NB3 48 : ITEST(IPT3.ICOLOR(I))=1 49 : 43 CONTINUE 50 : ICHCOL=-1 51 : DO 44 I=0,(NBCOUL-1) 52 : IF (ITEST(I).EQ.1) THEN 53 : IF (ICHCOL.EQ.-1) THEN 54 : ICHCOL=I 55 : ELSE 56 : ICHCOL=ITABM(ICHCOL,I) 57 : ENDIF 58 : ENDIF 59 : 44 CONTINUE 60 : NBELEM=NB2 61 : NBELE1=NBELEM+1 62 : SEGINI MTRAV 63 : DO 11 I=1,NB2 64 : Z=0. 65 : DO 12 J=1,NBNN 66 : IREF=IPT2.NUM(J,I)*IDIMP1-IDIM 67 : Z=Z+XCOOR(IREF)+XCOOR(IREF+1) 68 : IF (IDIM.NE.2) Z=Z+XCOOR(IREF+2) 69 : 12 CONTINUE 70 : Z=Z/NBNN 71 : TA(I)=Z 72 : IF(Z.GT.TMAX) TMAX=Z 73 : IF(Z.LT.TMIN) TMIN=Z 74 : 11 CONTINUE 75 : C 76 : C CLASSEMENT APPROXIMATIF PAR ' DISTANCE ' 77 : C 78 : IF ((ABS(TMAX).GE.XPETIT).AND.(TMAX-TMIN)/TMAX.GE.1E-6) GOTO 6 79 : TMAX=TMAX+1. 80 : TMIN=TMIN-1. 81 : 6 CONTINUE 82 : TDEC=(TMAX-TMIN)/NBELEM*1.0001 83 : N = PREC/TDEC + 1. 84 : C* Boucle 3 redondante avec SEGINI,MTRAV 85 : C* DO 3 I=1,NBELE1 86 : C* 3 NP1(I)=0 87 : DO 4 I=1,NBELEM 88 : IPLA=(TA(I)-TMIN)/TDEC+1. 89 : 4 NP1(IPLA)=NP1(IPLA)+1 90 : DO 400 I=2,NBELE1 91 : 400 NP1(I)=NP1(I-1)+NP1(I) 92 : DO 5 I=1,NBELEM 93 : IPLA=(TA(I)-TMIN)/TDEC+1. 94 : IPLB=NP1(IPLA) 95 : NP1(IPLA)=NP1(IPLA)-1 96 : NP2(IPLB)=I 97 : 5 CONTINUE 98 : C 99 : C DANS NP1 ADDRESSE DU DEBUT DE ZONE 100 : C DANS NP2 NUMERO DES ELEMENTS EN NUMEROTATION LOCALE 101 : C DANS TA DISTANCE DES ELEMENTS 102 : C 103 : C IL FAUT PREPARER LE SEGMENT TAMPON OU METTRE LES ELEMS CREES. 104 : NBREF=0 105 : NBSOUS=0 106 : NBNNOR=NBNN 107 : NBNN=2*NBNN+NBNM 108 : NBELEM=NB1+NB2 109 : SEGINI MELEME 110 : IPT4=MELEME 111 : NBT=NBELEM 112 : NBELEM=NB2 113 : NUMELG=0 114 : C 115 : C BOUCLE SUR TOUS LES ELEMENTS POUR CONNAITRE LEUR FACES ET REGARDER SI 116 : C LE CENTRE DE GRAVITE EST CONFONDU A PREC PRES DE CELUI D'UN ELEMENT 117 : C COQUE 118 : C 119 : DO 20 I=1,NB1 120 : ZAA=0. 121 : DO 21 J=1,NBNNOR 122 : IREF=IPT1.NUM(J,I)*IDIMP1-IDIM 123 : ZAA=ZAA+XCOOR(IREF)+XCOOR(IREF+1) 124 : IF (IDIM.NE.2) ZAA=ZAA+XCOOR(IREF+2) 125 : 21 CONTINUE 126 : ZAA=ZAA/NBNNOR 127 : IZO=(ZAA-TMIN)/TDEC+1. 128 : IZO1=IZO-N 129 : IZO2=IZO+N 130 : IF(IZO1.LT.1) IZO1=1 131 : IF(IZO2.GT.NBELEM) IZO2=NBELEM 132 : IF (IZO.LT.0.OR.IZO.GT.NBELE1) GOTO 20 133 : DO 28 IZO=IZO1,IZO2 134 : IDEP=NP1(IZO)+1 135 : IFIN=NP1(IZO+1) 136 : IF(IFIN.LT.IDEP) GO TO 28 137 : DO 23 JFA=IDEP,IFIN 138 : IB=NP2(JFA) 139 : IF(ABS(TA(IB)-ZAA).GT.PREC3) GO TO 23 140 : IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM 141 : DO 24 IK=1,NBNNOR 142 : IREFB=IPT2.NUM(IK,IB)*IDIMP1-IDIM 143 : IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 24 144 : IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 24 145 : IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2) 146 : # GOTO 24 147 : ISTA=IK 148 : GO TO 26 149 : 24 CONTINUE 150 : GO TO 23 151 : 26 CONTINUE 152 : ISENS=1 153 : ISTA1=ISTA+1 154 : ISTAA=ISTA 155 : IF (ISTA1.GT.NBNNOR) ISTA1=1 156 : IREFA=IPT1.NUM(2,I)*IDIMP1-IDIM 157 : IREFB=IPT2.NUM(ISTA1,IB)*IDIMP1-IDIM 158 : Z=XCOOR(IREFA)-XCOOR(IREFB) 159 : IF(ABS(Z).GT.PREC) ISENS=-1 160 : Z=XCOOR(IREFA+1)-XCOOR(IREFB+1) 161 : IF(ABS(Z).GT.PREC) ISENS=-1 162 : IF (IDIM.NE.2) THEN 163 : Z=XCOOR(IREFA+2)-XCOOR(IREFB+2) 164 : IF (ABS(Z).GT.PREC) ISENS=-1 165 : ENDIF 166 : DO 30 IJ=2,NBNNOR 167 : IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM 168 : ISTAA=ISTAA+ISENS 169 : IF (ISTAA.EQ.0) ISTAA=NBNNOR 170 : IF (ISTAA.GT.NBNNOR) ISTAA=1 171 : IREFB=IPT2.NUM(ISTAA,IB)*IDIMP1-IDIM 172 : DO 32 KLP=1,IDIM 173 : Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1) 174 : IF(ABS(Z).GT.PREC) GO TO 23 175 : 32 CONTINUE 176 : 30 CONTINUE 177 : C 178 : IZC=(ZAA-TMIN)/TDEC+1. 179 : DO 33 IC=1,NB3 180 : ZAC=0. 181 : DO 31 J=1,NBNM 182 : IREF=IPT3.NUM(J,IC)*IDIMP1-IDIM 183 : ZAC=ZAC+XCOOR(IREF)+XCOOR(IREF+1) 184 : IF (IDIM.NE.2) ZAC=ZAC+XCOOR(IREF+2) 185 : 31 CONTINUE 186 : ZAC=ZAC/NBNM 187 : IF(ABS(ZAA-ZAC).GT.PREC3) GO TO 33 188 : C ON VIENT D'IDENTIFIER UN ELEMENT DE RACCOR ON VA LE CREER 189 : IREFA=IPT1.NUM(1,I)*IDIMP1-IDIM 190 : DO 34 IK=1,NBNM 191 : IREFB=IPT3.NUM(IK,IC)*IDIMP1-IDIM 192 : IF (ABS(XCOOR(IREFA)-XCOOR(IREFB)).GT.PREC) GOTO 34 193 : IF (ABS(XCOOR(1+IREFA)-XCOOR(1+IREFB)).GT.PREC) GOTO 34 194 : IF (ABS(XCOOR(2+IREFA)-XCOOR(2+IREFB)).GT.PREC.AND.IDIM.NE.2) 195 : # GOTO 34 196 : ISTC=IK 197 : GO TO 36 198 : 34 CONTINUE 199 : GO TO 33 200 : 36 CONTINUE 201 : ISENT=1 202 : ISTC1=ISTC+1 203 : ISTCC=ISTC 204 : IF (ISTC1.GT.NBNM) ISTC1=1 205 : IREFA=IPT1.NUM(3,I)*IDIMP1-IDIM 206 : IREFB=IPT3.NUM(ISTC1,IC)*IDIMP1-IDIM 207 : Z=XCOOR(IREFA)-XCOOR(IREFB) 208 : IF(ABS(Z).GT.PREC) ISENT=-1 209 : Z=XCOOR(IREFA+1)-XCOOR(IREFB+1) 210 : IF(ABS(Z).GT.PREC) ISENT=-1 211 : IF (IDIM.NE.2) THEN 212 : Z=XCOOR(IREFA+2)-XCOOR(IREFB+2) 213 : IF (ABS(Z).GT.PREC) ISENT=-1 214 : ENDIF 215 : DO 50 IJ=3,NBNNOR,2 216 : IREFA=IPT1.NUM(IJ,I)*IDIMP1-IDIM 217 : ISTCC=ISTCC+ISENT 218 : IF (ISTCC.EQ.0) ISTCC=NBNM 219 : IF (ISTCC.GT.NBNM) ISTCC=1 220 : IREFB=IPT3.NUM(ISTCC,IC)*IDIMP1-IDIM 221 : DO 52 KLP=1,IDIM 222 : Z=XCOOR(IREFA+KLP-1)-XCOOR(IREFB+KLP-1) 223 : IF(ABS(Z).GT.PREC) GO TO 33 224 : 52 CONTINUE 225 : 50 CONTINUE 226 : C CREATION D'UN ELEM RACCORD 227 : NUMELG=NUMELG+1 227 : IF (NUMELG.GT.NBMAX) CALL ERREUR(31) 228 : IF (IERR.NE.0) GOTO 101 229 : IM=0 230 : DO 27 IK=1,NBNNOR 231 : IP1=IPT1.NUM(IK,I) 232 : IP2=IPT2.NUM(ISTA,IB) 233 : NUM(IK,NUMELG)=IP1 234 : NUM(2*NBNNOR-IK+1,NUMELG)=IP2 235 : ISTA=ISTA+ISENS 236 : IF (ISTA.EQ.0) ISTA=NBNNOR 237 : IF (ISTA.GT.NBNNOR) ISTA=1 238 : IF (IK.EQ.IBSOM(NSPOS(IPT1.ITYPEL)+IM)) THEN 239 : IM=IM+1 240 : IP3=IPT3.NUM(ISTC,IC) 241 : NUM(2*NBNNOR+IM,NUMELG)=IP3 242 : ISTC=ISTC+ISENT 243 : IF (ISTC.EQ.0) ISTC=NBNM 244 : IF (ISTC.GT.NBNM) ISTC=1 245 : IF ((IP1.NE.IP2).AND.(IP1.NE.IP3).AND.(IP2.NE.IP3)) GO TO 27 246 : INTERR(1)=NUMELG 246 : CALL ERREUR(101) 247 : ENDIF 248 : IF (IP1.NE.IP2) GO TO 27 249 : INTERR(1)=NUMELG 249 : CALL ERREUR(101) 250 : 27 CONTINUE 251 : 33 CONTINUE 252 : C 253 : 23 CONTINUE 254 : 28 CONTINUE 255 : 20 CONTINUE 256 : C WRITE(IOIMP,29) NUMELG 257 : C 29 FORMAT(//,' NOMBRE D''ELEMENTS DE RACCORD CREES : ',I5) 258 : MELEME=0 259 : NBELEM=NUMELG 260 : IF (NBELEM.EQ.0) THEN 260 : CALL ERREUR(26) 261 : GOTO 101 262 : ENDIF 263 : SEGINI MELEME 264 : IF (NBNN.EQ.8) ITYPEL=29 265 : DO 100 J=1,NBELEM 266 : ICOLOR(J)=ICHCOL 267 : DO 100 I=1,NBNN 268 : NUM(I,J)=IPT4.NUM(I,J) 269 : 100 CONTINUE 270 : 101 SEGSUP IPT4 271 : SEGSUP MTRAV 272 : RETURN 273 : END 274 : 275 :
© Cast3M 2003 - All rights reserved.
Disclaimer