Télécharger rdepla.eso

Retour à la liste

Numérotation des lignes :

  1. C RDEPLA SOURCE BP208322 15/06/22 21:21:33 8543
  2. SUBROUTINE RDEPLA(MCHPOI)
  3. C=====================================================================
  4. C OPERATEUR POUR CHANGER DE REPERE SUR UN CHAMP DE DEPLACEMENTS
  5. C (OU TOUT CHAMP PAR POINTS)
  6. C
  7. C MCHPO1 = RDEP MCHPOI IVEC1 (IVEC2)
  8. C Entrées : MCHPOI : MCHPOI Champ de déplacements
  9. C VEC1 : POINT Premier vecteur du repère
  10. C VEC2 : POINT Deuxième vecteur du repère
  11. C Sortie : MCHPO1 : MCHPOI Champ de déplacements
  12. C
  13. C=====================================================================
  14. C
  15. IMPLICIT INTEGER(I-N)
  16. IMPLICIT REAL*8(A-H,O-Z)
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC CCHAMP
  21. -INC SMCHPOI
  22. -INC SMCOORD
  23. C
  24. C Déclarations
  25. C
  26. *** Vecteurs du repère
  27. REAL*8 XU(3), XV(3), XW(3)
  28. *** Tableau de pointeurs sur des segments
  29. INTEGER IDEP(6,2)
  30. *** Tableau des déplacements d'un noeud
  31. REAL*8 XDEP(3), XROT(3)
  32. *** Matrice de changement de repère
  33. REAL*8 XMATC(3,3)
  34. C
  35. C Corps
  36. C
  37. IRET=0
  38. C
  39. C Lecture du champ de déplacements
  40. C
  41. * CALL LIROBJ('CHPOINT', MCHPOI, 1, IRET)
  42. * IF (IERR.NE.0) RETURN
  43. C
  44. C Lecture du ou des vecteurs du repère
  45. C
  46. CALL LIROBJ('POINT', IVEC1, 1, IRET)
  47. IF (IERR.NE.0) RETURN
  48. IREU = (IDIM + 1)*(IVEC1 - 1)
  49. XNORU = 0.
  50. DO 1 IC = 1, IDIM
  51. XU(IC) = XCOOR(IREU + IC)
  52. XNORU = XNORU + XU(IC)*XU(IC)
  53. 1 CONTINUE
  54. XNORU = SQRT(XNORU)
  55. DO 10 IC = 1, IDIM
  56. 10 XU(IC) = XU(IC)/XNORU
  57. IF (IDIM .EQ. 3) THEN
  58. CALL LIROBJ('POINT', IVEC2, 1, IRET)
  59. IF (IERR.NE.0) RETURN
  60. IREV = (IDIM + 1)*(IVEC2 - 1)
  61. XNORV = 0.
  62. DO 2 IC = 1, IDIM
  63. XV(IC) = XCOOR(IREV + IC)
  64. XNORV = XNORV + XV(IC)*XV(IC)
  65. 2 CONTINUE
  66. XNORV = SQRT(XNORV)
  67. DO 11 IC = 1, IDIM
  68. 11 XV(IC) = XV(IC)/XNORV
  69. XW(1) = XU(2)*XV(3) - XU(3)*XV(2)
  70. XW(2) = XU(3)*XV(1) - XU(1)*XV(3)
  71. XW(3) = XU(1)*XV(2) - XU(2)*XV(1)
  72. XNORW = 0.
  73. DO 8 IC = 1, IDIM
  74. XNORW = XNORW + XW(IC)*XW(IC)
  75. 8 CONTINUE
  76. XNORW = SQRT(XNORW)
  77. DO 15 IC = 1, IDIM
  78. 15 XW(IC) = XW(IC)/XNORW
  79. XV(1) = XW(2)*XU(3) - XW(3)*XU(2)
  80. XV(2) = XW(3)*XU(1) - XW(1)*XU(3)
  81. XV(3) = XW(1)*XU(2) - XW(2)*XU(1)
  82. DO 12 IC = 1, IDIM
  83. XMATC(1, IC) = XU(IC)
  84. XMATC(2, IC) = XV(IC)
  85. XMATC(3, IC) = XW(IC)
  86. 12 CONTINUE
  87. ELSE
  88. XV(1) = -XU(2)
  89. XV(2) = XU(1)
  90. DO 13 IC = 1, IDIM
  91. XMATC(1, IC) = XU(IC)
  92. XMATC(2, IC) = XV(IC)
  93. 13 CONTINUE
  94. ENDIF
  95. * WRITE (*,*) 'Matrice de changement de repère :'
  96. * DO 14 IL = 1, IDIM
  97. * IF (IDIM .EQ. 3) THEN
  98. * WRITE (*,*) ' ',XMATC(IL,1),' ',XMATC(IL,2),
  99. * # ' ',XMATC(IL,3)
  100. * ELSE
  101. * WRITE (*,*) ' ',XMATC(IL,1),' ',XMATC(IL,2)
  102. * ENDIF
  103. * 14 CONTINUE
  104. DO 30 II = 1, 6
  105. DO 30 IJ = 1, 2
  106. 30 IDEP(II, IJ) = 0
  107. SEGINI, MCHPO1 = MCHPOI
  108. SEGACT, MCHPOI
  109. DO 80 IMS = 1, MCHPOI.IPCHP(/1)
  110. MSOUPO = MCHPOI.IPCHP(IMS)
  111. SEGACT, MSOUPO
  112. SEGINI, MSOUP1 = MSOUPO
  113. MPOVAL = MSOUPO.IPOVAL
  114. SEGINI, MPOVA1 = MPOVAL
  115. MSOUP1.IPOVAL = MPOVA1
  116. MCHPO1.IPCHP(IMS) = MSOUP1
  117. SEGDES, MSOUPO
  118. SEGDES, MSOUP1
  119. SEGDES, MPOVA1
  120. 80 CONTINUE
  121. IF (IFOMOD .EQ. 0 .OR. IFOMOD .EQ. 1) GOTO 100
  122. SEGACT, MCHPOI
  123. * WRITE (*,*) 'Nombre de pointeurs sur MSOUPO',MCHPO1.IPCHP(/1)
  124. DO 3 IMS = 1, MCHPO1.IPCHP(/1)
  125. * WRITE (*,*) ' MSOUPO # ', IMS
  126. MSOUPO = MCHPOI.IPCHP(IMS)
  127. SEGACT, MSOUPO
  128. * WRITE(*,*) ' ', MSOUPO.NOHARM(/1), ' composantes'
  129. DO 70 II = 1, 6
  130. DO 70 IJ = 1, 2
  131. 70 IDEP(II, IJ) = 0
  132. DO 4 IC = 1, MSOUPO.NOHARM(/1)
  133. * WRITE (*,*) ' :',MSOUPO.NOCOMP(IC)
  134. ***-----------Pour UX
  135. CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(1), 4, IRET)
  136. IF (IRET .EQ. 1) THEN
  137. IDEP(1,1) = IMS
  138. IDEP(1,2) = IC
  139. IRET = 0
  140. * WRITE (*,*) NOMDD(1),'détecté en ',IDEP(1,2),' de ',IDEP(1,1)
  141. ELSE
  142. ***-----------Pour UY
  143. CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(2), 4, IRET)
  144. IF (IRET .EQ. 1) THEN
  145. IDEP(2,1) = IMS
  146. IDEP(2,2) = IC
  147. IRET = 0
  148. * WRITE (*,*) NOMDD(2),'détecté en ',IDEP(2,2),' de ',IDEP(2,1)
  149. ELSE
  150. ***-----------Pour UZ
  151. CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(3), 4, IRET)
  152. IF (IRET .EQ. 1) THEN
  153. IDEP(3,1) = IMS
  154. IDEP(3,2) = IC
  155. IRET = 0
  156. * WRITE (*,*) NOMDD(3),'détecté en ',IDEP(3,2),' de ',IDEP(3,1)
  157. ELSE
  158. ***-----------Pour RX
  159. CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(4), 4, IRET)
  160. IF (IRET .EQ. 1) THEN
  161. IDEP(4,1) = IMS
  162. IDEP(4,2) = IC
  163. IRET = 0
  164. * WRITE (*,*) NOMDD(4),'détecté en ',IDEP(4,2),' de ',IDEP(4,1)
  165. ELSE
  166. ***-----------Pour RY
  167. CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(5), 4, IRET)
  168. IF (IRET .EQ. 1) THEN
  169. IDEP(5,1) = IMS
  170. IDEP(5,2) = IC
  171. IRET = 0
  172. * WRITE (*,*) NOMDD(5),'détecté en ',IDEP(5,2),' de ',IDEP(5,1)
  173. ELSE
  174. ***-----------Pour RZ
  175. CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(6), 4, IRET)
  176. IF (IRET .EQ. 1) THEN
  177. IDEP(6,1) = IMS
  178. IDEP(6,2) = IC
  179. IRET = 0
  180. * WRITE (*,*) NOMDD(6),'détecté en ',IDEP(6,2),' de ',IDEP(6,1)
  181. ENDIF
  182. ENDIF
  183. ENDIF
  184. ENDIF
  185. ENDIF
  186. ENDIF
  187. 4 CONTINUE
  188. MPOVAL = MSOUPO.IPOVAL
  189. SEGACT, MPOVAL
  190. INP = MPOVAL.VPOCHA(/1)
  191. ***----Pour chaque composante à transformer
  192. MSOUP1 = MCHPO1.IPCHP(IMS)
  193. SEGACT, MSOUP1
  194. MPOVA1 = MSOUP1.IPOVAL
  195. SEGACT, MPOVA1*MOD
  196. * DO 400 IC = 1, 6
  197. * WRITE (*,*) ' '
  198. * WRITE (*,*) ' IDEP(',IC,',1) = ', IDEP(IC,1)
  199. * WRITE (*,*) ' IDEP(',IC,',2) = ', IDEP(IC,2)
  200. * 400 CONTINUE
  201. DO 50 IN = 1, INP
  202. DO 40 IC = 1, 3
  203. IF (IDEP(IC,1) .NE. 0) THEN
  204. XDEP(IC) = MPOVAL.VPOCHA(IN,IDEP(IC,2))
  205. * WRITE (*,*) 'XDEP(',IC,') = ', XDEP(IC)
  206. ENDIF
  207. ICL = IC + 3
  208. IF (IDEP(ICL,1) .NE. 0) THEN
  209. XROT(IC) = MPOVAL.VPOCHA(IN,IDEP(ICL,2))
  210. * WRITE (*,*) 'XROT(',IC,') = ', XROT(IC)
  211. ENDIF
  212. 40 CONTINUE
  213. DO 41 IC = 1, 3
  214. IF (IDEP(IC,1) .NE. 0) THEN
  215. MPOVA1.VPOCHA(IN,IDEP(IC,2)) = 0.
  216. DO 42 IJ = 1, 3
  217. MPOVA1.VPOCHA(IN,IDEP(IC,2)) =
  218. # MPOVA1.VPOCHA(IN,IDEP(IC,2)) + XMATC(IC,IJ)*XDEP(IJ)
  219. 42 CONTINUE
  220. ENDIF
  221. ICL = IC + 3
  222. IF (IDEP(ICL,1) .NE. 0) THEN
  223. MPOVA1.VPOCHA(IN,IDEP(ICL,2)) = 0.
  224. DO 43 IJ = 1, 3
  225. MPOVA1.VPOCHA(IN,IDEP(ICL,2)) =
  226. # MPOVA1.VPOCHA(IN,IDEP(ICL,2)) + XMATC(IC,IJ)*XROT(IJ)
  227. 43 CONTINUE
  228. ENDIF
  229. 41 CONTINUE
  230. 50 CONTINUE
  231. SEGDES, MPOVA1
  232. SEGDES, MSOUP1
  233. SEGDES, MPOVAL
  234. SEGDES, MSOUPO
  235. 3 CONTINUE
  236.  
  237. SEGDES, MCHPOI
  238. SEGDES, MCHPO1
  239. C
  240. C Ecriture du champ de déplacements
  241. C
  242. 100 CONTINUE
  243. CALL ECROBJ('CHPOINT', MCHPO1)
  244. RETURN
  245. END
  246.  
  247.  
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  

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