Télécharger proch2.eso

Retour à la liste

Numérotation des lignes :

  1. C PROCH2 SOURCE PV 15/07/10 21:15:12 8569
  2. SUBROUTINE PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,
  3. & LIMAGE, INSYM, MTAB3,I)
  4. ************************************************************************
  5. *
  6. * P R O C H 2
  7. * -----------
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. * RECHERCHE D'UN MODE PROPRE.
  13. *
  14. * MODE D'APPEL:
  15. * -------------
  16. *
  17. * CALL PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE,INSYM)
  18. *
  19. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  20. * -----------
  21. *
  22. * FREQ REEL DP (E) FREQUENCE A APPROCHER PAR UNE FREQUENCE
  23. * PROPRE.
  24. * IPRIGI ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT
  25. * LA MATRICE DE RIGIDITE.
  26. * IPMASS ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT
  27. * LA MATRICE MASSE.
  28. * INF0 ENTIER (E) NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA
  29. * 'RIGIDITE' "K" DECOMPOSEE EN L.D.LT .
  30. * CE NOMBRE N'EST PAS NUL A CAUSE DE LA FACON
  31. * DONT SONT INTRODUITS LES BLOCAGES DES
  32. * D.D.L. (MULTIPLICATEURS DE LAGRANGE "LX").
  33. * IPMODE ENTIER (S) POINTEUR DE L'OBJET 'SOLUTION' CONTENANT
  34. * LE MODE PROPRE TROUVE.
  35. * INSYM ENTIER (E) INDICATEUR DE LA NON SYMETRIE DE LA RIGIDITE
  36. * NON SYMETRIQUE: MODES COMPLEXES
  37. * MTAB3 TABLE (S) TABLE D'UN COUPLE SOLUTION
  38. *
  39. * LEXIQUE: (ORDRE ALPHABETIQUE)
  40. * --------
  41. *
  42. * CONVRG LOGIQUE VOIR LE SOUS-PROGRAMME "ITINV".
  43. * FREDEC REEL DP FREQUENCE DE DECALAGE EFFECTIVE (EN GENERAL,
  44. * EGALE A "FREQ")
  45. * FREQPP REEL DP FREQUENCE PROPRE CALCULEE PROCHE DE "FREQ".
  46. * IPKW2M ENTIER POINTEUR DE LA 'RIGIDITE' "DECALEE" K - W2.M
  47. * IPRX ENTIER POINTEUR DU 'CHPOINT' QUI CONTIENT DES NOMBRES
  48. * ALEATOIRES, PUIS UN VECTEUR PROPRE REEL.
  49. * IPIX ENTIER POINTEUR DU 'CHPOINT' CONTENANT UN VECTEUR
  50. * PROPRE IMAGINAIRE EN FIN D'ITERATIONS
  51. * ITERMX ENTIER VOIR LE SOUS-PROGRAMME "ITINV".
  52. * NUMACC ENTIER VOIR LE SOUS-PROGRAMME "ITINV".
  53. * OMEGA2 REEL DP PULSATION PROPRE TROUVEE AU CARRE.
  54. * PRECI1 REEL SP VOIR LE SOUS-PROGRAMME "ITINV".
  55. * PRECI2 REEL SP VOIR LE SOUS-PROGRAMME "ITINV".
  56. * PROPRE REEL DP VOIR LE SOUS-PROGRAMME "ITINV".
  57. * W2 REEL DP PULSATION AU CARRE A APPROCHER.
  58. *
  59. * MODE DE FONCTIONNEMENT:
  60. * -----------------------
  61. *
  62. * LE CALCUL D'UN VECTEUR PROPRE SE FAIT PAR LA METHODE DES
  63. * ITERATIONS INVERSES (DITE AUSSI DE LA PUISSANCE INVERSE), AVEC
  64. * DECALAGE INITIAL ("SHIFTING").
  65. *
  66. * SOUS-PROGRAMMES APPELES:
  67. * ------------------------
  68. *
  69. * ALEAT1, CREMOD, DECALE, DTRIGI, ECCHPO, ECSOLU, ERREUR, ITINV,
  70. * ITINVC, W2FREQ.
  71. *
  72. * AUTEUR, DATE DE CREATION:
  73. * -------------------------
  74. *
  75. * PASCAL MANIGOT 16 OCTOBRE 1984
  76. *
  77. * MODIFICATION
  78. *-------------
  79. * C. LE BIDEAU JUILLET 2001
  80. * Benoit PRABEL MARS 2009
  81. *
  82. * LANGAGE:
  83. * --------
  84. *
  85. * FORTRAN77 + ESOPE
  86. *
  87. ************************************************************************
  88. *
  89. IMPLICIT INTEGER(I-N)
  90. IMPLICIT REAL*8 (A-H,O-Z)
  91. -INC CCREEL
  92. -INC CCOPTIO
  93. -INC SMTABLE
  94. *
  95. PARAMETER (LPROPR = 10)
  96. *
  97. LOGICAL CONVRG,LIMAGE
  98. *
  99. REAL*8 PROPRE(LPROPR),PROPR2(LPROPR)
  100. *
  101. PARAMETER (ITERMX = 30)
  102. PARAMETER (PRECI1 = 1.D-8)
  103. PARAMETER (PRECI2 = 1.D-8)
  104. PARAMETER (DEUXPI = (2.D0*XPI))
  105. PARAMETER (NUMACC = 5)
  106. *
  107. * -- CREATION DE (K-W2M) --
  108. *
  109. W2 = (FREQ * DEUXPI) ** 2
  110. IF(LIMAGE) THEN
  111. W2 = SIGN(W2,FREQ)
  112. ENDIF
  113. CALL DECALE (IPRIGI,IPMASS, W2, IPKW2M)
  114. IF (IERR .NE. 0) RETURN
  115. *
  116. * -- INITIALISATION DES ITERATIONS: CREATION D'UN 'CHPOINT'
  117. * ALEATOIRE --
  118. *
  119. IPRX = 0
  120. * bp (03.2009) : si on souhaite eventuellement fournir 1 CHPOINT
  121. call LIROBJ('CHPOINT',ICHP1,0,IRET1)
  122. if(IRET1.eq.0) then
  123. IF(IALEAT.EQ.0) CALL ALEAT1 (IPKW2M,IALEAT)
  124. IF (IERR.NE.0) RETURN
  125. CALL COPIE2(IALEAT,IPRX)
  126. else
  127. CALL COPIE2(ICHP1,IPRX)
  128. endif
  129. C
  130. C CALCUL DE M*X
  131. C
  132. CALL MUCPRI(IPRX,IPMASS,IPMX)
  133.  
  134. IF (IERR .NE. 0) RETURN
  135. IF (IIMPI .EQ. 747) THEN
  136. CALL ECCHPO (IPRX,0)
  137. END IF
  138. *
  139. * -- RESOLUTION PAR ITERATIONS INVERSES --
  140. *
  141. IF (INSYM .EQ. 0) THEN
  142. CALL ITINV (IPKW2M,IPMASS,IPRX,PROPRE,CONVRG,ITERMX,NUMACC
  143. & ,PRECI1,PRECI2,IPMX)
  144. PROPRE(6) = 0.D0
  145. IF (IERR .NE. 0) RETURN
  146. IF (.NOT.CONVRG) THEN
  147. INTERR(1) = ITERMX
  148. NUMERR = 151
  149. CALL ERREUR (NUMERR)
  150. END IF
  151. ELSE
  152. CALL ITINVC (IPKW2M,IPMASS,IPRX,IPIX,PROPRE,CONVRG,ITERMX,IPMX)
  153.  
  154. IF (IERR .NE. 0) RETURN
  155. IF (.NOT.CONVRG) THEN
  156. INTERR(1) = ITERMX
  157. NUMERR = 151
  158. CALL ERREUR (NUMERR)
  159. END IF
  160. END IF
  161. *
  162. * -- NUMERO DU MODE --
  163. *(relativement a W2=lambda^shift, puisque propre(1) est la valeur shiftée) --
  164. *
  165. if(PROPRE(1) .lt. 0.) then
  166. NUMOD2 = 0
  167. else
  168. NUMOD2 = 1
  169. endif
  170. *
  171. * -- FREQUENCE PROPRE --
  172. *
  173. IF (INSYM .EQ. 0 ) THEN
  174. CALL W2FREQ (PROPRE(1),W2, OMEGA2,FREQPP,LIMAGE)
  175. IF (IERR .NE. 0) RETURN
  176. PROPRE(1) = FREQPP
  177.  
  178. ELSE
  179. CALL W2FRQC (PROPRE(1), PROPRE(6), W2, XRW2, XIW2, XRFREQ,
  180. & XIFREQ)
  181. IF (IERR .NE. 0) RETURN
  182. * on se débarasse des erreurs d'arrondis de W2FRQC
  183. if (PROPRE(6) .eq. 0.) then
  184. if ( (PROPRE(1) + W2) .lt. 0.) then
  185. PROPRE(1)= 0.
  186. PROPRE(6)= XIFREQ
  187. else
  188. PROPRE(1)= XRFREQ
  189. PROPRE(6)= 0.
  190. endif
  191. else
  192. PROPRE(1)= XRFREQ
  193. PROPRE(6)= XIFREQ
  194. endif
  195. END IF
  196. *
  197. IF (IIMPI .EQ. 747) THEN
  198. IF (INSYM .EQ. 0) THEN
  199. WRITE (IOIMP,*) 'FREQUENCE PROPRE CALCULEE = ',FREQPP
  200. WRITE (IOIMP,*) '-------------------------'
  201. WRITE (IOIMP,*) 'CHPOINT PROPRE:'
  202. CALL ECCHPO (IPRX,0)
  203. ELSE
  204. WRITE (IOIMP,*) 'FREQUENCE PROPRE REELLE CALCULEE = ',XRFREQ
  205. IF (PROPRE(6) .NE. 0) THEN
  206. WRITE (IOIMP,*) 'FREQUENCE PROPRE IMAGINAIRE CALCULEE = ',XIFREQ
  207. END IF
  208. WRITE (IOIMP,*) '-------------------------'
  209. WRITE (IOIMP,*) 'CHPOINT PROPRE REEL:'
  210. CALL ECCHPO (IPRX,0)
  211. IF (PROPRE(6) .NE. 0) THEN
  212. WRITE (IOIMP,*) 'CHPOINT PROPRE IMAGINAIRE:'
  213. CALL ECCHPO (IPIX,0)
  214. END IF
  215. END IF
  216. END IF
  217. *
  218. * -- CREATION DE L'OBJET REPRESENTANT LE MODE --
  219. *
  220. * NUMOD2 = 0
  221. IF (INSYM .EQ. 0) THEN
  222. * CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,FREQ,NUMOD2,IPMODE)
  223. CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,NUMOD2,IPMODE)
  224. IF (IERR .NE. 0) RETURN
  225. ELSE
  226. * CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I)
  227. CALL CREBAS (PROPRE,IPRX,IPIX,IPKW2M,INF0,NUMOD2,MTAB3,I)
  228. I = I + 1
  229. * dans le Cas d'un mode Reel Double,
  230. * on a stocké dans IPIX le 2eme vecteur du sous espace
  231. if( ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.))
  232. & .and. (IPIX .ne. 0) ) then
  233. do ipro2=1,LPROPR
  234. PROPR2(ipro2) = PROPRE(ipro2)
  235. enddo
  236. PROPR2(2)=PROPRE(7)
  237. * CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I)
  238. CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,NUMOD2,MTAB3,I)
  239. I = I + 1
  240. endif
  241. END IF
  242. *
  243. * IMPRESSION DU MODE:
  244. IF (IIMPI.EQ.2) THEN
  245. IF (INSYM .EQ. 0) THEN
  246. WRITE (IOIMP,2000)
  247. 2000 FORMAT ('1MODE PROPRE CALCULE:'/' --------------------'//)
  248. CALL ECMODE (IPMODE)
  249. ELSE
  250. CALL ECTABL (MTAB3)
  251. END IF
  252. ENDIF
  253. *
  254. * -- SUPPRESSION DES OBJETS DE TRAVAIL --
  255. *
  256. CALL DTRIGI (IPKW2M)
  257. *
  258. END
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  

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