Télécharger arpack.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPACK SOURCE CB215821 17/07/20 21:15:01 9511
  2. SUBROUTINE ARPACK (IPRIG1,IPRIG2,IPRIG3,IPSOLU,FREQ,NVAL,CHOIX,
  3. & INSYM,LAGDUA)
  4.  
  5. ************************************************************************
  6. *
  7. * A R P A C K
  8. * -----------
  9. *
  10. * SOUS-PROGRAMME ASSOCIE A L'OPTION "IRAM" DE L'OPERATEUR
  11. * "VIBRATION".
  12. *
  13. * FONCTION:
  14. * ---------
  15. *
  16. * DETERMINER UNE SERIE DE MODES PROPRES AVEC LA LIBRAIRIE ARPACK
  17. *
  18. *
  19. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  20. * -----------
  21. *
  22. *
  23. * IPRIG1 ENTIER (E) POINTEUR D'UN MRIGID
  24. *
  25. * IPRIG2 ENTIER (E) POINTEUR D'UN MRIGID
  26. *
  27. * IPRIG3 ENTIER (E) POINTEUR D'UN MRIGID
  28. *
  29. * IPSOLU ENTIER (S) POINTEUR OBJET SOLUTION
  30. *
  31. * FREQ COMPLEXE DP (E) FREQUENCE DE SHIFT
  32. *
  33. * NVAL ENTIER (E) NOMBRE DE MODES A CALCULER
  34. *
  35. * CHOIX CHAINE*2 (E) VALEURS PROPRES VOULUES
  36. * LM - VP DE MODULE MAX
  37. * SM - VP DE MODULE MIN
  38. * LR - VP DE PARTIE R MAX
  39. * SR - VP DE PARTIE R MIN
  40. * LI - VP DE PARTIE I MAX
  41. * SI - VP DE PARTIE I MIN
  42. * LA - VP MAX
  43. * SA - VP MIN
  44. * BE - VP DE CHAQUE COTE
  45. *
  46. * INSYM ENTIER (S) PROBLEME SYMETRIQUE OU NON
  47. *
  48. * LAGDUA ENTIER (E) NB DE M DE LAGRANGE DUALISES
  49. *
  50. * SOUS-PROGRAMMES APPELES:
  51. * ------------------------
  52. *
  53. * WHICH1,QZTRIR,NBINC,ACHECK,ARPSHI,ARPSOL,ARPSOQ
  54. *
  55. * AUTEUR, DATE DE CREATION:
  56. * -------------------------
  57. *
  58. * PASCAL BOUDA 29 JUIN 2015
  59. *
  60. * LANGAGE:
  61. * --------
  62. *
  63. * FORTRAN 77 & 90
  64. *
  65. ***********************************************************************
  66.  
  67. IMPLICIT INTEGER(I-N)
  68. IMPLICIT REAL*8 (A-H,O-Z)
  69.  
  70. -INC CCOPTIO
  71. -INC SMRIGID
  72.  
  73. INTEGER IPRIG1
  74. INTEGER IPRIG2
  75. INTEGER IPRIG3
  76.  
  77. INTEGER LAGDUA
  78. INTEGER IPSOLU
  79. COMPLEX*16 FREQ
  80. INTEGER NVAL
  81. CHARACTER*2 CHOIX
  82. INTEGER INSYM
  83.  
  84. INTEGER IPRIGI
  85. INTEGER IPMASS
  86. INTEGER IPAMOR
  87. INTEGER NK,NM,NA
  88. LOGICAL FLAG
  89. LOGICAL INVER
  90. LOGICAL PIRE
  91. LOGICAL CHOLE
  92. REAL*8 EPSI
  93. COMPLEX*16 SIGMA,ZERO
  94. LOGICAL SYM
  95. LOGICAL QUAD
  96.  
  97. ZERO=CMPLX(0.D0,0.D0)
  98.  
  99. **********************************
  100. ** TOLERANCE SUR LES EIGENPAIRS **
  101. **********************************
  102.  
  103. EPSI=1.D-08
  104. c EPSI=1.D-10
  105.  
  106.  
  107. **********************************
  108.  
  109. *Identification du degre du probleme: lineaire, quadratique
  110. IF (IPRIG3 .EQ. 0) THEN
  111. QUAD=.FALSE.
  112. IF (IIMPI .GT. 2) THEN
  113. WRITE(IOIMP,*) 'LE PROBLEME EST LINEAIRE'
  114. ENDIF
  115. ELSE
  116. QUAD=.TRUE.
  117. IF (IIMPI .GT. 2) THEN
  118. WRITE(IOIMP,*) 'LE PROBLEME EST QUADRATIQUE'
  119. ENDIF
  120. ENDIF
  121.  
  122. *Determination de la matrice de masse, de rigidite et eventuellement
  123. *d'amortissement
  124. IF (.NOT. QUAD) THEN
  125. CALL WHICH1 (IPRIG1,IPRIG2,IPRIGI,IPMASS)
  126. IF (IERR .NE. 0) RETURN
  127. ELSE
  128. IPRIGI=IPRIG1
  129. IPMASS=IPRIG2
  130. IPAMOR=IPRIG3
  131. CALL QZTRIR (IPMASS,IPRIGI,IPAMOR)
  132. IF (IERR .NE. 0) RETURN
  133. ENDIF
  134. *Calcul du nombre d'inconnues + triangularisation si necessaire
  135. CALL NBINC (IPRIGI,NK)
  136. IF (IERR.NE.0) RETURN
  137. CALL NBINC (IPMASS,NM)
  138. IF (IERR.NE.0) RETURN
  139.  
  140. IF (QUAD) THEN
  141. CALL NBINC (IPAMOR,NA)
  142. IF (IERR.NE.0) RETURN
  143. ENDIF
  144. IF(IIMPI.GE.1) THEN
  145. WRITE(IOIMP,*) 'NOMBRE DE VALEURS PROPRES DEMANDEES=',NVAL
  146. WRITE(IOIMP,*) 'SHIFT EN FREQUENCE=', REAL(FREQ)
  147. ENDIF
  148.  
  149. *Verification de la solvabilite du probleme
  150. CALL ACHECK(IPRIGI,IPMASS,QUAD,SYM,FREQ,NK,FLAG,
  151. & INVER,PIRE,CHOLE,EPSI)
  152. IF (IERR.NE.0) RETURN
  153.  
  154. *Valeur du insym depend du type de probleme resolu
  155. IF (SYM) THEN
  156. INSYM=0
  157. IF (IIMPI.GE.1) WRITE(IOIMP,*) 'LE PROBLEME EST SYMETRIQUE'
  158. ELSE
  159. INSYM=1
  160. IF (IIMPI.GE.1) WRITE(IOIMP,*)'LE PROBLEME N EST PAS SYMETRIQUE'
  161. ENDIF
  162.  
  163.  
  164. * Conversion du shift "frequence" en shift "valeur propre";
  165. CALL ARPSHI (FREQ,SIGMA,QUAD,INVER,1)
  166. IF (IERR.NE.0) RETURN
  167.  
  168. ************************************************************************
  169. * 27/07/2015 : La resolution avec shift complexe n'est pas implementee
  170. * Mise a zero de la partie imaginaire du shift
  171. SIGMA=CMPLX(REAL(SIGMA),0.D0)
  172. ************************************************************************
  173.  
  174. IF (FLAG) THEN
  175.  
  176. IF (.NOT. QUAD) THEN
  177. CALL ARPSOL (SIGMA,CHOIX,QUAD,NVAL,IPRIGI,IPMASS,LAGDUA,NK,NM,
  178. & INVER,PIRE,SYM,CHOLE,IPSOLU,EPSI)
  179.  
  180. ELSE
  181. CALL ARPSOQ (SIGMA,CHOIX,QUAD,NVAL,IPRIGI,IPMASS,IPAMOR,
  182. & LAGDUA,NK,NM,INVER,SYM,CHOLE,IPSOLU,EPSI)
  183. ENDIF
  184. IF (IERR.NE.0) RETURN
  185.  
  186. ENDIF
  187.  
  188. END
  189.  
  190.  

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