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