C AFFINI SOURCE SP204843 24/03/15 21:15:02 11871 C Ce sous-programme prepare l'affinite d'un objet C 10/2003 : cas IDIM=1, operateur indisponible SUBROUTINE AFFINI IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMELEME C Segment NON utilise : SEGMENT ICPR(nbpts) COMMON / CTOURN / XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2, . XVEC,YVEC,ZVEC,ANGLE,ICLE,XP1,YP1,ZP1 IF (IDIM.EQ.1) THEN INTERR(1)=IDIM CALL ERREUR(709) RETURN ENDIF ICLE=4 C Lecture du rapport de l'affinite CALL MESLIR(-130) CALL LIRREE(XXX,1,IRETOU) ANGLE=XXX IF (ANGLE.EQ.0.) CALL ERREUR(21) IF (IERR.NE.0) RETURN C Lecture d'un maillage, sinon lecture d'un point ICAS=1 CALL MESLIR(-131) CALL LIROBJ('MAILLAGE',IOBJ,0,IRETOU) IF (IRETOU.NE.1) THEN ICAS=0 CALL MESLIR(-131) CALL LIROBJ('POINT ',IOBJ,1,IRETOU) ENDIF C Lecture des points definissant l'axe de l'affinite CALL MESLIR(-132) CALL LIROBJ('POINT ',IPT1,1,IRETOU) CALL MESLIR(-133) CALL LIROBJ('POINT ',IPT2,1,IRETOU) IF (IERR.NE.0) RETURN idimp1=IDIM+1 SEGACT MCOORD*mod IREF=(IPT1-1)*idimp1 XPT1=XCOOR(IREF+1) YPT1=XCOOR(IREF+2) ZPT1=0. IF (IDIM.GE.3) ZPT1=XCOOR(IREF+3) IREF=(IPT2-1)*idimp1 XPT2=XCOOR(IREF+1) YPT2=XCOOR(IREF+2) ZPT2=0. IF (IDIM.GE.3) ZPT2=XCOOR(IREF+3) XVEC=XPT2-XPT1 YVEC=YPT2-YPT1 ZVEC=ZPT2-ZPT1 DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC) IF (DVEC.EQ.0.) CALL ERREUR(21) IF (IERR.NE.0) RETURN XVEC=XVEC/DVEC YVEC=YVEC/DVEC ZVEC=ZVEC/DVEC XV1=-YVEC YV1=XVEC DV1=XV1*XV1+YV1*YV1 IF (DV1.GE.0.1) THEN ZV1=0. DV1=SQRT(DV1) XV1=XV1/DV1 YV1=YV1/DV1 ELSE XV1=0. YV1=-ZVEC ZV1=YVEC DV1=SQRT(YV1*YV1+ZV1*ZV1) YV1=YV1/DV1 ZV1=ZV1/DV1 ENDIF XV2=YVEC*ZV1-ZVEC*YV1 YV2=ZVEC*XV1-XVEC*ZV1 ZV2=XVEC*YV1-YVEC*XV1 IF (ICAS.EQ.1) THEN CALL INTOPE(IOBJ) RETURN ENDIF IREF=(IOBJ-1)*idimp1 XD=XCOOR(IREF+1)-XPT1 YD=XCOOR(IREF+2)-YPT1 ZD=0. IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1 XE=XD*XV1+YD*YV1+ZD*ZV1 YE=XD*XV2+YD*YV2+ZD*ZV2 ZE=XD*XVEC+YD*YVEC+ZD*ZVEC XD=XE YD=YE ZD=ZE*ANGLE SEGADJ MCOORD IPoin=(NBPTS-1)*idimp1 XCOOR(IPoin+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 XCOOR(IPoin+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 IF (IDIM.GE.3) XCOOR(IPoin+3)=XD*ZV1+YD*ZV2+ZD*ZVEC+ZPT1 XCOOR(IPoin+idimp1)=XCOOR(IREF+idimp1) CALL ECROBJ('POINT ',NBPTS) RETURN END