Sources Esope | Cast3M

arpsol
C ARPSOL    SOURCE    BP208322  20/02/06    21:15:11     10512          
      SUBROUTINE ARPSOL (SIGMA,CHOIX,QUAD,NVAL,IPRIGI,IPMASS,LAGDUA,NK,
     &                      NM,INVER,PIRE,SYM,CHOLE,IPSOLU,EPSI)
 
***********************************************************************
*
*                          A R P S O L
*
* FONCTION:
* ---------
*
*     SOLVEUR DU PROBLEME LINAIRE 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)
*
*     INVER   LOGIQUE    (E)   .TRUE. -> PRODUIT SCALAIRE X'KX
*                              .FALSE. -> PRODUIT SCALAIRE X'MX
*
*     PIRE     LOGIQUE   (E)   PRODUIT SCALAIRE EUCLIDIEN
*
*     SYM     LOGIQUE    (E)    PROBLEME SYMETRIQUE OU NON
*
*     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,ARPITL,ARPOST
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL BOUDA     29 JUIN 2015
*
* LANGAGE:
* --------
*
*     FORTRAN 77 & 90
*
***********************************************************************
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC TARWORK
 
      COMPLEX*16 SIGMA
      CHARACTER*2 CHOIX
      LOGICAL QUAD
      INTEGER NVAL
      INTEGER IPRIGI
      INTEGER IPMASS
      INTEGER LAGDUA
      INTEGER NK
      INTEGER NM
      LOGICAL INVER
      LOGICAL PIRE
      LOGICAL SYM
      LOGICAL CHOLE
      INTEGER IPSOLU
      REAL*8 EPSI
 
      INTEGER ITER
      INTEGER IPRTRA
      INTEGER IPBUFF
      LOGICAL OUT
 
 
*Nombre maximal d'iteration autorise
      MAXITE=MIN(100*MAX(NK,NM),10000)
 
*Initialisation de tous les paramètres ARPACK
      CALL ARPINI (NVAL,NK,SYM,CHOLE,INVER,PIRE,
     &                                 SIGMA,CHOIX,IPMAUP,MAXITE)
 
*Construction des operateurs de travail
      CALL ARPOPE (IPRIGI,IPMASS,0,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 N°:',ITER,'***'
*Iteration
        CALL ARPITL (IPRTRA,IPMAUP,SIGMA,INVER,SYM,EPSI,OUT)
        IF (IERR.NE.0) GOTO 999
*Sortie si convergence
 
        IF (OUT) THEN
          GOTO 999
        END IF
 
      ENDDO
 
*     sortie car on a atteint le nombre maxi d'iterations sans converger
*     "Pas de convergence apres %i1 iterations. L'execution continue"
      INTERR(1)=MAXITE
      CALL ERREUR(151)
 
999   CONTINUE
 
      IF (IIMPI.GE.1)
     & WRITE(IOIMP,*) '*** SORTIE APRES :',ITER,' ITERATIONS ***'
 
*Post-traitement des resultats: creation de l'objet solution
      CALL ARPOST (IPRTRA,LAGDUA,SIGMA,QUAD,SYM,INVER,
     &                                          IPMAUP,IPSOLU,EPSI)
      IF (IERR.NE.0) RETURN
 
*Destruction des operateurs de travail (matrices principales exclues)
 
      MRITRA=IPRTRA
      SEGACT MRITRA*MOD
      DO i=3,RIGI(/1)
        IF (RIGI(i) .NE. 0) THEN
          IPBUFF=RIGI(i)
          CALL DTRIGI(IPBUFF)
c           RIGI(i)=0
        ENDIF
      ENDDO
      SEGSUP MRITRA
      IF (IERR.NE.0) RETURN
 
*Suppression du segment de travail ARPACK
      MAUP=IPMAUP
c       SEGSUP MAUP
 
      END