Télécharger la plaquette Cast3M


fr en

Télécharger sespa3.eso

Retour à la liste

Numérotation des lignes : 

sespa3

  1. C SESPA3    SOURCE    CHAT      09/11/25    21:15:20     6548
  2. ************************************************************************
  3. *
  4. *                                SESPA3
  5. *                             -----------
  6. *
  7. * FONCTION:
  8. * ---------
  9. *
  10. *  CALCUL DE LA LISTE DES VALEURS PROPRES IPLVAL ET DE  LA MATRICE
  11. *  DES VECTEURS PROPRES PHI DANS LE CAS D'UN PETIT PROBLEME:
  12. *
  13. *                           K1*V=LAMBDA*M1*V
  14. *                                                                                 *
  15. *
  16. *
  17. * MODE D'APPEL:
  18. *
  19. *     CALL SESPA3 ( IPK1 , IPM1 , IPHI , IPLVAL )
  20. *
  21. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE
  22. * -----------
  23. *
  24. *     IPK1    ENTIER    (E)  POINTEUR DE L'OBJET 'MATRIX' REPRESENTANT
  25. *                            LA MATRICE K1 A DIAGONALISER
  26. *                       (S)  MATRICE DIAGONALISEE
  27. *
  28. *     IPM1    ENTIER    (E)  POINTEUR DE L'OBJET 'MATRIX' REPRESENTANT
  29. *                            LA MATRICE M1 A DIAGONALISER
  30. *                       (S)  MATRICE DIAGONALISEE
  31. *
  32. *     IPLVAL  ENTIER    (S)  POINTEUR LISTE DE REELS DES VALEURS
  33. *                            PROPRES
  34. *
  35. *     IPHI    ENTIER     (S) POINTEUR DE L'OBJET 'MATRIX' DONT LES COLONNES
  36. *                            SONT LES VECTEURS PROPRES DU PROBLEME
  37. *
  38. *
  39. * AUTEURS, DATE DE CREATION:
  40. * -------------------------
  41. *
  42. *   A.M. JOLIVALT,  W. PASILLAS  16 / 07 / 94.    ( ESOPE )                                     *
  43. ************************************************************
  44. ******************************************************
  45. *
  46. * Effectue les transformations de jacobi successives
  47. *  th: seuil
  48. *  cf: coupling factor
  49. *  t1: 1 si test verifié 0 sinon
  50. *  t2: 1 si test verifié 0 sinon
  51. *
  52. *******************************************************
  53. C
  54.          SUBROUTINE SESPA3(IPK1,IPM1,IPHI,IPLVAL)
  55.       IMPLICIT INTEGER(I-N)
  56.          IMPLICIT REAL*8 (A-H,O-Z)
  57. C
  58. C
  59.          INTEGER I,J,K,P,Q,T1,T2,T3,IND
  60.          REAL*8 ALPHA,GAMMA,TH,CF1,CF2
  61. C
  62. -INC SMLREEL
  63.          SEGMENT MATRIX
  64.           REAL*8 A(N,N)
  65.          ENDSEGMENT
  66. C
  67. C
  68.          POINTEUR IPK1.MATRIX, IPM1.MATRIX, IPHI.MATRIX, IPM3.MATRIX
  69.          POINTEUR IPK2.MATRIX, IPM2.MATRIX, IPLVAL.MLREEL
  70. C
  71.          SEGACT ,IPK1*mod,ipm1*mod
  72.          N = IPK1.A(/1)
  73.          JG = N
  74. *
  75.            SEGINI ,IPHI ,IPK2 ,IPM2  ,IPLVAL
  76. C
  77. *         CALL SJACO1(IPHI,N)
  78.           do i=1,n
  79.           iphi.a(i,i)=1.d0
  80.           enddo
  81. C
  82. C
  83.          segini,ipm3=ipm1
  84.  
  85. *         DO 100 K=1,10000
  86.          DO 100 K=1, 15
  87.          IND=2*K
  88.          TH=(1.D1)**(-IND)
  89. *
  90.  
  91.          call shiftd(ipk1.A,ipk2.A,N*N)
  92.          call shiftd(ipm1.A,ipm2.A,N*N)
  93.  
  94.          call sjjcoi(ipk1.a,ipm1.a,iphi.A,n,th)
  95.  
  96.          CALL SJACO6(IPK1,IPK2,IPM1,IPM2,T1,N,K)
  97. C
  98. *-------------------------------------------------
  99. *- 1er test: cv des valaeurs propres -------------
  100. *-------------------------------------------------
  101.          IF (T1.EQ.1) THEN
  102.            CALL SJACO7(IPK1,T2,N,K)
  103.            CALL SJACO7(IPM1,T3,N,K)
  104. C
  105. *-------------------------------------------------
  106. *--- 2 test: rapport des termes diagonaux --------
  107. *-------    et extra diagonaux    ----------------
  108. *-------------------------------------------------
  109.            IF ((T2.EQ.1).AND.(T3.EQ.1)) THEN
  110.              GOTO 110
  111.            ENDIF
  112. C
  113.          ENDIF
  114. 100     CONTINUE
  115. 110     CONTINUE
  116. C
  117.         CALL SJACO8 (IPHI,IPM3)
  118. *
  119. *      -- On met les val propres dans lval --
  120. *
  121.         SEGACT ,IPLVAL*MOD, IPK1, IPM1
  122.         DO 300 IB300 = 1, N
  123.            XK1 = IPK1.A(IB300,IB300)
  124.            XM1 = IPM1.A(IB300,IB300)
  125.            XALPHA =  XK1 /  XM1
  126.            IPLVAL.PROG( IB300 ) = XALPHA
  127.  300    CONTINUE
  128. *        SEGDES ,IPLVAL
  129. C
  130.         SEGSUP ,IPK1, IPM1, IPK2 , IPM2, IPM3
  131. C
  132.         RETURN
  133.         END
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  

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