Sources Esope | Cast3M

arpsoq
C ARPSOQ    SOURCE    BP208322  20/02/06    21:15:12     10512          
      SUBROUTINE ARPSOQ (SIGMA,CHOIX,QUAD,NVAL,IPRIGI,IPMASS,IPAMOR,
     &                         LAGDUA,NK,NM,INVER,SYM,CHOLE,IPSOLU,EPSI)
 
***********************************************************************
*
*                          A R P S O Q
*
* FONCTION:
* ---------
*
*     SOLVEUR DU PROBLEME QUADRATIQUE AUX VALEURS PROPRES AVEC LA
*     METHODE IRAM (METHODE D'ARNOLDI AVEC REDEMARRAGE IMPLICITE)
*
*
* PARAMETRES:  (E)=ENTREE   (S)=SORTIE
* -----------
*
*     SIGMA   COMPLEX DP (E)    VALEUR PROPRE DE SHIFT
*
*     CHOIX   CHAINE*2     (E)    VALEURS PROPRES VOULUES
*                                      LM - VP DE MODULE MAX
*                                      SM - VP DE MODULE MIN
*                                      LR - VP DE PARTIE R MAX
*                                      SR - VP DE PARTIE R MIN
*                                      LI - VP DE PARTIE I MAX
*                                      SI - VP DE PARTIE I MIN
*                                      LA - VP MAX
*                                      SA - VP MIN
*                                      BE - VP DE CHAQUE COTE
*
*     QUAD    LOGIQUE    (E)    PROBLEME QUADRATIQUE OU NON
*
*     NVAL    ENTIER     (E)    NOMBRE DE MODES PROPRES A CALCULER
*
*     IPRIGI  ENTIER     (E)    POINTEUR D'UNE RIGIDITE
*
*     IPMASS  ENTIER     (E)    POINTEUR D'UNE MASSE
*
*     LAGDUA  ENTIER     (E)    NB DE M. DE LAGRANGE DUALISES
*
*     NK      ENTIER     (E)    DIMENSION DU PROBLEME (K)
*
*     NM      ENTIER     (E)    DIMENSION DU PROBLEME (M)
*
*     CHOLE   LOGIQUE    (E)    CHOLESKY NON ALTERNATIVE POSSIBLE
*
*     IPSOLU  ENTIER     (S)    POINTEUR SUR LA SOLUTION CREE
*
*     EPSI    REEL DP    (E)    ZERO DE TOLERANCE
*
*
* SOUS-PROGRAMMES APPELES:
* ------------------------
*
*     ARPINI,ARPALE,ARPOPE,ARPITQ,ARPOST
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL BOUDA     17 JUILLET 2015
*
* LANGAGE:
* --------
*
*     FORTRAN 77 & 90
*
***********************************************************************
 
 
-INC PPARAM
-INC CCOPTIO
-INC TARWORK
 
 
      COMPLEX*16 SIGMA
      CHARACTER*2 CHOIX
      LOGICAL QUAD
      INTEGER NVAL
      INTEGER IPRIGI
      INTEGER IPMASS
      INTEGER IPAMOR
      INTEGER LAGDUA
      INTEGER NK
      INTEGER NM
      LOGICAL CHOLE
      INTEGER IPSOLU
      REAL*8 EPSI
 
      INTEGER IPBUFF
      INTEGER ITER
      INTEGER IPRTRA
      LOGICAL OUT
      LOGICAL SYM
      LOGICAL INVER
 
 
*Nombre maximal d'iteration autorise
      MAXITE=MIN(100*MAX(NK,NM),10000)
 
*Initialisation de tous les paramètres ARPACK
      CALL ARPINI (NVAL,2*NK,.FALSE.,CHOLE,.FALSE.,.FALSE.,
     &                                  SIGMA,CHOIX,IPMAUP,MAXITE)
 
*Construction des operateurs de travail
      CALL ARPOPE (IPRIGI,IPMASS,IPAMOR,QUAD,SIGMA,IPRTRA)
 
*Inititalisation du vecteur residu d'arpack
      CALL ARPALE (IPRTRA,IPMAUP,QUAD)
      IF (IERR.NE.0) GOTO 999
 
*Boucle pour la factorisation d'Arnoldi
      DO ITER=1,MAXITE
        IF (IIMPI.GE.10) WRITE(IOIMP,*) '***ITERATION :',ITER,' ***'
*Iteration
        CALL ARPITQ (IPRTRA,IPMAUP,SIGMA,INVER,EPSI,OUT)
        IF (IERR.NE.0) GOTO 999
*Sortie si convergence
        IF (OUT) GOTO 999
      ENDDO
 
999   CONTINUE
 
      IF (IIMPI.GE.1)
     & WRITE(IOIMP,*) '*** SORTIE APRES :',ITER,' ITERATIONS ***'
 
*Destruction des operateurs de travail (matrices principales exclues)
      MRITRA=IPRTRA
      SEGACT MRITRA*MOD
      DO i=4,RIGI(/1)
        IF (RIGI(i) .NE. 0) THEN
          IPBUFF=RIGI(i)
          CALL DTRIGI(IPBUFF)
          RIGI(i)=0
        ENDIF
      ENDDO
 
      SEGDES MRITRA
 
      IF (IERR.NE.0) RETURN
 
*Posttraitement des resultats: creation de l'objet solution
      CALL ARPOST (IPRTRA,LAGDUA,SIGMA,QUAD,SYM,INVER,
     &                                          IPMAUP,IPSOLU,EPSI)
      IF (IERR.NE.0) RETURN
 
*Suppression du segment de travail ARPACK
      MAUP=IPMAUP
c       SEGSUP MAUP
 
      END