Télécharger crebas.eso

Retour à la liste

Numérotation des lignes :

  1. C CREBAS SOURCE CHAT 09/10/09 21:16:42 6519
  2. * SUBROUTINE CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,FREQ,
  3. * > NUMODE2,MTAB3,I)
  4. SUBROUTINE CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,
  5. > NUMODE2,MTAB3,I)
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8 (A-H,O-Z)
  8. ************************************************************************
  9. *
  10. * C R E B A S
  11. * -----------
  12. *
  13. * FONCTION:
  14. * ---------
  15. *
  16. * CREATION D'UNE BASE DE MODES PROPRES COMPLEXES POUR PROCHE
  17. *
  18. * MODE D'APPEL:
  19. * -------------
  20. *
  21. * CALL CREBAS (PROPRE,IPRX, IPIX,IPKW2M,INF0,FREQ,NUMODE2,MTAB3)
  22. *
  23. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  24. * -----------
  25. *
  26. * PROPRE REEL DP (E) TABLEAU DE CARACTERISTIQUES DU MODE PROPRE
  27. * CALCULE:
  28. * PROPRE(1) = FREQUENCE PROPRE REELLE,
  29. * PROPRE(2) = MASSE GENERALISEE,
  30. * PROPRE(3,4 ET 5) = DEPLACEMENTS GENERALISES
  31. * REELS
  32. * PROPRE(6) = FREQUENCE PROPRE IMAGINAIRE
  33. * PROPRE(8,9,10) = DEPL. GEN. IMAGINAIRES
  34. * IPRX ENTIER (E) POINTEUR DU 'CHPOINT' PROPRE REEL.
  35. * IPIX ENTIER (E) POINTEUR DU 'CHPOINT' PROPRE IMAGINAIRE.
  36. * IPKW2M ENTIER (E) POINTEUR DE LA 'RIGIDITE' "DECALEE" QUI A
  37. * SERVI AU CALCUL DU MODE PROPRE.
  38. * INF0 ENTIER (E) NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA
  39. * 'RIGIDITE' "K" NON "DECALEE" LORSQU'ELLE
  40. * EST DECOMPOSEE EN LT.D.L.
  41. * FREQ REEL DP (E) FREQUENCE QUI A ETE UTILISEE POUR LE
  42. * DECALAGE DE LA 'RIGIDITE' "K".
  43. * MTAB3 TABLE (S) POINTEUR DE L'OBJET 'SOLUTION' REPRESENTANT
  44. * LA BASE DE MODE PROPRE.
  45. *
  46. * SOUS-PROGRAMMES APPELES:
  47. * ------------------------
  48. *
  49. * DIAGN1, ECR..., LIR.ALL/LIMO.
  50. *
  51. * AUTEUR, DATE DE CREATION:
  52. * -------------------------
  53. *
  54. * C. LE BIDEAU JUILLET 2001
  55. * MODIF: Benoit Prabel Mars 2009
  56. *
  57. * LANGAGE:
  58. * --------
  59. *
  60. * FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS.
  61. *
  62. ************************************************************************
  63. *
  64. -INC CCOPTIO
  65. -INC SMTABLE
  66. -INC CCREEL
  67. -INC SMLCHPO
  68. -INC SMLMOTS
  69. -INC SMCHPOI
  70. -INC SMRIGID
  71. *
  72. REAL*8 PROPRE(*)
  73. *
  74. *******************************************
  75. * Creation de la table BASE_DE_MODES *
  76. *******************************************
  77. *
  78. CALL CRTABL(IPTAB2)
  79. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  80. & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0)
  81.  
  82.  
  83. *
  84. *******************************************
  85. * VERIFICATION DU MODES *
  86. *******************************************
  87. *
  88. * NUMERO DU MODE
  89. CALL DIAGN1(IPKW2M,NMODEN)
  90. * BP : Attention !!! le nombre de terme négatif de [K-wshift^2M]
  91. * n'a pas vraiment le meme sens que dans le cas symetrique
  92. * (qui est = au nombre de val propre < shift) !!!
  93. IF (IERR .NE. 0) RETURN
  94. NUMODE = NMODEN + NUMODE2
  95. NUMODE = NUMODE - INF0
  96. * write(6,*)'crebas : (NMODEN + NUMODE2) - INFO = NUMODE'
  97. * write(6,*) NMODEN,NUMODE2,INF0,NUMODE
  98. * selon CREMOD, INF0 est toujours nul car le traitement des LX a changé,
  99. * et le nbre de terme diag <0 est bien celui des inconnues en depalcements
  100. *
  101. *******************************************
  102. * CREATION DU MODE
  103. *******************************************
  104.  
  105. * si lambda_I = 0 (<=> w Re ou Im pur), alors vp réel
  106. * IF ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.)) GOTO 1000
  107.  
  108.  
  109. *------- Cas d'un mode Complexe ---------------------------------------*
  110.  
  111. ZERO = 0.D0
  112. CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)
  113. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'NUMERO_MODE',.TRUE.,0,
  114. & 'ENTIER',NUMODE,0.D0,' ',.TRUE.,0)
  115. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'POINT_REPERE',.TRUE.,0,
  116. & 'POINT',0,0.D0,' ',.TRUE.,IPOIN)
  117.  
  118. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'FREQUENCE_REELLE',.TRUE.,0,
  119. & 'FLOTTANT',0,PROPRE(1),' ',.TRUE.,0)
  120. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'FREQUENCE_IMAGINAIRE',.TRUE.,0
  121. & ,'FLOTTANT',0,PROPRE(6),' ',.TRUE.,0)
  122.  
  123. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'MASSE_GENERALISEE',.TRUE.,0
  124. & ,'FLOTTANT',0,PROPRE(2),' ',.TRUE.,0)
  125.  
  126. if(IPRX .ne. 0) then
  127. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_REELLE',
  128. & .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IPRX)
  129. else
  130. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_REELLE',
  131. & .TRUE.,0,'MOT',0,0.D0,'NULLE',.TRUE.,0)
  132. endif
  133. if(IPIX .ne. 0) then
  134. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_IMAGINAIRE',
  135. & .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IPIX)
  136. else
  137. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'DEFORMEE_MODALE_IMAGINAIRE',
  138. & .TRUE.,0,'MOT',0,0.D0,'NULLE',.TRUE.,0)
  139. endif
  140. *
  141. * DEPLACEMENTS GENERALISES
  142.  
  143. if(IPRX .ne. 0) then
  144. CALL CRTABL(IPTDG11)
  145. CALL ECCTAB(IPTDG11,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  146. & 'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',.TRUE.,0)
  147. CALL ECCTAB(IPTDG11,'ENTIER',1,0.0D0,' ',
  148. & .TRUE.,0,'FLOTTANT',0,PROPRE(3),' ',.TRUE.,0)
  149. CALL ECCTAB(IPTDG11,'ENTIER',2,0.0D0,' ',
  150. & .TRUE.,0,'FLOTTANT',0,PROPRE(4),' ',.TRUE.,0)
  151. CALL ECCTAB(IPTDG11,'ENTIER',3,0.0D0,' ',
  152. & .TRUE.,0,'FLOTTANT',0,PROPRE(5),' ',.TRUE.,0)
  153. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,
  154. & 'DEPLACEMENTS_GENERALISES_REELS',
  155. & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG11)
  156. endif
  157.  
  158. if(IPIX .ne. 0) then
  159. CALL CRTABL(IPTDG3)
  160. CALL ECCTAB(IPTDG3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  161. & 'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_IMAGINAIRES',.TRUE.,0)
  162. CALL ECCTAB(IPTDG3,'ENTIER',1,0.0D0,' ',
  163. & .TRUE.,0,'FLOTTANT',0,PROPRE(8),' ',.TRUE.,0)
  164. CALL ECCTAB(IPTDG3,'ENTIER',2,0.0D0,' ',
  165. & .TRUE.,0,'FLOTTANT',0,PROPRE(9),' ',.TRUE.,0)
  166. CALL ECCTAB(IPTDG3,'ENTIER',3,0.0D0,' ',
  167. & .TRUE.,0,'FLOTTANT',0,PROPRE(10),' ',.TRUE.,0)
  168. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,
  169. & 'DEPLACEMENTS_GENERALISES_IMAGINAIRES',
  170. & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG3)
  171. endif
  172.  
  173. c Ecriture dans MTAB3 . I
  174. CALL ECCTAB(MTAB3,'ENTIER',I,0.0D0,' ',
  175. & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2)
  176.  
  177. GOTO 2000
  178.  
  179. *
  180. *------- Cas des modes Reels ---------------------------------------*
  181. * L'ecriture specifique pour ce cas est abandonnée au profit de celle ci-dessus
  182. * qui est plus générale pour l'utilisation des données résultats
  183. * 1000 CONTINUE
  184. *
  185. * ZERO = 0.D0
  186. * CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)
  187. * CALL CRTABL(IPTAB2)
  188. * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'NUMERO_MODE',.TRUE.,0,
  189. * & 'ENTIER',NUMODE,0.0D0,' ',.TRUE.,0)
  190. * CALL CREPO1(0.0D0,0.0D0,0.0D0,IPOIN)
  191. * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,
  192. * & 'POINT',0,0.0D0,' ',.TRUE.,IPOIN)
  193. * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'FREQUENCE_REELLE',.TRUE.
  194. * & ,0,'FLOTTANT',0,PROPRE(1),' ',.TRUE.,0)
  195. * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MASSE_GENERALISEE',.TRUE.
  196. * & ,0,'FLOTTANT',0,PROPRE(2),' ',.TRUE.,0)
  197. * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
  198. * & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,IPRX)
  199. * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'COMPOSANTES_IMAGINAIRES',
  200. * & .TRUE.,0,'MOT',0,0.0D0,'NULLES',.TRUE.,0)
  201. **
  202. ** DEPLACEMENTS GENERALISES
  203. **
  204. * CALL CRTABL(IPTDG11)
  205. * CALL ECCTAB(IPTDG11,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  206. * & 'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',.TRUE.,0)
  207. *
  208. * CALL ECCTAB(IPTDG11,'ENTIER',1,0.0D0,' ',
  209. * & .TRUE.,0,'FLOTTANT',0,PROPRE(3),' ',.TRUE.,0)
  210. * CALL ECCTAB(IPTDG11,'ENTIER',2,0.0D0,' ',
  211. * & .TRUE.,0,'FLOTTANT',0,PROPRE(4),' ',.TRUE.,0)
  212. * CALL ECCTAB(IPTDG11,'ENTIER',3,0.0D0,' ',
  213. * & .TRUE.,0,'FLOTTANT',0,PROPRE(5),' ',.TRUE.,0)
  214. **
  215. ** CREATION DE L'OBJET SOLUTION REEL
  216. **
  217. * CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'DEPLACEMENTS_GENERALISES_REELS',
  218. * & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTDG11)
  219. * CALL ECCTAB(MTAB3,'ENTIER',I,0.0D0,' ',
  220. * & .TRUE.,0,'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2)
  221.  
  222.  
  223.  
  224. 2000 CONTINUE
  225.  
  226. END
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  

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