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