Télécharger rdepla.eso

Retour à la liste

Numérotation des lignes :

rdepla
  1. C RDEPLA SOURCE CB215821 20/11/25 13:38:39 10792
  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. IF (MSOUPO.NOCOMP(IC) .EQ. NOMDD(1)) THEN
  136. IDEP(1,1) = IMS
  137. IDEP(1,2) = IC
  138. IRET = 0
  139. * WRITE (*,*) NOMDD(1),'détecté en ',IDEP(1,2),' de ',IDEP(1,1)
  140. ELSE
  141. ***-----------Pour UY
  142. IF (MSOUPO.NOCOMP(IC) .EQ. NOMDD(2)) 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. IF (MSOUPO.NOCOMP(IC) .EQ. NOMDD(3)) THEN
  150. IDEP(3,1) = IMS
  151. IDEP(3,2) = IC
  152. IRET = 0
  153. * WRITE (*,*) NOMDD(3),'détecté en ',IDEP(3,2),' de ',IDEP(3,1)
  154. ELSE
  155. ***-----------Pour RX
  156. IF (MSOUPO.NOCOMP(IC) .EQ. NOMDD(4)) THEN
  157. IDEP(4,1) = IMS
  158. IDEP(4,2) = IC
  159. IRET = 0
  160. * WRITE (*,*) NOMDD(4),'détecté en ',IDEP(4,2),' de ',IDEP(4,1)
  161. ELSE
  162. ***-----------Pour RY
  163. IF (MSOUPO.NOCOMP(IC) .EQ. NOMDD(5)) THEN
  164. IDEP(5,1) = IMS
  165. IDEP(5,2) = IC
  166. IRET = 0
  167. * WRITE (*,*) NOMDD(5),'détecté en ',IDEP(5,2),' de ',IDEP(5,1)
  168. ELSE
  169. ***-----------Pour RZ
  170. IF (MSOUPO.NOCOMP(IC) .EQ. NOMDD(6)) THEN
  171. IDEP(6,1) = IMS
  172. IDEP(6,2) = IC
  173. IRET = 0
  174. * WRITE (*,*) NOMDD(6),'détecté en ',IDEP(6,2),' de ',IDEP(6,1)
  175. ENDIF
  176. ENDIF
  177. ENDIF
  178. ENDIF
  179. ENDIF
  180. ENDIF
  181. 4 CONTINUE
  182. MPOVAL = MSOUPO.IPOVAL
  183. SEGACT, MPOVAL
  184. INP = MPOVAL.VPOCHA(/1)
  185. ***----Pour chaque composante à transformer
  186. MSOUP1 = MCHPO1.IPCHP(IMS)
  187. SEGACT, MSOUP1
  188. MPOVA1 = MSOUP1.IPOVAL
  189. SEGACT, MPOVA1*MOD
  190. * DO 400 IC = 1, 6
  191. * WRITE (*,*) ' '
  192. * WRITE (*,*) ' IDEP(',IC,',1) = ', IDEP(IC,1)
  193. * WRITE (*,*) ' IDEP(',IC,',2) = ', IDEP(IC,2)
  194. * 400 CONTINUE
  195. DO 50 IN = 1, INP
  196. DO 40 IC = 1, 3
  197. IF (IDEP(IC,1) .NE. 0) THEN
  198. XDEP(IC) = MPOVAL.VPOCHA(IN,IDEP(IC,2))
  199. * WRITE (*,*) 'XDEP(',IC,') = ', XDEP(IC)
  200. ENDIF
  201. ICL = IC + 3
  202. IF (IDEP(ICL,1) .NE. 0) THEN
  203. XROT(IC) = MPOVAL.VPOCHA(IN,IDEP(ICL,2))
  204. * WRITE (*,*) 'XROT(',IC,') = ', XROT(IC)
  205. ENDIF
  206. 40 CONTINUE
  207. DO 41 IC = 1, 3
  208. IF (IDEP(IC,1) .NE. 0) THEN
  209. MPOVA1.VPOCHA(IN,IDEP(IC,2)) = 0.
  210. DO 42 IJ = 1, 3
  211. MPOVA1.VPOCHA(IN,IDEP(IC,2)) =
  212. # MPOVA1.VPOCHA(IN,IDEP(IC,2)) + XMATC(IC,IJ)*XDEP(IJ)
  213. 42 CONTINUE
  214. ENDIF
  215. ICL = IC + 3
  216. IF (IDEP(ICL,1) .NE. 0) THEN
  217. MPOVA1.VPOCHA(IN,IDEP(ICL,2)) = 0.
  218. DO 43 IJ = 1, 3
  219. MPOVA1.VPOCHA(IN,IDEP(ICL,2)) =
  220. # MPOVA1.VPOCHA(IN,IDEP(ICL,2)) + XMATC(IC,IJ)*XROT(IJ)
  221. 43 CONTINUE
  222. ENDIF
  223. 41 CONTINUE
  224. 50 CONTINUE
  225. SEGDES, MPOVA1
  226. SEGDES, MSOUP1
  227. SEGDES, MPOVAL
  228. SEGDES, MSOUPO
  229. 3 CONTINUE
  230.  
  231. SEGDES, MCHPOI
  232. SEGDES, MCHPO1
  233. C
  234. C Ecriture du champ de déplacements
  235. C
  236. 100 CONTINUE
  237. CALL ECROBJ('CHPOINT', MCHPO1)
  238. RETURN
  239. END
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  

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