Sources Esope | Cast3M

trjtrj
C TRJTRJ    SOURCE    CHAT      05/01/13    03:51:36     5004
      SUBROUTINE TRJTRJ(Y,X,ITYP,JTYP,JFA,IFA,IOR)
C
C
C       ISSU DE TRATRA DANS TRIOEF
C     UTILISE DANS LE CALCUL DES TRAJECTOIRES AU CHANGEMENT D ELEMENT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C S      Y COORDONNEES DE REFERENCES DANS L ELEMENT D ARRIVEE
C E      X    "         "      "       "  "    "    DE DEPART
C
C E      ITYP TYPE DE L ELEMENT DE DEPART
C E      JTYP   "   "      "     D ARRIVEE
C
C E      IFA NUMERO DE LA FACE DE DEPART
C E      JFA   "     "  "   "  D  ARRIVEE
C
C E      IOR ORIENTATION DES DEUX FACES EN VIS A VIS
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C      METHODE: ON UTILISE LES RELATIONS ENTRE COORDONNEES BARYCENTRIQUES
C         ET COORDONNEES DE REFERENCES.
C         ON EXPRIME LES COORDONNEES BARYCENTRIQUE DU POINT
C         PAR RAPPORT AU SOMMETS DE LA FACE DANS CHACUN DES ELEMENTS
C         CONCERNES. ON EN DEDUIT LES COORDONNEES DE REFERENCE DANS
C         L ELEMENT D'ARRIVEE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION Y(3),X(3),X1(4),Z(4)
      DIMENSION IATRI(3,3),IJKTRI(3,3)
      DIMENSION IAQUA(4,4),IJKQUA(2,2),SQUA(2,4),ISQUA(4,4)
      DIMENSION IATQ(3,4),IJKTQ(2,4),ITQ(3,4)
      DIMENSION IAQT(4,3),IJKQT(2,4),IQT(4,3)
      DIMENSION IAPRI(4,5,5),IJKPRI(3,21),SPRI(3,8),DPRI(3,4)
      DIMENSION IDPRI(4,5,5),IPRI(4,5,5)
      DIMENSION IACUB(4,6,6),IJKCUB(3,24),SCUB(3,24),CPM(3)
      DIMENSION CPD(3),JPC(4,5,6),BCP(3,3),ACP(3,3),IBCP(4,5,6)
      DIMENSION IACP(3,12),IJKCP(4,6,5),SCP(3,8),ICP(4,6,5)
      DIMENSION IAPC(3,12),JAPC(4,5,6)
      DIMENSION ICTET4(4,24),ITTET4(3,4,4),ITET4P(3,4),IPTET4(3,4,2)
C
C
C
      DATA IATRI/3,1,2, 1,2,3, 2,3,1/
      DATA IJKTRI/1,3,2, 2,1,3, 3,2,1/
C
      DATA IAQUA / 1,2,1,2, 2,1,2,1, 1,2,1,2, 2,1,2,1/
      DATA ISQUA / 2,4,1,3, 4,1,3,2, 1,3,2,4, 3,2,4,1/
      DATA IJKQUA/1,2, 2,1/
      DATA SQUA/1.,-1., -1.,1., 1.,1., -1.,-1./
C
      DATA IAQT / 1,2,1,2, 4,3,4,3, 2,1,2,1/
      DATA IJKQT/1,2, 2,1, 2,2, 1,1/
      DATA IQT / 2,4,1,3, 1,1,2,2, 3,2,4,1/
C
      DATA IATQ / 1,4,2, 2,3,1, 1,4,2, 2,3,1 /
      DATA IJKTQ/1,2, 2,1, 3,2, 2,3/
      DATA ITQ / 2,2,3, 4,4,2, 1,1,4, 3,3,1 /
C
      DATA IJKPRI/1,4,2, 1,2,4, 1,4,3, 1,3,4,
     *            2,1,4, 2,3,4, 2,4,3, 2,4,1,
     *            3,2,4, 3,4,1, 3,1,4, 3,4,2,
     *            4,1,2, 4,3,1, 4,1,3, 4,2,3, 4,3,2, 4,2,1,
     *            4,4,2, 4,4,1, 4,4,3/
      DATA SPRI/1.,1.,1., 1.,1.,-1., 1.,0.5,2., 1.,-0.5,2.,
     *         -0.5,1.,2., 0.5,1.,2., 0.5,-0.5,2., -0.5,0.5,2./
      DATA DPRI /0.,0.,0., 0.,0.5,-1., 0.5,0.,-1., 0.5,0.5,-1./
      DATA IAPRI /5,4,9,1,  2,11, 6, 1,  1, 1, 1, 1,  1, 1, 1, 1,
     *         1, 1, 1, 1,  2, 6,11, 1,  5, 9, 4, 1,  1, 1, 1, 1,
     *         1, 1, 1, 1,  1, 1, 1, 1,  1, 1, 1, 1,  1, 1, 1, 1,
     *        18, 2,16, 9, 20,11,21, 4,  5, 8, 6, 7,  1, 1, 1, 1,
     *         1, 1, 1, 1, 17, 6,14, 4, 19, 2,20, 5,  9,12,11,10,
     *         1, 1, 1, 1,  1, 1, 1, 1,  5,15,11,13,  9,21, 6,19,
     *         1, 4, 3, 2 /
      DATA IPRI/ 1,1,1,1, 2,2,2,1, 1,1,1,1, 1,1,1,1, 1,1,1,1,
     *           2,2,2,1, 1,1,1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1,
     *           1,1,1,1, 1,1,1,1, 6,2,5,1, 8,2,7,1, 1,4,2,3,
     *           1,1,1,1, 1,1,1,1, 6,2,5,1, 8,2,7,1, 1,4,2,3,
     *           1,1,1,1, 1,1,1,1, 1,6,2,5, 1,8,2,7, 3,1,4,2 /
      DATA IDPRI / 20*1, 20*1,
     *          1,1,1,1, 1,1,1,1, 3,1,3,1, 4,1,4,1, 1,2,1,2,
     *          1,1,1,1, 1,1,1,1, 3,1,3,1, 4,1,4,1, 1,2,1,2,
     *          1,1,1,1, 1,1,1,1, 1,3,1,3, 1,4,1,4, 2,1,2,1 /
C
      DATA IJKCUB/1,3,2, 1,2,3, 1,3,2, 1,2,3,
     *            1,2,3, 1,3,2, 1,2,3, 1,3,2,
     *            2,1,3, 2,3,1, 2,1,3, 2,3,1,
     *            2,3,1, 2,1,3, 2,3,1, 2,1,3,
     *            3,2,1, 3,1,2, 3,2,1, 3,1,2,
     *            3,1,2, 3,2,1, 3,1,2, 3,2,1/
      DATA SCUB/1.,1.,1., 1.,-1.,1., 1.,-1.,-1., 1.,1.,-1.,
     *         -1.,1.,1., -1.,1.,-1., -1.,-1.,-1., -1.,-1.,1.,
     *          1.,1.,1., 1.,-1.,1., 1.,-1.,-1., 1.,1.,-1.,
     *         -1.,1.,1., -1.,1.,-1., -1.,-1.,-1., -1.,-1.,1.,
     *          1.,1.,1., 1.,-1.,1., 1.,-1.,-1., 1.,1.,-1.,
     *         -1.,1.,1., -1.,1.,-1., -1.,-1.,-1., -1.,-1.,1./
      DATA IACUB/ 9, 5,16, 2,  4,14, 7,11,  1,21, 8,18, 12,22,15,19,
     *          20, 6,23, 3, 17,13,24,10,  4,11, 7,14,  9, 2,16, 5,
     *          20, 3,23, 6, 17,10,24,13,  1,18, 8,21, 12,19,15,22,
     *           1,12, 6,13, 10, 3,15, 8, 17, 4,22, 5, 18,11,23,16,
     *           2,19, 7,24,  9,20,14,21, 21,22,23,24, 17,20,19,18,
     *          13,14,15,16,  1, 4, 3, 2,  9,12,11,10,  5, 6, 7, 8,
     *          10, 8,15, 3,  1,13, 6,12,  2,24, 7,19,  9,21,14,20,
     *          17, 5,22, 4, 18,16,23,24, 17,18,19,20, 21,24,23,22,
     *          9,10,11,12,  5, 8, 7, 6, 13,16,15,14,  1, 2, 3, 4 /
C
C
      DATA IACP/1,2,3, 1,3,2, 1,1,3, 1,1,2,
     *          2,1,3, 2,3,1, 2,2,3, 2,2,1,
     *          3,1,2, 3,2,1, 3,3,2, 3,3,1/
      DATA JAPC / 8*0,  2, 6, 2, 6, 12, 8,12, 8,  6, 4, 6, 4,
     *        8*0,  6, 2, 6, 2,  8,12, 8,12,  4, 6, 4, 6,
     *        8*0,  6, 1, 6, 1,  9, 5, 9, 5,  3, 7, 3, 7,
     *        8*0,  4, 3, 4, 3, 11,10,11,10,  1, 2, 1, 2,
     *        8*0,  1, 6, 1, 6,  5, 9, 5, 9,  7, 3, 7, 3,
     *        8*0,  3, 4, 3, 4, 10,11,10,11,  2, 1, 2, 1 /
      DATA IAPC/1,2,3, 1,3,2, 2,1,3, 2,3,1, 2,4,3, 3,2,1,
     *          3,1,2, 3,2,4, 3,4,2, 4,2,3, 4,3,2, 2,3,4/
      DATA IJKCP / 48*0,
     *        2, 6, 2, 6,  6, 2, 6, 2, 10, 1,10, 1,  9, 5, 9, 5,
     *        1,10, 1,10,  5, 9, 5, 9,  4, 8, 4, 8,  8, 4, 8, 4,
     *       12, 3,12, 3, 11, 7,11, 7,  3,12, 3,12,  7,11, 7,11,
     *       10, 9,10, 9,  9,10, 9,10,  5, 6, 5, 6,  1, 2, 1, 2,
     *        6, 5, 6, 5,  2, 1, 2, 1 /
      DATA SCP/1.,1.,1., 1.,-1.,1., 1.,1.,-1., 1.,-1.,-1.,
     *        -1.,1.,1., -1.,-1.,1., -1.,1.,-1., -1.,-1.,-1./
      DATA ICP / 48*0 ,
     *       1,3,7,5, 2,4,3,6, 1,3,7,5, 2,4,8,6, 2,4,8,6, 1,3,7,5,
     *       5,7,4,2, 5,7,4,2, 5,7,4,2, 5,7,4,2, 5,7,4,2, 5,7,4,2,
     *       1,2,4,3, 5,6,8,7, 1,2,4,3, 5,6,8,7, 5,6,8,7, 1,2,4,3 /
       DATA JPC / 0,0,0,0, 0,0,0,0, 1,5,6,2, 1,5,6,2, 1,5,6,2,
     *        0,0,0,0, 0,0,0,0, 3,4,8,7, 3,4,8,7, 3,4,8,7,
     *        0,0,0,0, 0,0,0,0, 1,3,7,5, 1,3,7,5, 1,3,7,5,
     *        0,0,0,0, 0,0,0,0, 5,7,8,6, 5,7,8,6, 5,7,8,6,
     *       0,0,0,0, 0,0,0,0, 2,6,8,4, 2,6,8,4, 2,6,8,4,
     *       0,0,0,0, 0,0,0,0, 1,2,4,3, 1,2,4,3, 1,2,4,3/
      DATA BCP/2.,2.,1., 2.,1.,2., 1.,2.,2./
      DATA ACP/1.,1.,0., 1.,0.,1., 0.,1.,1./
      DATA IBCP/ 0,0,0,0, 0,0,0,0, 2,3,2,3, 2,3,2,3, 3,2,3,2,
     *       0,0,0,0, 0,0,0,0, 3,2,3,2, 3,2,3,2, 2,3,2,3,
     *       0,0,0,0, 0,0,0,0, 3,1,3,1, 3,1,3,1, 1,3,1,3,
     *       0,0,0,0, 0,0,0,0, 2,1,2,1, 2,1,2,1, 1,2,1,2,
     *       0,0,0,0, 0,0,0,0, 1,3,1,3, 1,3,1,3, 3,1,3,1,
     *       0,0,0,0, 0,0,0,0, 1,2,1,2, 1,2,1,2, 2,1,2,1/
      DATA CPD/0.5,0.5,1.0/
      DATA CPM/0.5,0.5,0.0/
C       ICTET4 TOUTES LES PERMUTATIONS DES COORDONNEES BARYCENTRIQUES
C     DU TETRAEDRE QUI VONT ETRE UTILISEES
C     ITTET4 IPTET4 ITET4P POINTEURS DANS CE TABLEAU
      DATA ICTET4/ 1,2,3,4, 1,3,4,2, 1,4,2,3,
     *             2,1,4,3, 2,3,1,4, 2,4,3,1,
     *             3,2,4,1, 3,1,2,4, 3,4,1,2,
     *             4,2,1,3, 4,3,2,1, 4,1,3,2,
     *             1,2,4,3, 1,3,2,4, 1,4,3,2,
     *             2,1,3,4, 2,3,4,1, 2,4,1,3,
     *             3,2,1,4, 3,1,4,2, 3,4,2,1,
     *             4,2,3,1, 4,3,1,2, 4,1,2,3/
      DATA IPTET4/ 6,9,3, 7,2,4, 1,5,8, 11,12,10,
     *            21,15,18, 17,20,13, 14,16,19, 22,23,24/
      DATA ITTET4/ 11,5,2, 6,1,12, 3,10,4, 7,8,9,
     *              6,9,3, 7,2,4,  1,5,8,  11,12,10,
     *             12,8,4, 9,5,10, 6,11,7,  2,1,3,
     *             7,10,1, 11,3,8 , 2,9,12, 6,4,5/
      DATA ITET4P /6,1,12, 7,2,4, 9,5,10, 11,3,8/
C
C
C
      IF(ITYP.EQ.4) GO TO 30
      IF(ITYP.EQ.8) GO TO 40
      IF(ITYP.EQ.6) GO TO 30
      IF(ITYP.EQ.7) GO TO 30
      IF(ITYP.EQ.11) GO TO 40
      IF(ITYP.EQ.16) GO TO 60
      IF(ITYP.EQ.14) GO TO 80
      IF(ITYP.EQ.23) GO TO 90
C
C
  30  CONTINUE
      X1(1)=X(1)
      X1(2)=X(2)
      X1(3)=1.D0-X(1)-X(2)
C
      IF(JTYP.EQ.8)GO TO 35
      IF(JTYP.EQ.11)GO TO 35
C
C***  TRIANGLE-TRIANGLE
C
      DO 31 I=1,2
      Y(I)=X1(IJKTRI(I,IATRI(IFA,JFA)))
  31  CONTINUE
      RETURN
C
C***  TRIANGLE-QUADRANGLE
C
  35  CONTINUE
      DO 36 I=1,2
      Y(I)=(2.D0*X1(IJKTQ(I,IATQ(IFA,JFA)))-1.D0)*SQUA(I,ITQ(IFA,JFA))
  36  CONTINUE
      RETURN
C
  40  CONTINUE
      IF(JTYP.EQ.4)GO TO 45
      IF(JTYP.EQ.6)GO TO 45
      IF(JTYP.EQ.7)GO TO 45
C
C***  QUADRANGLE-QUADRANGLE
C
C     WRITE(6,*)
C     WRITE(6,*)' IFA ',IFA,' JFA ',JFA
      DO 41 I=1,2
      IA=IAQUA(IFA,JFA)
      IS=ISQUA(IFA,JFA)
C     WRITE(6,*)' IA ',IA,' IS ',IS
      Y(I)=X(IJKQUA(I,IA))*SQUA(I,IS)
  41  CONTINUE
C     WRITE(6,*)
      RETURN
C
C***  QUADRANGLE-TRIANGLE
C
  45  CONTINUE
      DO 46 I=1,2
      Y(I)=0.5D0*(1.D0+X(IJKQT(I,IAQT(IFA,JFA)))
     *                  *SQUA(I,IQT(IFA,JFA)))
  46  CONTINUE
      RETURN
C
  60  CONTINUE
      X1(1)=X(1)
      X1(2)=X(2)
      X1(3)=1.D0-X(1)-X(2)
      X1(4)=X(3)
      IF(JTYP.EQ.14)GO TO 65
      IF(JTYP.EQ.23)GO TO 68
C
C***  PRISME-PRISME
C
      DO 61 I=1,3
      Y(I)=DPRI(I,IDPRI(IOR,IFA,JFA))+
     *     SPRI(I,IPRI(IOR,IFA,JFA))*X1(IJKPRI(I,IAPRI(IOR,IFA,JFA)))
  61  CONTINUE
      RETURN
C
C***  PRISME-CUBE
C
  65  CONTINUE
      Z(1)=X(1)
      Z(2)=X(2)
      Z(3)=X(3)
      Z(4)=1.D0-X(1)-X(2)
      DO 66 I=1,3
      Y(I)=SCP(I,JPC(IOR,IFA,JFA))*(BCP(I,IBCP(IOR,IFA,JFA))*
     *  Z(IAPC(I,JAPC(IOR,IFA,JFA)))-ACP(I,IBCP(IOR,IFA,JFA)))
  66  CONTINUE
C      write(6,*)' prisme cube',ior,ifa,jfa,(y(i),i=1,3)
      RETURN
C
C***  PRISME-TETRAEDRE
C
   68 CONTINUE
      X1(1)=1.D0-X(1)-X(2)
      X1(2)=X(1)
      X1(3)=X(2)
      X1(4)=0.D0
      IA=IPTET4(IOR,JFA,IFA)
      DO 69 I=1,3
      Y(I)=X1(ICTET4(I,IA))
   69 CONTINUE
      RETURN
C
  80  CONTINUE
      IF(JTYP.EQ.16)GO TO 85
C
C***  CUBE-CUBE
C
      DO 81 I=1,3
      Y(I)=X(IJKCUB(I,IACUB(IOR,IFA,JFA)))*
     *          SCUB(I,IACUB(IOR,IFA,JFA))
  81  CONTINUE
      RETURN
C
C***  CUBE-PRISME
C
  85  CONTINUE
      DO 86 I=1,3
      Y(I)=CPM(I)+CPD(I)*SCP(I,ICP(IOR,IFA,JFA))*
     *       X(IACP(I,IJKCP(IOR,IFA,JFA)))
  86  CONTINUE
      RETURN
C                                   TETRAEDRE
   90 CONTINUE
      X1(1)=1.D0-X(1)-X(2)-X(3)
      X1(2)=X(1)
      X1(3)=X(2)
      X1(4)=X(3)
      IF(JTYP.EQ.16)GO TO 95
C
C***  TETRAEDRE-TETRAEDRE
C
      IA= ITTET4(IOR,JFA,IFA)
      DO 92 I=1,3
      Y(I)=X1(ICTET4(I,IA))
   92 CONTINUE
      RETURN
   95 CONTINUE
C
C***  TETRAEDRE-PRISME
C
      IA= ITET4P(IOR,IFA)
      DO 98 I=1,2
      Y(I)=X1(ICTET4(I,IA))
   98 CONTINUE
      Y(3)=1.D0
      IF(JFA.EQ.1)Y(3)=-1.D0
      RETURN
C
C
C
      END