Télécharger copba3.eso

Retour à la liste

Numérotation des lignes :

  1. C COPBA3 SOURCE PV 09/03/12 21:18:14 6325
  2. SUBROUTINE COPBA3(ITBAS,MOTCLE,IMODE,IMAIL,INOMA,LCHAIN,KTRCHP,
  3. & KTRCHA,KTRAV,ICONT)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6.  
  7. *--------------------------------------------------------------------*
  8. * *
  9. * Effectue une op{ration g{om{trique de translation (MOTCLE = *
  10. * 'PLUS') ou de rotation (MOTCLE = 'ROTA') sur ITBAS contenant *
  11. * les modes, les pseudo-modes de la structure. *
  12. * *
  13. * Param}tres: *
  14. * *
  15. * e ITBAS table contenant les modes, ou les pseudo-modes *
  16. * e MOTCLE mot : PLUS ou ROTA *
  17. * *
  18. * Auteur, date de cr{ation: *
  19. * *
  20. * Lionel VIVAN, le 31 mai 1990. *
  21. * *
  22. *--------------------------------------------------------------------*
  23. * *
  24. -INC CCOPTIO
  25. -INC SMCHPOI
  26. -INC SMCHAML
  27. -INC SMELEME
  28. -INC SMTABLE
  29. *
  30. SEGMENT ITRCHP
  31. INTEGER ICHCA(NSOU),ICHCN(NSOU)
  32. ENDSEGMENT
  33. SEGMENT ITRCHA
  34. INTEGER ICHAM(NSOUS)
  35. ENDSEGMENT
  36. SEGMENT MTRAV
  37. REAL*8 XPT(IDIMB),XPTP(IDIMB),XP1PT(IDIMB),XMPT(IDIMB,IDIMB)
  38. ENDSEGMENT
  39. SEGMENT MTRA2
  40. INTEGER IDEP(3),IROT(3)
  41. REAL*8 XDEP(3),XROT(3)
  42. ENDSEGMENT
  43. SEGMENT MTRA3
  44. REAL*8 XDGEN(3),XDGE2(3)
  45. ENDSEGMENT
  46. SEGMENT MTRA4
  47. INTEGER IFOR(3),IMOM(3)
  48. REAL*8 XFOR(3),XMOM(3)
  49. ENDSEGMENT
  50. *
  51. INTEGER LCHAIN(*)
  52. CHARACTER*4 COMP,MOTCLE
  53. *
  54. ITRCHP = KTRCHP
  55. NSOU = ICHCA(/1)
  56. IF (ICONT.EQ.1) THEN
  57. ITRCHA = KTRCHA
  58. NSOUS = ICHAM(/1)
  59. ENDIF
  60. IF (MOTCLE.EQ.'ROTA') MTRAV = KTRAV
  61. *
  62. MTABLE = ITBAS
  63. SEGACT MTABLE*MOD
  64. LONG = MLOTAB
  65. IM = IMODE
  66. DO 10 I = 1,LONG
  67. IF (MTABTI(I).EQ.'ENTIER ' .AND. MTABII(I).EQ.IM .AND.
  68. & MTABTV(I).EQ.'TABLE ') THEN
  69. ITMOD = MTABIV(I)
  70. IM = IM + 1
  71. MTAB1 = ITMOD
  72. SEGACT MTAB1*MOD
  73. LON1 = MTAB1.MLOTAB
  74. DO 20 I1 = 1,LON1
  75. IF (MTAB1.MTABTI(I1).EQ.'MOT ') THEN
  76. IF (MTAB1.MTABII(I1).EQ.LCHAIN(3) .OR.
  77. & MTAB1.MTABII(I1).EQ.LCHAIN(6)) THEN
  78. IF (MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
  79. ICHDEP = MTAB1.MTABIV(I1)
  80. MCHPOI = ICHDEP
  81. SEGACT MCHPOI
  82. DO 22 INS = 1,NSOU
  83. MSOUPO = IPCHP(INS)
  84. SEGACT MSOUPO*MOD
  85. IF (MOTCLE.EQ.'ROTA') THEN
  86. NCOM = NOCOMP(/2)
  87. SEGINI MTRA2
  88. MPOVAL = IPOVAL
  89. SEGACT MPOVAL
  90. NPOIN = VPOCHA(/1)
  91. DO 24 IP = 1,NPOIN
  92. ICD = 0
  93. ICR = 0
  94. DO 26 IC = 1,NCOM
  95. COMP = NOCOMP(IC)
  96. IF (COMP(1:1).EQ.'U') THEN
  97. ICD = ICD + 1
  98. IDEP(ICD) = IC
  99. XDEP(ICD) = VPOCHA(IP,IC)
  100. ELSE IF (COMP(1:1).EQ.'R') THEN
  101. ICR = ICR + 1
  102. IROT(ICR) = IC
  103. XROT(ICR) = VPOCHA(IP,IC)
  104. ENDIF
  105. 26 CONTINUE
  106. * end do
  107. DO 28 IDE = 1,ICD
  108. XVAL = 0.D0
  109. DO 30 ID2 = 1,ICD
  110. XVAL = XVAL + XMPT(IDE,ID2) * XDEP(ID2)
  111. 30 CONTINUE
  112. * end do
  113. IC = IDEP(IDE)
  114. VPOCHA(IP,IC) = XVAL
  115. 28 CONTINUE
  116. * end do
  117. IF (IDIM.EQ.3) THEN
  118. DO 32 IRO = 1,ICR
  119. XVAL = 0.D0
  120. DO 34 IR2 = 1,ICR
  121. XVAL = XVAL + XMPT(IRO,IR2) * XROT(IR2)
  122. 34 CONTINUE
  123. * end do
  124. IC = IROT(IRO)
  125. VPOCHA(IP,IC) = XVAL
  126. 32 CONTINUE
  127. * end do
  128. ENDIF
  129. 24 CONTINUE
  130. * end do
  131. SEGDES MPOVAL
  132. SEGSUP MTRA2
  133. ENDIF
  134. IGEOC = ICHCN(INS)
  135. SEGDES MSOUPO
  136. 22 CONTINUE
  137. * end do
  138. SEGDES MCHPOI
  139. MTAB1.MTABIV(I1) = ICHDEP
  140. ENDIF
  141. ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(5) .OR.
  142. & MTAB1.MTABII(I1).EQ.LCHAIN(8)) THEN
  143. IF (MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
  144. ICHDEP = MTAB1.MTABIV(I1)
  145. MCHPOI = ICHDEP
  146. SEGACT MCHPOI
  147. NSOU2 = IPCHP(/1)
  148. DO 40 INS = 1,NSOU2
  149. MSOUPO = IPCHP(INS)
  150. SEGACT MSOUPO*MOD
  151. IF (MOTCLE.EQ.'ROTA') THEN
  152. NCOM2 = NOCOMP(/2)
  153. SEGINI MTRA4
  154. MPOVAL = IPOVAL
  155. SEGACT MPOVAL
  156. NPOI2 = VPOCHA(/1)
  157. NCOM2 = VPOCHA(/2)
  158. DO 42 IP = 1,NPOI2
  159. ICF = 0
  160. ICM = 0
  161. DO 44 IC = 1,NCOM2
  162. COMP = NOCOMP(IC)
  163. IF (COMP(1:1).EQ.'F') THEN
  164. ICF = ICF + 1
  165. IFOR(ICF) = IC
  166. XFOR(ICF) = VPOCHA(IP,IC)
  167. ELSE IF (COMP(1:1).EQ.'M') THEN
  168. ICM = ICM + 1
  169. IMOM(ICM) = IC
  170. XMOM(ICM) = VPOCHA(IP,IC)
  171. ENDIF
  172. 44 CONTINUE
  173. * end do
  174. DO 46 IDE = 1,ICF
  175. XVAL = 0.D0
  176. DO 48 ID2 = 1,ICF
  177. XVAL = XVAL + XMPT(IDE,ID2) * XFOR(ID2)
  178. 48 CONTINUE
  179. * end do
  180. IC = IFOR(IDE)
  181. VPOCHA(IP,IC) = XVAL
  182. 46 CONTINUE
  183. * end do
  184. IF (IDIM.EQ.3) THEN
  185. DO 50 IRO = 1,ICM
  186. XVAL = 0.D0
  187. DO 52 IR2 = 1,ICM
  188. XVAL = XVAL + XMPT(IRO,IR2) * XMOM(IR2)
  189. 52 CONTINUE
  190. * end do
  191. IC = IMOM(IRO)
  192. VPOCHA(IP,IC) = XVAL
  193. 50 CONTINUE
  194. * end do
  195. ENDIF
  196. 42 CONTINUE
  197. * end do
  198. SEGDES MPOVAL
  199. SEGSUP MTRA4
  200. ENDIF
  201. IPT1 = IGEOC
  202. SEGINI,MELEME=IPT1
  203. NBE = NUM(/2)
  204. NBP = NUM(/1)
  205. DO 54 IE = 1,NBE
  206. DO 56 IP = 1,NBP
  207. IPTS = NUM(IP,IE)
  208. CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
  209. IF (IERR.NE.0) RETURN
  210. NUM(IP,IE) = INOPT
  211. 56 CONTINUE
  212. * end do
  213. 54 CONTINUE
  214. * end do
  215. SEGDES MELEME
  216. IGEOC = MELEME
  217. SEGDES MSOUPO
  218. 40 CONTINUE
  219. * end do
  220. SEGDES MCHPOI
  221. MTAB1.MTABIV(I1) = ICHDEP
  222. ENDIF
  223. ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(4) .OR.
  224. & MTAB1.MTABII(I1).EQ.LCHAIN(7)) THEN
  225. IF (MTAB1.MTABTV(I1).EQ.'MCHAML ') THEN
  226. ICHCON = MTAB1.MTABIV(I1)
  227. MCHELM = ICHCON
  228. SEGACT MCHELM*MOD
  229. DO 60 INS = 1,NSOUS
  230. IMACHE(INS) = ICHAM(INS)
  231. 60 CONTINUE
  232. * end do
  233. SEGDES MCHELM
  234. MTAB1.MTABIV(I1) = ICHCON
  235. ENDIF
  236. ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(9) .AND.
  237. & MTAB1.MTABTV(I1).EQ.'CHPOINT ') THEN
  238. ICHDEP = MTAB1.MTABIV(I1)
  239. MCHPOI = ICHDEP
  240. SEGACT MCHPOI
  241. NSOU3 = IPCHP(/1)
  242. DO 80 INS = 1,NSOU3
  243. MSOUPO = IPCHP(INS)
  244. SEGACT MSOUPO
  245. IPT1 = IGEOC
  246. SEGINI,MELEME=IPT1
  247. NBE = NUM(/2)
  248. NBP = NUM(/1)
  249. DO 82 IE = 1,NBE
  250. DO 84 IP = 1,NBP
  251. IPTS = NUM(IP,IE)
  252. CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
  253. IF (IERR.NE.0) RETURN
  254. NUM(IP,IE) = INOPT
  255. 84 CONTINUE
  256. * end do
  257. 82 CONTINUE
  258. * end do
  259. SEGDES MELEME
  260. IGEOC = MELEME
  261. SEGDES MSOUPO
  262. 80 CONTINUE
  263. * end do
  264. SEGDES MCHPOI
  265. MTAB1.MTABIV(I1) = ICHDEP
  266. ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(10) .AND.
  267. & MTAB1.MTABTV(I1).EQ.'POINT ') THEN
  268. IPTS = MTAB1.MTABIV(I1)
  269. CALL BAPOIN(IMAIL,IPTS,INOMA,INOPT)
  270. IF (IERR.NE.0) RETURN
  271. MTAB1.MTABIV(I1) = INOPT
  272. ELSE IF (MTAB1.MTABII(I1).EQ.LCHAIN(2) .AND.
  273. & MTAB1.MTABTV(I1).EQ.'TABLE ') THEN
  274. IF (MOTCLE.EQ.'ROTA') THEN
  275. ITDEPG = MTAB1.MTABIV(I1)
  276. SEGINI MTRA3
  277. MTAB2 = ITDEPG
  278. SEGACT MTAB2
  279. LON2 = MTAB2.MLOTAB
  280. IDG = 1
  281. DO 70 I2 = 1,LON2
  282. IF (MTAB2.MTABTI(I2).EQ.'ENTIER ' .AND.
  283. & MTAB2.MTABII(I2).EQ.IDG .AND.
  284. & MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN
  285. XDGEN(IDG) = MTAB2.RMTABV(I2)
  286. IDG = IDG + 1
  287. ENDIF
  288. 70 CONTINUE
  289. * end do
  290. DO 72 ID1 = 1,IDIM
  291. XVAL = 0.D0
  292. DO 74 ID2 = 1,IDIM
  293. XVAL = XVAL + (XMPT(ID1,ID2) * XDGEN(ID2))
  294. 74 CONTINUE
  295. * end do
  296. XDGE2(ID1) = XVAL
  297. 72 CONTINUE
  298. * end do
  299. IDG = 1
  300. DO 76 I2 = 1,LON2
  301. IF (MTAB2.MTABTI(I2).EQ.'ENTIER ' .AND.
  302. & MTAB2.MTABII(I2).EQ.IDG .AND.
  303. & MTAB2.MTABTV(I2).EQ.'FLOTTANT') THEN
  304. MTAB2.RMTABV(I2) = XDGE2(IDG)
  305. IDG = IDG + 1
  306. ENDIF
  307. 76 CONTINUE
  308. * end do
  309. SEGDES MTAB2
  310. MTAB1.MTABIV(I1) = ITDEPG
  311. SEGSUP MTRA3
  312. ENDIF
  313. ENDIF
  314. ENDIF
  315. 20 CONTINUE
  316. * end do
  317. SEGDES MTAB1
  318. MTABIV(I) = ITMOD
  319. ENDIF
  320. 10 CONTINUE
  321. * end do
  322. SEGDES MTABLE
  323. *
  324. END
  325.  
  326.  
  327.  
  328.  
  329.  

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