Télécharger la plaquette Cast3M


fr en

Télécharger etoile.eso

Retour à la liste

Numérotation des lignes : 

etoile

  1. C ETOILE    SOURCE    PV        20/09/26    21:16:44     10724          
  2.       SUBROUTINE ETOILE(M1,M2,M3,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C     ************************************************
  6. C     * Routine effectuant la multiplication de 2    *
  7. C     * MATRIK sous stockage morse                   *
  8. C     * M1 : entree                                  *
  9. C     * M2 : entree                                  *
  10. C     * M3 : Sortie sous stockage morse              *
  11. C     *        M3 = M1 * M2                          *
  12. C     ************************************************
  13.  
  14. -INC SMELEME
  15.       POINTEUR MELEMD.MELEME
  16.  
  18.       POINTEUR M1.MATRIK,M2.MATRIK,M3.MATRIK
  19.       POINTEUR PMS3.PMORS, IZA3.IZA
  20.       POINTEUR IMAT1.IMATRI,IMAT2.IMATRI,IMAT3.IMATRI
  21.  
  22.       INTEGER CI
  23.       REAL*8 TEMP
  24.  
  25.       IRET=0
  26.  
  27.       SEGACT M1
  28.  
  29. C     Si les matrices ne sont pas morse, on les crees
  30. C     en morse
  31.       IF (M1.IRIGEL(7,1).NE.6) THEN
  32.         CALL ELMORS(M1,1)
  33.       END IF
  34.  
  35.       SEGACT M2
  36.  
  37.       IF (M2.IRIGEL(7,1).NE.6) THEN
  38.         CALL ELMORS(M2,1)
  39.       END IF
  40.  
  41.       SEGACT M1,M2
  42.  
  43. C     ***********************
  44.       MELEMD=M1.IRIGEL(2,1)
  45.       MELEME=M2.IRIGEL(1,1)
  46.  
  47.       SEGACT MELEMD,MELEME
  48.       NBSOUP=MELEME.LISOUS(/1)
  49.       NBSOUD=MELEMD.LISOUS(/1)
  50.       SEGDES MELEMD,MELEME
  51.       NMATR1=M1.IRIGEL(/2)
  52.  
  53.       IF (NMATR1.GT.1) THEN
  54.          WRITE(6,*) 'ETOILE: Impossible de mutiplier la'
  55.          WRITE(6,*) 'matrice morse 1: NMATRI =',NMATR1,'>1.'
  56.          IRET=1
  57.          RETURN
  58.       END IF
  59.  
  60.       NMATR2=M2.IRIGEL(/2)
  61.  
  62.       IF (NMATR2.GT.1) THEN
  63.          WRITE(6,*) 'ETOILE: Impossible de mutiplier la'
  64.          WRITE(6,*) 'matrice morse 2: NMATRI =',NMATR2,'>1.'
  65.          IRET=1
  66.          RETURN
  67.       END IF
  68.  
  69. C     ***********************
  70. C     On recupere les segments necessaire pour le produit
  71.  
  72.       PMS1=M1.IRIGEL(5,1)
  73.       PMS2=M2.IRIGEL(5,1)
  74.       IZA1=M1.IRIGEL(6,1)
  75.       IZA2=M2.IRIGEL(6,1)
  76.       IMAT1=M1.IRIGEL(4,1)
  77.       IMAT2=M2.IRIGEL(4,1)
  78.  
  79.       SEGACT IMAT1,IMAT2
  80.       SEGACT PMS1,PMS2
  81.       SEGACT IZA1,IZA2
  82.  
  83. C ****************************************************
  84.  
  85.       NBME1=IMAT1.LIZAFM(/2)
  86.       NBSOU1=IMAT1.LIZAFM(/1)
  87.  
  88.       NBME2=IMAT2.LIZAFM(/2)
  89.       NBSOU2=IMAT2.LIZAFM(/1)
  90.  
  91.       IF (NBME1.NE.NBME2) THEN
  92.         WRITE(6,*) 'ETOILE : Produit entre ces deux MATRIK'
  93.         WRITE(6,*) 'incompatible'
  94.         IRET=1
  95.         RETURN
  96.       ELSE
  97.         IFLAG=0
  98.         DO I=1,NBME1
  99.            IF (IMAT1.LISPRI(I).NE.IMAT2.LISDUA(I)) THEN
  100.                IFLAG=1
  101.            END IF
  102.         END DO
  103.         IF (IFLAG.EQ.1) THEN
  104.            WRITE(6,*) 'ETOILE : Produit entre ces deux MATRIK'
  105.            WRITE(6,*) 'incompatible'
  106.            IRET=1
  107.            RETURN
  108.         END IF
  109.       END IF
  110.  
  111.       NBME=NBME1
  112.       NBSOUS=MAX(NBSOUP,NBSOUD)
  113.       IF (NBSOUS.EQ.0) NBSOUS=1
  114.  
  115.       SEGINI IMAT3
  116.  
  117. C     Le primal de M3 est le primal de M2 et
  118. C     le dual de M3 est le dual de M1
  119.       DO I=1,NBME
  120.          IMAT3.LISPRI(I)=IMAT2.LISPRI(I)
  121.          IMAT3.LISDUA(I)=IMAT1.LISDUA(I)
  122.       END DO
  123.  
  124. C     Si Apres le produit on a plus qu'une composante en primal
  125. C     ET en dual avec NBME>1 alors on ajuste a NBME=1.
  126.       IF (NBME.NE.1) THEN
  127.          IF ((IMAT3.LISPRI(1).EQ.IMAT3.LISPRI(2)).AND.
  128.      &        (IMAT3.LISDUA(1).EQ.IMAT3.LISDUA(2))) THEN
  129.             NBME=1
  130.             SEGADJ IMAT3
  131.          END IF
  132.       END IF
  133.  
  134. C     On initialise M3
  135.       NMATRI=1
  136.       NRIGE=7
  137.       NKID=9
  138.       NKMT=7
  139.       SEGINI M3
  140.  
  141.       NTT=PMS1.IA(/1)-1
  142.       NTTP=M2.KNTTP
  143.  
  144. C     On initialise les segments morses de M3
  145.       NJA=1
  146.       NBVA=1
  147.       SEGINI PMS3,IZA3
  148.       M=0
  149.  
  150. C     On calcule le produit:
  151.       DO I=1,NTT
  152.          LI1=PMS1.IA(I)
  153.          NB1=PMS1.IA(I+1) - PMS1.IA(I)
  154.  
  155.          DO K=1,NTTP
  156.  
  157.             TEMP=0.0D0
  158.             DO L=1,NB1
  159.                CI=PMS1.JA(LI1+L-1)
  160.  
  161.                LI2=PMS2.IA(CI)
  162.                NB2=PMS2.IA(CI+1)-PMS2.IA(CI)
  163.  
  164.                DO J=1,NB2
  165.                   IF (PMS2.JA(LI2+J-1).EQ.K) THEN
  166.                      TEMP=TEMP + (IZA1.A(LI1+L-1)*
  167.      &                  IZA2.A(LI2+J-1))
  168.                   ELSEIF (PMS2.JA(LI2+J-1).GT.K) THEN
  169.                      GOTO 10
  170.                   END IF
  171.                END DO
  172.  10            CONTINUE
  173.  
  174.  
  175.             END DO
  176.  
  177. C     On optimise en considerant que ce qui est < E-12 est = 0.
  178.             IF (ABS(TEMP).LT.1.E-15) TEMP=0.0
  179.             IF (TEMP.NE.0.0D0) THEN
  180.                M=M+1
  181.  20            IF (NBVA.LT.M) THEN
  182.                   NBVA=NBVA+100
  183.                   NJA=NBVA
  184.                   SEGADJ IZA3,PMS3
  185.                   GOTO 20
  186.                END IF
  187.  
  188. C     remplissage ligne
  189.                IF (PMS3.IA(I).EQ.0) THEN
  190.                   PMS3.IA(I)=M
  191.                END IF
  192. C     remplissage colonne
  193.                PMS3.JA(M)=K
  194.  
  195.                IZA3.A(M)=TEMP
  196.             END IF
  197. C     On fait attention aux lignes vide.
  198.             IF ((PMS3.IA(I-1).EQ.0).AND.(I.NE.1)) PMS3.IA(I-1) = M+1
  199.          END DO
  200.       END DO
  201.  
  202. C     On oublie pas de remplir la derniere ligne.
  203.       PMS3.IA(NTT+1)=M+1
  204.  
  205. C on fait attention si la derniere ligne est vide.
  206.       IF (PMS3.IA(NTT).EQ.0) PMS3.IA(NTT) = M+1
  207.  
  208. C     On ajuste les segments morse de M3 si necessaire
  209.       IF (NBVA.GT.M) THEN
  210.          NBVA=M
  211.          NJA=NBVA
  212.          SEGADJ IZA3,PMS3
  213.       END IF
  214.  
  215. C     On remplit les pointeurs de M3
  216.       M3.IRIGEL(5,1)=PMS3
  217.       M3.IRIGEL(6,1)=IZA3
  218.  
  219.       IMAT3.KSPGP=IMAT2.KSPGP
  220.       IMAT3.KSPGD=IMAT1.KSPGD
  221.  
  222.       M3.IRIGEL(1,1)=M2.IRIGEL(1,1)
  223.       M3.IRIGEL(2,1)=M1.IRIGEL(2,1)
  224.       M3.IRIGEL(4,1)=IMAT3
  225.       M3.IRIGEL(7,1)=6
  226.  
  227.       M3.KSYM=2
  228.       M3.KNTTP=M2.KNTTP
  229.       M3.KNTTD=M1.KNTTD
  230.       M3.KMINCP=M2.KMINCP
  231.       M3.KMINCD=M1.KMINCD
  232.  
  233.       SEGDES PMS3,IZA3
  234.       SEGDES PMS1,PMS2
  235.       SEGDES IZA1,IZA2
  236.       SEGDES M1,M2,M3
  237.       SEGDES IMAT1,IMAT2,IMAT3
  238.       RETURN
  239.       END
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales