1 : C DEPLAC SOURCE BP208322 13/06/27 21:15:05 7783 2 : 3 : C CE SOUS-PROGRAMME A POUR PROPOS DE DEPLACER L'ENSEMBLE DES POINTS 4 : C CONTENUS DANS UN OBJET 5 : C 09/2003 : Modifications dans le cas IDIM=1. 6 : 7 : SUBROUTINE DEPLAC 8 : 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : 12 : -INC CCREEL 13 : -INC CCOPTIO 14 : -INC SMCOORD 15 : -INC SMELEME 16 : -INC SMCHPOI 17 : 18 : CHARACTER*4 MCLE(11) 19 : CHARACTER*4 MCL2(3) 20 : CHARACTER*4 MCL3(7) 21 : CHARACTER*4 MCL4(2) 22 : CHARACTER*4 MCL5(2) 23 : DIMENSION XU(3),XV(3),XW(3),XP(3) 24 : REAL*8 XXX,RAP 25 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 26 : 27 : DATA NCLE / 11 / 28 : DATA MCLE / 'PLUS','MOIN','TOUR','HOMO','AFFI','SYME','PROJ', 29 : . 'COOR','MILI','BARS','DEDU' / 30 : DATA MCL2 / 'POIN','DROI','PLAN' / 31 : DATA MCL3 / 'PLAN','SPHE','CYLI','CONI','TORI','DROI','CERC' / 32 : DATA MCL4 / 'CYLI','CONI' / 33 : DATA MCL5 / 'CYLI','CART' / 34 : 35 : C Lecture de l'option de la directive DEPLACER 35 : CALL LIRMOT(MCLE,NCLE,ICLE,1) 36 : IF (IERR.NE.0) RETURN 37 : C Cas IDIM=1, seules les options suivantes sont disponibles : 38 : C 'PLUS','MOIN','HOMO','SYME','MILI','DEDU' 39 : IF (IDIM.EQ.1) THEN 40 : IF ((ICLE.NE.1).AND.(ICLE.NE.2).AND.(ICLE.NE.4).AND. 41 : . (ICLE.NE.6).AND.(ICLE.NE.9).AND.(ICLE.NE.11)) THEN 42 : MOTERR(1:4)=MCLE(ICLE) 43 : INTERR(1)=IDIM 43 : CALL ERREUR(971) 44 : RETURN 45 : ENDIF 46 : ENDIF 47 : 48 : idimp1=IDIM+1 49 : ITYPLU=2 50 : 51 : C Option BARS : Elements de BARSOUM 52 : C --------------- 53 : C Deplacement des noeuds milieu autour de la pointe de fissure 54 : IF (ICLE.EQ.10) THEN 54 : CALL BARSOU 55 : RETURN 56 : ENDIF 57 : 58 : C Option DEDU : 59 : C --------------- 60 : C Transformation affine definie par au plus (IDIM+1) points 61 : IF (ICLE.EQ.11) THEN 61 : CALL DEDU(1) 62 : RETURN 63 : ENDIF 64 : 64 : CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU) 65 : ITYPSA=MELEME 66 : IF (IRETOU.NE.1) THEN 67 : ITYPLU=1 67 : CALL LIROBJ('POINT',IP,1,IRETOU) 68 : IF (IERR.NE.0) RETURN 69 : ITYPSA=IP 69 : CALL CRELEM(IP) 70 : MELEME=IP 71 : ENDIF 72 : SEGACT MCOORD*MOD 73 : 74 : C Option MILI : 75 : C --------------- 76 : IF (ICLE.EQ.9) GOTO 1900 77 : 78 : C Remplissage du tableau ICPR des points a deplacer 79 : SEGINI ICPR 80 : C Est-ce bien utile apres un SEGINI ? 81 : c DO i=1,ICPR(/1) 82 : c ICPR(i)=0 83 : c ENDDO 84 : c petite numerotation locale dans ICPR 85 : NICPR=0 86 : SEGACT MELEME 87 : IPT1=MELEME 88 : DO io=1,MAX(1,LISOUS(/1)) 89 : IF (LISOUS(/1).NE.0) THEN 90 : IPT1=LISOUS(io) 91 : SEGACT IPT1 92 : ENDIF 93 : DO i=1,IPT1.NUM(/1) 94 : DO j=1,IPT1.NUM(/2) 95 : I1=IPT1.NUM(i,j) 96 : if(ICPR(I1).eq.0) then 97 : NICPR=NICPR+1 98 : ICPR(I1)=NICPR 99 : endif 100 : ENDDO 101 : ENDDO 102 : IF (LISOUS(/1).NE.0) SEGDES IPT1 103 : ENDDO 104 : SEGDES MELEME 105 : 106 : C Lecture des donnees supplementaires (selon ICLE) et action 107 : C ICLE=1 : PLUS 1 POINT (VECTEUR) 108 : C ICLE=2 : MOIN 1 POINT (VECTEUR) 109 : C ICLE=3 : TOUR 1 NOMBRE (ANGLE) 1 OU 2 POINTS (AXE 2 OU 3 D) 110 : C ICLE=4 : HOMO 1 NOMBRE (RAPPORT) 1 POINT (CENTRE) 111 : C ICLE=5 : AFFI 1 NOMBRE (RAPPORT) 1 POINT (INVARIANT) 112 : C 1 POINT(VECTEUR) 113 : C ICLE=6 : SYME 1 MOT (POIN DROI OU PLAN) 1,2 OU 3 POINTS 114 : C ICLE=7 : PROJ 1 MOT (PLAN SPHE CYLI CONI TORI DROI CERC) 115 : C DES DONNEES EN RAPPORT 116 : C ICLE=8 : COOR 1 MOT (CART CYLI) 117 : GOTO (100,200,300,400,500,600,700,1800),ICLE 118 : 119 : C Option PLUS : 120 : C --------------- 121 : 100 XSENS=1.D0 122 : GOTO 201 123 : C Option MOIN : 124 : C --------------- 125 : 200 XSENS=-1.D0 125 : 201 CALL LIROBJ('POINT',IP,0,IRETOU) 126 : IF (IERR.NE.0) GOTO 10000 127 : IF (IRETOU.EQ.0) THEN 127 : CALL LIROBJ('CHPOINT ',IPCH,1,IRETOU) 128 : IF (IERR.NE.0) GOTO 10000 128 : CALL DEPCHP(ICPR,IPCH,XSENS) 129 : GOTO 1000 130 : ENDIF 131 : IREF=idimp1*(IP-1) 132 : DO j=1,IDIM 133 : XV(j)=XCOOR(IREF+j)*XSENS 134 : ENDDO 135 : DO i=1,ICPR(/1) 136 : IF (ICPR(i).NE.0) THEN 137 : IREF=idimp1*(i-1) 138 : DO j=1,IDIM 139 : XCOOR(IREF+j)=XCOOR(IREF+j)+XV(j) 140 : ENDDO 141 : ENDIF 142 : ENDDO 143 : GOTO 1000 144 : 145 : C Option TOUR : 146 : C --------------- 147 : c lecture de l'angle 147 : 300 CALL LIRREE(ANG,0,IRETOU) 148 : IF (IERR.NE.0) GOTO 10000 149 : IPCH1=0 150 : C -- bp (nouvelle option 06/2013) : TOUR CHPOint -- 151 : IF (IRETOU.EQ.0) THEN 151 : CALL LIROBJ('CHPOINT ',IPCH1,1,IRET1) 152 : IF (IERR.NE.0) GOTO 10000 153 : c creation d'un MPOVAL coherent avec ICPR 154 : c avec comme composantes COS et SIN 155 : N=NICPR 156 : NC=2 157 : SEGINI,MPOVAL 158 : DO I=1,N 159 : VPOCHA(I,1)=1.D0 160 : c VPOCHA(I,2)=0.D0 =sin(0) 161 : ENDDO 162 : c remplissage du MPOVAL depuis le MCHPO1 163 : MCHPO1=IPCH1 164 : SEGACT,MCHPO1 165 : DO IP=1,MCHPO1.IPCHP(/1) 166 : MSOUP1=MCHPO1.IPCHP(IP) 167 : SEGACT,MSOUP1 168 : IPT1=MSOUP1.IGEOC 169 : SEGACT,IPT1 170 : MPOVA1=MSOUP1.IPOVAL 171 : SEGACT,MPOVA1 172 : N1 = MPOVA1.VPOCHA(/1) 173 : NC1 = MPOVA1.VPOCHA(/2) 174 : IF (NC1.ne.1) THEN 174 : call ERREUR(180) 175 : GOTO 10000 176 : ENDIF 177 : DO 303 J1=1,N1 178 : I = ICPR(IPT1.NUM(1,J1)) 179 : IF(I.eq.0) GOTO 303 180 : ANG=MPOVA1.VPOCHA(J1,1)/180.D0*XPI 181 : VPOCHA(I,1)=COS(ANG) 182 : VPOCHA(I,2)=SIN(ANG) 183 : 303 CONTINUE 184 : SEGDES,MPOVA1,IPT1 185 : SEGDES,MSOUP1 186 : ENDDO 187 : SEGDES,MCHPO1 188 : ELSE 189 : ANG=ANG/180.D0*XPI 190 : CO=COS(ANG) 191 : SI=SIN(ANG) 192 : ENDIF 193 : c lecture des points centre et axe + fabrication repere de rotation 193 : CALL LIROBJ('POINT',IP1,1,IRETOU) 193 : IF (IDIM.EQ.3) CALL LIROBJ('POINT',IP2,1,IRETOU) 194 : IF (IERR.NE.0) GOTO 10000 195 : IREF=idimp1*(IP1-1) 196 : XP(1)=XCOOR(IREF+1) 197 : XP(2)=XCOOR(IREF+2) 198 : IF (IDIM.LT.3) THEN 199 : XP(3)=0.D0 200 : XW(1)=0.D0 201 : XW(2)=0.D0 202 : XW(3)=1.D0 203 : ELSE 204 : XP(3)=XCOOR(IREF+3) 205 : IREF=idimp1*(IP2-1) 206 : XW(1)=XCOOR(IREF+1)-XP(1) 207 : XW(2)=XCOOR(IREF+2)-XP(2) 208 : XW(3)=XCOOR(IREF+3)-XP(3) 209 : XN=SQRT(XW(1)**2+XW(2)**2+XW(3)**2) 209 : IF (XN.EQ.0.D0) CALL ERREUR(21) 210 : IF (IERR.NE.0) GOTO 10000 211 : XW(1)=XW(1)/XN 212 : XW(2)=XW(2)/XN 213 : XW(3)=XW(3)/XN 214 : ENDIF 215 : XU(1)=-XW(2) 216 : XU(2)=XW(1) 217 : XN=SQRT(XU(1)**2+XU(2)**2) 218 : IF (XN.GE.0.1D0) THEN 219 : XU(3)=0.D0 220 : XU(1)=XU(1)/XN 221 : XU(2)=XU(2)/XN 222 : ELSE 223 : XU(1)=0.D0 224 : XU(2)=-XW(3) 225 : XU(3)=XW(2) 226 : XN=SQRT(XU(2)**2+XU(3)**2) 227 : XU(2)=XU(2)/XN 228 : XU(3)=XU(3)/XN 229 : ENDIF 230 : XV(1)=XW(2)*XU(3)-XW(3)*XU(2) 231 : XV(2)=XW(3)*XU(1)-XW(1)*XU(3) 232 : XV(3)=XW(1)*XU(2)-XW(2)*XU(1) 233 : c boucle sur les noeuds + rotation 234 : DO i=1,ICPR(/1) 235 : IF (ICPR(i).NE.0) THEN 236 : IREF=idimp1*(i-1) 237 : XD=XCOOR(IREF+1)-XP(1) 238 : YD=XCOOR(IREF+2)-XP(2) 239 : ZD=0.D0 240 : IF (IDIM.EQ.3) ZD=XCOOR(IREF+3)-XP(3) 241 : XE=XD*XU(1)+YD*XU(2)+ZD*XU(3) 242 : YE=XD*XV(1)+YD*XV(2)+ZD*XV(3) 243 : ZE=XD*XW(1)+YD*XW(2)+ZD*XW(3) 244 : IF(IPCH1.ne.0) THEN 245 : CO = VPOCHA(ICPR(i),1) 246 : SI = VPOCHA(ICPR(i),2) 247 : ENDIF 248 : XD=XE*CO-YE*SI 249 : YD=XE*SI+YE*CO 250 : ZD=ZE 251 : XCOOR(IREF+1)=XD*XU(1)+YD*XV(1)+ZD*XW(1)+XP(1) 252 : XCOOR(IREF+2)=XD*XU(2)+YD*XV(2)+ZD*XW(2)+XP(2) 253 : IF (IDIM.EQ.3) XCOOR(IREF+3)=XD*XU(3)+YD*XV(3)+ZD*XW(3)+XP(3) 254 : ENDIF 255 : ENDDO 256 : IF(IPCH1.ne.0) SEGSUP,MPOVAL 257 : GOTO 1000 258 : 259 : C Option HOMO : 260 : C --------------- 260 : 400 CALL LIRREE(RAP,1,IRETOU) 260 : CALL LIROBJ('POINT',IP,1,IRETOU) 260 : IF (RAP.EQ.0.D0) CALL ERREUR(36) 261 : IF (IERR.NE.0) GOTO 10000 262 : IREF=idimp1*(IP-1) 263 : DO j=1,IDIM 264 : XP(j)=XCOOR(IREF+j) 265 : ENDDO 266 : DO i=1,ICPR(/1) 267 : IF (ICPR(i).NE.0) THEN 268 : IREF=idimp1*(i-1) 269 : DO j=1,IDIM 270 : XCOOR(IREF+j)=XP(j)+RAP*(XCOOR(IREF+j)-XP(j)) 271 : ENDDO 272 : ENDIF 273 : ENDDO 274 : GOTO 1000 275 : 276 : C Option AFFI : 277 : C --------------- 277 : 500 CALL LIRREE(RAP,1,IRETOU) 277 : CALL LIROBJ('POINT',IPC,1,IRETOU) 277 : CALL LIROBJ('POINT',IPV,1,IRETOU) 277 : IF (RAP.EQ.0.D0) CALL ERREUR(36) 278 : IF (IERR.NE.0) GOTO 10000 279 : RAP=RAP-1. 280 : IREF=idimp1*(IPC-1) 281 : XP(1)=XCOOR(IREF+1) 282 : XP(2)=XCOOR(IREF+2) 283 : XP(3)=0.D0 284 : IF (IDIM.EQ.3) XP(3)=XCOOR(IREF+3) 285 : IREF=idimp1*(IPV-1) 286 : XV(1)=XCOOR(IREF+1)-XP(1) 287 : XV(2)=XCOOR(IREF+2)-XP(2) 288 : XV(3)=0.D0 289 : IF (IDIM.EQ.3) XV(3)=XCOOR(IREF+3)-XP(3) 290 : XN=XV(1)**2+XV(2)**2+XV(3)**2 290 : IF (XN.EQ.0.D0) CALL ERREUR(21) 291 : IF (IERR.NE.0) GOTO 10000 292 : XN=SQRT(XN) 293 : XV(1)=XV(1)/XN 294 : XV(2)=XV(2)/XN 295 : XV(3)=XV(3)/XN 296 : DO i=1,ICPR(/1) 297 : IF (ICPR(i).NE.0) THEN 298 : IREF=idimp1*(i-1) 299 : XU(1)=XCOOR(IREF+1)-XP(1) 300 : XU(2)=XCOOR(IREF+2)-XP(2) 301 : XU(3)=0.D0 302 : IF (IDIM.EQ.3) XU(3)=XCOOR(IREF+3)-XP(3) 303 : SCA=(XU(1)*XV(1)+XU(2)*XV(2)+XU(3)*XV(3))*RAP 304 : DO j=1,IDIM 305 : XCOOR(IREF+j)=XP(j)+XU(j)+SCA*XV(j) 306 : ENDDO 307 : ENDIF 308 : ENDDO 309 : GOTO 1000 310 : 311 : C Option SYME : 312 : C --------------- 312 : 600 CALL LIRMOT(MCL2,3,JCLE,1) 313 : IF (IERR.NE.0) GOTO 10000 314 : IF ((IDIM.EQ.1).AND.(JCLE.NE.1)) THEN 315 : MOTERR(1:4)=MCL2(JCLE) 316 : INTERR(1)=IDIM 316 : CALL ERREUR(971) 317 : GOTO 10000 318 : ENDIF 319 : GOTO (610,620,630),JCLE 320 : 321 : C Option SYME POIN : 322 : C -------------------- 322 : 610 CALL LIROBJ('POINT',IP,1,IRETOU) 323 : IF (IERR.NE.0) GOTO 10000 324 : IREF=idimp1*(IP-1) 325 : DO j=1,IDIM 326 : XP(j)=2*XCOOR(IREF+j) 327 : ENDDO 328 : DO i=1,ICPR(/1) 329 : IF (ICPR(i).NE.0) THEN 330 : IREF=idimp1*(i-1) 331 : DO j=1,IDIM 332 : XCOOR(IREF+j)=XP(j)-XCOOR(IREF+j) 333 : ENDDO 334 : ENDIF 335 : ENDDO 336 : GOTO 1000 337 : 338 : C Option SYME DROI : 339 : C -------------------- 339 : 620 CALL LIROBJ('POINT',IP1,1,IRETOU) 339 : CALL LIROBJ('POINT',IP2,1,IRETOU) 340 : IF (IERR.NE.0) GOTO 10000 341 : IREF=idimp1*(IP1-1) 342 : XP(1)=XCOOR(IREF+1) 343 : XP(2)=XCOOR(IREF+2) 344 : XP(3)=0.D0 345 : IF (IDIM.EQ.3) XP(3)=XCOOR(IREF+3) 346 : IREF=idimp1*(IP2-1) 347 : XU(1)=XCOOR(IREF+1)-XP(1) 348 : XU(2)=XCOOR(IREF+2)-XP(2) 349 : XU(3)=0.D0 350 : IF (IDIM.EQ.3) XU(3)=XCOOR(IREF+3)-XP(3) 351 : XN=XU(1)**2+XU(2)**2+XU(3)**2 351 : IF (XN.EQ.0.D0) CALL ERREUR(21) 352 : IF (IERR.NE.0) GOTO 10000 353 : XN=SQRT(XN) 354 : XU(1)=XU(1)/XN 355 : XU(2)=XU(2)/XN 356 : XU(3)=XU(3)/XN 357 : DO i=1,ICPR(/1) 358 : IF (ICPR(i).NE.0) THEN 359 : IREF=idimp1*(i-1) 360 : XV(1)=XCOOR(IREF+1)-XP(1) 361 : XV(2)=XCOOR(IREF+2)-XP(2) 362 : XV(3)=0.D0 363 : IF (IDIM.GE.3) XV(3)=XCOOR(IREF+3)-XP(3) 364 : SCA=2*(XU(1)*XV(1)+XU(2)*XV(2)+XU(3)*XV(3)) 365 : DO j=1,IDIM 366 : XCOOR(IREF+j)=XP(j)+SCA*XU(j)-XV(j) 367 : ENDDO 368 : ENDIF 369 : ENDDO 370 : GOTO 1000 371 : 372 : C Option SYME PLAN : 373 : C -------------------- 373 : 630 IF (IDIM.EQ.2) CALL ERREUR(21) 374 : IF (IERR.NE.0) GOTO 10000 374 : CALL LIROBJ('POINT',IP1,1,IRETOU) 374 : CALL LIROBJ('POINT',IP2,1,IRETOU) 374 : CALL LIROBJ('POINT',IP3,1,IRETOU) 375 : IF (IERR.NE.0) GOTO 10000 376 : IREF=idimp1*(IP1-1) 377 : XP(1)=XCOOR(IREF+1) 378 : XP(2)=XCOOR(IREF+2) 379 : XP(3)=XCOOR(IREF+3) 380 : IREF=idimp1*(IP2-1) 381 : XU(1)=XCOOR(IREF+1)-XP(1) 382 : XU(2)=XCOOR(IREF+2)-XP(2) 383 : XU(3)=XCOOR(IREF+3)-XP(3) 384 : IREF=idimp1*(IP3-1) 385 : XV(1)=XCOOR(IREF+1)-XP(1) 386 : XV(2)=XCOOR(IREF+2)-XP(2) 387 : XV(3)=XCOOR(IREF+3)-XP(3) 388 : XW(1)=XU(2)*XV(3)-XU(3)*XV(2) 389 : XW(2)=XU(3)*XV(1)-XU(1)*XV(3) 390 : XW(3)=XU(1)*XV(2)-XU(2)*XV(1) 391 : XN=XW(1)**2+XW(2)**2+XW(3)**2 391 : IF (XN.EQ.0.D0) CALL ERREUR(21) 392 : IF (IERR.NE.0) GOTO 10000 393 : XN=SQRT(XN) 394 : XW(1)=XW(1)/XN 395 : XW(2)=XW(2)/XN 396 : XW(3)=XW(3)/XN 397 : DO i=1,ICPR(/1) 398 : IF (ICPR(i).NE.0) THEN 399 : IREF=idimp1*(i-1) 400 : XU(1)=XCOOR(IREF+1)-XP(1) 401 : XU(2)=XCOOR(IREF+2)-XP(2) 402 : XU(3)=XCOOR(IREF+3)-XP(3) 403 : SCA=2*(XU(1)*XW(1)+XU(2)*XW(2)+XU(3)*XW(3)) 404 : XCOOR(IREF+1)=XP(1)+XU(1)-SCA*XW(1) 405 : XCOOR(IREF+2)=XP(2)+XU(2)-SCA*XW(2) 406 : XCOOR(IREF+3)=XP(3)+XU(3)-SCA*XW(3) 407 : ENDIF 408 : ENDDO 409 : GOTO 1000 410 : 411 : C Option SYME PROJ : 412 : C -------------------- 412 : 700 CALL LIRMOT(MCL4,2,ITYYP,0) 413 : C Lecture du vecteur de projection ou du centre (projection conique) 413 : CALL LIROBJ('POINT',IP1,1,IRETOU) 414 : IF (IERR.NE.0) GOTO 10000 415 : IREF=idimp1*(IP1-1) 416 : XVECS=XCOOR(IREF+1) 417 : YVECS=XCOOR(IREF+2) 418 : ZVECS=0.D0 419 : IF (IDIM.GE.3) ZVECS=XCOOR(IREF+3) 420 : ICARR=1 421 : IF (ITYYP.NE.0) ICARR=0 421 : CALL LIRMOT(MCL3,7,JCLE,ICARR) 422 : IF (IERR.NE.0) GOTO 10000 423 : IF (JCLE.EQ.0) THEN 424 : JCLE=ITYYP+2 425 : ITYYP=0 426 : ENDIF 426 : IF ((IDIM.EQ.2).AND.(JCLE.LE.5)) CALL ERREUR(34) 426 : IF ((IDIM.EQ.3).AND.(JCLE.GE.6)) CALL ERREUR(34) 427 : IF (IERR.NE.0) GOTO 10000 428 : C Projection cylindrique normalisation du vecteur 429 : IF (ITYYP.NE.2) THEN 430 : SVECS=SQRT(XVECS*XVECS+YVECS*YVECS+ZVECS*ZVECS) 430 : IF (SVECS.EQ.0.D0) CALL ERREUR(21) 431 : IF (IERR.NE.0) GOTO 10000 432 : XVEC=XVECS/SVECS 433 : YVEC=YVECS/SVECS 434 : ZVEC=ZVECS/SVECS 435 : ENDIF 436 : GOTO (710,720,730,740,750,760,770),JCLE 437 : 438 : C Option PROJ PLAN : 439 : C -------------------- 439 : 710 CALL LIROBJ('POINT',IP1,1,IRETOU) 439 : CALL LIROBJ('POINT',IP2,1,IRETOU) 439 : CALL LIROBJ('POINT',IP3,1,IRETOU) 440 : IF (IERR.NE.0) GOTO 10000 441 : IREF=idimp1*(IP1-1) 442 : XPT1=XCOOR(IREF+1) 443 : YPT1=XCOOR(IREF+2) 444 : ZPT1=XCOOR(IREF+3) 445 : IREF=idimp1*(IP2-1) 446 : XV2=XCOOR(IREF+1)-XPT1 447 : YV2=XCOOR(IREF+2)-YPT1 448 : ZV2=XCOOR(IREF+3)-ZPT1 449 : IREF=idimp1*(IP3-1) 450 : XV3=XCOOR(IREF+1)-XPT1 451 : YV3=XCOOR(IREF+2)-YPT1 452 : ZV3=XCOOR(IREF+3)-ZPT1 453 : XV1=YV2*ZV3-ZV2*YV3 454 : YV1=ZV2*XV3-XV2*ZV3 455 : ZV1=XV2*YV3-YV2*XV3 456 : SV1=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1) 456 : IF (SV1.EQ.0.D0) CALL ERREUR(21) 457 : IF (IERR.NE.0) GOTO 10000 458 : XV1=XV1/SV1 459 : YV1=YV1/SV1 460 : ZV1=ZV1/SV1 461 : GOTO 780 462 : 463 : C Option PROJ SPHE : 464 : C -------------------- 464 : 720 CALL LIROBJ('POINT',IPCEN,1,IRETOU) 464 : CALL LIROBJ('POINT',IP1,1,IRETOU) 465 : IF (IERR.NE.0) GOTO 10000 466 : IREF=(IPCEN-1)*idimp1 467 : XPT1=XCOOR(IREF+1) 468 : YPT1=XCOOR(IREF+2) 469 : ZPT1=XCOOR(IREF+3) 470 : IREF=(IP1-1)*idimp1 471 : XV1=XCOOR(IREF+1)-XPT1 472 : YV1=XCOOR(IREF+2)-YPT1 473 : ZV1=XCOOR(IREF+3)-ZPT1 474 : ANGLE=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1) 474 : IF (ANGLE.EQ.0.D0) CALL ERREUR(21) 475 : IF (IERR.NE.0) GOTO 10000 476 : GOTO 780 477 : 478 : C Option PROJ CYLI : 479 : C -------------------- 479 : 730 CALL LIROBJ('POINT',IPOIN1,1,IRETOU) 479 : CALL LIROBJ('POINT',IPOIN2,1,IRETOU) 479 : CALL LIROBJ('POINT',IP1,1,IRETOU) 480 : IF (IERR.NE.0) GOTO 10000 481 : IREF=(IPOIN1-1)*idimp1 482 : XPT1=XCOOR(IREF+1) 483 : YPT1=XCOOR(IREF+2) 484 : ZPT1=XCOOR(IREF+3) 485 : IREF=(IPOIN2-1)*idimp1 486 : XV1=XCOOR(IREF+1)-XPT1 487 : YV1=XCOOR(IREF+2)-YPT1 488 : ZV1=XCOOR(IREF+3)-ZPT1 489 : S=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1) 489 : IF (S.EQ.0.D0) CALL ERREUR(21) 490 : IF (IERR.NE.0) GOTO 10000 491 : XV1=XV1/S 492 : YV1=YV1/S 493 : ZV1=ZV1/S 494 : IREF=(IP1-1)*idimp1 495 : XV2=XCOOR(IREF+1)-XPT1 496 : YV2=XCOOR(IREF+2)-YPT1 497 : ZV2=XCOOR(IREF+3)-ZPT1 498 : XV3=YV1*ZV2-ZV1*YV2 499 : YV3=ZV1*XV2-XV1*ZV2 500 : ZV3=XV1*YV2-YV1*XV2 501 : ANGLE=SQRT(XV3*XV3+YV3*YV3+ZV3*ZV3) 501 : IF (ANGLE.EQ.0) CALL ERREUR(21) 502 : IF (IERR.NE.0) RETURN 503 : GOTO 780 504 : 505 : C Option PROJ CONI : 506 : C -------------------- 506 : 740 CALL LIROBJ('POINT',IPT1,1,IRETOU) 506 : CALL LIROBJ('POINT',IP1,1,IRETOU) 506 : CALL LIROBJ('POINT',IP2,1,IRETOU) 507 : IF (IERR.NE.0) GOTO 10000 508 : IREF=(IPT1-1)*idimp1 509 : XPT1=XCOOR(IREF+1) 510 : YPT1=XCOOR(IREF+2) 511 : ZPT1=XCOOR(IREF+3) 512 : IREF=(IP1-1)*idimp1 513 : XV1=XCOOR(IREF+1)-XPT1 514 : YV1=XCOOR(IREF+2)-YPT1 515 : ZV1=XCOOR(IREF+3)-ZPT1 516 : SV1=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1) 516 : IF (SV1.EQ.0.D0) CALL ERREUR(21) 517 : IF (IERR.NE.0) GOTO 10000 518 : XV1=XV1/SV1 519 : YV1=YV1/SV1 520 : ZV1=ZV1/SV1 521 : IREF=(IP2-1)*idimp1 522 : XV2=XCOOR(IREF+1)-XPT1 523 : YV2=XCOOR(IREF+2)-YPT1 524 : ZV2=XCOOR(IREF+3)-ZPT1 525 : SV2=SQRT(XV2*XV2+YV2*YV2+ZV2*ZV2) 525 : IF (SV2.EQ.0.D0) CALL ERREUR(21) 526 : IF (IERR.NE.0) GOTO 10000 527 : XV2=XV2/SV2 528 : YV2=YV2/SV2 529 : ZV2=ZV2/SV2 530 : ANGLE=(XV1*XV2+YV1*YV2+ZV1*ZV2)**2 531 : GOTO 780 532 : 533 : C Option PROJ TORI 534 : C ------------------ 534 : 750 CALL LIROBJ('POINT',IPT1,1,IRETOU) 534 : CALL LIROBJ('POINT',IPAX,1,IRETOU) 534 : CALL LIROBJ('POINT',IPCS,1,IRETOU) 534 : CALL LIROBJ('POINT',IP1 ,1,IRETOU) 535 : IF (IERR.NE.0) GOTO 10000 536 : IREF=(IPT1-1)*idimp1 537 : XPT1=XCOOR(IREF+1) 538 : YPT1=XCOOR(IREF+2) 539 : ZPT1=XCOOR(IREF+3) 540 : IREF=(IPAX-1)*idimp1 541 : XV1=XCOOR(IREF+1)-XPT1 542 : YV1=XCOOR(IREF+2)-YPT1 543 : ZV1=XCOOR(IREF+3)-ZPT1 544 : SV1=XV1*XV1+YV1*YV1+ZV1*ZV1 544 : IF (SV1.EQ.0.D0) CALL ERREUR(21) 545 : IF (IERR.NE.0) GOTO 10000 546 : SV1=SQRT(SV1) 547 : XV1=XV1/SV1 548 : YV1=YV1/SV1 549 : ZV1=ZV1/SV1 550 : IREF=(IPCS-1)*idimp1 551 : XV2=XCOOR(IREF+1)-XPT1 552 : YV2=XCOOR(IREF+2)-YPT1 553 : ZV2=XCOOR(IREF+3)-ZPT1 554 : SCA=XV2*XV1+YV2*YV1+ZV2*ZV1 555 : XPT1=XPT1+SCA*XV1 556 : YPT1=YPT1+SCA*YV1 557 : ZPT1=ZPT1+SCA*ZV1 558 : XV2=XV2-SCA*XV1 559 : YV2=YV2-SCA*YV1 560 : ZV2=ZV2-SCA*ZV1 561 : GR2=XV2*XV2+YV2*YV2+ZV2*ZV2 561 : IF (GR2.EQ.0.D0) CALL ERREUR(21) 562 : IF (IERR.NE.0) GOTO 10000 563 : IREF=(IP1-1)*idimp1 564 : XV2=XCOOR(IREF+1)-XPT1 565 : YV2=XCOOR(IREF+2)-YPT1 566 : ZV2=XCOOR(IREF+3)-ZPT1 567 : SCA=XV2*XV1+YV2*YV1+ZV2*ZV1 568 : XC=XV2-SCA*XV1 569 : YC=YV2-SCA*YV1 570 : ZC=ZV2-SCA*ZV1 571 : SC=XC*XC+YC*YC+ZC*ZC 571 : IF (SC.EQ.0.D0) CALL ERREUR(21) 572 : IF (IERR.NE.0) GOTO 10000 573 : RAP=SQRT(GR2/SC) 574 : XC=XC*RAP 575 : YC=YC*RAP 576 : ZC=ZC*RAP 577 : PR2=(XV2-XC)**2+(YV2-YC)**2+(ZV2-ZC)**2 577 : IF (PR2.EQ.0.D0) CALL ERREUR(21) 578 : IF (IERR.NE.0) GOTO 10000 579 : XV2=PR2 580 : YV2=GR2 581 : GOTO 780 582 : 583 : C Option PROJ DROI : 584 : C -------------------- 584 : 760 CALL LIROBJ('POINT',IP1,1,IRETOU) 584 : CALL LIROBJ('POINT',IP2,1,IRETOU) 585 : IF (IERR.NE.0) GOTO 10000 586 : IREF=(IP1-1)*idimp1 587 : XPT1=XCOOR(IREF+1) 588 : YPT1=XCOOR(IREF+2) 589 : ZPT1=0.D0 590 : IREF=(IP2-1)*idimp1 591 : XV2=XCOOR(IREF+1)-XPT1 592 : YV2=XCOOR(IREF+2)-YPT1 593 : ZV2=0.D0 594 : XV3=0.D0 595 : YV3=0.D0 596 : ZV3=1.D0 597 : XV1=YV2*ZV3-ZV2*YV3 598 : YV1=ZV2*XV3-XV2*ZV3 599 : ZV1=XV2*YV3-YV2*XV3 600 : SV1=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1) 600 : IF (SV1.EQ.0.D0) CALL ERREUR(21) 601 : IF (IERR.NE.0) GOTO 10000 602 : XV1=XV1/SV1 603 : YV1=YV1/SV1 604 : ZV1=ZV1/SV1 605 : GOTO 780 606 : 607 : C Option PROJ CERC : 608 : C -------------------- 608 : 770 CALL LIROBJ('POINT',IPCEN,1,IRETOU) 608 : CALL LIROBJ('POINT',IP1,1,IRETOU) 609 : IF (IERR.NE.0) GOTO 10000 610 : IREF=(IPCEN-1)*idimp1 611 : XPT1=XCOOR(IREF+1) 612 : YPT1=XCOOR(IREF+2) 613 : ZPT1=0.D0 614 : IREF=(IP1-1)*idimp1 615 : XV1=XCOOR(IREF+1)-XPT1 616 : YV1=XCOOR(IREF+2)-YPT1 617 : ZV1=0.D0 618 : ANGLE=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1) 618 : IF (ANGLE.EQ.0.D0) CALL ERREUR(21) 619 : IF (IERR.NE.0) GOTO 10000 620 : GOTO 780 621 : C Traitement commun - Options PROJ 622 : 780 DO i=1,ICPR(/1) 623 : IF (ICPR(i).NE.0) THEN 624 : IREF=(i-1)*idimp1 625 : XPOIN=XCOOR(IREF+1) 626 : YPOIN=XCOOR(IREF+2) 627 : ZPOIN=0.D0 628 : IF (IDIM.GE.3) ZPOIN=XCOOR(IREF+3) 629 : IF (ITYYP.EQ.2) THEN 630 : XVEC=XVECS-XPOIN 631 : YVEC=YVECS-YPOIN 632 : ZVEC=ZVECS-ZPOIN 633 : SVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC) 633 : IF (SVEC.EQ.0.D0) CALL ERREUR(21) 634 : IF (IERR.NE.0) RETURN 635 : XVEC=XVEC/SVEC 636 : YVEC=YVEC/SVEC 637 : ZVEC=ZVEC/SVEC 638 : ENDIF 639 : GOTO (810,820,830,840,850,860,870),JCLE 640 : C Option PROJ PLAN 641 : 810 XV2=XPOIN-XPT1 642 : YV2=YPOIN-YPT1 643 : ZV2=ZPOIN-ZPT1 644 : DENUM=XV2*XV1+YV2*YV1+ZV2*ZV1 645 : DENOM=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 645 : IF (DENOM.EQ.0.D0) CALL ERREUR(21) 646 : IF (IERR.NE.0) GOTO 10000 647 : RAP=-DENUM/DENOM 648 : XPOIN=XPOIN+RAP*XVEC 649 : YPOIN=YPOIN+RAP*YVEC 650 : ZPOIN=ZPOIN+RAP*ZVEC 651 : GOTO 880 652 : C Option PROJ SPHE 653 : 820 XV1=XPT1-XPOIN 654 : YV1=YPT1-YPOIN 655 : ZV1=ZPT1-ZPOIN 656 : SCA=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 657 : XV1=XVEC*SCA 658 : YV1=YVEC*SCA 659 : ZV1=ZVEC*SCA 660 : S2=(XPOIN+XV1-XPT1)**2+(YPOIN+YV1-YPT1)**2+(ZPOIN+ZV1-ZPT1)**2 660 : IF (S2.GT.(ANGLE*ANGLE)) CALL ERREUR(21) 661 : IF (IERR.NE.0) GOTO 10000 662 : C=SQRT(ANGLE*ANGLE-S2) 663 : IF (SCA.LT.0.D0) C=-C 664 : XPOIN=XPOIN+XV1-C*XVEC 665 : YPOIN=YPOIN+YV1-C*YVEC 666 : ZPOIN=ZPOIN+ZV1-C*ZVEC 667 : GOTO 880 668 : C Option PROJ CYLI 669 : 830 XV2=YVEC*ZV1-ZVEC*YV1 670 : YV2=ZVEC*XV1-XVEC*ZV1 671 : ZV2=XVEC*YV1-YVEC*XV1 672 : S2V2=XV2*XV2+YV2*YV2+ZV2*ZV2 672 : IF (S2V2.EQ.0.D0) CALL ERREUR(21) 673 : IF (IERR.NE.0) GOTO 10000 674 : C2=(XVEC*XV1+YVEC*YV1+ZVEC*ZV1)**2 674 : IF (C2.EQ.1.D0) CALL ERREUR(21) 675 : IF (IERR.NE.0) GOTO 10000 676 : XV3=XPT1-XPOIN 677 : YV3=YPT1-YPOIN 678 : ZV3=ZPT1-ZPOIN 679 : XV4=YV3*ZV1-ZV3*YV1 680 : YV4=ZV3*XV1-XV3*ZV1 681 : ZV4=XV3*YV1-YV3*XV1 682 : DNUM=(XV4*XVEC+YV4*YVEC+ZV4*ZVEC)**2 683 : DIS2=DNUM/S2V2 683 : IF (DIS2.GT.ANGLE**2) CALL ERREUR(21) 684 : IF (IERR.NE.0) GOTO 10000 685 : DMU=SQRT((ANGLE**2-DIS2)/(1.D0-C2)) 686 : DNUM=XV2*XV4+YV2*YV4+ZV2*ZV4 687 : DLA=DNUM/S2V2 688 : DMU=SIGN(DMU,DLA) 689 : XPOIN=XPOIN+XVEC*(DLA-DMU) 690 : YPOIN=YPOIN+YVEC*(DLA-DMU) 691 : ZPOIN=ZPOIN+ZVEC*(DLA-DMU) 692 : GOTO 880 693 : C Option PROJ CONI 694 : 840 XV2=XPOIN-XPT1 695 : YV2=YPOIN-YPT1 696 : ZV2=ZPOIN-ZPT1 697 : VECV1=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 698 : VEC2=XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC 699 : V2V1=XV2*XV1+YV2*YV1+ZV2*ZV1 700 : VECV2=XVEC*XV2+YVEC*YV2+ZVEC*ZV2 701 : V22=XV2*XV2+YV2*YV2+ZV2*ZV2 702 : A=VECV1*VECV1-ANGLE*VEC2 703 : B=2*(V2V1*VECV1-ANGLE*VECV2) 704 : C=V2V1*V2V1-ANGLE*V22 705 : DELTA=B*B-4*A*C 705 : IF (DELTA.LT.0.D0) CALL ERREUR(21) 706 : IF (IERR.NE.0) GOTO 10000 707 : DEL=SQRT(DELTA) 708 : X1=(-B+DEL)/(2*A) 709 : X2=(-B-DEL)/(2*A) 710 : X=X2 711 : IF (ABS(X1).LT.ABS(X2)) X=X1 712 : XPOIN=XPOIN+X*XVEC 713 : YPOIN=YPOIN+X*YVEC 714 : ZPOIN=ZPOIN+X*ZVEC 715 : GOTO 880 716 : C Option PROJ TORI 717 : 850 PR2=XV2 718 : GR2=YV2 719 : XOP=XPOIN-XPT1 720 : YOP=YPOIN-YPT1 721 : ZOP=ZPOIN-ZPT1 722 : OPV=XOP*XVEC+YOP*YVEC+ZOP*ZVEC 723 : R2=XOP*XOP+YOP*YOP+ZOP*ZOP-GR2-PR2 724 : VA=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 725 : QR2VA2=4*GR2*VA*VA 726 : OPA=XOP*XV1+YOP*YV1+ZOP*ZV1 727 : HR2PV=8*GR2*OPA*VA 728 : R=4*GR2*OPA*OPA-4*PR2*GR2 729 : RLMD=0.D0 730 : C Resolution de l'equation du 4eme degre par iteration 731 : DO iter=1,25 732 : EXP1=RLMD*(RLMD+2*OPV)+R2 733 : FDLM=EXP1*EXP1+QR2VA2*RLMD*RLMD+HR2PV*RLMD+R 734 : FPDLM=4*EXP1*(RLMD+OPV)+QR2VA2*2*RLMD+HR2PV 734 : IF (FPDLM.EQ.0.D0) CALL ERREUR(40) 735 : IF (IERR.NE.0) GOTO 10000 736 : CORR=FDLM/FPDLM 737 : RLMD=RLMD-CORR 738 : IF ((RLMD.NE.0.D0).AND.(ABS(CORR/RLMD).LT.1E-5)) GOTO 851 739 : ENDDO 739 : CALL ERREUR(40) 740 : GOTO 10000 741 : 851 XPOIN=XPOIN+RLMD*XVEC 742 : YPOIN=YPOIN+RLMD*YVEC 743 : ZPOIN=ZPOIN+RLMD*ZVEC 744 : GOTO 880 745 : C Option PROJ DROI 746 : 860 XV2=XPOIN-XPT1 747 : YV2=YPOIN-YPT1 748 : ZV2=0.D0 749 : DENUM=XV2*XV1+YV2*YV1+ZV2*ZV1 750 : DENOM=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 750 : IF (DENOM.EQ.0.D0) CALL ERREUR(21) 751 : IF (IERR.NE.0) GOTO 10000 752 : RAP=-DENUM/DENOM 753 : XPOIN=XPOIN+RAP*XVEC 754 : YPOIN=YPOIN+RAP*YVEC 755 : ZPOIN=ZPOIN+RAP*ZVEC 756 : GOTO 880 757 : C Option PROJ CERC 758 : 870 XV1=XPT1-XPOIN 759 : YV1=YPT1-YPOIN 760 : ZV1=0.D0 761 : SCA=XVEC*XV1+YVEC*YV1+ZVEC*ZV1 762 : XV1=XVEC*SCA 763 : YV1=YVEC*SCA 764 : ZV1=ZVEC*SCA 765 : S2=(XPOIN+XV1-XPT1)**2+(YPOIN+YV1-YPT1)**2+(ZPOIN+ZV1-ZPT1)**2 765 : IF (S2.GT.ANGLE**2) CALL ERREUR(21) 766 : IF (IERR.NE.0) GOTO 10000 767 : C=SQRT(ANGLE*ANGLE-S2) 768 : IF (SCA.LT.0.D0) C=-C 769 : XPOIN=XPOIN+XV1-C*XVEC 770 : YPOIN=YPOIN+YV1-C*YVEC 771 : ZPOIN=ZPOIN+ZV1-C*ZVEC 772 : GOTO 880 773 : C Traitement commun des options 774 : 880 XCOOR(IREF+1)=XPOIN 775 : XCOOR(IREF+2)=YPOIN 776 : IF (IDIM.EQ.3) XCOOR(IREF+3)=ZPOIN 777 : ENDIF 778 : ENDDO 779 : GOTO 1000 780 : 781 : C Option COOR : Changement de systeme de coordonnees 782 : C --------------- 782 : 1800 CALL LIRMOT(MCL5,2,ICYLI,1) 783 : IF (IERR.NE.0) GOTO 10000 784 : IF (ICYLI.EQ.1) THEN 784 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 785 : IF (IERR.NE.0) GO TO 10000 785 : CALL LIROBJ('POINT ',IP2,1,IRETOU) 786 : IF (IERR.NE.0) GO TO 10000 786 : IF (IDIM.EQ.3) CALL LIROBJ('POINT ',IP3,1,IRETOU) 787 : IF (IERR.NE.0) GO TO 10000 788 : ENDIF 789 : C Transformation des coordonnees cartesiennes en cylindriques 790 : IF (ICYLI.EQ.1) THEN 791 : IREF=(IP1-1)*idimp1 792 : XP11=XCOOR(IREF+1) 793 : XP12=XCOOR(IREF+2) 794 : XP13=0.D0 795 : IF (IDIM.EQ.3) XP13=XCOOR(IREF+3) 796 : IREF=(IP2-1)*idimp1 797 : XP21=XCOOR(IREF+1)-XP11 798 : XP22=XCOOR(IREF+2)-XP12 799 : XP23=0.D0 800 : IF(IDIM.EQ.3) XP23 = XCOOR(IREF+3)-XP13 801 : XL=SQRT(XP21*XP21+XP22*XP22+XP23*XP23) 802 : IF (XL.EQ.0.D0) THEN 802 : CALL ERREUR(21) 803 : GOTO 10000 804 : ENDIF 805 : XP21=XP21/XL 806 : XP22=XP22/XL 807 : YP21=-XP22 808 : YP22=XP21 809 : YP23=0.D0 810 : IF (IDIM.EQ.3) THEN 811 : XP23=XP23/XL 812 : XP31=XP21 813 : XP32=XP22 814 : XP33=XP23 815 : IREF=(IP3-1)*idimp1 816 : XP21=XCOOR(IREF+1)-XP11 817 : XP22=XCOOR(IREF+2)-XP12 818 : XP23=XCOOR(IREF+3)-XP13 819 : XXX=XP21*XP31+XP22*XP32+XP23*XP33 820 : XP21=XP21-XXX*XP31 821 : XP22=XP22-XXX*XP32 822 : XP23=XP23-XXX*XP33 823 : XL=SQRT(XP21*XP21+XP22*XP22+XP23*XP23) 824 : IF (XL.EQ.0.D0) THEN 824 : CALL ERREUR(21) 825 : GOTO 10000 826 : ENDIF 827 : XP21=XP21/XL 828 : XP22=XP22/XL 829 : XP23=XP23/XL 830 : YP21=XP32*XP23-XP33*XP22 831 : YP22=XP33*XP21-XP31*XP23 832 : YP23=XP31*XP22-XP32*XP21 833 : ENDIF 834 : SCA=180.D0/XPI 835 : DO i=1,ICPR(/1) 836 : IF (ICPR(i).NE.0) THEN 837 : IREF=(i-1)*idimp1 838 : XD=XCOOR(IREF+1)-XP11 839 : YD=XCOOR(IREF+2)-XP12 840 : ZD=0.D0 841 : IF (IDIM.EQ.3) THEN 842 : ZD=XCOOR(IREF+3)-XP13 843 : ZF=XD*XP31+YD*XP32+ZD*XP33 844 : XD=XD-ZF*XP31 845 : YD=YD-ZF*XP32 846 : ZD=ZD-ZF*XP33 847 : ENDIF 848 : XA=XD*XP21+YD*XP22+ZD*XP23 849 : YA=XD*YP21+YD*YP22+ZD*YP23 850 : RHO=SQRT(XA*XA+YA*YA) 851 : TETA=ATAN2(YA,XA) 852 : XCOOR(IREF+1)=RHO 853 : XCOOR(IREF+2)=TETA*SCA 854 : IF (IDIM.EQ.3) XCOOR(IREF+3)=ZF 855 : ENDIF 856 : ENDDO 857 : C Transformation des coordonnees cylindriques en cartesiennes 858 : C L'axe X est conserve, ainsi que l'axe Z. 859 : ELSE IF (ICYLI.EQ.2) THEN 860 : SCA=XPI/180.D0 861 : DO i=1,ICPR(/1) 862 : IF (ICPR(I).NE.0) THEN 863 : IREF=(i-1)*idimp1 864 : XD=XCOOR(IREF+1) 865 : YD=XCOOR(IREF+2)*SCA 866 : XCOOR(IREF+1)=XD*COS(YD) 867 : XCOOR(IREF+2)=XD*SIN(YD) 868 : ENDIF 869 : ENDDO 870 : ENDIF 871 : GOTO 1000 872 : 873 : C Fin normale de l'operateur - Ecriture des objets (ICLE = 1 a 8) 874 : C ----------------------------------------------------------------- 875 : 1000 SEGSUP ICPR 875 : IF (ITYPLU.EQ.1) CALL ECROBJ('POINT',ITYPSA) 875 : IF (ITYPLU.EQ.2) CALL ECROBJ('MAILLAGE',ITYPSA) 876 : RETURN 877 : 878 : C Option MILI : 879 : C --------------- 880 : 1900 IF (IDIM.GE.2) THEN 880 : CALL ECROBJ('MAILLAGE',MELEME) 880 : CALL CHANLG 880 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 881 : IF (IERR.NE.0) RETURN 882 : ENDIF 883 : SEGACT MELEME 884 : IPT1=MELEME 885 : INSO=LISOUS(/1) 886 : DO j=1,MAX(1,INSO) 887 : IF (INSO.NE.0) THEN 888 : IPT1=LISOUS(j) 889 : SEGACT IPT1 890 : ENDIF 891 : IF (IPT1.ITYPEL.EQ.3) THEN 892 : DO i=1,IPT1.NUM(/2) 893 : IRef1=idimp1*(IPT1.NUM(1,i)-1) 894 : IRef2=idimp1*(IPT1.NUM(3,i)-1) 895 : IRef3=idimp1*(IPT1.NUM(2,i)-1) 896 : X1=XCOOR(IRef1+1) 897 : X2=XCOOR(IRef2+1) 898 : X3=XCOOR(IRef3+1) 899 : X2X1=X2-X1 900 : X3M=(X2+X1)*0.5-X3 901 : XNUM=X2X1*X3M 902 : XDEN=X2X1*X2X1 903 : IF (IDIM.GE.2) THEN 904 : Y1=XCOOR(IRef1+2) 905 : Y2=XCOOR(IRef2+2) 906 : Y3=XCOOR(IRef3+2) 907 : Y2Y1=Y2-Y1 908 : Y3M=(Y2+Y1)*0.5-Y3 909 : XNUM=XNUM+Y2Y1*Y3M 910 : XDEN=XDEN+Y2Y1*Y2Y1 911 : IF (IDIM.GE.3) THEN 912 : Z1=XCOOR(IRef1+3) 913 : Z2=XCOOR(IRef2+3) 914 : Z3=XCOOR(IRef3+3) 915 : Z2Z1=Z2-Z1 916 : Z3M=(Z2+Z1)*0.5-Z3 917 : XNUM=XNUM+Z2Z1*Z3M 918 : XDEN=XDEN+Z2Z1*Z2Z1 919 : ENDIF 920 : ENDIF 921 : IF (XDEN.LT.1.D-20) THEN 922 : wrITE (6,*) 'noeud double ' , IPT1.NUM(1,i) 923 : xnum = 0.D0 924 : xden = 1.D0 925 : c RETURN 926 : endif 927 : XLAMBD=XNUM/XDEN 928 : XCOOR(IRef3+1)=X3+XLAMBD*X2X1 929 : IF (IDIM.GE.2) THEN 930 : XCOOR(IRef3+2)=Y3+XLAMBD*Y2Y1 931 : IF (IDIM.GE.3) THEN 932 : XCOOR(IRef3+3)=Z3+XLAMBD*Z2Z1 933 : ENDIF 934 : ENDIF 935 : ENDDO 936 : ENDIF 937 : SEGDES IPT1 938 : ENDDO 939 : SEGDES MELEME 940 : RETURN 941 : 942 : C Traitement des erreurs (options ICLE = 1 a 8) 943 : C ----------------------------------------------- 944 : 10000 SEGSUP ICPR 945 : RETURN 946 : 947 : END 948 : 949 : 950 : 951 : 952 : 953 : 954 : 955 : 956 :
© Cast3M 2003 - All rights reserved.
Disclaimer