Sources Esope | Cast3M

mulqp2
C MULQP2    SOURCE    CHAT      05/01/13    01:55:29     5004
      SUBROUTINE MULQP2(P, Q, R)
C
C     Procedure de multiplication de 2 polynomes de 2 variables
C     Entree : P(30) : premier polynome : les coefficients sont
C                       ranges comme suit :
C               indice : 1 2  3    4    5    6      7       8    9
C               terme :  1 T1 T2 T1*T2 T1^2 T2^2 T1*T2^2 T1^2*T2 T1^3
C               indice : 10   11      12        13        14   15
C               terme :  T2^3 T1*T2^3 T1^2*T2^2 T1^3*T1^3 T1^4 T2^4
C               indice : 16      17        18        19      20   21
C               terme :  T1*T2^4 T1^2*T2^3 T1^3*T2^2 T1^4*T2 T1^5 T2^5
C               indice : 22      23        24        25        26
C               terme :  T1*T2^5 T1^2*T2^4 T1^3*T2^3 T1^4*T2^2 T1^5*T2
C               indice : 27        28        29        30
C               terme :  T1^2*T2^5 T1^3*T2^4 T1^4*T2^3 T1^5*T2^2
C              Q(30) : deuxieme polynome
C     Sortie : R(30) : polynome resultat de la multiplication
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION P(30), Q(30), R(30), INXM(13, 13)
      DATA INXM/ 1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13,
     2           2,  5,  4,  8,  9,  7, 12, 13, 14, 11, 17, 18, 19,
     3           3,  4,  6,  7,  8, 10, 11, 12, 13, 15, 16, 17, 18,
     4           4,  8,  7, 12, 13, 11, 17, 18, 19, 16, 23, 24, 25,
     5           5,  9,  8, 13, 14, 12, 18, 19, 20, 17, 24, 25, 26,
     6           6,  7, 10, 11, 12, 15, 16, 17, 18, 21, 22, 23, 24,
     7           7, 12, 11, 17, 18, 16, 23, 24, 25, 22, 27, 28, 29,
     8           8, 13, 12, 18, 19, 17, 24, 25, 26, 23, 28, 29, 30,
     9           9, 14, 13, 19, 20, 18, 25, 26,  0, 24,  0, 30,  0,
     9          10, 11, 15, 16, 17, 21, 22, 23, 24,  0,  0, 27, 28,
     1          11, 17, 16, 23, 24, 22, 27, 28,  0,  0,  0,  0,  0,
     2          12, 18, 17, 24, 25, 23, 28, 29, 30, 27,  0,  0,  0,
     3          13, 19, 18, 25, 26, 24, 29, 30,  0, 28,  0,  0,  0/
C
C     Initialisation du polynome resultat
C
      DO 50 I = 1, 30
  50     R(I) = 0.D0
C
C     Multiplication de P et Q
C
      DO 60 I = 1, 13
         DO 60 J = 1, 13
            IF (INXM(I, J) .NE. 0) THEN
               R(INXM(I,J)) = R(INXM(I,J)) + P(I)*Q(J)
            ENDIF
  60  CONTINUE
      RETURN
      END