Télécharger psevrc.eso

Retour à la liste

Numérotation des lignes :

  1. C PSEVRC SOURCE FANDEUR 10/12/14 21:18:59 6812
  2. SUBROUTINE PSEVRC(ICONT,ITPS,IBAS,IBOO,IPX,KCHAR)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5.  
  6. *--------------------------------------------------------------------*
  7. * *
  8. * Prise en compte des pseudo-modes pour une recombinaison. *
  9. * *
  10. * Param}tres: *
  11. * *
  12. * e ICONT recombinaison d'un d{placement ( ICONT = 0 ) *
  13. * recombinaison d'une contrainte ( ICONT = 1 ) *
  14. * recombinaison d'une r{action ( ICONT = 2 ) *
  15. * e ITPS table repr{sentant les pseudo-modes *
  16. * e IBAS table repr{sentant la base modale *
  17. * es IBOO segment des points en recombinaison *
  18. * e IPX listreel des temps de recombinaison *
  19. * e KCHAR chargement de la structure *
  20. * *
  21. * Auteur, date de cr{ation: *
  22. * *
  23. * Lionel VIVAN, le 2 mai 1990. *
  24. * *
  25. *--------------------------------------------------------------------*
  26. * *
  27. -INC CCOPTIO
  28. -INC SMCHARG
  29. -INC SMCHPOI
  30. -INC SMLREEL
  31. *
  32. SEGMENT NUMOO
  33. INTEGER NUMO(N),KLIST(N)
  34. CHARACTER*4 NUDDL(N)
  35. ENDSEGMENT
  36. LOGICAL L0,L1
  37. CHARACTER*4 COMP
  38. CHARACTER*8 TYPRET,CHARRE
  39. CHARACTER*40 CMOT
  40. PARAMETER (TOLER = 1.D-6)
  41. *
  42. NUMOO = IBOO
  43. SEGACT NUMOO
  44. NP = NUMO(/1)
  45. DO 2 I = 1,NP
  46. MLREE3 = KLIST(I)
  47. SEGACT MLREE3*MOD
  48. 2 CONTINUE
  49. *
  50. MLREEL= IPX
  51. SEGACT MLREEL
  52. LDIM = PROG(/1)
  53. *
  54. MCHARG = KCHAR
  55. SEGACT MCHARG
  56. NCHAR = KCHARG(/1)
  57. *
  58. * Boucle sur les pseudo-modes
  59. *
  60. IPS = 0
  61. 10 CONTINUE
  62. IPS = IPS + 1
  63. TYPRET = ' '
  64. CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
  65. & TYPRET,I1,X1,CHARRE,L1,ITPM)
  66. IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
  67. CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  68. & 'MOT',I1,X1,CMOT,L1,IP1)
  69. IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
  70. CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  71. & 'CHPOINT',I1,X1,' ',L1,ICHBB)
  72. *
  73. * boucle sur les chargements {l{mentaires
  74. *
  75. DO 20 ICHA =1,NCHAR
  76. ICHARG = KCHARG(ICHA)
  77. SEGACT ICHARG
  78. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  79. & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  80. SEGDES ICHARG
  81. GOTO 20
  82. ENDIF
  83. IF (ICHBB.EQ.ICHPO1) GOTO 100
  84. 20 CONTINUE
  85. * end do
  86. * on n'a pas trouv{ le chargement
  87. INTERR(1) = IPS
  88. CALL ERREUR(428)
  89. SEGDES ICHARG
  90. GOTO 10
  91. ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
  92. CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
  93. & 'ENTIER',IENT,X1,' ',L1,IP1)
  94. CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
  95. & 'TABLE',I1,X1,' ',L1,ITMK)
  96. CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
  97. & L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
  98. CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
  99. & 'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
  100. *
  101. * boucle sur les chargements {l{mentaires
  102. *
  103. DO 30 ICHA =1,NCHAR
  104. ICHARG = KCHARG(ICHA)
  105. SEGACT ICHARG
  106. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  107. & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  108. SEGDES ICHARG
  109. GOTO 30
  110. ENDIF
  111. MCHPOI = ICHPO1
  112. SEGACT MCHPOI
  113. MSOUPO = IPCHP(1)
  114. SEGDES MCHPOI
  115. SEGACT MSOUPO
  116. MPOVAL = IPOVAL
  117. SEGDES MSOUPO
  118. SEGACT MPOVAL
  119. QXYZ = VPOCHA(1,1)
  120. SEGDES MPOVAL
  121. EPS = ABS(QXYZ + XQXYZ)
  122. IF (EPS.LT.TOLER) GOTO 100
  123. 30 CONTINUE
  124. * end do
  125. * on n'a pas trouv{ le chargement
  126. INTERR(1) = IPS
  127. CALL ERREUR(428)
  128. SEGDES ICHARG
  129. GOTO 10
  130. ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
  131. CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  132. & 'CHPOINT',I1,X1,' ',L1,ICHBB)
  133. *
  134. * boucle sur les chargements {l{mentaires
  135. *
  136. DO 40 ICHA =1,NCHAR
  137. ICHARG = KCHARG(ICHA)
  138. SEGACT ICHARG
  139. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  140. & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  141. SEGDES ICHARG
  142. GOTO 40
  143. ENDIF
  144. IF (ICHBB.EQ.ICHPO1) GOTO 100
  145. 40 CONTINUE
  146. * end do
  147. * on n'a pas trouv{ le chargement
  148. INTERR(1) = IPS
  149. CALL ERREUR(428)
  150. SEGDES ICHARG
  151. GOTO 10
  152. ENDIF
  153. *
  154. 100 CONTINUE
  155. ICDEP = 0
  156. IF (ICONT.EQ.0) THEN
  157. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  158. & 'CHPOINT',I1,X1,' ',L1,ICDEP)
  159. ELSE IF (ICONT.EQ.1) THEN
  160. CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
  161. & 'MCHAML ',I1,X1,' ',L1,ICHAM1)
  162. C* Manque le passage en MCHAML aux noeuds avec le modele !!!
  163. C* CALL CHASUP(IPMODL,ICHAM1,ICHAM2,IRETOU,1)
  164. C* IF (IRETOU.EQ.0) THEN
  165. C* INTERR(1) = IPS
  166. C* CALL ERREUR(___)
  167. C* SEGDES ICHARG
  168. C* GOTO 10
  169. C* ENDIF
  170. C* CALL CHAMPO(ICHAM2,2,ICDEP,IRETOU)
  171. CALL CHAMPO(ICHAM1,2,ICDEP,IRETOU)
  172. IF (IRETOU.EQ.0) THEN
  173. INTERR(1) = IPS
  174. CALL ERREUR(428)
  175. SEGDES ICHARG
  176. GOTO 10
  177. ENDIF
  178. ELSE IF (ICONT.EQ.2) THEN
  179. CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
  180. & 'CHPOINT',I1,X1,' ',L1,ICDEP)
  181. ENDIF
  182. MLREE1 = ICHPO2
  183. SEGACT MLREE1
  184. NF = MLREE1.PROG(/1)
  185. MLREE2 = ICHPO3
  186. SEGACT MLREE2
  187. IF (IIMPI.EQ.1804) THEN
  188. WRITE(IOIMP,*)'PSEVRC : pseudo-mode num{ro ',IPS
  189. WRITE(IOIMP,*)'PSEVRC : chargement ',KCHAR
  190. WRITE(IOIMP,*)'PSEVRC : num{ro ',ICHA
  191. ENDIF
  192. N1 = 1
  193. N2 = 2
  194. DO 110 IT = 1,LDIM
  195. XTEMP = PROG(IT)
  196. CALL INTLIN(XTEMP,ICHPO2,ICHPO3,NF,N1,N2,XFTEM,IRETOU)
  197. IF (IRETOU.EQ.0) THEN
  198. INTERR(1) = IPS
  199. CALL ERREUR(428)
  200. SEGDES MLREE1
  201. SEGDES MLREE2
  202. SEGDES ICHARG
  203. GOTO 10
  204. ENDIF
  205. IF (IIMPI.EQ.1804) THEN
  206. WRITE(IOIMP,*)'PSEVRC : temps ',XTEMP
  207. WRITE(IOIMP,*)'PSEVRC : f(t) ',XFTEM
  208. ENDIF
  209. *
  210. DO 120 IP = 1,NP
  211. IPOIN = NUMO(IP)
  212. COMP = NUDDL(IP)
  213. CALL EXTRA9(ICDEP,IPOIN,COMP,KERRE,XFLOT)
  214. IF (KERRE.NE.0) THEN
  215. INTERR(1) = IPS
  216. CALL ERREUR(428)
  217. SEGDES MLREE1
  218. SEGDES MLREE2
  219. SEGDES ICHARG
  220. GOTO 10
  221. ENDIF
  222. XVAL = XFLOT * XFTEM
  223. IF (IIMPI.EQ.1804) THEN
  224. WRITE(IOIMP,*)'PSEVRC : au point ',IPOIN
  225. WRITE(IOIMP,*)'PSEVRC : de composante ',COMP
  226. WRITE(IOIMP,*)'PSEVRC : valeur calcul{e ',XVAL
  227. ENDIF
  228. MLREE3 = KLIST(IP)
  229. MLREE3.PROG(IT) = MLREE3.PROG(IT) + XVAL
  230. 120 CONTINUE
  231. 110 CONTINUE
  232. SEGDES MLREE1
  233. SEGDES MLREE2
  234. SEGDES ICHARG
  235. GOTO 10
  236. ENDIF
  237. *
  238. SEGDES MCHARG
  239. SEGDES MLREEL
  240. DO 4 I = 1,NP
  241. MLREE3 = KLIST(I)
  242. SEGDES MLREE3
  243. 4 CONTINUE
  244. IBOO = NUMOO
  245. *
  246. IF (ICONT.EQ.1) THEN
  247. MCHPO1 = ICDEP
  248. SEGSUP MCHPO1
  249. ENDIF
  250. *
  251. RETURN
  252. END
  253.  
  254.  
  255.  

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