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 PPARAM
  61. -INC CCOPTIO
  62. -INC SMLREEL
  63. -INC SMLENTI
  64. -INC SMRIGID
  65. -INC SMTABLE
  66.  
  67.  
  68. ******
  69. * -- PARAMETRES --
  70. ***
  71. POINTEUR IPFREQ.MLREEL, IPNMOD.MLENTI , IBASC.MTABLE
  72. INTEGER IPRIGI, IPMASS, IPSOLU,INF0,INSYM, NRG, NBR
  73. LOGICAL LIMAGE
  74.  
  75. ******
  76. * -- VARIABLES LOCALES --
  77. ***
  78. REAL*8 FREQ
  79. INTEGER NBFREQ, NBMOD, IB100, IPSOL1, IPMODE, I
  80.  
  81. INF0 = 0
  82. INSYM = 0
  83.  
  84. SEGACT ,IPFREQ, IPNMOD
  85. NBFREQ = IPFREQ.PROG(/1)
  86. ******
  87. * --TEST DE LA SYMETRIE--
  88. ******
  89.  
  90. MRIGID=IPRIGI
  91. SEGACT MRIGID*MOD
  92. NRG = IRIGEL(/1)
  93. NBR = IRIGEL(/2)
  94. IF(NBR.EQ.0) THEN
  95. SEGDES MRIGID
  96. CALL ERREUR(727)
  97. RETURN
  98. ENDIF
  99. *
  100. *
  101. IF (NRG.GE.7) THEN
  102. C ... On teste si la matrice contient des matrices non symétriques ...
  103. *
  104. *
  105. DO 9 IN = 1,NBR
  106. IANTI=IRIGEL(7,IN)
  107. IF(IANTI.GT.0) THEN
  108. IF(NORINC.NE.0.AND.NORIND.EQ.0) THEN
  109. CALL ERREUR(760)
  110. SEGDES,MRIGID
  111. RETURN
  112. ENDIF
  113. *
  114. INSYM = 1
  115. ENDIF
  116. 9 CONTINUE
  117. END IF
  118. * WRITE(6,*)'INSYM = ',INSYM
  119. *
  120. ******
  121. * -- POUR CHAQUE FREQUENCE --
  122. ***
  123. *
  124. IF (INSYM .EQ. 1) THEN
  125. I = 1
  126. CALL CRTABL(IBASC)
  127. CALL ECCTAB(IBASC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  128. & 'MOT',0,0.0D0,'TABLE_DE_MODES',.TRUE.,0)
  129. CALL CRTABL(MTAB3)
  130. CALL ECCTAB(IBASC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  131. & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
  132. *
  133. ******
  134. * CREATION DE L'OBJET SOLUTION
  135. ***
  136. *
  137. CALL CRTABL(MTAB3)
  138. CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.
  139. & ,0,'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
  140.  
  141. END IF
  142. DO 100 IB100=1,NBFREQ
  143. FREQ = IPFREQ.PROG(IB100)
  144. NBMOD = IPNMOD.LECT(IB100)
  145. ******
  146. * -- RECHERCHE D'UN MODE ET AJOUT A L'ENSEMBLE DES MODES
  147. * DEJA TROUVES. POUR LES MODES SIMPLES, ON UTILISE LA
  148. * METHODE DE LA PUISSANCE INVERSE. POUR LES MODES MULTIPLES
  149. * L'ITERATION D'UN SOUS-ESPACE. --
  150. ***
  151. IF ( NBMOD .LE. 1 ) THEN
  152. IALEAT = 0
  153. CALL PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE,
  154. & INSYM, MTAB3,I)
  155. IF ( IERR .NE. 0 ) RETURN
  156. if (IALEAT.ne.0) CALL DTCHPO ( IALEAT )
  157. ELSE
  158. CALL PROCH3 (FREQ,NBMOD,IPRIGI,IPMASS,INF0,IPMODE,
  159. & LIMAGE,INSYM, MTAB3, I)
  160. ENDIF
  161. IF ( IERR .NE. 0 ) RETURN
  162. *
  163. *
  164. IF (INSYM .EQ. 0 ) THEN
  165. IF (IB100 .EQ. 1) THEN
  166. IPSOLU = IPMODE
  167. ELSE
  168. CALL FUSOLU (IPSOLU, IPMODE, IPSOL1)
  169. IF ( IERR .NE. 0 ) RETURN
  170. CALL DESOLU(IPMODE)
  171. IF ( IERR .NE. 0 ) RETURN
  172. CALL DESOLU(IPSOLU)
  173. IF ( IERR .NE. 0 ) RETURN
  174. IPSOLU = IPSOL1
  175. ENDIF
  176. ****
  177. ** SI MODES COMPLEXES, TABLES D'OBJETS SOLUTIONS
  178. ** UN ELEMENT DE MBASC CORRESPOND A UN COUPLE SOLUTION
  179. ****
  180. ELSE
  181.  
  182. CALL ECCTAB(IBASC,'MOT',0,0.0D0,'MODES',.TRUE.,0,
  183. & 'TABLE',0,0.0D0,' ',.TRUE.,MTAB3)
  184. END IF
  185. 100 CONTINUE
  186. SEGDES ,IPFREQ, IPNMOD
  187. RETURN
  188. END
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  

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