Télécharger proch1.eso

Retour à la liste

Numérotation des lignes :

  1. C PROCH1 SOURCE CHAT 09/10/09 21:21:56 6519
  2. C SUBROUTINE PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU,LIMAGE,IBASC,
  3. C INSYM)
  4. ************************************************************************
  5. *
  6. * P R O C H 1
  7. * -----------
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. * EXECUTER LA FONCTION ATTRIBUEE A L'OPERATEUR "PROCHE".
  13. * VOIR LE SOUS-PROGRAMME "PROCHE".
  14. *
  15. * MODE D'APPEL:
  16. * -------------
  17. *
  18. * CALL PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU,LIMAGE)
  19. *
  20. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  21. * -----------
  22. *
  23. * IPFREQ ENTIER (E) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT LA
  24. * SUITE DE FREQUENCES A APPROCHER PAR DES
  25. * FREQUENCES PROPRES.
  26. * IPNMOD ENTIER (E) POINTEUR DE L'OBJET 'LISTENTI' CONTENANT LA
  27. * SUITE DES ORDRES DE MULTIPLICITE DES FREQUENCES
  28. * PROPRES
  29. * IPRIGI ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT
  30. * LA MATRICE DE RIGIDITE.
  31. * IPMASS ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT
  32. * LA MATRICE MASSE.
  33. * IPSOLU ENTIER (S) POINTEUR DE L'OBJET 'SOLUTION' CONTENANT
  34. * LA SUITE DE MODES PROPRES SOLUTIONS.
  35. * INSYM ENTIER INDIQUE LA NON SYMETRIE DE LA MATRICE
  36. * DE RIGIDITE
  37. * LIMAGE BOOLEEN (E) VRAI SI ON SOUHAITE DES FREQ. NEGATIVES.
  38. * IBASC TABLE (S) TABLE D'OBJETS SOLUTION CAS NON SYMETRIQUE
  39. *
  40. *
  41. *
  42. * AUTEUR, DATE DE CREATION:
  43. * -------------------------
  44. *
  45. * PASCAL MANIGOT 16 OCTOBRE 1984 ( ESOPE )
  46. *
  47. * MODIFICATION :
  48. *---------------
  49. * C. LE BIDEAU JUILLET 2001
  50. * Benoit PRABEL MARS 2009
  51. *
  52. ************************************************************************
  53.  
  54. SUBROUTINE PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU,
  55. & LIMAGE,IBASC, INSYM)
  56.  
  57. IMPLICIT INTEGER(I-N)
  58. IMPLICIT REAL*8 (A-H,O-Z)
  59.  
  60. -INC CCOPTIO
  61. -INC SMLREEL
  62. -INC SMLENTI
  63. -INC SMRIGID
  64. -INC SMTABLE
  65.  
  66.  
  67. ******
  68. * -- PARAMETRES --
  69. ***
  70. POINTEUR IPFREQ.MLREEL, IPNMOD.MLENTI , IBASC.MTABLE
  71. INTEGER IPRIGI, IPMASS, IPSOLU,INF0,INSYM, NRG, NBR
  72. LOGICAL LIMAGE
  73.  
  74. ******
  75. * -- VARIABLES LOCALES --
  76. ***
  77. REAL*8 FREQ
  78. INTEGER NBFREQ, NBMOD, IB100, IPSOL1, IPMODE, I
  79.  
  80. INF0 = 0
  81. INSYM = 0
  82.  
  83. SEGACT ,IPFREQ, IPNMOD
  84. NBFREQ = IPFREQ.PROG(/1)
  85. ******
  86. * --TEST DE LA SYMETRIE--
  87. ******
  88.  
  89. MRIGID=IPRIGI
  90. SEGACT MRIGID*MOD
  91. NRG = IRIGEL(/1)
  92. NBR = IRIGEL(/2)
  93. IF(NBR.EQ.0) THEN
  94. SEGDES MRIGID
  95. CALL ERREUR(727)
  96. RETURN
  97. ENDIF
  98. *
  99. *
  100. IF (NRG.GE.7) THEN
  101. C ... On teste si la matrice contient des matrices non symétriques ...
  102. *
  103. *
  104. DO 9 IN = 1,NBR
  105. IANTI=IRIGEL(7,IN)
  106. IF(IANTI.GT.0) THEN
  107. IF(NORINC.NE.0.AND.NORIND.EQ.0) THEN
  108. CALL ERREUR(760)
  109. SEGDES,MRIGID
  110. RETURN
  111. ENDIF
  112. *
  113. INSYM = 1
  114. ENDIF
  115. 9 CONTINUE
  116. END IF
  117. * WRITE(6,*)'INSYM = ',INSYM
  118. *
  119. ******
  120. * -- POUR CHAQUE FREQUENCE --
  121. ***
  122. *
  123. IF (INSYM .EQ. 1) THEN
  124. I = 1
  125. CALL CRTABL(IBASC)
  126. CALL ECCTAB(IBASC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  127. & 'MOT',0,0.0D0,'TABLE_DE_MODES',.TRUE.,0)
  128. CALL CRTABL(MTAB3)
  129. CALL ECCTAB(IBASC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  130. & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
  131. *
  132. ******
  133. * CREATION DE L'OBJET SOLUTION
  134. ***
  135. *
  136. CALL CRTABL(MTAB3)
  137. CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.
  138. & ,0,'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
  139.  
  140. END IF
  141. DO 100 IB100=1,NBFREQ
  142. FREQ = IPFREQ.PROG(IB100)
  143. NBMOD = IPNMOD.LECT(IB100)
  144. ******
  145. * -- RECHERCHE D'UN MODE ET AJOUT A L'ENSEMBLE DES MODES
  146. * DEJA TROUVES. POUR LES MODES SIMPLES, ON UTILISE LA
  147. * METHODE DE LA PUISSANCE INVERSE. POUR LES MODES MULTIPLES
  148. * L'ITERATION D'UN SOUS-ESPACE. --
  149. ***
  150. IF ( NBMOD .LE. 1 ) THEN
  151. IALEAT = 0
  152. CALL PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE,
  153. & INSYM, MTAB3,I)
  154. IF ( IERR .NE. 0 ) RETURN
  155. if (IALEAT.ne.0) CALL DTCHPO ( IALEAT )
  156. ELSE
  157. CALL PROCH3 (FREQ,NBMOD,IPRIGI,IPMASS,INF0,IPMODE,
  158. & LIMAGE,INSYM, MTAB3, I)
  159. ENDIF
  160. IF ( IERR .NE. 0 ) RETURN
  161. *
  162. *
  163. IF (INSYM .EQ. 0 ) THEN
  164. IF (IB100 .EQ. 1) THEN
  165. IPSOLU = IPMODE
  166. ELSE
  167. CALL FUSOLU (IPSOLU, IPMODE, IPSOL1)
  168. IF ( IERR .NE. 0 ) RETURN
  169. CALL DESOLU(IPMODE)
  170. IF ( IERR .NE. 0 ) RETURN
  171. CALL DESOLU(IPSOLU)
  172. IF ( IERR .NE. 0 ) RETURN
  173. IPSOLU = IPSOL1
  174. ENDIF
  175. ****
  176. ** SI MODES COMPLEXES, TABLES D'OBJETS SOLUTIONS
  177. ** UN ELEMENT DE MBASC CORRESPOND A UN COUPLE SOLUTION
  178. ****
  179. ELSE
  180.  
  181. CALL ECCTAB(IBASC,'MOT',0,0.0D0,'MODES',.TRUE.,0,
  182. & 'TABLE',0,0.0D0,' ',.TRUE.,MTAB3)
  183. END IF
  184. 100 CONTINUE
  185. SEGDES ,IPFREQ, IPNMOD
  186. RETURN
  187. END
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  

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