C ORIENT    SOURCE    GOUNAND   08/06/09    21:15:11     6122           
C   CET OPERATEUR ORIENTE LES ELEMENTS ORIENTABLES EN FONCTION DE XP
C     
      SUBROUTINE ORIENT(IPT1,IPT2,XP,ICLE)
*     
*   ICLE=1 ORIEN DIRE
*   ICLE=2 ORIEN POINT
*     
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-z)
      DIMENSION XP(3)
      DIMENSION XQ(3)
      LOGICAL LQUAF
-INC CCREEL
-INC SMELEME
-INC CCGEOME
-INC CCOPTIO
-INC SMCOORD
      IF (ICLE.NE.1.AND.ICLE.NE.2) CALL ERREUR(5)
      IF (ICLE.EQ.1) THEN
*  NORMALISATION DU VECTEUR
         DP=SQRT(XP(1)**2+XP(2)**2+XP(3)**2)
         IF (DP.LE.XPETIT) THEN
            CALL ERREUR(277)
            DP=1.D0
         ENDIF
         XQ(1)=XP(1)/DP
         XQ(2)=XP(2)/DP
         XQ(3)=XP(3)/DP
      ENDIF
      NBREF=IPT1.LISREF(/1)
      NBSOUS=0
      NBELEM=IPT1.NUM(/2)
      NBNN=IPT1.NUM(/1)
      ITYP=KSURF(IPT1.ITYPEL)
      IF (ITYP.NE.0.AND.ITYP.EQ.IPT1.ITYPEL) GOTO 1
* ce n'est pas des éléments de surface
* est-on en présence de cub8 (shb8)
*     
      if(ipt1.itypel.eq.14) then
         nbref=2
         segini ipt2
         nbnn=4
         nbref=0
         segini ipt3,ipt4
         ipt2.lisref(1)=ipt3
         ipt2.lisref(2)=ipt4
         ipt3.itypel=8
         ipt4.itypel=8
         ipt2.itypel=14
         idim1=idim+1
         do i=1,ipt1.num(/2)
            ia=ipt1.num(1,i) - 1
            ib=ipt1.num(5,i) - 1
            ic=ipt1.num(2,i) - 1
            id=ipt1.num(3,i) - 1
            xab=xcoor(ib*idim1+1)-xcoor(ia*idim1+1)
            yab=xcoor(ib*idim1+2)-xcoor(ia*idim1+2)
            zab=xcoor(ib*idim1+3)-xcoor(ia*idim1+3)
            xac=xcoor(ic*idim1+1)-xcoor(ia*idim1+1)
            yac=xcoor(ic*idim1+2)-xcoor(ia*idim1+2)
            zac=xcoor(ic*idim1+3)-xcoor(ia*idim1+3)
            xad=xcoor(id*idim1+1)-xcoor(ia*idim1+1)
            yad=xcoor(id*idim1+2)-xcoor(ia*idim1+2)
            zad=xcoor(id*idim1+3)-xcoor(ia*idim1+3)
            xpvec= yac*zad - zac*yad
            ypvec= zac*xad - xac*zad
            zpvec= xac*yad - yac*xad
            pmix=xpvec*xab+ypvec*yab+zpvec*zab
            isens=0
            if(pmix.ge.0.d0) isens=1
            if(icle.eq.1) then
               xsc=xab*xq(1)+yab*xq(2)+zab*xq(3)
            else
               xsc= xab*(xq(1)-xcoor(ib*idim1+1))+
     $              yab*(xq(2)-xcoor(ib*idim1+2))+
     $              zab*(xq(3)-xcoor(ib*idim1+3))
            endif
            if(xsc.ge.0.d0) then
               do j=1,8
                  ipt2.num(j,i)=ipt1.num(j,i)
               enddo
               if(isens.eq.2) then
                  iu=ipt2.num(2,i)
                  ipt2.num(2,i)=ipt2.num(4,i)
                  ipt2.num(4,i)=iu
                  iu=ipt2.num(6,i)
                  ipt2.num(6,i)=ipt2.num(8,i)
                  ipt2.num(8,i)=iu
               endif
            else
               ipt2.num(1,i)=ipt1.num(5,i)
               ipt2.num(2,i)=ipt1.num(8,i)
               ipt2.num(3,i)=ipt1.num(7,i)
               ipt2.num(4,i)=ipt1.num(6,i)
               ipt2.num(5,i)=ipt1.num(1,i)
               ipt2.num(6,i)=ipt1.num(4,i)
               ipt2.num(7,i)=ipt1.num(3,i)
               ipt2.num(8,i)=ipt1.num(2,i)
               if(isens.eq.2) then
                  iu=ipt2.num(2,i)
                  ipt2.num(2,i)=ipt2.num(4,i)
                  ipt2.num(4,i)=iu
                  iu=ipt2.num(6,i)
                  ipt2.num(6,i)=ipt2.num(8,i)
                  ipt2.num(8,i)=iu
               endif
            endif
            ipt2.icolor(i)=ipt1.icolor(i)
            ipt3.num(1,i)=ipt2.num(1,i)
            ipt3.num(2,i)=ipt2.num(2,i)
            ipt3.num(3,i)=ipt2.num(3,i)
            ipt3.num(4,i)=ipt2.num(4,i)
            ipt3.icolor(i)=ipt2.icolor(i)
            ipt4.num(1,i)=ipt2.num(5,i)
            ipt4.num(2,i)=ipt2.num(6,i)
            ipt4.num(3,i)=ipt2.num(7,i)
            ipt4.num(4,i)=ipt2.num(8,i)
            ipt4.icolor(i)=ipt2.icolor(i)
         enddo
         segdes ipt3,ipt4
         return
      endif
      IPT2=IPT1
      RETURN
*     
*  on a des vrais éléments de surfaces
*     
 1    CONTINUE
* Cas QUAF TRI7 ou QUA9
      LQUAF=(ITYP.EQ.11.OR.ITYP.EQ.7)
      SEGINI IPT2
      IPT2.ITYPEL=ITYP
      IF (NBREF.EQ.0) GOTO 3
      DO 2 I=1,NBREF
         IPT2.LISREF(I)=IPT1.LISREF(I)
 2    CONTINUE
 3    CONTINUE
      SEGACT MCOORD
      IB=NSPOS(ITYP)-1
      IS1=IBSOM(IB+1)
      IS2=IBSOM(IB+2)
      IS3=IBSOM(IB+3)


      DO 4 J=1,NBELEM
         IP1=IPT1.NUM(IS1,J)
         IP2=IPT1.NUM(IS2,J)
         IP3=IPT1.NUM(IS3,J)
         IREF1=(IDIM+1)*(IP1-1)
         IREF2=(IDIM+1)*(IP2-1)
         IREF3=(IDIM+1)*(IP3-1)
         XV1=XCOOR(IREF2+1)-XCOOR(IREF1+1)
         YV1=XCOOR(IREF2+2)-XCOOR(IREF1+2)
         ZV1=XCOOR(IREF2+3)-XCOOR(IREF1+3)
         IF (IDIM.NE.3) ZV1=0.D0
         XV2=XCOOR(IREF2+1)-XCOOR(IREF3+1)
         YV2=XCOOR(IREF2+2)-XCOOR(IREF3+2)
         ZV2=XCOOR(IREF2+3)-XCOOR(IREF3+3)
         IF (IDIM.NE.3) ZV2=0.D0
         XV3=ZV1*YV2-ZV2*YV1
         YV3=XV1*ZV2-XV2*ZV1
         ZV3=YV1*XV2-YV2*XV1
         XVN=SQRT(XV3**2+YV3**2+ZV3**2)
         IF (ICLE.EQ.2) THEN
            XQ(1)=0.D0
            XQ(2)=0.D0
            XQ(3)=0.D0
            DO 10 L=1,NBNN
               IREF=(IPT1.NUM(L,J)-1)*(IDIM+1)
               DO 11 K=1,3
                  XQ(K)=XQ(K)+XCOOR(IREF+K)
 11            CONTINUE
 10         CONTINUE
            XQ(1)=XQ(1)/NBNN
            XQ(2)=XQ(2)/NBNN
            XQ(3)=XQ(3)/NBNN
            XQ(1)=XP(1)-XQ(1)
            XQ(2)=XP(2)-XQ(2)
            XQ(3)=XP(3)-XQ(3)
            DP=SQRT(XQ(1)**2+XQ(2)**2+XQ(3)**2)
            IF (DP.LE.XPETIT) THEN
               CALL ERREUR(277)
               DP=1.D0
            ENDIF
            XQ(1)=XQ(1)/DP
            XQ(2)=XQ(2)/DP
            XQ(3)=XQ(3)/DP
         ENDIF
         TEST=XV3*XQ(1)+YV3*XQ(2)+ZV3*XQ(3)
         IF (ABS(TEST).LE.0.0175D0*XVN) CALL ERREUR(278)
         IF (TEST.GE.0.D0) THEN
            DO 6 I=1,NBNN
               IPT2.NUM(I,J)=IPT1.NUM(I,J)
 6          CONTINUE
         ELSE
            IF (.NOT.LQUAF) THEN
               DO 7 I=1,NBNN
                  IPT2.NUM(MOD(NBNN+1-I,NBNN)+1,J)=IPT1.NUM(I,J)
 7             CONTINUE
            ELSE
               NBNN1=NBNN-1
               DO 8 I=1,NBNN1
                  IPT2.NUM(MOD(NBNN1+1-I,NBNN1)+1,J)=IPT1.NUM(I,J)
 8             CONTINUE
               IPT2.NUM(NBNN,J)=IPT1.NUM(NBNN,J)
            ENDIF
         ENDIF
         IPT2.ICOLOR(J)=IPT1.ICOLOR(J)
 4    CONTINUE
      RETURN
      END