Télécharger arpope.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPOPE SOURCE PV 15/11/25 21:15:05 8707
  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. -INC CCOPTIO
  53. -INC SMRIGID
  54. -INC TARWORK
  55.  
  56.  
  57. INTEGER IPRIGI
  58. INTEGER IPMASS
  59. INTEGER IPAMOR
  60. LOGICAL QUAD
  61. COMPLEX*16 SIGMA
  62. INTEGER IPRTRA
  63.  
  64. INTEGER IPBUFF
  65. INTEGER IPINT
  66. INTEGER IPCHO
  67. INTEGER NBR, NRG
  68.  
  69. * Liste des operateurs construits
  70. *
  71. * K MATRICE DE RIGIDITE
  72. * M MATRICE DE MASSE
  73. * C MATRICE D'AMORTISSEMENT
  74.  
  75.  
  76. * RIGI(1)=K
  77. * RIGI(2)=M OU KSIGMA
  78. * RIGI(3)=C
  79. * RIGI(4)=K-RE(SIGMA)*M
  80. * RIGI(5)=C+RE(SIGMA)*M
  81. * RIGI(6)=K+RE(SIGMA)*(C+RE(SIGMA)*M)
  82.  
  83. * SYME indique si l'operateur construit est symetrique
  84. *ou non
  85.  
  86.  
  87. NB=6
  88. SEGINI MRITRA
  89.  
  90. DO i=1,RIGI(/1)
  91. RIGI(i)=0
  92. ENDDO
  93.  
  94. RIGI(1)=IPRIGI
  95. RIGI(2)=IPMASS
  96.  
  97.  
  98. IF (.NOT. QUAD) THEN
  99.  
  100. CALL DECALE(IPRIGI,IPMASS,REAL(SIGMA),IPBUFF)
  101. RIGI(4)=IPBUFF
  102.  
  103. ELSE
  104.  
  105. RIGI(3)=IPAMOR
  106.  
  107. CALL DECALE (IPAMOR,IPMASS,-REAL(SIGMA),IPINT)
  108. RIGI(5)=IPINT
  109.  
  110. CALL DECALE (IPRIGI,IPINT,-REAL(SIGMA),IPBUFF)
  111. RIGI(6)=IPBUFF
  112.  
  113. ENDIF
  114.  
  115. *Triangularisation des operateurs de travail si necessaire
  116. DO i=1,RIGI(/1)
  117.  
  118. IF (RIGI(i) .NE. 0) THEN
  119.  
  120. MRIGID=RIGI(i)
  121. SEGACT MRIGID
  122. IPCHO=ICHOLE
  123.  
  124. NRG = IRIGEL(/1)
  125. NBR = IRIGEL(/2)
  126.  
  127. SYME(i)=0
  128.  
  129. IF (NRG .GE. 7) THEN
  130. DO j=1,NBR
  131. IANTI=IRIGEL(7,j)
  132. IF (IANTI .GT. 0) THEN
  133. SYME(i)=1
  134. ENDIF
  135. ENDDO
  136. ENDIF
  137.  
  138. SEGDES MRIGID
  139.  
  140. IF (IPCHO .EQ. 0) THEN
  141. IPBUFF=RIGI(i)
  142. IF (SYME(i) .EQ. 0) THEN
  143. CALL TRIANG (IPBUFF,1.D-18,0)
  144. IF (IERR .NE. 0) RETURN
  145. ELSE
  146. CALL LDMT1(IPBUFF,1.D-18)
  147. IF (IERR .NE. 0) RETURN
  148. ENDIF
  149. RIGI(i)=IPBUFF
  150. ENDIF
  151.  
  152. ENDIF
  153.  
  154. ENDDO
  155.  
  156.  
  157. IPRTRA=MRITRA
  158. SEGDES MRITRA
  159.  
  160. END
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  

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