C SESPA3    SOURCE    CHAT      09/11/25    21:15:20     6548
************************************************************************
*
*                                SESPA3
*                             -----------
*
* FONCTION:
* ---------
*
*  CALCUL DE LA LISTE DES VALEURS PROPRES IPLVAL ET DE  LA MATRICE
*  DES VECTEURS PROPRES PHI DANS LE CAS D'UN PETIT PROBLEME:
*
*                           K1*V=LAMBDA*M1*V
*                                                                                 *
*
*
* MODE D'APPEL:
*
*     CALL SESPA3 ( IPK1 , IPM1 , IPHI , IPLVAL )
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE
* -----------
*
*     IPK1    ENTIER    (E)  POINTEUR DE L'OBJET 'MATRIX' REPRESENTANT
*                            LA MATRICE K1 A DIAGONALISER
*                       (S)  MATRICE DIAGONALISEE
*
*     IPM1    ENTIER    (E)  POINTEUR DE L'OBJET 'MATRIX' REPRESENTANT
*                            LA MATRICE M1 A DIAGONALISER
*                       (S)  MATRICE DIAGONALISEE
*
*     IPLVAL  ENTIER    (S)  POINTEUR LISTE DE REELS DES VALEURS
*                            PROPRES
*
*     IPHI    ENTIER     (S) POINTEUR DE L'OBJET 'MATRIX' DONT LES COLONNES
*                            SONT LES VECTEURS PROPRES DU PROBLEME
*
*
* AUTEURS, DATE DE CREATION:
* -------------------------
*
*   A.M. JOLIVALT,  W. PASILLAS  16 / 07 / 94.    ( ESOPE )                                     *
************************************************************
******************************************************
*
* Effectue les transformations de jacobi successives
*  th: seuil
*  cf: coupling factor
*  t1: 1 si test verifié 0 sinon
*  t2: 1 si test verifié 0 sinon
*
*******************************************************
C
         SUBROUTINE SESPA3(IPK1,IPM1,IPHI,IPLVAL)
      IMPLICIT INTEGER(I-N)
         IMPLICIT REAL*8 (A-H,O-Z)
C
C
         INTEGER I,J,K,P,Q,T1,T2,T3,IND
         REAL*8 ALPHA,GAMMA,TH,CF1,CF2
C
-INC SMLREEL
         SEGMENT MATRIX
          REAL*8 A(N,N)
         ENDSEGMENT
C
C
         POINTEUR IPK1.MATRIX, IPM1.MATRIX, IPHI.MATRIX, IPM3.MATRIX
         POINTEUR IPK2.MATRIX, IPM2.MATRIX, IPLVAL.MLREEL
C
         SEGACT ,IPK1*mod,ipm1*mod
         N = IPK1.A(/1)
         JG = N
*
           SEGINI ,IPHI ,IPK2 ,IPM2  ,IPLVAL
C
*         CALL SJACO1(IPHI,N)
          do i=1,n
          iphi.a(i,i)=1.d0
          enddo
C
C
         segini,ipm3=ipm1

*         DO 100 K=1,10000
         DO 100 K=1, 15
         IND=2*K
         TH=(1.D1)**(-IND)
*

         call shiftd(ipk1.A,ipk2.A,N*N)
         call shiftd(ipm1.A,ipm2.A,N*N)

         call sjjcoi(ipk1.a,ipm1.a,iphi.A,n,th)

         CALL SJACO6(IPK1,IPK2,IPM1,IPM2,T1,N,K)
C
*-------------------------------------------------
*- 1er test: cv des valaeurs propres -------------
*-------------------------------------------------
         IF (T1.EQ.1) THEN
           CALL SJACO7(IPK1,T2,N,K)
           CALL SJACO7(IPM1,T3,N,K)
C
*-------------------------------------------------
*--- 2 test: rapport des termes diagonaux --------
*-------    et extra diagonaux    ----------------
*-------------------------------------------------
           IF ((T2.EQ.1).AND.(T3.EQ.1)) THEN
             GOTO 110
           ENDIF
C
         ENDIF
100     CONTINUE
110     CONTINUE
C
        CALL SJACO8 (IPHI,IPM3)
*
*      -- On met les val propres dans lval --
*
        SEGACT ,IPLVAL*MOD, IPK1, IPM1
        DO 300 IB300 = 1, N
           XK1 = IPK1.A(IB300,IB300)
           XM1 = IPM1.A(IB300,IB300)
           XALPHA =  XK1 /  XM1
           IPLVAL.PROG( IB300 ) = XALPHA
 300    CONTINUE
*        SEGDES ,IPLVAL
C
        SEGSUP ,IPK1, IPM1, IPK2 , IPM2, IPM3
C
        RETURN
        END