1 : C CONGE4 SOURCE CHAT 05/01/12 22:17:15 5004 2 : SUBROUTINE CONGE4 (L1,L2,RCONGE,NCONGE, NL1,LRAC,NL2) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : ************************************************************************ 6 : * 7 : * C O N G E 4 8 : * ----------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * CREER UN CONGE DE RACCORDEMENT ENTRE DEUX LIGNES NON COPLANAIRES 14 : * 15 : * TYPE DU CONGE : DOUBLE COUDE 16 : * 17 : * 18 : * MODULES UTILISES: 19 : * ----------------- 20 : * 21 : -INC CCOPTIO 22 : -INC SMELEME 23 : -INC CCREEL 24 : * 25 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 26 : * ----------- 27 : * 28 : * L1 (E) PREMIERE LIGNE A RACCORDER 29 : * L2 (E) DEUXIEME LIGNE A RACCORDER 30 : * RCONGE (E) RAYON DU CONGE DU RACCORDEMENT 31 : * NCONGE (E) FACTEUR DE DECOUPAGE DU CONGE (CONVENTIONS 32 : * CLASSIQUES SUR SON SIGNE) 33 : * = 0 SI NON FOURNI 34 : * NL1 (S) LIGNE APPUYEE SUR L1 ET ABOUTISSANT SUR LE CONGE 35 : * LRAC (S) CONGE DE RACCORDEMENT 36 : * NL2 (S) LIGNE APPUYEE SUR L2 ET COMMENCANT SUR LE CONGE 37 : * 38 : INTEGER NCONGE 39 : REAL*8 RCONGE 40 : * 41 : * CONSTANTES: 42 : * ----------- 43 : * 44 : * 45 : PARAMETER (DEMI=0.5D0) 46 : * 47 : * VARIABLES: 48 : * ---------- 49 : * 50 : INTEGER N,NBNOEU,NBELEM,NL,ND, 51 : & ITYPLM,NBSOUS,NBREF,NBNN 52 : REAL*8 MU,L 53 : * 54 : * 55 : * AUTEUR, DATE DE CREATION: 56 : * ------------------------- 57 : * 58 : * GILLES DUVERGER 06 OCTOBRE 1988 59 : * 60 : * LANGAGE: 61 : * -------- 62 : * 63 : * ESOPE + FORTRAN77 64 : * 65 : ************************************************************************ 66 : * 67 : MELEME=L1 68 : SEGACT,MELEME 69 : NL=LISOUS(/1) 70 : IF (NL.NE.0) THEN 70 : CALL ERREUR(25) 71 : RETURN 72 : END IF 73 : NBNOEU=NUM(/1) 74 : NBELEM=NUM(/2) 75 : IP9=NUM(NBNOEU,NBELEM) 76 : IP8=NUM(1,NBELEM) 77 : SEGDES,MELEME 78 : * 79 : MELEME=L2 80 : SEGACT,MELEME 81 : NL=LISOUS(/1) 82 : IF (NL.NE.0) THEN 82 : CALL ERREUR(25) 83 : RETURN 84 : END IF 85 : NBNOEU=NUM(/1) 86 : IP1=NUM(1,1) 87 : IP2=NUM(NBNOEU,1) 88 : SEGDES,MELEME 89 : * 89 : CALL EXCOO1(IP9,X9,Y9,Z9,D9) 89 : CALL EXCOO1(IP8,X8,Y8,Z8,D8) 89 : CALL EXCOO1(IP1,X1,Y1,Z1,D1) 89 : CALL EXCOO1(IP2,X2,Y2,Z2,D2) 90 : * 91 : * VECTEURS DIRECTEURS DE L1 ET L2 92 : * 93 : XN9 = SQRT((X8-X9)**2+(Y8-Y9)**2+(Z8-Z9)**2) 94 : XN1 = SQRT((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2) 95 : A1=(X8-X9)/XN9 96 : B1=(Y8-Y9)/XN9 97 : C1=(Z8-Z9)/XN9 98 : A2=(X2-X1)/XN1 99 : B2=(Y2-Y1)/XN1 100 : C2=(Z2-Z1)/XN1 101 : * 102 : * RECHERCHE DES POINTS M1 SUR L1 ET M2 SUR L2 TELS QUE 103 : * D(M1;M2) = D(L1;L2) 104 : * 105 : B=-(A1*A2+B1*B2+C1*C2) 106 : * 107 : D=(X1-X9)*A1+(Y1-Y9)*B1+(Z1-Z9)*C1 108 : E=-((X1-X9)*A2+(Y1-Y9)*B2+(Z1-Z9)*C2) 109 : ALPHA=(B*E-D)/(B**2-1) 110 : BETA=(B*D-E)/(B**2-1) 111 : * 112 : XM1=X9+ALPHA*A1 113 : YM1=Y9+ALPHA*B1 114 : ZM1=Z9+ALPHA*C1 114 : CALL CREPO1(XM1,YM1,ZM1,IPM1) 115 : XM2=X1+BETA*A2 116 : YM2=Y1+BETA*B2 117 : ZM2=Z1+BETA*C2 117 : CALL CREPO1(XM2,YM2,ZM2,IPM2) 118 : * 119 : * DISTANCE ENTRE LES DEUX DROITES 120 : * 121 : D2D=SQRT((XM2-XM1)**2+(YM2-YM1)**2+(ZM2-ZM1)**2) 122 : * 123 : * TEST DE LA VALEUR DE RCONGE 124 : * 125 : IF (RCONGE.LT.(D2D*DEMI)) THEN 125 : CALL ERREUR(401) 126 : RETURN 127 : END IF 128 : * 129 : * CALCUL PREALABLE 130 : * 131 : BB=D2D*D2D 132 : AA=2*(1+B) 133 : MU=-(1+B) 134 : * 135 : S=(BB*AA+2*AA*(BB-4*RCONGE*RCONGE)-2*MU*MU*(BB+4*RCONGE*RCONGE)) 136 : &/(AA*(AA-MU*MU)) 137 : T=(AA*(BB-4*RCONGE*RCONGE)*(BB-4*RCONGE*RCONGE)+2*AA*BB*(BB-4* 138 : &RCONGE*RCONGE)-MU*MU*(BB+4*RCONGE*RCONGE)*(BB+4*RCONGE*RCONGE))/ 139 : &(AA*AA*(AA-MU*MU)) 140 : U=BB*(BB-4*RCONGE*RCONGE)/(AA*AA*(AA-MU*MU)) 141 : * 141 : CALL DEGRE3(U,T,S,XR1,XI1,XR2,XI2,XR3,XI3) 142 : * 143 : QQ=T/3-S*S/9 144 : RR=(T*S-3*U)/6-S*S*S/27 145 : D=QQ*QQ*QQ+RR*RR 146 : IF (D .LT. 0) THEN 147 : X=MAX(XR1,XR2,XR3) 148 : ELSE 149 : X=XR1 150 : END IF 151 : L=SQRT(AA*X+BB)*COS(XPI-2*ATAN(SQRT(AA*X+BB)/(2*RCONGE)))/MU 152 : * 153 : * RECHERCHE DU POINT P1 SUR L1 154 : * 155 : XP1=XM1+L*A1 156 : YP1=YM1+L*B1 157 : ZP1=ZM1+L*C1 157 : CALL CREPO1(XP1,YP1,ZP1,IPP1) 158 : * 159 : * RECHERCHE DU POINT P2 SUR L2 160 : * 161 : * JE PENSE QUE LAMBDA VAUT 1 PV 162 : LAMBDA=1 163 : XP2=XM2+LAMBDA*L*A2 164 : YP2=YM2+LAMBDA*L*B2 165 : ZP2=ZM2+LAMBDA*L*C2 165 : CALL CREPO1(XP2,YP2,ZP2,IPP2) 166 : * 167 : * RECHERCHE DU POINT O ,MILIEU DE P1 P2 168 : * 169 : XO=(XP1+XP2)*DEMI 170 : YO=(YP1+YP2)*DEMI 171 : ZO=(ZP1+ZP2)*DEMI 171 : CALL CREPO1(XO,YO,ZO,IPO) 172 : * 173 : * CREATION DE LA DROITE P1-O 174 : * 175 : ND=1 175 : CALL ECRENT(ND) 175 : CALL ECROBJ('POINT',IPO) 175 : CALL ECROBJ('POINT',IPP1) 175 : CALL LIGNE(1,1,DEN1,DEN2,N) 176 : IF (IERR.NE.0) RETURN 176 : CALL LIROBJ('MAILLAGE',L3,1,IRETOU) 177 : IF (IERR.NE.0) RETURN 178 : * 179 : * CREATION DE LA DROITE O-P2 180 : * 181 : ND=1 181 : CALL ECRENT(ND) 181 : CALL ECROBJ('POINT',IPP2) 181 : CALL ECROBJ('POINT',IPO) 181 : CALL LIGNE(1,1,DEN1,DEN2,N) 182 : IF (IERR.NE.0) RETURN 182 : CALL LIROBJ('MAILLAGE',L4,1,IRETOU) 183 : IF (IERR.NE.0) RETURN 184 : * 185 : * CREATION DU CONGE DOUBLE 186 : * 187 : NCONGE=(NCONGE+1)/2 187 : CALL CONGE2(L1,L4,RCONGE,NCONGE,NL1,LRAC1,NL4) 188 : IF (IERR.NE.0) RETURN 188 : CALL CONGE2(L3,L2,RCONGE,NCONGE,NL3,LRAC2,NL2) 189 : IF (IERR.NE.0) RETURN 190 : * 191 : * LES 2 ARCS DE CERCLE ONT UN POINT EN COMMUN: 192 : MELEME=LRAC1 193 : SEGACT,MELEME 194 : NBNOEU=NUM(/1) 195 : NBELEM=NUM(/2) 196 : IPO1=NUM(NBNOEU,NBELEM) 197 : SEGDES,MELEME 198 : MELEME=LRAC2 199 : SEGACT,MELEME 200 : NUM(1,1)=IPO1 201 : SEGDES,MELEME 202 : * ON REUNIT LES 2 DEMI-CERCLES: 202 : CALL ECROBJ('MAILLAGE',LRAC2) 202 : CALL ECROBJ('MAILLAGE',LRAC1) 202 : CALL PRFUSE 203 : IF (IERR.NE.0) RETURN 203 : CALL LIROBJ('MAILLAGE',LRAC,1,IRETOU) 204 : IF (IERR.NE.0) RETURN 205 : MELEME=LRAC1 206 : SEGSUP,MELEME 207 : MELEME=LRAC2 208 : SEGSUP,MELEME 209 : * 210 : MELEME=L3 211 : SEGSUP,MELEME 212 : MELEME=NL3 213 : SEGSUP,MELEME 214 : MELEME=L4 215 : SEGSUP,MELEME 216 : MELEME=NL4 217 : SEGSUP,MELEME 218 : * 219 : 220 : END 221 : 222 : 223 :
© Cast3M 2003 - All rights reserved.
Disclaimer