Télécharger projta.eso

Retour à la liste

Numérotation des lignes :

  1. C PROJTA SOURCE CB215821 19/07/30 21:17:46 10273
  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. IF (MTYPOI.EQ.'FLX ') IDEPI = 1
  61. * bp: ce test ne semble pas tres robuste... --> a revisiter + tard...
  62. * if(mtypoi(1).eq.moforc(1).and.mtypoi(2).eq.moforc(2)) idepi=0
  63. * if (idepi.lt.0) then
  64. * moterr(1:8) = 'chpoint'
  65. * call erreur(302)
  66. * return
  67. * endif
  68.  
  69. *
  70. ***** etalpr de IP1 : chpoint 2nd membre F *****
  71. *
  72. CALL ETALPR(IP1,KIINC,KICPR,KCONTR)
  73. IF(IERR.NE.0) RETURN
  74. * on recupere le MCONTR
  75. MCONTR = KCONTR
  76. SEGACT MCONTR
  77. NNI1 = MCONTR(/1)
  78. IPR1 = MCONTR(/2)
  79. * on cree 2 MVA : KMVA pour les X_i et KMVB pour F
  80. SEGINI MVA
  81. KMVA = MVA
  82. SEGINI MVA
  83. KMVB = MVA
  84. c * on cree un IPB pour les X_i
  85. c SEGINI IPB
  86. c KIPB = IPB
  87. c SEGDES IPB
  88.  
  89. * on remplit le MVA de KMVB avec les valeurs de F:
  90. * on etale F dans KMVB
  91. CALL ETALCH(IP1,KIINC,KICPR,KCONTR,KMVB,KZERO,NPR2,1)
  92.  
  93. * fabrication de la liste des inconnues primales IINC2
  94. * correspondant aux duales IINC
  95. IINC = KIINC
  96. SEGINI IINC2
  97. DO 6 I = 1,NNI1
  98. IDDL = CIINC(I)
  99. DO 7 J = 1,LNOMDD
  100. IF(IDDL.NE.NOMDU(J)) GOTO 7
  101. CIINC2(I) = NOMDD(J)
  102. GOTO 6
  103. 7 CONTINUE
  104. MOTERR(1:4) = IDDL
  105. CALL ERREUR(108)
  106. * on ne trouve pas iddl dans CCHAMP
  107. RETURN
  108. 6 CONTINUE
  109. KIINC2 = IINC2
  110. *
  111. *
  112. ***** on initialise le chpoint de sortie *****
  113. *
  114. if (IPSTA.gt.0) then
  115. NSOUPO = 2
  116. else
  117. NSOUPO = 1
  118. endif
  119. NAT=1
  120. SEGINI,MCHPOI
  121. IRET = MCHPOI
  122. MTYPOI = ' '
  123. MOCHDE=' J''AI ETE FABRIQUE PAR PJBA'
  124. IFOPOI = IFOUR
  125. * champ de force nodal: nature discrete
  126. JATTRI(1)=2
  127.  
  128. *---- boucle sur ISOUPO (=sur les composantes FALF et FBET) ----
  129. DO 100 ISOUPO=1,NSOUPO
  130.  
  131. if(ISOUPO.eq.1) then
  132. IP2 = IPMOD
  133. MODEFO(1:15) = 'DEFORMEE_MODALE'
  134. else
  135. IP2 = IPSTA
  136. MODEFO(1:15) = 'DEFORMEE'
  137. endif
  138. if(iimpi.ge.333) write(ioimp,*) ISOUPO,IP2,MODEFO
  139.  
  140. *
  141. ***** on compte le nombre de modes *****
  142. LDEPL = 0
  143. 10 CONTINUE
  144. LDEPL = LDEPL + 1
  145. TYPRET = ' '
  146. CALL ACCTAB(IP2,'ENTIER',LDEPL,X0,' ',L0,IP0,
  147. & TYPRET,I1,X1,CHARRE,L1,ITMOD)
  148. IF(IERR.NE.0) RETURN
  149. IF (TYPRET.EQ.'TABLE ' .AND. ITMOD.NE.0) GOTO 10
  150. LDEPL = LDEPL - 1
  151. if(iimpi.ge.333) write(ioimp,*) 'nombre de modes=',LDEPL
  152.  
  153. ***** on initialise le MSOUPO du chpoint de sortie *****
  154. NC = 1
  155. SEGINI,MSOUPO
  156. IPCHP(ISOUPO) = MSOUPO
  157. if(ISOUPO.eq.1) then
  158. NOCOMP(1) = 'FALF'
  159. else
  160. NOCOMP(1) = 'FBET'
  161. endif
  162. NOHARM(1) = NIFOUR
  163. N = LDEPL
  164. SEGINI MPOVAL
  165. IPOVAL = MPOVAL
  166. *
  167. NBNN = 1
  168. NBELEM = LDEPL
  169. NBSOUS = 0
  170. NBREF = 0
  171. SEGINI MELEME
  172. IGEOC = MELEME
  173. ITYPEL = 1
  174. *
  175. ***** boucle sur les chpoints de deformee X_i *****
  176. *
  177. DO 11 IM = 1,LDEPL
  178.  
  179. * recup du i eme mode (indice IM)
  180. CALL ACCTAB(IP2,'ENTIER',IM,X0,' ',L0,IP0,
  181. & 'TABLE',I1,X1,' ',L1,ITMOD)
  182. IF(IERR.NE.0) RETURN
  183.  
  184. * recup du point repere
  185. CALL ACCTAB(ITMOD,'MOT',I0,X0,'POINT_REPERE',L0,IP0,
  186. & 'POINT',I1,X1,' ',L1,IPTR)
  187. IF(IERR.NE.0) RETURN
  188. * + ecriture du point dans le maillage du chpoint projete
  189. NUM(1,IM) = IPTR
  190. ICOLOR(IM) = IDCOUL
  191.  
  192. * recup de la deformee X_i (chpoint IPP1)
  193. CALL ACCTAB(ITMOD,'MOT',I0,X0,MODEFO,L0,IP0,
  194. & 'CHPOINT',I1,X1,' ',L1,IPP1)
  195. IF(IERR.NE.0) RETURN
  196. CALL ACTOBJ('CHPOINT ',IPP1,1)
  197.  
  198. * Calcul effectif du terme F^T * X_i
  199. XRET = 0.D0
  200.  
  201. * -force imposee => idepi=0
  202. IF (IDEPI.NE.1) THEN
  203. * on etale X_i dans KMVA
  204. * selon le format defini par KIINC2, KICPR et KCONTR
  205. CALL ETALCH(IPP1,KIINC2,KICPR,KCONTR,KMVA,KZERO,IBID,0)
  206. IF (IERR.NE.0) RETURN
  207. *
  208. MVA = KMVA
  209. c IPB = KIPB
  210. MVA1 = KMVB
  211. * boucle sur les elements definis par F
  212. DO 80 J1 = 1,NPR2
  213. c JJ1 = IPB(J1)
  214. DO 80 I1 = 1,NNI1
  215. c XRET = XRET + VA(I1,JJ1) * MVA1.VA(I1,JJ1)
  216. XRET = XRET + VA(I1,J1) * MVA1.VA(I1,J1)
  217. 80 CONTINUE
  218.  
  219. * -deplacement impose => idepi=1
  220. ELSE
  221. CALL ACCTAB(ITMOD,'MOT',I0,X0,'FREQUENCE',L0,IP0,
  222. & 'FLOTTANT',I1,X1,' ',L1,IP1)
  223. IF(IERR.NE.0) RETURN
  224. OM = X1
  225. OM = 2.D0 * XPI * OM
  226. OM = OM * OM
  227. XRET = -XRET / OM
  228. *bp XRET vaut toujours 0 !?!?!
  229. ENDIF
  230. VPOCHA(IM,1) = XRET
  231.  
  232. 11 CONTINUE
  233. *
  234.  
  235. 100 continue
  236. *---- fin de boucle sur ISOUPO (=sur les composantes FALF et FBET) ----
  237.  
  238. SEGSUP MVA,MVA1
  239. c SEGSUP,IPB
  240. ICPR = KICPR
  241. SEGSUP ICPR,IINC,IINC2
  242. *
  243.  
  244. IF (IDEPI.NE.KDEPI) THEN
  245. *** la base ne contient pas la solution statique necessaire au
  246. *** calcul de la reponse au deplacement impose
  247. CALL ERREUR(303)
  248. CALL ECRCHA('GEOM')
  249. CALL DTCHPO(MCHPOI)
  250. IRET = 0
  251. ENDIF
  252. *
  253. END
  254.  
  255.  
  256.  

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