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

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