Télécharger qzrest.eso

Retour à la liste

Numérotation des lignes :

  1. C QZREST SOURCE BP208322 16/01/21 21:15:19 8791
  2. SUBROUTINE QZREST(IPBASR, IPBASC, MTAB1)
  3. *
  4. *****************************************************************************
  5. * RESTITUTION D'UNE BASE DE MODES COMPLEXES A PARTIR *
  6. * D'UNE BASE DE MODES COMPLEXES DEFINIE *
  7. * RELATIVEMENT A UNE BASE REELLE *
  8. * _________________________________________________________________________ *
  9. * *
  10. * DATE : le 31 Juillet 1995 *
  11. * AUTEUR : Nicolas BENECH *
  12. * _________________________________________________________________________ *
  13. * *
  14. * MODULE(S) APPELANT(S) : VIBRAC *
  15. * *
  16. * MODULE(S) APPELE(S) : ACCTAB, CRTABL, ECCTAB, EXTRA9, EXTR11 *
  17. * _________________________________________________________________________ *
  18. * *
  19. * EN ENTREE : *
  20. * - IPBASR : BASE DE MODES REELS PHYSIQUE *
  21. * - IPBASC : BASE DE MODES COMPLEXES RELATIVE A IPBASR *
  22. * _________________________________________________________________________ *
  23. * *
  24. * EN SORTIE : *
  25. * - MTAB1 : BASE DE MODES COMPLEXES PHYSIQUE *
  26. *****************************************************************************
  27. *
  28. IMPLICIT INTEGER(I-N)
  29. -INC CCOPTIO
  30. -INC SMCHPOI
  31. -INC SMCOORD
  32. -INC SMELEME
  33. -INC SMLMOTS
  34. -INC SMTABLE
  35. *
  36. REAL*8 XVALRE
  37. LOGICAL LOGRE
  38. CHARACTER*(8) CHARRE
  39. REAL*8 XVAL1, XVAL2, XVAL4
  40. INTEGER I, J, K, NNOEUD, NCOMP, NBMODR, NBMODC, SWAP, PT1, PT2
  41. INTEGER IOBRE
  42. LOGICAL AFFICH
  43. CHARACTER* (8) TYPEMODR, TYPEMODC
  44. CHARACTER*4 MOT1, MOT2
  45. *
  46. POINTEUR IPBASR2.MTABLE, IPBASR3.MTABLE
  47. POINTEUR IPBASC2.MTABLE, IPBASC3.MTABLE
  48. POINTEUR MCHPO5.MCHPOI
  49. *
  50. *----- Ecriture des messages pour verification
  51. NUMAFF = 23
  52. AFFICH = ((MOD(IIMPI, NUMAFF).EQ.0) .AND. (IIMPI.NE.0))
  53. * AFFICH = .TRUE.
  54. *
  55. *----- Fin faute de donnees
  56. IF (IPBASR*IPBASC .EQ. 0) RETURN
  57. *
  58. *----- Lecture des donnees
  59. IF (AFFICH) WRITE (*,*) 'Lecture des donnees ...'
  60. CALL ACCTAB(IPBASR,'MOT',0,0.0D0,'MODES',.TRUE.,0,
  61. & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR2)
  62. CALL ACCTAB(IPBASC,'MOT',0,0.0D0,'MODES',.TRUE.,0,
  63. & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC2)
  64. *
  65. * --- Tri des donnees
  66. IF (AFFICH) WRITE (*,*) 'TEST : ordre des donnees ...'
  67. CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0,
  68. & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3)
  69. CALL ACCTAB(IPBASC2,'ENTIER',1,0.0D0,' ',.TRUE.,0,
  70. & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC3)
  71. *
  72. CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  73. & 'MOT',IVALRE,XVALRE,TYPEMODR,LOGRE,IOBRE)
  74. CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  75. & 'MOT',IVALRE,XVALRE,TYPEMODC,LOGRE,IOBRE)
  76. IF (AFFICH) THEN
  77. WRITE (*,*) 'TYPEMODR = ',TYPEMODR
  78. WRITE (*,*) 'TYPEMODC = ',TYPEMODC
  79. ENDIF
  80. *
  81. IF (((TYPEMODR.EQ.'MODE_COM') .OR. (TYPEMODR.EQ.'MODE_ANN'))
  82. & .AND. (TYPEMODC.EQ.'MODE')) THEN
  83. IF (AFFICH) WRITE (*,*) 'Permutation !'
  84. SWAP=IPBASR
  85. IPBASR=IPBASC
  86. IPBASC=SWAP
  87. SWAP=IPBASR2
  88. IPBASR2=IPBASC2
  89. IPBASC2=SWAP
  90. TYPEMODR='MODE'
  91. TYPEMODC='MODE_COM'
  92. ENDIF
  93. IF (.NOT. AFFICH) GOTO 1
  94. IF ((TYPEMODR.EQ.'MODE') .AND. ((TYPEMODC.EQ.'MODE_COM')
  95. & .OR. (TYPEMODR.EQ.'MODE_ANN')))
  96. & THEN
  97. WRITE (*,*) 'OK'
  98. ELSE
  99. WRITE (*,*) 'Erreur !'
  100. ENDIF
  101. 1 CONTINUE
  102. *
  103. *******************************************
  104. * Donnees fondamentales *
  105. *******************************************
  106. * --- nombre de modes complexes
  107. SEGACT, IPBASC2
  108. NBMODC = IPBASC2.MLOTAB-2
  109. SEGDES, IPBASC2
  110. * --- nombre de modes reels
  111. SEGACT, IPBASR2
  112. NBMODR = IPBASR2.MLOTAB-2
  113. SEGDES, IPBASR2
  114. * --- nombre de SOUPO dans les chpoints reels
  115. CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0,
  116. & 'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3)
  117. CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE',.TRUE.,
  118. & 0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO1)
  119. *
  120. SEGACT, MCHPO1
  121. NSOUPO=MCHPO1.IPCHP(/1)
  122. SEGDES, MCHPO1
  123. *
  124. *************************************************
  125. * Creation de la table MTAB2 BASE_DE_MODES *
  126. *************************************************
  127. *
  128. IF (AFFICH) WRITE (*,*) 'Creation de la table BASE_DE_MODES ...'
  129. CALL CRTABL(MTAB2)
  130. CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  131. & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0)
  132. *
  133. CALL ACCTAB(IPBASR2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0,
  134. & 'MAILLAGE',IVALRE,XVALRE,CHARRE,LOGRE,IPT1)
  135. CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0,
  136. & 'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT1)
  137. *
  138. *
  139. *=========================================*
  140. * Boucle sur les modes Complexes *
  141. *=========================================*
  142. *
  143. DO 20, I=1, NBMODC
  144. IF (AFFICH) WRITE (*,*) 'Boucle sur les MODES ...', I
  145. *
  146. ************************************************
  147. * Creation de la table MTAB3 du MODE I *
  148. ************************************************
  149. *
  150. CALL ACCTAB(IPBASC2,'ENTIER',I,0.0D0,' ',.TRUE.,0,
  151. & 'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC3)
  152. SEGINI, MTAB3=IPBASC3
  153. SEGDES, MTAB3
  154. CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  155. & 'MOT',IVALRE,XVALRE,TYPEMODC,LOGRE,IOBRE)
  156. IF (TYPEMODC .EQ. 'MODE_ANN') GOTO 20
  157. *
  158. ***** CALCUL DE LA DEFORMEE MODALE (mchpo3 + i mchpo4) *****
  159. *
  160. * --- Recup de ALFA_R du mode I (=mchpo2)
  161. CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
  162. & .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO2)
  163. * --- Recup de ALFA_I du mode I (=mchpo2)
  164. CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE',
  165. & .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO4)
  166.  
  167. * --- creation du chpoint Resultat depuis le 1er chpoint mode reel mis à 0
  168. * partie réelle MCHPO3
  169. SEGINI, MCHPO3=MCHPO1
  170. SEGACT, MCHPO1
  171. DO 30, J=1, NSOUPO
  172. IF (AFFICH) WRITE (*,*) 'création MCHPO3: Boucle sur les SOUPO',J
  173. MSOUP1 = MCHPO1.IPCHP(J)
  174. SEGINI, MSOUP3=MSOUP1
  175. MCHPO3.IPCHP(J) = MSOUP3
  176. SEGACT, MSOUP1
  177. MPOVA1 = MSOUP1.IPOVAL
  178. SEGDES, MSOUP1
  179. SEGACT, MPOVA1
  180. N = MPOVA1.VPOCHA(/1)
  181. NC = MPOVA1.VPOCHA(/2)
  182. SEGDES, MPOVA1
  183. SEGINI, MPOVA3
  184. SEGDES, MPOVA3
  185. MSOUP3.IPOVAL = MPOVA3
  186. SEGDES, MSOUP3
  187. * Maillage et nom de Composantes ne seront pas detruits
  188. 30 CONTINUE
  189. SEGDES, MCHPO1,MCHPO3
  190. *
  191. * partie imaginaire MCHPO5
  192. SEGINI, MCHPO5=MCHPO1
  193. SEGACT, MCHPO1
  194. DO 31, J=1, NSOUPO
  195. IF (AFFICH) WRITE (*,*) 'création MCHPO5: Boucle sur les SOUPO',J
  196. MSOUP1 = MCHPO1.IPCHP(J)
  197. SEGINI, MSOUP5=MSOUP1
  198. MCHPO5.IPCHP(J) = MSOUP5
  199. SEGACT, MSOUP1
  200. MPOVA1 = MSOUP1.IPOVAL
  201. SEGDES, MSOUP1
  202. SEGACT, MPOVA1
  203. N = MPOVA1.VPOCHA(/1)
  204. NC = MPOVA1.VPOCHA(/2)
  205. SEGDES, MPOVA1
  206. SEGINI, MPOVA5
  207. SEGDES, MPOVA5
  208. MSOUP5.IPOVAL = MPOVA5
  209. SEGDES, MSOUP5
  210. * Maillage et nom de Composantes ne seront pas detruits
  211. 31 CONTINUE
  212. SEGDES, MCHPO1,MCHPO5
  213.  
  214. * --- Points supports
  215. SEGACT, MCHPO2
  216. nsou=MCHPO2.IPCHP(/1)
  217.  
  218. * -- boucle sur les eventuelles zones
  219. do 25 isou=1,nsou
  220. MSOUP2 = MCHPO2.IPCHP(isou)
  221.  
  222. SEGACT, MSOUP2
  223. IPT2 = MSOUP2.IGEOC
  224. SEGDES, MSOUP2
  225. SEGACT, IPT2
  226. NBP2 = IPT2.NUM(/2)
  227. SEGDES, IPT2
  228. * --- composantes (rem : on ne fait rien si plus de 1 composante....)
  229. CALL EXTR11(MCHPO2,MLMOT2)
  230. SEGACT, MLMOT2
  231. MOT2=MLMOT2.MOTS(1)
  232. SEGDES, MLMOT2
  233. *
  234. *
  235. ******************************************
  236. * Boucle sur les noeuds supports *
  237. ******************************************
  238. *
  239. DO 50, K=1, NBP2
  240.  
  241. IF (AFFICH) WRITE (*,*) '--- Noeud support ',K,' ---'
  242. SEGACT, IPT2
  243. PT2 = IPT2.NUM(1,K)
  244. SEGDES, IPT2
  245. * --- Contribution a mchpo3
  246. CALL EXTRA9(MCHPO2,PT2,MOT2,KERRE,XVAL2)
  247. * --- Contribution a mchpo5
  248. CALL EXTRA9(MCHPO4,PT2,MOT2,KERR2,XVAL4)
  249. IF (AFFICH) WRITE (*,*) ' alfa_R et alfa_I = ',XVAL2,XVAL4
  250.  
  251. * --- on recherche le chpoint reel correspondant
  252. L=1
  253. 60 CALL ACCTAB(IPBASR2,'ENTIER',L,0.0D0,' ',.TRUE.,
  254. & 0,'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3)
  255. CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,
  256. & 0,'POINT',IVALRE,XVALRE,CHARRE,LOGRE,PT1)
  257. IF (PT1 .NE. PT2) THEN
  258. L=L+1
  259. IF (L .LE. NBMODR) GOTO 60
  260. ELSE
  261. CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE',
  262. & .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,
  263. & MCHPO1)
  264. IF (AFFICH) WRITE (*,*) ' Prise en compte du MCHPO1', L,MCHPO1
  265. *
  266. * --- Sommes...
  267. MSOMM3=0
  268. XVAL1=1.d0
  269. IF (AFFICH) WRITE (*,*) 'Somme ...',MSOMM3,XVAL1,XVAL2
  270. * --- ... pour mchpo3
  271. call ADCHPO(MCHPO3,MCHPO1,MSOMM3,XVAL1,XVAL2)
  272. call DTCHPO(MCHPO3)
  273. MCHPO3=MSOMM3
  274. * --- ... pour mchpo5
  275. call ADCHPO(MCHPO5,MCHPO1,MSOMM5,XVAL1,XVAL4)
  276. call DTCHPO(MCHPO5)
  277. MCHPO5=MSOMM5
  278. *
  279. ENDIF
  280.  
  281. 50 CONTINUE
  282. *********************************************
  283. * Fin de boucle sur les noeuds support *
  284. *********************************************
  285. *
  286. 25 continue
  287.  
  288.  
  289. IF (AFFICH) WRITE (*,*) 'Enregistrement du CHPOINT ...'
  290. * --- enregistrement du chpoint
  291. CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
  292. & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO3)
  293. * --- enregistrement du chpoint
  294. CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE',
  295. & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO5)
  296. * --- enregistrement du mode
  297. CALL ECCTAB(MTAB2,'ENTIER',I,0.0D0,' ',
  298. & .TRUE.,0,'TABLE ',0,0.0D0,' ',.TRUE.,MTAB3)
  299.  
  300. 20 CONTINUE
  301. ******************************************
  302. * Fin boucle sur les modes *
  303. ******************************************
  304. *
  305. *
  306. ******************************************
  307. * Creation de la table BASE_MODALE *
  308. ******************************************
  309. *
  310. CALL CRTABL(MTAB1)
  311. CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  312. & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
  313. CALL ECCTAB(MTAB1,'MOT',I,0.0D0,'MODES',
  314. & .TRUE.,0,'TABLE ',0,0.0D0,' ',.TRUE.,MTAB2)
  315. *
  316. * --- fin
  317. *
  318. RETURN
  319. END
  320. *
  321.  
  322.  
  323.  
  324.  
  325.  

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