Télécharger dyn205.eso

Retour à la liste

Numérotation des lignes :

  1. C DYN205 SOURCE CHAT 05/01/12 23:10:52 5004
  2. SUBROUTINE DYN205(I,ITLB,ITYP,KTLIAB,NPLB)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. *--------------------------------------------------------------------*
  6. * *
  7. * Operateur DYNE : algorithme de Fu - de Vogelaere *
  8. * ________________________________________________ *
  9. * *
  10. * Remplissage des tableaux de description des liaisons sur *
  11. * la base a partir des informations contenues dans la *
  12. * TABLE ILIB (LIAISON DE TYPE POINT_POINT_ROTATION_PLASTIQUE). *
  13. * *
  14. * Parametres: *
  15. * *
  16. * e I Numero de la liaison. *
  17. * e ITLB Table rassemblant la description d'une liaison. *
  18. * e ITYP Type de la liaison. *
  19. * s KTLIAB Segment descriptif des liaisons sur base B. *
  20. * e NPLB Nombre total de points. *
  21. * *
  22. * *
  23. * Auteur, date de creation: *
  24. * *
  25. * Nicolas WECXSTEEN 04/96 point-point- ... -plastique *
  26. * *
  27. *--------------------------------------------------------------------*
  28. -INC CCOPTIO
  29. -INC SMCOORD
  30. -INC SMEVOLL
  31. -INC SMLREEL
  32. *
  33. SEGMENT MTLIAB
  34. INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  35. REAL*8 XPALB(NLIAB,NXPALB)
  36. REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  37. ENDSEGMENT
  38. *
  39. LOGICAL L1,L0,LPERM,LELAS,LECRO
  40. CHARACTER*8 MONAMO,CHARRE,MONPER,MONELA,TYPRET
  41. CHARACTER*20 MONECR
  42.  
  43. *
  44. MTLIAB = KTLIAB
  45. *
  46. * --- choc elementaire POINT_POINT_ROTATION_PLASTIQUE avec ou sans
  47. * amortissement
  48. *
  49. IF (ITYP.EQ.50) THEN
  50. CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
  51. & 'POINT',I1,X1,' ',L1,INOA)
  52. IF (IERR.NE.0) RETURN
  53. CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
  54. & 'POINT',I1,X1,' ',L1,INOB)
  55. IF (IERR.NE.0) RETURN
  56. CALL ACCTAB(ITLB,'MOT',I0,X0,'AXE_ROTATION',L0,IP0,
  57. & 'POINT',I1,X1,' ',L1,IPOI)
  58. IF (IERR.NE.0) RETURN
  59. CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
  60. & 'FLOTTANT',I0,XJEU,' ',L1,IP1)
  61. IF (IERR.NE.0) RETURN
  62. CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
  63. & 'EVOLUTIO',I1,X1,' ',L1,IPEVO)
  64. IF (IERR.NE.0) RETURN
  65. *
  66. MONPER = ' '
  67. LPERM = .FALSE.
  68. CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0,
  69. & IP0,MONPER,I0,X1,' ',LPERM,IP1)
  70. IF (IERR.NE.0) RETURN
  71. TYPRET = ' '
  72. CALL ACCTAB(ITLB,'MOT',I1,X0,'ECROUISSAGE',L0,
  73. & IP0,TYPRET,I0,X1,MONECR,L1,IP1)
  74. IF (IERR.NE.0) RETURN
  75. LECRO = (TYPRET.EQ.'MOT')
  76. MONELA = ' '
  77. LELAS = .FALSE.
  78. CALL ACCTAB(ITLB,'MOT',I1,X0,'COMPORTEMENT_ELASTIQUE',L0,
  79. & IP0,MONELA,I0,X1,' ',LELAS,IP1)
  80. IF (IERR.NE.0) RETURN
  81. IPERM = 0
  82. *
  83. * iperm = -2 : liaison elastique permanente
  84. * iperm = -1 : choc elastique
  85. * iperm = 0 : donnees incoherentes ou insuffisantes
  86. * iperm = 1 : choc plastique
  87. * iperm = 2 : liaison plastique isotrope
  88. * iperm = 3 : liaison plastique cinematique
  89. *
  90.  
  91. IF (LPERM) THEN
  92. IF (LELAS.AND.(.NOT.LECRO)) IPERM = -2
  93. IF (MONECR.EQ.'ISOTROPE'.AND.(.NOT.LELAS)) IPERM = 2
  94. IF (MONECR.EQ.'CINEMATIQUE'.AND.(.NOT.LELAS)) IPERM = 3
  95. IF (.NOT.(XJEU.EQ.0.)) THEN
  96. * WRITE(*,*) 'Liaison permanente, mise a zero du jeu.'
  97. XJEU = 0.D0
  98. ENDIF
  99. ELSE
  100. IF (.NOT.LECRO) THEN
  101. IF (LELAS) THEN
  102. IPERM = -1
  103. ELSE
  104. IPERM = 1
  105. ENDIF
  106. ENDIF
  107. ENDIF
  108. IF (IPERM.EQ.0) THEN
  109. CALL ERREUR(905)
  110. RETURN
  111. ENDIF
  112. *
  113. MEVOLL = IPEVO
  114. *
  115. * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  116. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
  117. * tableaux xabsci et xordon
  118. *
  119. SEGACT MEVOLL
  120. KEVOLL = IEVOLL(1)
  121. SEGACT KEVOLL
  122. MLREE1 = IPROGX
  123. MLREE2 = IPROGY
  124. SEGACT MLREE1
  125. SEGACT MLREE2
  126. * NIP = MLREE1.PROG(/1)
  127. NIP = XABSCI(/2)
  128. *
  129. DO 10 MM=1,NIP
  130. XABSCI (I,MM) = MLREE1.PROG(MM)
  131. XORDON (I,MM) = MLREE2.PROG(MM)
  132. 10 CONTINUE
  133. *
  134. SEGDES MLREE1
  135. SEGDES MLREE2
  136. SEGDES KEVOLL
  137. SEGDES MEVOLL
  138. *
  139. MONAMO = ' '
  140. CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
  141. & MONAMO,I0,XAMON,CHARRE,L1,IP1)
  142. IF (IERR.NE.0) RETURN
  143. *
  144. IPALB(I,1) = ITYP
  145. IPALB(I,3) = IDIM
  146. IPALB(I,5) = IPERM
  147. XPALB(I,1) = XJEU
  148. *
  149. * normalisation de l'axe de rotation
  150. *
  151. IPNV = (IDIM + 1) * (IPOI - 1)
  152. PS = 0.D0
  153. DO 20 ID = 1,IDIM
  154. XC = XCOOR(IPNV + ID)
  155. PS = PS + XC * XC
  156. 20 CONTINUE
  157. * end do
  158. IF (PS.LE.0.D0) THEN
  159. CALL ERREUR(162)
  160. RETURN
  161. ENDIF
  162. IF (MONAMO.EQ.'FLOTTANT') THEN
  163. IPALB(I,1) = 51
  164. XPALB(I,2) = XAMON
  165. DO 22 ID = 1,IDIM
  166. ID2 = 2 + ID
  167. XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  168. 22 CONTINUE
  169. * end do
  170. ELSE
  171. DO 24 ID = 1,IDIM
  172. ID2 = 1 + ID
  173. XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  174. 24 CONTINUE
  175. * end do
  176. ENDIF
  177. *
  178. CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  179. IPLIB(I,1) = IPLAC
  180. CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  181. IPLIB(I,2) = IPLAC
  182. *
  183. *
  184. * --- choc elementaire POINT_POINT...
  185. *
  186. * ELSE IF (ITYP.EQ. ) THEN
  187. * ...
  188. * ...
  189. ENDIF
  190. *
  191. END
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  

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