Sources Esope | Cast3M

arpack
C ARPACK    SOURCE    PB245956  20/12/21    21:15:00     10747          
C      SUBROUTINE ARPACK (IPRIG1,IPRIG2,IPRIG3,IPSOLU,FSHIFT,NVAL,CHOIX,
C     &                                                  INSYM,LAGDUA)
 
************************************************************************
*
*                             A R P A C K
*                             -----------
*
*     SOUS-PROGRAMME ASSOCIE A L'OPTION "IRAM" DE L'OPERATEUR
*     "VIBRATION".
*
* FONCTION:
* ---------
*
*     DETERMINER UNE SERIE DE MODES PROPRES AVEC LA LIBRAIRIE ARPACK
*
*
* PARAMETRES:  (E)=ENTREE   (S)=SORTIE
* -----------
*
*
*     IPRIG1  ENTIER       (E)    POINTEUR D'UN MRIGID
*
*     IPRIG2  ENTIER       (E)    POINTEUR D'UN MRIGID
*
*     IPRIG3  ENTIER       (E)    POINTEUR D'UN MRIGID
*
*     IPSOLU  ENTIER       (S)    POINTEUR OBJET SOLUTION
*
*     FSHIFT  COMPLEXE DP  (E)    FREQUENCE DE SHIFT
*
*     NVAL    ENTIER       (E)    NOMBRE DE MODES A CALCULER
*
*     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
*
*     INSYM    ENTIER      (S)    PROBLEME SYMETRIQUE OU NON
*
*     LAGDUA   ENTIER      (E)    NB DE M DE LAGRANGE DUALISES
*
* SOUS-PROGRAMMES APPELES:
* ------------------------
*
*     WHICH1,QZTRIR,NBINC,ACHECK,ARPSHI,ARPSOL,ARPSOQ
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL BOUDA     29 JUIN 2015
*     PASCAL BOUDA     AOUT 2020 : sortie du pretraitement 
*              (analyse des matrices) + posttraitement (objet solution)
*
* LANGAGE:
* --------
*
*     FORTRAN 77 & 90
*
***********************************************************************
      SUBROUTINE ARPACK (IPSOLU,IPMASS,IPRIGI,IPAMOR,FSHIFT,NVAL,CHOIX,
     &                                                     INSYM,LAGDUA)
 
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
 
      INTEGER IPRIG1
      INTEGER IPRIG2
      INTEGER IPRIG3
 
      INTEGER LAGDUA
      INTEGER IPSOLU
      COMPLEX*16 FSHIFT
      INTEGER NVAL
      CHARACTER*2 CHOIX
      INTEGER INSYM
 
      INTEGER IPRIGI
      INTEGER IPMASS
      INTEGER IPAMOR
      INTEGER NK,NM,NA
      LOGICAL FLAG
      LOGICAL INVER
      LOGICAL PIRE
      LOGICAL CHOLE
      REAL*8 EPSI
      COMPLEX*16 SIGMA,ZERO
      LOGICAL SYM
      LOGICAL QUAD
 
      ZERO=CMPLX(0.D0,0.D0)
 
**********************************
** TOLERANCE SUR LES EIGENPAIRS **
**********************************
 
       EPSI=1.D-08
c        EPSI=1.D-10
 
 
**********************************
 
*Identification du degre du probleme: lineaire, quadratique
      IF (IPAMOR .EQ. 0) THEN
        QUAD=.FALSE.
        IF (IIMPI .GT. 2) THEN
          WRITE(IOIMP,*) 'LE PROBLEME EST LINEAIRE'
        ENDIF
      ELSE
        QUAD=.TRUE.
        IF (IIMPI .GT. 2) THEN
          WRITE(IOIMP,*) 'LE PROBLEME EST QUADRATIQUE'
        ENDIF
      ENDIF
 
 
*pb nov20: le travail est desormais fait en amont (cf vibrat.eso)
**Determination de la matrice de masse, de rigidite et eventuellement
**d'amortissement
*      IF (.NOT. QUAD) THEN
*        CALL WHICH1 (IPRIG1,IPRIG2,IPRIGI,IPMASS)
*        IF (IERR .NE. 0) RETURN
*      ELSE
*        IPRIGI=IPRIG1
*        IPMASS=IPRIG2
*        IPAMOR=IPRIG3
*        CALL QZTRIR (IPMASS,IPRIGI,IPAMOR)
*        IF (IERR .NE. 0) RETURN
*      ENDIF
*Calcul du nombre d'inconnues + triangularisation si necessaire
      CALL NBINC (IPRIGI,NK)
      IF (IERR.NE.0) RETURN
      CALL NBINC (IPMASS,NM)
      IF (IERR.NE.0) RETURN
 
      IF (QUAD) THEN
        CALL NBINC (IPAMOR,NA)
        IF (IERR.NE.0) RETURN
      ENDIF
      IF(IIMPI.GE.1) THEN
        WRITE(IOIMP,*) 'NOMBRE DE VALEURS PROPRES DEMANDEES=',NVAL
        WRITE(IOIMP,*) 'SHIFT EN FREQUENCE=', REAL(FSHIFT)
      ENDIF
 
*Verification de la solvabilite du probleme
      CALL ACHECK(IPRIGI,IPMASS,QUAD,SYM,FSHIFT,NK,FLAG,
     &                                 INVER,PIRE,CHOLE,EPSI)
      IF (IERR.NE.0) RETURN
*Valeur du insym depend du type de probleme resolu
      IF (SYM) THEN
        INSYM=0
        IF (IIMPI.GE.1) WRITE(IOIMP,*) 'LE PROBLEME EST SYMETRIQUE'
      ELSE
        INSYM=1
        IF (IIMPI.GE.1) WRITE(IOIMP,*)'LE PROBLEME N EST PAS SYMETRIQUE'
      ENDIF
 
* Conversion du shift "frequence" en shift "valeur propre";
      CALL ARPSHI (FSHIFT,SIGMA,QUAD,1)
      IF (IERR.NE.0) RETURN
 
* 27/07/2015 : La resolution avec shift complexe n'est pas implementee
* Mise a zero de la partie imaginaire du shift
      SIGMA=CMPLX(REAL(SIGMA),0.D0)
      IF (FLAG) THEN
 
        IF (.NOT. QUAD) THEN
c         RESOLUTION DU PB AUX VALEURS PROPRES LINEAIRE
          CALL ARPSOL (SIGMA,CHOIX,QUAD,NVAL,IPRIGI,IPMASS,LAGDUA,NK,NM,
     &                 INVER,PIRE,SYM,CHOLE,IPSOLU,EPSI)
 
        ELSE
c         RESOLUTION DU PB AUX VALEURS PROPRES QUADRATIQUE
          CALL ARPSOQ (SIGMA,CHOIX,QUAD,NVAL,IPRIGI,IPMASS,IPAMOR,
     &                         LAGDUA,NK,NM,INVER,SYM,CHOLE,IPSOLU,EPSI)
        ENDIF
        IF (IERR.NE.0) RETURN
 
      ENDIF
 
      END