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

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