Télécharger projta.eso

Retour à la liste

Numérotation des lignes :

  1. C PROJTA SOURCE BP208322 16/11/18 21:20:17 9177
  2. SUBROUTINE PROJTA(IP1,IPMOD,IPSTA,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. ************************************************************************
  6. * *
  7. * PROJECTION DU CHAMP IP1 SUR LES ELEMENTS DE LA BASE MODALE IP2 *
  8. * *
  9. * PARAMETRES: *
  10. * *
  11. * E IP1 chpoint second membre *
  12. * E IPMOD table des modes de sous-type base_de_modes *
  13. * E IPSTA table des modes de sous-type liaisons_statiques *
  14. * S IRET chpoint resultat *
  15. * *
  16. * REMARQUES: *
  17. * *
  18. * ce sous-programme est une copie de projba *
  19. * ce sous-programme est appele par pjba, psmo, copba4 *
  20. * *
  21. * AUTEUR, DATE DE CREATION : lionel vivan, aout 1990 *
  22. * MODIFS : ajout des liaisons statiques (BP, 05/08/2014) *
  23. * amelioration compatibilite (BP, 2015-09-24) *
  24. * *
  25. ************************************************************************
  26. *
  27. -INC CCOPTIO
  28. -INC CCGEOME
  29. -INC CCREEL
  30. -INC SMCHPOI
  31. -INC SMELEME
  32. -INC CCHAMP
  33. *
  34. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  35. SEGMENT IINC
  36. CHARACTER*4 CIINC(0)
  37. ENDSEGMENT
  38. SEGMENT IINC2
  39. CHARACTER*4 CIINC2(NNI1)
  40. ENDSEGMENT
  41. SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA
  42. SEGMENT IPB(IPR1)
  43. SEGMENT MCONTR(NNI1,IPR1)
  44. LOGICAL L0,L1
  45. CHARACTER*4 IDDL
  46. CHARACTER*8 TYPRET,CHARRE
  47. CHARACTER*15 MODEFO
  48. DATA KZERO/0/
  49. *
  50. IRET = 0
  51.  
  52. ***** s'agit-il d'un second membre de type deplacement impose ? *****
  53. *
  54. * deplacement impose => idepi=1
  55. * force imposee => idepi=0
  56. IDEPI = 0
  57. * idepi = -1
  58. KDEPI = 0
  59. MCHPOI = IP1
  60. SEGACT MCHPOI
  61. IF (MTYPOI.EQ.'FLX ') IDEPI = 1
  62. * bp: ce test ne semble pas tres robuste... --> a revisiter + tard...
  63. * if(mtypoi(1).eq.moforc(1).and.mtypoi(2).eq.moforc(2)) idepi=0
  64. SEGDES MCHPOI
  65. * if (idepi.lt.0) then
  66. * moterr(1:8) = 'chpoint'
  67. * call erreur(302)
  68. * return
  69. * endif
  70.  
  71. *
  72. ***** etalpr de IP1 : chpoint 2nd membre F *****
  73. *
  74. CALL ETALPR(IP1,KIINC,KICPR,KCONTR)
  75. IF(IERR.NE.0) RETURN
  76. * on recupere le MCONTR
  77. MCONTR = KCONTR
  78. SEGACT MCONTR
  79. NNI1 = MCONTR(/1)
  80. IPR1 = MCONTR(/2)
  81. SEGDES MCONTR
  82. * on cree 2 MVA : KMVA pour les X_i et KMVB pour F
  83. SEGINI MVA
  84. KMVA = MVA
  85. SEGDES MVA
  86. SEGINI MVA
  87. KMVB = MVA
  88. SEGDES MVA
  89. c * on cree un IPB pour les X_i
  90. c SEGINI IPB
  91. c KIPB = IPB
  92. c SEGDES IPB
  93.  
  94. * on remplit le MVA de KMVB avec les valeurs de F:
  95. * on etale F dans KMVB
  96. CALL ETALCH(IP1,KIINC,KICPR,KCONTR,KMVB,KZERO,NPR2,1)
  97.  
  98. * fabrication de la liste des inconnues primales IINC2
  99. * correspondant aux duales IINC
  100. IINC = KIINC
  101. SEGACT IINC
  102. SEGINI IINC2
  103. DO 6 I = 1,NNI1
  104. IDDL = CIINC(I)
  105. DO 7 J = 1,LNOMDD
  106. IF(IDDL.NE.NOMDU(J)) GOTO 7
  107. CIINC2(I) = NOMDD(J)
  108. GOTO 6
  109. 7 CONTINUE
  110. MOTERR(1:4) = IDDL
  111. CALL ERREUR(108)
  112. * on ne trouve pas iddl dans CCHAMP
  113. RETURN
  114. 6 CONTINUE
  115. SEGDES IINC,IINC2
  116. KIINC2 = IINC2
  117. *
  118. *
  119. ***** on initialise le chpoint de sortie *****
  120. *
  121. if (IPSTA.gt.0) then
  122. NSOUPO = 2
  123. else
  124. NSOUPO = 1
  125. endif
  126. NAT=1
  127. SEGINI,MCHPOI
  128. IRET = MCHPOI
  129. MTYPOI = ' '
  130. MOCHDE=' J''AI ETE FABRIQUE PAR PJBA'
  131. IFOPOI = IFOUR
  132. * champ de force nodal: nature discrete
  133. JATTRI(1)=2
  134.  
  135. *---- boucle sur ISOUPO (=sur les composantes FALF et FBET) ----
  136. DO 100 ISOUPO=1,NSOUPO
  137.  
  138. if(ISOUPO.eq.1) then
  139. IP2 = IPMOD
  140. MODEFO(1:15) = 'DEFORMEE_MODALE'
  141. else
  142. IP2 = IPSTA
  143. MODEFO(1:15) = 'DEFORMEE'
  144. endif
  145. if(iimpi.ge.333) write(ioimp,*) ISOUPO,IP2,MODEFO
  146.  
  147. *
  148. ***** on compte le nombre de modes *****
  149. LDEPL = 0
  150. 10 CONTINUE
  151. LDEPL = LDEPL + 1
  152. TYPRET = ' '
  153. CALL ACCTAB(IP2,'ENTIER',LDEPL,X0,' ',L0,IP0,
  154. & TYPRET,I1,X1,CHARRE,L1,ITMOD)
  155. IF(IERR.NE.0) RETURN
  156. IF (TYPRET.EQ.'TABLE ' .AND. ITMOD.NE.0) GOTO 10
  157. LDEPL = LDEPL - 1
  158. if(iimpi.ge.333) write(ioimp,*) 'nombre de modes=',LDEPL
  159.  
  160. ***** on initialise le MSOUPO du chpoint de sortie *****
  161. NC = 1
  162. SEGINI,MSOUPO
  163. IPCHP(ISOUPO) = MSOUPO
  164. if(ISOUPO.eq.1) then
  165. NOCOMP(1) = 'FALF'
  166. else
  167. NOCOMP(1) = 'FBET'
  168. endif
  169. NOHARM(1) = NIFOUR
  170. N = LDEPL
  171. SEGINI MPOVAL
  172. IPOVAL = MPOVAL
  173. *
  174. NBNN = 1
  175. NBELEM = LDEPL
  176. NBSOUS = 0
  177. NBREF = 0
  178. SEGINI MELEME
  179. IGEOC = MELEME
  180. ITYPEL = 1
  181. *
  182. ***** boucle sur les chpoints de deformee X_i *****
  183. *
  184. DO 11 IM = 1,LDEPL
  185.  
  186. * recup du i eme mode (indice IM)
  187. CALL ACCTAB(IP2,'ENTIER',IM,X0,' ',L0,IP0,
  188. & 'TABLE',I1,X1,' ',L1,ITMOD)
  189. IF(IERR.NE.0) RETURN
  190.  
  191. * recup du point repere
  192. CALL ACCTAB(ITMOD,'MOT',I0,X0,'POINT_REPERE',L0,IP0,
  193. & 'POINT',I1,X1,' ',L1,IPTR)
  194. IF(IERR.NE.0) RETURN
  195. * + ecriture du point dans le maillage du chpoint projete
  196. NUM(1,IM) = IPTR
  197. ICOLOR(IM) = IDCOUL
  198.  
  199. * recup de la deformee X_i (chpoint IPP1)
  200. CALL ACCTAB(ITMOD,'MOT',I0,X0,MODEFO,L0,IP0,
  201. & 'CHPOINT',I1,X1,' ',L1,IPP1)
  202. IF(IERR.NE.0) RETURN
  203.  
  204. * Calcul effectif du terme F^T * X_i
  205. XRET = 0.D0
  206.  
  207. * -force imposee => idepi=0
  208. IF (IDEPI.NE.1) THEN
  209. * on etale X_i dans KMVA
  210. * selon le format defini par KIINC2, KICPR et KCONTR
  211. CALL ETALCH(IPP1,KIINC2,KICPR,KCONTR,KMVA,KZERO,IBID,0)
  212. IF (IERR.NE.0) RETURN
  213. *
  214. MVA = KMVA
  215. c IPB = KIPB
  216. MVA1 = KMVB
  217. SEGACT MVA,MVA1
  218. c SEGACT,IPB
  219. * boucle sur les elements definis par F
  220. DO 80 J1 = 1,NPR2
  221. c JJ1 = IPB(J1)
  222. DO 80 I1 = 1,NNI1
  223. c XRET = XRET + VA(I1,JJ1) * MVA1.VA(I1,JJ1)
  224. XRET = XRET + VA(I1,J1) * MVA1.VA(I1,J1)
  225. 80 CONTINUE
  226. SEGDES MVA,MVA1
  227. c SEGDES,IPB
  228.  
  229. * -deplacement impose => idepi=1
  230. ELSE
  231. CALL ACCTAB(ITMOD,'MOT',I0,X0,'FREQUENCE',L0,IP0,
  232. & 'FLOTTANT',I1,X1,' ',L1,IP1)
  233. IF(IERR.NE.0) RETURN
  234. OM = X1
  235. OM = 2.D0 * XPI * OM
  236. OM = OM * OM
  237. XRET = -XRET / OM
  238. *bp XRET vaut toujours 0 !?!?!
  239. ENDIF
  240. VPOCHA(IM,1) = XRET
  241.  
  242. 11 CONTINUE
  243. *
  244. SEGDES MPOVAL,MELEME
  245. SEGDES MSOUPO
  246.  
  247. 100 continue
  248. *---- fin de boucle sur ISOUPO (=sur les composantes FALF et FBET) ----
  249. SEGDES MCHPOI
  250.  
  251. SEGSUP MVA,MVA1
  252. c SEGSUP,IPB
  253. ICPR = KICPR
  254. SEGSUP ICPR,IINC,IINC2
  255. *
  256.  
  257. IF (IDEPI.NE.KDEPI) THEN
  258. *** la base ne contient pas la solution statique necessaire au
  259. *** calcul de la reponse au deplacement impose
  260. CALL ERREUR(303)
  261. CALL ECRCHA('GEOM')
  262. CALL DTCHPO(MCHPOI)
  263. IRET = 0
  264. ENDIF
  265. *
  266. END
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  

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