Télécharger projba.eso

Retour à la liste

Numérotation des lignes :

  1. C PROJBA SOURCE BP208322 15/09/24 21:15:06 8631
  2. SUBROUTINE PROJBA(IP1,IP2,IP4,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C=======================================================================
  6. C SUBROUTINE APPELE PAR L OPERATEUR PJBA : PROJECTION DU CHPOINT IP1 SUR
  7. C LES ELEMENTS DE LA BASE MODALE IP2, SOUS BASE IP4.
  8. C LE RESULTAT EST MIS DANS IRET (CHPOINT).
  9. C POUR DEBOGUER IMPEC=10
  10. C
  11. C PROGRAMME PAR FARVACQUE
  12. C APPELE PAR PJBA
  13. C APPELLE : ETALPR,ETALCH,ERREUR(108,302,303)
  14. C=======================================================================
  15. -INC CCOPTIO
  16. -INC CCREEL
  17. -INC SMCHPOI
  18. -INC SMELEME
  19. -INC SMATTAC
  20. -INC SMBASEM
  21. -INC SMSOLUT
  22. -INC CCHAMP
  23. SEGMENT ITRAV(2)
  24. SEGMENT ITTT(0)
  25. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  26. SEGMENT IINC
  27. CHARACTER*4 CIINC(0)
  28. ENDSEGMENT
  29. SEGMENT IIDU
  30. CHARACTER*4 CIIDU(NNI1)
  31. ENDSEGMENT
  32. SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA
  33. SEGMENT IPB(IPR1)
  34. SEGMENT MCONTR(NNI1,IPR1)
  35. SEGMENT/IWRK/(ITRAVV(LDEPL1,2),TRAV(LDEPL)*D)
  36. CHARACTER*4 IDDL
  37. DATA IMPEC/10/
  38. DATA KZERO/0/
  39. C
  40. IRET=0
  41. C
  42. C DEPLACEMENT IMPOSE => IDEPI=1
  43. C FORCE IMPOSEE => IDEPI=0
  44. C
  45. IDEPI=0
  46. C IDEPI=-1
  47. KDEPI=0
  48. MCHPOI=IP1
  49. SEGACT MCHPOI
  50. IF(MTYPOI.EQ.'FLX ') IDEPI=1
  51. C IF(MTYPOI(1).EQ.MOFORC(1).AND.MTYPOI(2).EQ.MOFORC(2)) IDEPI=0
  52. SEGDES MCHPOI
  53. C IF(IDEPI.LT.0) THEN
  54. C MOTERR(1:8)='CHPOINT'
  55. C CALL ERREUR(302)
  56. C RETURN
  57. C ENDIF
  58. C
  59. NBNN=1
  60. NBREF=0
  61. NBSOUS=0
  62. MBASEM=IP2
  63. SEGACT MBASEM
  64. SEGINI ITRAV
  65. SEGINI ITTT
  66. MSOBAS=LISBAS(IP4)
  67. SEGDES MBASEM
  68. SEGACT MSOBAS
  69. ITRAV(1)=IBSTRM(2)
  70. ITRAV(2)=IBSTRM(3)
  71. SEGDES MSOBAS
  72. C
  73. DO 1 IT=1,2
  74. MSOLUT=ITRAV(IT)
  75. IF(MSOLUT.EQ.0) GO TO 1
  76. SEGACT MSOLUT
  77. MSOLEN=MSOLIS(5)
  78. IF(IT.EQ.2) MSOLE1=MSOLIS(10)
  79. MELEME=MSOLIS(3)
  80. SEGDES MSOLUT
  81. SEGACT MSOLEN
  82. LDEPL=ISOLEN(/1)
  83. LDEPL1=LDEPL+1
  84. IF(IT.EQ.2) SEGINI IWRK
  85. IF(IIMPI.EQ.IMPEC)WRITE(6,8000) IT,MSOLEN,MSOLE1,LDEPL
  86. 8000 FORMAT(' *****IT=',I4,' MSOLEN=',I5,' MSOLE1=',I5,' LDEPL=',I5)
  87. C
  88. C **** ETALPR DU CHPOINT DE LA SOLUTION
  89. C
  90. IPM=ISOLEN(1)
  91. CALL ETALPR(IPM,KIINC,KICPR,KCONTR)
  92. IF(IERR.NE.0) GO TO 5000
  93. MCONTR=KCONTR
  94. SEGACT MCONTR
  95. NNI1=MCONTR(/1)
  96. IPR1=MCONTR(/2)
  97. SEGDES MCONTR
  98. SEGINI MVA
  99. KMVA=MVA
  100. SEGDES MVA
  101. SEGINI MVA
  102. KMVB=MVA
  103. SEGDES MVA
  104. SEGINI IPB
  105. KIPB=IPB
  106. SEGDES IPB
  107. IINC=KIINC
  108. SEGACT IINC
  109. SEGINI IIDU
  110. DO 6 I=1,NNI1
  111. IDDL=CIINC(I)
  112. DO 7 J=1,LNOMDD
  113. IF(IDDL.NE.NOMDD(J))GO TO 7
  114. CIIDU(I)=NOMDU(J)
  115. GO TO 6
  116. 7 CONTINUE
  117. MOTERR(1:4)=IDDL
  118. CALL ERREUR(108)
  119. C ON NE TROUVE PAS IDDL DANS CCHAMP
  120. GO TO 5000
  121. 6 CONTINUE
  122. SEGDES IINC,IIDU
  123. KINCDU=IIDU
  124. IF(IIMPI.EQ.IMPEC)WRITE(6,8002)(CIINC(I),CIIDU(I),I=1,NNI1)
  125. 8002 FORMAT(20(1X,A4))
  126. C
  127. C **** ON REGARDE SI LES POINTS DE F CORRESPONDENT
  128. C **** ON MET F DANS KMVB
  129. C
  130. CALL ETALCH(IP1,KINCDU,KICPR,KCONTR,KMVB,KIPB,NPR2,1)
  131. IF(IERR.NE.0) GO TO 5000
  132. C
  133. C **** SI IT=1 ON INITIALISE MSOUPO,MPOVAL,MELEME
  134. C
  135. IF(IT.NE.1) GO TO 100
  136. NC=1
  137. SEGINI MSOUPO
  138. NOCOMP(1)='FALF'
  139. N=LDEPL
  140. SEGINI MPOVAL
  141. IPOVAL=MPOVAL
  142. IGEOC=MELEME
  143. SEGDES MSOUPO
  144. IF(IDEPI.EQ.1) MSOLE2=MSOLIS(4)
  145. 100 CONTINUE
  146. IF(IT.EQ.2) SEGACT MSOLE1
  147. ICON1=0
  148. ICON2=0
  149. SEGACT MSOLEN,MELEME
  150. C
  151. C ****BOUCLE SUR LES CHPOINTS DE DEPL
  152. C
  153. DO 11 IM=1,LDEPL
  154. XRET=0.D0
  155. IPP1=ISOLEN(IM)
  156. IPOIN=NUM(1,IM)
  157. IF(IIMPI.EQ.IMPEC)WRITE(6,8003) IPP1,IPOIN
  158. 8003 FORMAT(' IPP1=',I6,' IPOIN=',I6)
  159. IF(IT.EQ.1.OR.IDEPI.NE.1) THEN
  160. CALL ETALCH(IPP1,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID,1)
  161. IF(IERR.NE.0) GO TO 5000
  162. C
  163. MVA=KMVA
  164. IPB=KIPB
  165. MVA1=KMVB
  166. SEGACT MVA,MVA1,IPB
  167. DO 80 J1=1,NPR2
  168. JJ1=IPB(J1)
  169. DO 80 I1=1,NNI1
  170. XRET=XRET+VA(I1,JJ1)*MVA1.VA(I1,JJ1)
  171. 80 CONTINUE
  172. SEGDES MVA,MVA1,IPB
  173. ENDIF
  174. C
  175. IF(IT.EQ.1) THEN
  176. IF(IDEPI.EQ.1) THEN
  177. MMODE=MSOLE2.ISOLEN(IM)
  178. SEGACT MMODE
  179. OM=FMMODD(1)
  180. SEGDES MMODE
  181. OM=2.D0*XPI*OM
  182. OM=OM*OM
  183. XRET=-XRET/OM
  184. ENDIF
  185. VPOCHA(IM,1)=XRET
  186. ELSE
  187. MJONCT=MSOLE1.ISOLEN(IM)
  188. IF(IIMPI.EQ.IMPEC)WRITE(6,8004) MJONCT
  189. 8004 FORMAT(' MJONCT=',I6)
  190. SEGACT MJONCT
  191. IF(MJODDL.EQ.'LX') THEN
  192. ITRAVV(IM,1)=IPOIN
  193. ICON1=ICON1+1
  194. ELSE
  195. ITRAVV(IM,2)=IPOIN
  196. ICON2=ICON2+1
  197. IF(IP1.EQ.IPCHJO(1)) THEN
  198. XRET=1.D0
  199. KDEPI=1
  200. ENDIF
  201. ENDIF
  202. SEGDES MJONCT
  203. TRAV(IM)=XRET
  204. ENDIF
  205. 11 CONTINUE
  206. SEGDES MSOLEN,MELEME
  207. SEGSUP MVA,MVA1,IPB
  208. ICPR=KICPR
  209. SEGSUP ICPR,IINC,IIDU
  210. C
  211. GO TO(31,32),IT
  212. C
  213. 31 SEGDES MPOVAL,MELEME
  214. ITTT(**)=MSOUPO
  215. GO TO 30
  216. 32 CONTINUE
  217. ITRAVV(LDEPL1,1)=ICON1
  218. ITRAVV(LDEPL1,2)=ICON2
  219. DO 40 I=1,2
  220. NBELEM=ITRAVV(LDEPL1,I)
  221. IF(NBELEM.EQ.0) GO TO 40
  222. SEGINI MELEME
  223. NC=1
  224. SEGINI MSOUPO
  225. IF(I.EQ.1) NOCOMP(1)='FBET'
  226. IF(I.EQ.2) NOCOMP(1)='BETA'
  227. N=NBELEM
  228. SEGINI MPOVAL
  229. IPOVAL=MPOVAL
  230. IGEOC=MELEME
  231. SEGDES MSOUPO
  232. ITTT(**)=MSOUPO
  233. IK=0
  234. DO 41 J=1,LDEPL
  235. IF(ITRAVV(J,I).EQ.0) GO TO 41
  236. IK=IK+1
  237. NUM(1,IK)=ITRAVV(J,I)
  238. VPOCHA(IK,1)=TRAV(J)
  239. 41 CONTINUE
  240. SEGDES MPOVAL,MELEME
  241. 40 CONTINUE
  242. SEGDES MSOLE1
  243. SEGSUP IWRK
  244. C
  245. 30 CONTINUE
  246. 1 CONTINUE
  247. C
  248. C **** CREATION DU CHPOINT
  249. C
  250. NSOUPO=ITTT(/1)
  251. NAT=1
  252. SEGINI MCHPOI
  253. DO 60 I=1,NSOUPO
  254. IPCHP(I)=ITTT(I)
  255. 60 CONTINUE
  256. MOCHDE=' J''AI ETE FABRIQUE PAR L''OPERATEUR PROJBA'
  257. * Champ de forces nodales: nature discrete
  258. JATTRI(1)=2
  259. SEGDES MCHPOI
  260. IRET=MCHPOI
  261. IF(IDEPI.NE.KDEPI) THEN
  262. C *** LA BASE NE CONTIENT PAS LA SOLUTION STATIQUE NECESSAIRE AU
  263. C *** CALCUL DE LA REPONSE AU DEPLACEMENT IMPOSE
  264. CALL ERREUR(303)
  265. CALL ECRCHA('GEOM')
  266. CALL DTCHPO(MCHPOI)
  267. IRET=0
  268. ENDIF
  269. 5000 CONTINUE
  270. SEGSUP ITTT,ITRAV
  271. RETURN
  272. END
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  

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