Télécharger crtbas.eso

Retour à la liste

Numérotation des lignes :

  1. C CRTBAS SOURCE BP208322 15/09/21 21:15:00 8628
  2. SUBROUTINE CRTBAS(IPSOLU,IPMASS)
  3. C***********************************************************************
  4. C
  5. C C R T B A S
  6. C -----------
  7. C
  8. C SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "VIBRATION"
  9. C
  10. C FONCTION:
  11. C ---------
  12. C
  13. C CREATION D'UNE TABLE DE TYPE BASE_MODALE COMME SORTIE
  14. C DE L'OPERATEUR "VIBRATION"
  15. C
  16. C ARGUMENTS D'ENTREE:
  17. C ------------------
  18. C
  19. C IPSOLU = POINTEUR SUR L'OBJET SOLUTION
  20. C IPMASS = POINTEUR SUR LA MATRICE MASSE
  21. C
  22. C DESCRIPTION DE LA TABLE BASE_MODALE CREE:
  23. C ----------------------------------------
  24. C
  25. C TAB1 = 'TABLE' 'BASE_MODALE' ( POINTEUR IPTAB1 )
  26. C TAB2 = 'TABLE' 'BASE_DE_MODES' ( POINTEUR IPTAB2 )
  27. C DE MEME STRUCTURE QUE CELLE ISSUE DE LA PROCEDURE
  28. C TRADUIRE.
  29. C TAB3 = 'TABLE' 'MODE' ( POINTEUR IPTAB3 )
  30. C TAB4 = 'TABLE' 'DEPLACEMENTS_GENERALISES' ( POINTEUR IPTAB4 )
  31. C
  32. C ----------------------------------------
  33. C
  34. C TAB1.'SOUSTYPE' = 'BASE_MODALE'
  35. C TAB1.'MODES' = IPTAB2
  36. C
  37. C TAB2.'SOUSTYPE' = 'BASE_DE_MODES'
  38. C TAB2.'MAILLAGE' = IPG1 ( POINTEUR SUR LE
  39. C MAILLAGE EXTRAIT DE LA MATRICE
  40. C MASSE )
  41. C
  42. C PUIS POUR CHAQUE MODE IMOD1 CONTENU DANS L'OBJET SOLUTION
  43. C
  44. C TAB3.'SOUSTYPE' = 'MODE'
  45. C TAB4.'SOUSTYPE' = 'DEPLACEMENTS_GENERALISES'
  46. C
  47. C TAB4.1 = QX DU MODE
  48. C TAB4.2 = QY DU MODE
  49. C TAB4.3 = QZ DU MODE
  50. C
  51. C TAB3.'NUMERO_MODE' = NUME1 ( NUMERO DU MODE )
  52. C TAB3.'POINT_REPERE' = IPOIN1 ( NUMERO DU POINT ASSOCIE
  53. C AU MODE )
  54. C TAB3.'FREQUENCE' = FREQ1 DU MODE
  55. C TAB3.'MASSE_GENERALISEE' = XMGEN1 DU MODE
  56. C TAB3.'DEPLACEMENTS_GENERALISES' = IPTAB4
  57. C TAB3.'DEFORMEE_MODALE' = IPDEP1 ( POINTEUR SUR LE CHAMP
  58. C DE DEPLACEMENTS DU MODE )
  59. C
  60. C TAB2.IMOD1 = IPTAB3
  61. C
  62. C
  63. C AUTEUR, DATE DE CREATION:
  64. C -------------------------
  65. C
  66. C NADINE BLAY 21 OCTOBRE 1991
  67. C
  68. C***********************************************************************
  69. C
  70. IMPLICIT INTEGER(I-N)
  71. IMPLICIT REAL*8 (A-H,O-Z)
  72. C
  73. -INC CCOPTIO
  74. C
  75. -INC SMSOLUT
  76. -INC SMRIGID
  77. -INC SMTABLE
  78. -INC SMELEME
  79. -INC SMLREEL
  80. -INC SMLENTI
  81. -INC SMCHPOI
  82. CHARACTER*8 letyp,charre
  83. LOGICAL boolin,ltelq
  84. CHARACTER *72 ITEX
  85. C
  86. C--- RECUPERATION DU MAILLAGE DANS LA MATRICE MASSE
  87. C
  88. MRIGID=IPMASS
  89. SEGACT MRIGID
  90. NBSOUS=IRIGEL(/2)
  91. IPG1=IRIGEL(1,1)
  92. C
  93. c IF(NBSOUS.GT.1) THEN
  94. c DO 10 I=2,NBSOUS
  95. c IPP2=IRIGEL(1,I)
  96. c ltelq=.false.
  97. c CALL FUSE(IPG1,IPP2,IRET,ltelq)
  98. c IPG1=IRET
  99. c 10 CONTINUE
  100. c ENDIF
  101. cbp : FUSE ne teste pas si il genere des doublons...
  102. c on preferera utiliser fusebo
  103. IF(NBSOUS.GT.1) THEN
  104. nbref=0
  105. nbnn=0
  106. nbelem=0
  107. segini ipt4
  108. kt4 = 1
  109. ipt4.lisous(kt4) = IPG1
  110. DO 10 I=2,NBSOUS
  111. IPP2=IRIGEL(1,I)
  112. do 1029 kk=1,kt4
  113. c maillage deja vu --> on saute
  114. if(IPP2.eq.ipt4.lisous(kk)) goto 10
  115. 1029 continue
  116. kt4=kt4+1
  117. ipt4.lisous(kt4) = IPP2
  118. 10 CONTINUE
  119. nbsous = kt4
  120. segadj ipt4
  121. call fusebo(ipt4,IRET)
  122. IPG1=IRET
  123. ENDIF
  124. SEGDES MRIGID
  125. C
  126. C--- CREATION DE LA TABLE BASE_DE_MODES
  127. C
  128. CALL CRTABL(IPTAB2)
  129. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  130. # 'MOT',0,0.D0,'BASE_DE_MODES',.TRUE.,0)
  131. CALL ECCTAB(IPTAB2,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  132. # 'MAILLAGE',0,0.D0,' ',.TRUE.,IPG1)
  133. C
  134. C--- EXTRACTION DES INFORMATIONS DE L'OBJET SOLUTION
  135. C
  136.  
  137. MSOLUT=IPSOLU
  138. SEGACT MSOLUT
  139. C
  140. MSOLE1=MSOLIS(4)
  141. * si l'objet solution n'est pas vide
  142. if (msole1.ne.0) then
  143. SEGACT MSOLE1
  144. NBMOD1=MSOLE1.ISOLEN(/1)
  145. C
  146. MSOLE2=MSOLIS(5)
  147. SEGACT MSOLE2
  148. C
  149. DO 20 I=1,NBMOD1
  150. IMOD1=I
  151. C
  152. C--- CREATION DE LA TABLE MODE
  153. C
  154. CALL CRTABL(IPTAB3)
  155. CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  156. # 'MOT',0,0.D0,'MODE',.TRUE.,0)
  157. C
  158. C--- CREATION DE LA TABLE DEPLACEMENTS_GENERALISES
  159. C
  160. CALL CRTABL(IPTAB4)
  161. CALL ECCTAB(IPTAB4,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  162. # 'MOT',0,0.D0,'DEPLACEMENTS_GENERALISES',.TRUE.,0)
  163. C
  164. MMODE=MSOLE1.ISOLEN(IMOD1)
  165. SEGACT MMODE
  166. C
  167. NUME1=IMMODD(1)
  168. FRQ1=FMMODD(1)
  169. XMGEN1=FMMODD(2)
  170. QX1=FMMODD(3)
  171. QY1=FMMODD(4)
  172. QZ1=FMMODD(5)
  173. C
  174. MELEME=MSOLIS(3)
  175. SEGACT MELEME
  176. IPOIN1=NUM(1,IMOD1)
  177. SEGDES MELEME
  178. C
  179. IPDEP1=MSOLE2.ISOLEN(IMOD1)
  180. c ajout du titre au chpoint
  181. CALL TITMOD(MMODE,ITEX)
  182. MCHPOI=IPDEP1
  183. segact,MCHPOI*MOD
  184. MOCHDE=ITEX
  185. segdes,MCHPOI
  186. C
  187. C--- REMPLISSAGE DE LA TABLE DEPLACEMENTS_GENERALISES
  188. C
  189. CALL ECCTAB(IPTAB4,'ENTIER',1,0.D0,' ',.TRUE.,0,
  190. # 'FLOTTANT',0,QX1,' ',.TRUE.,0)
  191. CALL ECCTAB(IPTAB4,'ENTIER',2,0.D0,' ',.TRUE.,0,
  192. # 'FLOTTANT',0,QY1,' ',.TRUE.,0)
  193. CALL ECCTAB(IPTAB4,'ENTIER',3,0.D0,' ',.TRUE.,0,
  194. # 'FLOTTANT',0,QZ1,' ',.TRUE.,0)
  195. C
  196. C--- REMPLISSAGE DE LA TABLE MODE
  197. C
  198. CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'NUMERO_MODE',.TRUE.,0,
  199. # 'ENTIER',NUME1,0.D0,' ',.TRUE.,0)
  200. CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'POINT_REPERE',.TRUE.,0,
  201. # 'POINT',0,0.D0,' ',.TRUE.,IPOIN1)
  202. CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'FREQUENCE',.TRUE.,0,
  203. # 'FLOTTANT',0,FRQ1,' ',.TRUE.,0)
  204. CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'MASSE_GENERALISEE',.TRUE.,0,
  205. # 'FLOTTANT',0,XMGEN1,' ',.TRUE.,0)
  206. CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'DEPLACEMENTS_GENERALISES',
  207. # .TRUE.,0,'TABLE',0,0.D0,' ',.TRUE.,IPTAB4)
  208. CALL ECCTAB(IPTAB3,'MOT',0,0.D0,'DEFORMEE_MODALE',.TRUE.,0,
  209. # 'CHPOINT',0,0.D0,' ',.TRUE.,IPDEP1)
  210. C
  211. C--- SUITE DU REMPLISSAGE DE LA TABLE BASE_DE_MODES
  212. C
  213. CALL ECCTAB(IPTAB2,'ENTIER',IMOD1,0.D0,' ',.TRUE.,0,
  214. # 'TABLE',0,0.D0,' ',.TRUE.,IPTAB3)
  215. C
  216. SEGDES MMODE
  217. 20 CONTINUE
  218. C
  219. C
  220. SEGDES MSOLE1
  221. SEGDES MSOLE2
  222. SEGDES MSOLUT
  223.  
  224. endif
  225. *
  226. * tri selon les frequences
  227. jg = 10000
  228. segini mlreel,mlenti
  229. do 350 i = 1, 10000
  230. letyp=' '
  231. call acctab (iptab2,'ENTIER ',i,xva,charre,boolin,iobin,
  232. $ letyp,ivalre,xvalre,charre,boolin,mtab2)
  233. if(letyp.ne.'TABLE ') go to 351
  234. lect(i) = mtab2
  235. call acctab (mtab2,'MOT ',iva,xva,'FREQUENCE',boolin,iobin,
  236. $ 'FLOTTANT',ivalre,xvalre,charre,boolin,ioboi)
  237. prog(i) = xvalre
  238. 350 continue
  239. 351 jg = i - 1
  240. segadj mlreel,mlenti
  241.  
  242. call ecrobj('LISTENTI',mlenti)
  243. call ecrobj('LISTREEL',mlreel)
  244. call ORDONN
  245. call lirobj('LISTREEL',mlreel,1,IRETOU)
  246. call lirobj('LISTENTI',mlenti,1,IRETOU)
  247. IF (IERR.NE.0) RETURN
  248. segact mlenti
  249. do i = 1,jg
  250. mtab2 = lect(i)
  251. call ecctab (iptab2,'ENTIER ',i,xva,charre,boolin,iobin,
  252. $ 'TABLE ',ivalre,xvalre,charre,boolin,mtab2)
  253.  
  254. enddo
  255.  
  256. C
  257. C--- CREATION DE LA TABLE BASE_MODALE
  258. C
  259. CALL CRTABL(IPTAB1)
  260. CALL ECCTAB(IPTAB1,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  261. # 'MOT',0,0.D0,'BASE_MODALE',.TRUE.,0)
  262. CALL ECCTAB(IPTAB1,'MOT',0,0.D0,'MODES',.TRUE.,0,
  263. # 'TABLE',0,0.D0,' ',.TRUE.,IPTAB2)
  264. CALL ECROBJ('TABLE',IPTAB1)
  265. C
  266. END
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  

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