Télécharger arpope.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPOPE SOURCE BP208322 20/02/06 21:15:10 10512
  2. SUBROUTINE ARPOPE (IPRIGI,IPMASS,IPAMOR,QUAD,SIGMA,IPRTRA)
  3.  
  4.  
  5. ***********************************************************************
  6. *
  7. * A R P O P E
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. * CONSTRUCTION DES OPERATEURS DE TRAVAIL POUR ARPACK
  13. *
  14. *
  15. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  16. * -----------
  17. *
  18. *
  19. * IPRIGI ENTIER (E) POINTEUR DE LA RIGIDITE
  20. *
  21. * IPMASS ENTIER (E) POINTEUR DE LA MASSE
  22. *
  23. * IPAMOR ENTIER (E) POINTEUR DE L'AMORTISSEMENT
  24. *
  25. * QUAD LOGIQUE (E) PROBLEME QUADRATIQUE OU NON
  26. *
  27. * SIGMA COMPLEXE DP (E) VALEUR DU SHIFT
  28. *
  29. * IPRTRA ENTIER (S) POINTEUR VERS LE SEGMENT DES OPERATEURS
  30. *
  31. *
  32. * SOUS-PROGRAMMES APPELES:
  33. * ------------------------
  34. *
  35. * DECALE, TRIANG, LDMT1
  36. *
  37. * AUTEUR, DATE DE CREATION:
  38. * -------------------------
  39. *
  40. * PASCAL BOUDA 17 JUILLET 2015
  41. *
  42. * LANGAGE:
  43. * --------
  44. *
  45. * FORTRAN 77 & 90
  46. *
  47. ************************************************************************
  48.  
  49. IMPLICIT INTEGER(I-N)
  50. IMPLICIT REAL*8 (A-H,O-Z)
  51.  
  52.  
  53. -INC PPARAM
  54. -INC CCOPTIO
  55. -INC SMRIGID
  56. -INC TARWORK
  57.  
  58.  
  59. INTEGER IPRIGI
  60. INTEGER IPMASS
  61. INTEGER IPAMOR
  62. LOGICAL QUAD
  63. COMPLEX*16 SIGMA
  64. INTEGER IPRTRA
  65.  
  66. INTEGER IPBUFF
  67. INTEGER IPINT
  68. INTEGER IPCHO
  69. INTEGER NBR, NRG
  70.  
  71. * Liste des operateurs construits
  72. *
  73. * K MATRICE DE RIGIDITE
  74. * M MATRICE DE MASSE
  75. * C MATRICE D'AMORTISSEMENT
  76.  
  77.  
  78. * RIGI(1)=K
  79. * RIGI(2)=M OU KSIGMA
  80. * RIGI(3)=C
  81. * RIGI(4)=K-RE(SIGMA)*M
  82. * RIGI(5)=C+RE(SIGMA)*M
  83. * RIGI(6)=K+RE(SIGMA)*(C+RE(SIGMA)*M)
  84.  
  85. * SYME indique si l'operateur construit est symetrique
  86. *ou non
  87.  
  88.  
  89. NB=6
  90. SEGINI MRITRA
  91.  
  92. DO i=1,RIGI(/1)
  93. RIGI(i)=0
  94. ENDDO
  95.  
  96. RIGI(1)=IPRIGI
  97. RIGI(2)=IPMASS
  98.  
  99.  
  100. IF (.NOT. QUAD) THEN
  101.  
  102. CALL DECALE(IPRIGI,IPMASS,REAL(SIGMA),IPBUFF)
  103. RIGI(4)=IPBUFF
  104.  
  105. ELSE
  106.  
  107. RIGI(3)=IPAMOR
  108.  
  109. CALL DECALE (IPAMOR,IPMASS,-REAL(SIGMA),IPINT)
  110. RIGI(5)=IPINT
  111.  
  112. CALL DECALE (IPRIGI,IPINT,-REAL(SIGMA),IPBUFF)
  113. RIGI(6)=IPBUFF
  114.  
  115. ENDIF
  116.  
  117. *Triangularisation des operateurs de travail si necessaire
  118. DO i=1,RIGI(/1)
  119.  
  120. IF (RIGI(i) .NE. 0) THEN
  121.  
  122. MRIGID=RIGI(i)
  123. SEGACT MRIGID
  124. IPCHO=ICHOLE
  125.  
  126. NRG = IRIGEL(/1)
  127. NBR = IRIGEL(/2)
  128.  
  129. SYME(i)=0
  130.  
  131. IF (NRG .GE. 7) THEN
  132. DO j=1,NBR
  133. IANTI=IRIGEL(7,j)
  134. IF (IANTI .GT. 0) THEN
  135. SYME(i)=1
  136. ENDIF
  137. ENDDO
  138. ENDIF
  139.  
  140. SEGDES MRIGID
  141.  
  142. IF (IPCHO .EQ. 0) THEN
  143. IPBUFF=RIGI(i)
  144. IF (SYME(i) .EQ. 0) THEN
  145. CALL TRIANG (IPBUFF,1.D-18,0)
  146. IF (IERR .NE. 0) RETURN
  147. ELSE
  148. CALL LDMT1(IPBUFF,1.D-18)
  149. IF (IERR .NE. 0) RETURN
  150. ENDIF
  151. RIGI(i)=IPBUFF
  152. ENDIF
  153.  
  154. ENDIF
  155.  
  156. ENDDO
  157.  
  158.  
  159. IPRTRA=MRITRA
  160. SEGDES MRITRA
  161.  
  162. END
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  

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