1 : C PROOBJ SOURCE CHAT 05/01/13 02:34:30 5004 2 : C CE SOUS-PROGRAMME PREPARE LA PROJECTION D'UN OBJET SUR UNE 3 : C SURFACE : 4 : C PLAN P1 P2 P3 5 : C SPHE C P 6 : C CYLI C1 C2 P 7 : C CONI C C1 P 8 : C TORI C A Cs P 9 : C NOUVELLE POSSIBILITE EN 2D NOVEMBRE 1986 10 : C DROI P1 P2 11 : C CERCLE P1 12 : C 13 : C JANVIER 1987 INTRODUCTION DE LA PROJECTION CONIQUE 14 : C 15 : C SEPTEMBRE 1996 PROJECTION D'UN OBJET MAILLAGE SUR UN OBJET 16 : C MAILLAGE. 17 : SUBROUTINE PROOBJ 18 : IMPLICIT INTEGER(I-N) 19 : IMPLICIT REAL*8 (A-H,O-Z) 20 : -INC CCOPTIO 21 : -INC SMCOORD 22 : -INC SMELEME 23 : COMMON /CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC, 24 : # ZVEC,ANGLE,ICLE 25 : CHARACTER*4 MCLE(7),MTYPP(2) 26 : DATA MTYPP/'CYLI','CONI'/ 27 : DATA MCLE/'PLAN','SPHE','CYLI','CONI','TORI','DROI','CERC'/ 28 : SEGACT MCOORD 29 : MELEME=0 29 : CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU) 30 : IF (IRETOU.EQ.1) GOTO 1 31 : C C'EST UN POINT QU'ON PROJETTE 31 : CALL LIROBJ('POINT ',IPOIN,1,IRETOU) 32 : IF (IERR.NE.0) RETURN 33 : 1 CONTINUE 34 : * CONIQUE OU CYLINDRIQUE 34 : CALL LIRMOT(MTYPP,2,IYYT,0) 34 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 35 : IF (IERR.NE.0) RETURN 35 : CALL LIROBJ('MAILLAGE',IPPP,0,IRETO) 36 : IF (IYYT.EQ.1) THEN 37 : IF(IRETO.NE.0) THEN 37 : CALL PROOB1(MELEME,IPPP,IP1) 38 : RETURN 39 : ENDIF 40 : ENDIF 41 : IF (IYYT.EQ.2) THEN 42 : IF(IRETO.NE.0) THEN 42 : CALL PROOB4(MELEME,IPPP,IP1) 43 : RETURN 44 : ENDIF 45 : ENDIF 46 : SEGACT MCOORD 47 : IREF=(IDIM+1)*(IP1-1) 48 : XVEC=XCOOR(IREF+1) 49 : YVEC=XCOOR(IREF+2) 50 : ZVEC=XCOOR(IREF+3) 51 : IF (IDIM.EQ.2) ZVEC=0. 52 : IALIR=0 53 : IF (IYYT.EQ.0) IALIR=1 53 : CALL LIRMOT(MCLE,7,IVAL,IALIR) 54 : IF (IVAL.EQ.0) THEN 55 : IVAL=IYYT+2 56 : IYYT=0 57 : ENDIF 58 : IF (IERR.NE.0) RETURN 58 : IF (IDIM.EQ.2.AND.IVAL.LE.5) CALL ERREUR(34) 58 : IF (IDIM.EQ.3.AND.IVAL.GE.6) CALL ERREUR(34) 59 : IF (IERR.NE.0) RETURN 60 : ICLE=IVAL+7 61 : GOTO (10,20,30,40,50,60,70),IVAL 62 : 10 CONTINUE 63 : C PLAN ON LIT TROIS POINTS 63 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 63 : CALL LIROBJ('POINT ',IP2,1,IRETOU) 63 : CALL LIROBJ('POINT ',IP3,1,IRETOU) 64 : IF (IERR.NE.0) RETURN 65 : IREF=(IDIM+1)*(IP1-1) 66 : XPT1=XCOOR(IREF+1) 67 : YPT1=XCOOR(IREF+2) 68 : ZPT1=XCOOR(IREF+3) 69 : IREF=(IDIM+1)*(IP2-1) 70 : XV2=XCOOR(IREF+1)-XPT1 71 : YV2=XCOOR(IREF+2)-YPT1 72 : ZV2=XCOOR(IREF+3)-ZPT1 73 : IREF=(IDIM+1)*(IP3-1) 74 : XV3=XCOOR(IREF+1)-XPT1 75 : YV3=XCOOR(IREF+2)-YPT1 76 : ZV3=XCOOR(IREF+3)-ZPT1 77 : C ON GARDE LE VECTEUR NORMAL NORMALISE 78 : XV1=YV2*ZV3-ZV2*YV3 79 : YV1=ZV2*XV3-XV2*ZV3 80 : ZV1=XV2*YV3-YV2*XV3 81 : SV1=SQRT(XV1**2+YV1**2+ZV1**2) 81 : IF (SV1.EQ.0.) CALL ERREUR(21) 82 : IF (IERR.NE.0) RETURN 83 : XV1=XV1/SV1 84 : YV1=YV1/SV1 85 : ZV1=ZV1/SV1 86 : GOTO 100 87 : 20 CONTINUE 88 : C SPHERE ON LIT LE CENTRE ET UN POINT 88 : CALL LIROBJ('POINT ',IPCEN,1,IRETOU) 88 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 89 : IF (IERR.NE.0) RETURN 90 : IREF=(IPCEN-1)*(IDIM+1) 91 : XPT1=XCOOR(IREF+1) 92 : YPT1=XCOOR(IREF+2) 93 : ZPT1=XCOOR(IREF+3) 94 : IREF=(IP1-1)*(IDIM+1) 95 : XV=XCOOR(IREF+1)-XPT1 96 : YV=XCOOR(IREF+2)-YPT1 97 : ZV=XCOOR(IREF+3)-ZPT1 98 : ANGLE=SQRT(XV**2+YV**2+ZV**2) 98 : IF (ANGLE.EQ.0.) CALL ERREUR(21) 99 : IF (IERR.NE.0) RETURN 100 : GOTO 100 101 : 30 CONTINUE 102 : C CYLINDRE ON LIT DEUX POINTS DE L'AXE ET UN POINT DU CYLINDRE 102 : CALL LIROBJ('POINT ',IPOIN1,1,IRETOU) 102 : CALL LIROBJ('POINT ',IPOIN2,1,IRETOU) 102 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 103 : IF (IERR.NE.0) RETURN 104 : IREF=(IDIM+1)*(IPOIN1-1) 105 : XPT1=XCOOR(IREF+1) 106 : YPT1=XCOOR(IREF+2) 107 : ZPT1=XCOOR(IREF+3) 108 : IREF=(IDIM+1)*(IPOIN2-1) 109 : XV1=XCOOR(IREF+1)-XPT1 110 : YV1=XCOOR(IREF+2)-YPT1 111 : ZV1=XCOOR(IREF+3)-ZPT1 112 : S=SQRT(XV1**2+YV1**2+ZV1**2) 112 : IF (S.EQ.0.) CALL ERREUR(21) 113 : IF (IERR.NE.0) RETURN 114 : XV1=XV1/S 115 : YV1=YV1/S 116 : ZV1=ZV1/S 117 : IREF=(IDIM+1)*(IP1-1) 118 : XV2=XCOOR(IREF+1)-XPT1 119 : YV2=XCOOR(IREF+2)-YPT1 120 : ZV2=XCOOR(IREF+3)-ZPT1 121 : XV3=YV1*ZV2-ZV1*YV2 122 : YV3=ZV1*XV2-XV1*ZV2 123 : ZV3=XV1*YV2-YV1*XV2 124 : ANGLE=SQRT(XV3**2+YV3**2+ZV3**2) 125 : C RAYON DU CYLINDRE 125 : IF (ANGLE.EQ.0) CALL ERREUR(21) 126 : IF (IERR.NE.0) RETURN 127 : GOTO 100 128 : 40 CONTINUE 129 : C CONE ON LIT LE SOMMET UN POINT DE L'AXE ET UN POINT DU CONE 129 : CALL LIROBJ('POINT ',IPT1,1,IRETOU) 129 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 129 : CALL LIROBJ('POINT ',IP2,1,IRETOU) 130 : IF (IERR.NE.0) RETURN 131 : IREF=(IDIM+1)*(IPT1-1) 132 : XPT1=XCOOR(IREF+1) 133 : YPT1=XCOOR(IREF+2) 134 : ZPT1=XCOOR(IREF+3) 135 : IREF=(IDIM+1)*(IP1-1) 136 : XV1=XCOOR(IREF+1)-XPT1 137 : YV1=XCOOR(IREF+2)-YPT1 138 : ZV1=XCOOR(IREF+3)-ZPT1 139 : SV1=SQRT(XV1**2+YV1**2+ZV1**2) 139 : IF (SV1.EQ.0.) CALL ERREUR(21) 140 : IF (IERR.NE.0) RETURN 141 : XV1=XV1/SV1 142 : YV1=YV1/SV1 143 : ZV1=ZV1/SV1 144 : IREF=(IDIM+1)*(IP2-1) 145 : XV2=XCOOR(IREF+1)-XPT1 146 : YV2=XCOOR(IREF+2)-YPT1 147 : ZV2=XCOOR(IREF+3)-ZPT1 148 : SV2=SQRT(XV2**2+YV2**2+ZV2**2) 148 : IF (SV2.EQ.0.) CALL ERREUR(21) 149 : IF (IERR.NE.0) RETURN 150 : XV2=XV2/SV2 151 : YV2=YV2/SV2 152 : ZV2=ZV2/SV2 153 : ANGLE=(XV1*XV2+YV1*YV2+ZV1*ZV2)**2 154 : IF (IIMPI.NE.0) WRITE (IOIMP,1012) ANGLE 155 : 1012 FORMAT(' COS **2 DE ANGLE AU SOMMET ',G12.5) 156 : GOTO 100 157 : 50 CONTINUE 158 : C TORE ON LIT LE CENTRE UN POINT DE L'AXE UN CENTRE SECONDAIRE ET 159 : C UN POINT 159 : CALL LIROBJ('POINT ',IPT1,1,IRETOU) 159 : CALL LIROBJ('POINT ',IPAX,1,IRETOU) 159 : CALL LIROBJ('POINT ',IPCS,1,IRETOU) 159 : CALL LIROBJ('POINT ',IP1 ,1,IRETOU) 160 : IF (IERR.NE.0) RETURN 161 : IREF=(IDIM+1)*(IPT1-1) 162 : XPT1=XCOOR(IREF+1) 163 : YPT1=XCOOR(IREF+2) 164 : ZPT1=XCOOR(IREF+3) 165 : IREF=(IDIM+1)*(IPAX-1) 166 : XV1=XCOOR(IREF+1)-XPT1 167 : YV1=XCOOR(IREF+2)-YPT1 168 : ZV1=XCOOR(IREF+3)-ZPT1 169 : SV1=XV1**2+YV1**2+ZV1**2 169 : IF (SV1.EQ.0.) CALL ERREUR(21) 170 : IF (IERR.NE.0) RETURN 171 : SV1=SQRT(SV1) 172 : XV1=XV1/SV1 173 : YV1=YV1/SV1 174 : ZV1=ZV1/SV1 175 : IREF=(IDIM+1)*(IPCS-1) 176 : XV2=XCOOR(IREF+1)-XPT1 177 : YV2=XCOOR(IREF+2)-YPT1 178 : ZV2=XCOOR(IREF+3)-ZPT1 179 : SCA=XV2*XV1+YV2*YV1+ZV2*ZV1 180 : XPT1=XPT1+SCA*XV1 181 : YPT1=YPT1+SCA*YV1 182 : ZPT1=ZPT1+SCA*ZV1 183 : XV2=XV2-SCA*XV1 184 : YV2=YV2-SCA*YV1 185 : ZV2=ZV2-SCA*ZV1 186 : GR2=XV2**2+YV2**2+ZV2**2 186 : IF (GR2.EQ.0.) CALL ERREUR(21) 187 : IF (IERR.NE.0) RETURN 188 : IREF=(IDIM+1)*(IP1-1) 189 : XV2=XCOOR(IREF+1)-XPT1 190 : YV2=XCOOR(IREF+2)-YPT1 191 : ZV2=XCOOR(IREF+3)-ZPT1 192 : SCA=XV2*XV1+YV2*YV1+ZV2*ZV1 193 : XC=XV2-SCA*XV1 194 : YC=YV2-SCA*YV1 195 : ZC=ZV2-SCA*ZV1 196 : SC=XC**2+YC**2+ZC**2 196 : IF (SC.EQ.0.) CALL ERREUR(21) 197 : IF (IERR.NE.0) RETURN 198 : RAP=SQRT(GR2/SC) 199 : XC=XC*RAP 200 : YC=YC*RAP 201 : ZC=ZC*RAP 202 : PR2=(XV2-XC)**2+(YV2-YC)**2+(ZV2-ZC)**2 202 : IF (PR2.EQ.0.) CALL ERREUR(21) 203 : IF (IERR.NE.0) RETURN 204 : XV2=PR2 205 : YV2=GR2 206 : IF (IIMPI.NE.0) WRITE (IOIMP,1015) XV2,YV2,XPT1,YPT1,ZPT1, 207 : # XV1,YV1,ZV1 208 : 1015 FORMAT(' CARRE PETIT RAYON ',G12.5, 209 : # ' CARRE GRAND RAYON ',G12.5,/,' CENTRE ',3G13.5,' AXE ', 210 : # 3G12.5) 211 : GOTO 100 212 : 60 CONTINUE 213 : C DROITE ON LIT DEUX POINTS 213 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 213 : CALL LIROBJ('POINT ',IP2,1,IRETOU) 214 : IF (IERR.NE.0) RETURN 215 : IREF=(IDIM+1)*(IP1-1) 216 : XPT1=XCOOR(IREF+1) 217 : YPT1=XCOOR(IREF+2) 218 : ZPT1=0. 219 : IREF=(IDIM+1)*(IP2-1) 220 : XV2=XCOOR(IREF+1)-XPT1 221 : YV2=XCOOR(IREF+2)-YPT1 222 : ZV2=0. 223 : XV3=0. 224 : YV3=0. 225 : ZV3=1. 226 : C ON GARDE LE VECTEUR NORMAL NORMALISE 227 : XV1=YV2*ZV3-ZV2*YV3 228 : YV1=ZV2*XV3-XV2*ZV3 229 : ZV1=XV2*YV3-YV2*XV3 230 : SV1=SQRT(XV1**2+YV1**2+ZV1**2) 230 : IF (SV1.EQ.0.) CALL ERREUR(21) 231 : IF (IERR.NE.0) RETURN 232 : XV1=XV1/SV1 233 : YV1=YV1/SV1 234 : ZV1=ZV1/SV1 235 : GOTO 100 236 : 70 CONTINUE 237 : C CERCLE ON LIT LE CENTRE ET UN POINT 237 : CALL LIROBJ('POINT ',IPCEN,1,IRETOU) 237 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 238 : IF (IERR.NE.0) RETURN 239 : IREF=(IPCEN-1)*(IDIM+1) 240 : XPT1=XCOOR(IREF+1) 241 : YPT1=XCOOR(IREF+2) 242 : ZPT1=0. 243 : IREF=(IP1-1)*(IDIM+1) 244 : XV=XCOOR(IREF+1)-XPT1 245 : YV=XCOOR(IREF+2)-YPT1 246 : ZV=0. 247 : ANGLE=SQRT(XV**2+YV**2+ZV**2) 247 : IF (ANGLE.EQ.0.) CALL ERREUR(21) 248 : IF (IERR.NE.0) RETURN 249 : GOTO 100 250 : 100 CONTINUE 251 : IF (MELEME.EQ.0) GOTO 101 252 : IF (IYYT.EQ.2) THEN 253 : IVAL=IVAL+10000 254 : ICLE=ICLE+10000 255 : ENDIF 255 : CALL INTOPE(MELEME) 256 : RETURN 257 : 101 CONTINUE 258 : IREF=(IDIM+1)*(IPOIN-1) 259 : XPOIN=XCOOR(IREF+1) 260 : YPOIN=XCOOR(IREF+2) 261 : ZPOIN=XCOOR(IREF+3) 262 : TPOIN=XCOOR(IREF+4) 263 : IF (IDIM.EQ.2) ZPOIN=0 264 : IF (IDIM.EQ.2) TPOIN=XCOOR(IREF+3) 265 : IF (IYYT.EQ.2) THEN 266 : XVEC=XVEC-XPOIN 267 : YVEC=YVEC-YPOIN 268 : ZVEC=ZVEC-ZPOIN 269 : IF (IDIM.EQ.2) ZVEC=0. 270 : ENDIF 271 : SVEC=SQRT(XVEC**2+YVEC**2+ZVEC**2) 271 : IF (SVEC.EQ.0.) CALL ERREUR(21) 272 : IF (IERR.NE.0) RETURN 273 : XVEC=XVEC/SVEC 274 : YVEC=YVEC/SVEC 275 : ZVEC=ZVEC/SVEC 276 : GOTO (110,120,130,140,150,160,170),IVAL 277 : 110 CONTINUE 278 : XV=XPOIN-XPT1 279 : YV=YPOIN-YPT1 280 : ZV=ZPOIN-ZPT1 281 : DENUM=XV*XV1+YV*YV1+ZV*ZV1 282 : DENOM=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 282 : IF (DENOM.EQ.0.) CALL ERREUR(21) 283 : IF (IERR.NE.0) RETURN 284 : RAP=-DENUM/DENOM 285 : XPOIN=XPOIN+RAP*XVEC 286 : YPOIN=YPOIN+RAP*YVEC 287 : ZPOIN=ZPOIN+RAP*ZVEC 288 : GOTO 200 289 : 120 CONTINUE 290 : XV=XPT1-XPOIN 291 : YV=YPT1-YPOIN 292 : ZV=ZPT1-ZPOIN 293 : SCA=XVEC*XV+YVEC*YV+ZVEC*ZV 294 : XV=XVEC*SCA 295 : YV=YVEC*SCA 296 : ZV=ZVEC*SCA 297 : S2=(XPOIN+XV-XPT1)**2+(YPOIN+YV-YPT1)**2+(ZPOIN+ZV-ZPT1)**2 297 : IF (S2.GT.ANGLE**2) CALL ERREUR(21) 298 : IF (IERR.NE.0) RETURN 299 : C=SQRT(ANGLE**2-S2) 300 : IF (SCA.LT.0.) C=-C 301 : XPOIN=XPOIN+XV-C*XVEC 302 : YPOIN=YPOIN+YV-C*YVEC 303 : ZPOIN=ZPOIN+ZV-C*ZVEC 304 : GOTO 200 305 : 130 CONTINUE 306 : C V2 = VEC VECT V1 307 : XV2=YVEC*ZV1-ZVEC*YV1 308 : YV2=ZVEC*XV1-XVEC*ZV1 309 : ZV2=XVEC*YV1-YVEC*XV1 310 : S2V2=XV2**2+YV2**2+ZV2**2 310 : IF (S2V2.EQ.0.) CALL ERREUR(21) 311 : IF (IERR.NE.0) RETURN 312 : C2=(XVEC*XV1+YVEC*YV1+ZVEC*ZV1)**2 312 : IF (C2.EQ.1.) CALL ERREUR(21) 313 : IF (IERR.NE.0) RETURN 314 : C V3= POIN PT1 315 : XV3=XPT1-XPOIN 316 : YV3=YPT1-YPOIN 317 : ZV3=ZPT1-ZPOIN 318 : XV4=YV3*ZV1-ZV3*YV1 319 : YV4=ZV3*XV1-XV3*ZV1 320 : ZV4=XV3*YV1-YV3*XV1 321 : DNUM=(XV4*XVEC+YV4*YVEC+ZV4*ZVEC)**2 322 : DIS2=DNUM/S2V2 323 : IF (IIMPI.NE.0) WRITE (IOIMP,1000) DIS2,ANGLE 324 : 1000 FORMAT (' DISTANCE AU CARRE DES AXES ',G12.5, 325 : # 'RAYON DU CYLINDRE ',G12.5) 325 : IF (DIS2.GT.ANGLE**2) CALL ERREUR(21) 326 : IF (IERR.NE.0) RETURN 327 : DMU=SQRT((ANGLE**2-DIS2)/(1.-C2)) 328 : DNUM=XV2*XV4+YV2*YV4+ZV2*ZV4 329 : DLA=DNUM/S2V2 330 : DMU=SIGN(DMU,DLA) 331 : IF (IIMPI.NE.0) WRITE (IOIMP,1001) DLA,DMU 332 : 1001 FORMAT(' LAMBDA,MU ',2G13.5) 333 : XPOIN=XPOIN+XVEC*(DLA-DMU) 334 : YPOIN=YPOIN+YVEC*(DLA-DMU) 335 : ZPOIN=ZPOIN+ZVEC*(DLA-DMU) 336 : GOTO 200 337 : 140 CONTINUE 338 : XV2=XPOIN-XPT1 339 : YV2=YPOIN-YPT1 340 : ZV2=ZPOIN-ZPT1 341 : VECV1=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 342 : VEC2=XVEC**2+YVEC**2+ZVEC**2 343 : V2V1=XV2*XV1+YV2*YV1+ZV2*ZV1 344 : VECV2=XVEC*XV2+YVEC*YV2+ZVEC*ZV2 345 : V22=XV2**2+YV2**2+ZV2**2 346 : A=VECV1**2-ANGLE*VEC2 347 : B=2*(V2V1*VECV1-ANGLE*VECV2) 348 : C=V2V1**2-ANGLE*V22 349 : DELTA=B**2-4*A*C 349 : IF (DELTA.LT.0.) CALL ERREUR(21) 350 : IF (IERR.NE.0) RETURN 351 : DEL=SQRT(DELTA) 352 : X1=(-B+DEL)/(2*A) 353 : X2=(-B-DEL)/(2*A) 354 : X=X2 355 : IF (ABS(X1).LT.ABS(X2)) X=X1 356 : XPOIN=XPOIN+X*XVEC 357 : YPOIN=YPOIN+X*YVEC 358 : ZPOIN=ZPOIN+X*ZVEC 359 : GOTO 200 360 : 150 CONTINUE 361 : PR2=XV2 362 : GR2=YV2 363 : XOP=XPOIN-XPT1 364 : YOP=YPOIN-YPT1 365 : ZOP=ZPOIN-ZPT1 366 : OPV=XOP*XVEC+YOP*YVEC+ZOP*ZVEC 367 : R2=XOP**2+YOP**2+ZOP**2-GR2-PR2 368 : VA=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 369 : QR2VA2=4*GR2*VA**2 370 : OPA=XOP*XV1+YOP*YV1+ZOP*ZV1 371 : HR2PV=8*GR2*OPA*VA 372 : R=4*GR2*OPA**2-4*PR2*GR2 373 : RLMD=0 374 : C RESOLUTION DE L'EQUATION DU 4EME DEGRE PAR ITERATION 375 : DO 151 ITER=1,25 376 : EXP1=RLMD*(RLMD+2*OPV)+R2 377 : FDLM=EXP1**2+QR2VA2*RLMD**2+HR2PV*RLMD+R 378 : FPDLM=4*EXP1*(RLMD+OPV)+QR2VA2*2*RLMD+HR2PV 378 : IF (FPDLM.EQ.0.) CALL ERREUR(40) 379 : IF (IERR.NE.0) RETURN 380 : CORR=FDLM/FPDLM 381 : IF (IIMPI.NE.0) WRITE(IOIMP,1016) ITER,RLMD,CORR 382 : 1016 FORMAT(' ITER ',I6,' LAMBDA ',G12.5,' CORR ',G12.5) 383 : RLMD=RLMD-CORR 384 : IF (RLMD.EQ.0.) GOTO 151 385 : IF (ABS(CORR/RLMD).LT.1E-5) GOTO 152 386 : 151 CONTINUE 386 : CALL ERREUR(40) 387 : RETURN 388 : 152 CONTINUE 389 : XPOIN=XPOIN+RLMD*XVEC 390 : YPOIN=YPOIN+RLMD*YVEC 391 : ZPOIN=ZPOIN+RLMD*ZVEC 392 : GOTO 200 393 : 160 CONTINUE 394 : XV=XPOIN-XPT1 395 : YV=YPOIN-YPT1 396 : ZV=ZPOIN-ZPT1 397 : DENUM=XV*XV1+YV*YV1+ZV*ZV1 398 : DENOM=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 398 : IF (DENOM.EQ.0.) CALL ERREUR(21) 399 : IF (IERR.NE.0) RETURN 400 : RAP=-DENUM/DENOM 401 : XPOIN=XPOIN+RAP*XVEC 402 : YPOIN=YPOIN+RAP*YVEC 403 : ZPOIN=ZPOIN+RAP*ZVEC 404 : GOTO 200 405 : 170 CONTINUE 406 : XV=XPT1-XPOIN 407 : YV=YPT1-YPOIN 408 : ZV=ZPT1-ZPOIN 409 : SCA=XVEC*XV+YVEC*YV+ZVEC*ZV 410 : XV=XVEC*SCA 411 : YV=YVEC*SCA 412 : ZV=ZVEC*SCA 413 : S2=(XPOIN+XV-XPT1)**2+(YPOIN+YV-YPT1)**2+(ZPOIN+ZV-ZPT1)**2 413 : IF (S2.GT.ANGLE**2) CALL ERREUR(21) 414 : IF (IERR.NE.0) RETURN 415 : C=SQRT(ANGLE**2-S2) 416 : IF (SCA.LT.0.) C=-C 417 : XPOIN=XPOIN+XV-C*XVEC 418 : YPOIN=YPOIN+YV-C*YVEC 419 : ZPOIN=ZPOIN+ZV-C*ZVEC 420 : GOTO 200 421 : 200 CONTINUE 422 : NBPTS=XCOOR(/1)/(IDIM+1)+1 423 : SEGADJ MCOORD 424 : XCOOR((NBPTS-1)*(IDIM+1)+1)=XPOIN 425 : XCOOR((NBPTS-1)*(IDIM+1)+2)=YPOIN 426 : IF (IDIM.EQ.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=ZPOIN 427 : XCOOR(NBPTS*(IDIM+1))=TPOIN 427 : CALL ECROBJ('POINT ',NBPTS) 428 : RETURN 429 : END 430 : 431 : 432 :
© Cast3M 2003 - All rights reserved.
Disclaimer