Télécharger proch2.eso

Retour à la liste

Numérotation des lignes :

  1. C PROCH2 SOURCE CB215821 19/07/31 21:16:46 10277
  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.  
  93. -INC PPARAM
  94. -INC CCOPTIO
  95. -INC SMTABLE
  96. *
  97. PARAMETER (LPROPR = 10)
  98. *
  99. LOGICAL CONVRG,LIMAGE
  100. *
  101. REAL*8 PROPRE(LPROPR),PROPR2(LPROPR)
  102. *
  103. PARAMETER (ITERMX = 100)
  104. PARAMETER (PRECI1 = 1.D-10)
  105. PARAMETER (PRECI2 = 1.D-11)
  106. PARAMETER (DEUXPI = (2.D0*XPI))
  107. PARAMETER (NUMACC = 999999)
  108. *
  109. * -- CREATION DE (K-W2M) --
  110. *
  111. W2 = (FREQ * DEUXPI) ** 2
  112. IF(LIMAGE) THEN
  113. W2 = SIGN(W2,FREQ)
  114. ENDIF
  115. CALL DECALE (IPRIGI,IPMASS, W2, IPKW2M)
  116. IF (IERR .NE. 0) RETURN
  117. *
  118. * -- INITIALISATION DES ITERATIONS: CREATION D'UN 'CHPOINT'
  119. * ALEATOIRE --
  120. *
  121. IPRX = 0
  122. * bp (03.2009) : si on souhaite eventuellement fournir 1 CHPOINT
  123. call LIROBJ('CHPOINT ',ICHP1,0,IRET1)
  124. if(IRET1.eq.0) then
  125. IF(IALEAT.EQ.0) CALL ALEAT1 (IPKW2M,IALEAT)
  126. IF (IERR.NE.0) RETURN
  127. CALL COPIE2(IALEAT,IPRX)
  128. else
  129. call ACTOBJ('CHPOINT ',ICHP1,1)
  130. CALL COPIE2(ICHP1,IPRX)
  131. endif
  132. C
  133. C CALCUL DE M*X
  134. C
  135. CALL MUCPRI(IPRX,IPMASS,IPMX)
  136.  
  137. IF (IERR .NE. 0) RETURN
  138. IF (IIMPI .EQ. 747) THEN
  139. CALL ECCHPO (IPRX,0)
  140. END IF
  141. *
  142. * -- RESOLUTION PAR ITERATIONS INVERSES --
  143. *
  144. IF (INSYM .EQ. 0) THEN
  145. CALL ITINV (IPKW2M,IPMASS,IPRX,PROPRE,CONVRG,ITERMX,NUMACC
  146. & ,PRECI1,PRECI2,IPMX)
  147. PROPRE(6) = 0.D0
  148. IF (IERR .NE. 0) RETURN
  149. IF (.NOT.CONVRG) THEN
  150. INTERR(1) = ITERMX
  151. NUMERR = 151
  152. CALL ERREUR (NUMERR)
  153. END IF
  154. ELSE
  155. CALL ITINVC (IPKW2M,IPMASS,IPRX,IPIX,PROPRE,CONVRG,ITERMX,IPMX)
  156.  
  157. IF (IERR .NE. 0) RETURN
  158. IF (.NOT.CONVRG) THEN
  159. INTERR(1) = ITERMX
  160. NUMERR = 151
  161. CALL ERREUR (NUMERR)
  162. END IF
  163. END IF
  164. *
  165. * -- NUMERO DU MODE --
  166. *(relativement a W2=lambda^shift, puisque propre(1) est la valeur shiftée) --
  167. *
  168. if(PROPRE(1) .lt. 0.) then
  169. NUMOD2 = 0
  170. else
  171. NUMOD2 = 1
  172. endif
  173. *
  174. * -- FREQUENCE PROPRE --
  175. *
  176. IF (INSYM .EQ. 0 ) THEN
  177. CALL W2FREQ (PROPRE(1),W2, OMEGA2,FREQPP,LIMAGE)
  178. IF (IERR .NE. 0) RETURN
  179. PROPRE(1) = FREQPP
  180.  
  181. ELSE
  182. CALL W2FRQC (PROPRE(1), PROPRE(6), W2, XRW2, XIW2, XRFREQ,
  183. & XIFREQ)
  184. IF (IERR .NE. 0) RETURN
  185. * on se débarasse des erreurs d'arrondis de W2FRQC
  186. if (PROPRE(6) .eq. 0.) then
  187. if ( (PROPRE(1) + W2) .lt. 0.) then
  188. PROPRE(1)= 0.
  189. PROPRE(6)= XIFREQ
  190. else
  191. PROPRE(1)= XRFREQ
  192. PROPRE(6)= 0.
  193. endif
  194. else
  195. PROPRE(1)= XRFREQ
  196. PROPRE(6)= XIFREQ
  197. endif
  198. END IF
  199. *
  200. IF (IIMPI .EQ. 747) THEN
  201. IF (INSYM .EQ. 0) THEN
  202. WRITE (IOIMP,*) 'FREQUENCE PROPRE CALCULEE = ',FREQPP
  203. WRITE (IOIMP,*) '-------------------------'
  204. WRITE (IOIMP,*) 'CHPOINT PROPRE:'
  205. CALL ECCHPO (IPRX,0)
  206. ELSE
  207. WRITE (IOIMP,*) 'FREQUENCE PROPRE REELLE CALCULEE = ',XRFREQ
  208. IF (PROPRE(6) .NE. 0) THEN
  209. WRITE (IOIMP,*) 'FREQUENCE PROPRE IMAGINAIRE CALCULEE = ',XIFREQ
  210. END IF
  211. WRITE (IOIMP,*) '-------------------------'
  212. WRITE (IOIMP,*) 'CHPOINT PROPRE REEL:'
  213. CALL ECCHPO (IPRX,0)
  214. IF (PROPRE(6) .NE. 0) THEN
  215. WRITE (IOIMP,*) 'CHPOINT PROPRE IMAGINAIRE:'
  216. CALL ECCHPO (IPIX,0)
  217. END IF
  218. END IF
  219. END IF
  220. *
  221. * -- CREATION DE L'OBJET REPRESENTANT LE MODE --
  222. *
  223. * NUMOD2 = 0
  224. IF (INSYM .EQ. 0) THEN
  225. * CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,FREQ,NUMOD2,IPMODE)
  226. CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,NUMOD2,IPMODE)
  227. IF (IERR .NE. 0) RETURN
  228. ELSE
  229. * CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I)
  230. CALL CREBAS (PROPRE,IPRX,IPIX,IPKW2M,INF0,NUMOD2,MTAB3,I)
  231. I = I + 1
  232. * dans le Cas d'un mode Reel Double,
  233. * on a stocké dans IPIX le 2eme vecteur du sous espace
  234. if( ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.))
  235. & .and. (IPIX .ne. 0) ) then
  236. do ipro2=1,LPROPR
  237. PROPR2(ipro2) = PROPRE(ipro2)
  238. enddo
  239. PROPR2(2)=PROPRE(7)
  240. * CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I)
  241. CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,NUMOD2,MTAB3,I)
  242. I = I + 1
  243. endif
  244. END IF
  245. *
  246. * IMPRESSION DU MODE:
  247. IF (IIMPI.EQ.2) THEN
  248. IF (INSYM .EQ. 0) THEN
  249. WRITE (IOIMP,2000)
  250. 2000 FORMAT ('1MODE PROPRE CALCULE:'/' --------------------'//)
  251. CALL ECMODE (IPMODE)
  252. ELSE
  253. CALL ECTABL (MTAB3)
  254. END IF
  255. ENDIF
  256. *
  257. * -- SUPPRESSION DES OBJETS DE TRAVAIL --
  258. *
  259. CALL DTRIGI (IPKW2M)
  260. *
  261. END
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  

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