Télécharger psrcd2.eso

Retour à la liste

Numérotation des lignes :

  1. C PSRCD2 SOURCE FANDEUR 10/12/14 21:19:00 6812
  2. SUBROUTINE PSRCD2(TYPE,ITPS,IBAS,ICHCR,KCHAR,XTEMP,ITRES,IPOS,
  3. & ITLIA)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. *--------------------------------------------------------------------*
  7. * *
  8. * Prise en compte des pseudo-modes pour une recombinaison. *
  9. * *
  10. * Param}tres: *
  11. * *
  12. * e TYPE recombinaison d'une contrainte ou d'un d{placement *
  13. * ou d'une r{action *
  14. * e ITPS table repr{sentant les pseudo-modes *
  15. * e IBAS table repr{sentant la base modale *
  16. * es ICHCR nouveau chamelem ou chpoint *
  17. * e KCHAR chargement de la structure *
  18. * e XTEMP temps de recombinaison *
  19. * e ITRES table issue de l'op{rateur DYNE *
  20. * e IPOS position de XTEMP dans le listreel des temps *
  21. * e ITLIA table des liaisons *
  22. * *
  23. * Auteur, date de cr{ation: *
  24. * *
  25. * Lionel VIVAN, le 18 avril 1990. *
  26. * *
  27. * Passage aux nouveaux mchamls par jm CAMPENON le 01/91 *
  28. * *
  29. *--------------------------------------------------------------------*
  30. * *
  31. -INC CCOPTIO
  32. -INC CCREEL
  33. *-
  34. -INC SMCHARG
  35. -INC SMCHPOI
  36. -INC SMCOORD
  37. -INC SMELEME
  38. -INC SMLREEL
  39. *
  40. LOGICAL L0,L1
  41. CHARACTER*4 TYPE
  42. CHARACTER*8 TYPRET,CHARRE
  43. CHARACTER*40 CMOT,CTYP
  44. PARAMETER (TOLER = 1.D-6 , IUN = 1 , NBPP = 1)
  45. CHARACTER*13 MADIR1,MOTPPL(NBPP)
  46. CHARACTER*21 MADIR2,MOTPPA(NBPP),MOTPPB(NBPP)
  47. DATA MOTPPL/'FORCE_DE_CHOC'/
  48. DATA MOTPPA/'FORCE_DE_CHOC_POINT_A'/
  49. DATA MOTPPB/'FORCE_DE_CHOC_POINT_B'/
  50. *
  51. IF (KCHAR.NE.0) THEN
  52. MCHARG = KCHAR
  53. SEGACT MCHARG
  54. NCHAR = KCHARG(/1)
  55. ENDIF
  56. ITLIAB = 0
  57. IF (ITLIA.NE.0) THEN
  58. TYPRET = ' '
  59. CALL ACCTAB(ITLIA,'MOT',I0,X0,'LIAISON_B',L0,IP0,
  60. & TYPRET,I1,X1,CHARRE,L1,ITAB)
  61. IF (ITAB.NE.0 .AND. TYPRET.EQ.'TABLE ') ITLIAB = ITAB
  62. ENDIF
  63. CALL ACCTAB(IBAS,'MOT',I0,X0,'MAILLAGE',L1,IP0,
  64. & 'MAILLAGE',I1,X1,' ',L1,IMAIL)
  65. *
  66. * Boucle sur les pseudo-modes
  67. *
  68. IPS = 0
  69. 10 CONTINUE
  70. IPS = IPS + 1
  71. TYPRET = ' '
  72. CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
  73. & TYPRET,I1,X1,CHARRE,L1,ITPM)
  74. IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
  75. CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  76. & 'MOT',I1,X1,CMOT,L1,IP1)
  77. IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
  78. IF (KCHAR.EQ.0) GOTO 10
  79. CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  80. & 'CHPOINT',I1,X1,' ',L1,ICHBB)
  81. *
  82. * boucle sur les chargements {l{mentaires
  83. *
  84. DO 20 ICHA =1,NCHAR
  85. ICHARG = KCHARG(ICHA)
  86. SEGACT ICHARG
  87. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  88. & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  89. SEGDES ICHARG
  90. GOTO 20
  91. ENDIF
  92. IF (ICHBB.EQ.ICHPO1) GOTO 100
  93. 20 CONTINUE
  94. * end do
  95. * on n'a pas trouv{ le chargement
  96. INTERR(1) = IPS
  97. CALL ERREUR(428)
  98. SEGDES ICHARG
  99. GOTO 10
  100. ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
  101. IF (KCHAR.EQ.0) GOTO 10
  102. CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
  103. & 'ENTIER',IENT,X1,' ',L1,IP1)
  104. CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
  105. & 'TABLE',I1,X1,' ',L1,ITMK)
  106. CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
  107. & L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
  108. CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
  109. & 'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
  110. *
  111. * boucle sur les chargements {l{mentaires
  112. *
  113. DO 30 ICHA =1,NCHAR
  114. ICHARG = KCHARG(ICHA)
  115. SEGACT ICHARG
  116. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  117. & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  118.  
  119. SEGDES ICHARG
  120. GOTO 30
  121. ENDIF
  122. MCHPOI = ICHPO1
  123. SEGACT MCHPOI
  124. MSOUPO = IPCHP(1)
  125. SEGDES MCHPOI
  126. SEGACT MSOUPO
  127. MPOVAL = IPOVAL
  128. SEGDES MSOUPO
  129. SEGACT MPOVAL
  130. QXYZ = VPOCHA(1,1)
  131. SEGDES MPOVAL
  132. EPS = ABS(QXYZ + XQXYZ)
  133. IF (EPS.LT.TOLER) GOTO 100
  134. 30 CONTINUE
  135. * end do
  136. * on n'a pas trouv{ le chargement
  137. INTERR(1) = IPS
  138. CALL ERREUR(428)
  139. SEGDES ICHARG
  140. GOTO 10
  141. ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
  142. IF (KCHAR.EQ.0) GOTO 10
  143. CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  144. & 'CHPOINT',I1,X1,' ',L1,ICHBB)
  145. *
  146. * boucle sur les chargements {l{mentaires
  147. *
  148. DO 40 ICHA =1,NCHAR
  149. ICHARG = KCHARG(ICHA)
  150. SEGACT ICHARG
  151. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  152. & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  153. SEGDES ICHARG
  154. GOTO 40
  155. ENDIF
  156. IF (ICHBB.EQ.ICHPO1) GOTO 100
  157. 40 CONTINUE
  158. * end do
  159. * on n'a pas trouv{ le chargement
  160. INTERR(1) = IPS
  161. CALL ERREUR(428)
  162. SEGDES ICHARG
  163. GOTO 10
  164. ELSE IF (CMOT(1:9).EQ.'PSMO_LIAI') THEN
  165. IF (ITLIAB.EQ.0) GOTO 10
  166. CALL ACCTAB(ITPM,'MOT',I0,X0,'POINT',L0,IP0,
  167. & 'POINT',I1,X1,' ',L1,IPTS)
  168. *
  169. * Le point appartient-il au maillage ?
  170. *
  171. MELEME = IMAIL
  172. SEGACT MELEME
  173. NBEL = NUM(/2)
  174. DO 50 IE = 1,NBEL
  175. IPTR = NUM(1,IE)
  176. IF (IPTR.EQ.IPTS) GOTO 52
  177. 50 CONTINUE
  178. * END DO
  179. SEGDES MELEME
  180. GOTO 10
  181. 52 CONTINUE
  182. SEGDES MELEME
  183. CALL ACCTAB(ITPM,'MOT',I0,X0,'NORMALE',L0,IP0,
  184. & 'POINT',I1,X1,' ',L1,NORM)
  185. *
  186. * A quelle table de liaison appartient le point ?
  187. *
  188. ITL = 0
  189. 54 CONTINUE
  190. ITL = ITL + 1
  191. TYPRET = ' '
  192. CALL ACCTAB(ITLIAB,'ENTIER',ITL,X0,' ',L0,IP0,
  193. & TYPRET,I1,X1,CHARRE,L1,ITTL)
  194. IF (ITTL.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
  195. CALL ACCTAB(ITTL,'MOT',I0,X0,'TYPE_LIAISON',L0,IP0,
  196. & 'MOT',I1,X1,CTYP,L1,IP1)
  197. CALL ACCTAB(ITTL,'MOT',I0,X0,'NORMALE',L0,IP0,
  198. & 'POINT',I1,X1,' ',L1,INOR)
  199. IF (CTYP(1:10).EQ.'POINT_PLAN') THEN
  200. CALL ACCTAB(ITTL,'MOT',I0,X0,'SUPPORT',L0,IP0,
  201. & 'POINT',I1,X1,' ',L1,IPTR)
  202. IF (IPTR.EQ.IPTS .AND. INOR.EQ.NORM) GOTO 56
  203. GOTO 54
  204. ELSE IF (CTYP(1:11).EQ.'POINT_POINT') THEN
  205. NPTA = 0
  206. NPTB = 0
  207. CALL ACCTAB(ITTL,'MOT',I0,X0,'POINT_A',L0,IP0,
  208. & 'POINT',I1,X1,' ',L1,IPTA)
  209. IF (IPTA.EQ.IPTS .AND. INOR.EQ.NORM) THEN
  210. NPTA = 1
  211. GOTO 56
  212. ENDIF
  213. CALL ACCTAB(ITTL,'MOT',I0,X0,'POINT_B',L0,IP0,
  214. & 'POINT',I1,X1,' ',L1,IPTB)
  215. IF (IPTB.EQ.IPTS .AND. INOR.EQ.NORM) THEN
  216. NPTB = 1
  217. GOTO 56
  218. ENDIF
  219. GOTO 54
  220. ELSE
  221. GOTO 54
  222. ENDIF
  223. ENDIF
  224. GOTO 10
  225. 56 CONTINUE
  226. IF (TYPE.EQ.'DEPL') THEN
  227. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  228. & 'CHPOINT',I1,X1,' ',L1,ICDEP)
  229. ELSE IF (TYPE.EQ.'REAC') THEN
  230. CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
  231. & 'CHPOINT',I1,X1,' ',L1,ICDEP)
  232. ELSE IF (TYPE.EQ.'CONT') THEN
  233. TYPRET = ' '
  234. CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
  235. & TYPRET,I1,X1,CHARRE,L1,ICDEP)
  236. ENDIF
  237. TYPRET = ' '
  238. CALL ACCTAB(ITRES,'TABLE',I0,X0,' ',L0,ITTL,
  239. & TYPRET,I1,X1,CHARRE,L1,ITRL1)
  240. IF (ITRL1.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
  241. IF (CTYP(1:10).EQ.'POINT_PLAN') THEN
  242. MADIR1 = MOTPPL(NBPP)
  243. TYPRET = ' '
  244. CALL ACCTAB(ITRL1,'MOT',I0,X0,MADIR1,L0,IP0,
  245. & TYPRET,I1,X1,CHARRE,L1,ILRX)
  246. ELSE IF (CTYP(1:11).EQ.'POINT_POINT') THEN
  247. MADIR2 = ' '
  248. IF (NPTA.EQ.1) MADIR2 = MOTPPA(NBPP)
  249. IF (NPTB.EQ.1) MADIR2 = MOTPPB(NBPP)
  250. TYPRET = ' '
  251. CALL ACCTAB(ITRL1,'MOT',I0,X0,MADIR2,L0,IP0,
  252. & TYPRET,I1,X1,CHARRE,L1,ILRX)
  253. ENDIF
  254. IF (ILRX.NE.0 .AND. TYPRET.EQ.'LISTREEL') THEN
  255. MLREEL = ILRX
  256. SEGACT MLREEL
  257. XFC = PROG(IPOS)
  258. SEGDES MLREEL
  259. IPNV = (IDIM + 1) * (INOR - 1)
  260. PS = 0.D0
  261. DO 300 ID = 1,IDIM
  262. XC = XCOOR(IPNV + ID)
  263. PS = PS + XC * XC
  264. 300 CONTINUE
  265. * END DO
  266. IF (PS.LE.XPETIT) THEN
  267. INTERR(1) = IPS
  268. CALL ERREUR(428)
  269. GOTO 10
  270. ENDIF
  271. DO 200 ID = 1,IDIM
  272. XNORM = XCOOR(IPNV + ID) / SQRT(PS)
  273. XFTEM = XFC * XNORM
  274. IF (IIMPI.EQ.1804) THEN
  275. WRITE(IOIMP,*)'PSRCD2 : pseudo-mode num{ro ',IPS
  276. WRITE(IOIMP,*)'PSRCD2 : point concern{ ',IPTS
  277. WRITE(IOIMP,*)'PSRCD2 : temps ',XTEMP
  278. WRITE(IOIMP,*)'PSRCD2 : f(t) ',XFTEM
  279. ENDIF
  280. IF (TYPE.EQ.'CONT') THEN
  281. CALL MUCHEL(ICDEP,XFTEM,ICHR1,IUN)
  282. CALL ADCHEL(ICHCR,ICHR1,ICHCR,IUN)
  283. ELSE
  284. CALL ADCHPO(ICHCR,ICDEP,ICHCR,1D0,XFTEM)
  285. ENDIF
  286. 200 CONTINUE
  287. * END DO
  288. ENDIF
  289. ENDIF
  290. GOTO 54
  291. ELSE
  292. GOTO 10
  293. ENDIF
  294. *
  295. 100 CONTINUE
  296. IF (TYPE.EQ.'DEPL') THEN
  297. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  298. & 'CHPOINT',I1,X1,' ',L1,ICDEP)
  299. ELSE IF (TYPE.EQ.'REAC') THEN
  300. CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
  301. & 'CHPOINT',I1,X1,' ',L1,ICDEP)
  302. ELSE IF (TYPE.EQ.'CONT') THEN
  303. TYPRET = ' '
  304. CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
  305. & TYPRET,I1,X1,CHARRE,L1,ICDEP)
  306. ENDIF
  307. MLREE1 = ICHPO2
  308. SEGACT MLREE1
  309. NF = MLREE1.PROG(/1)
  310. MLREE2 = ICHPO3
  311. SEGACT MLREE2
  312. N1 = 1
  313. N2 = 2
  314. CALL INTLIN(XTEMP,ICHPO2,ICHPO3,NF,N1,N2,XFTEM,IRETOU)
  315. IF (IRETOU.EQ.0) THEN
  316. INTERR(1) = IPS
  317. CALL ERREUR(428)
  318. SEGDES MLREE1
  319. SEGDES MLREE2
  320. SEGDES ICHARG
  321. GOTO 10
  322. ENDIF
  323. SEGDES MLREE1
  324. SEGDES MLREE2
  325. SEGDES ICHARG
  326. IF (IIMPI.EQ.1804) THEN
  327. WRITE(IOIMP,*)'PSRCD2 : pseudo-mode num{ro ',IPS
  328. WRITE(IOIMP,*)'PSRCD2 : chargement ',KCHAR
  329. WRITE(IOIMP,*)'PSRCD2 : num{ro ',ICHA
  330. WRITE(IOIMP,*)'PSRCD2 : temps ',XTEMP
  331. WRITE(IOIMP,*)'PSRCD2 : f(t) ',XFTEM
  332. ENDIF
  333. IF (TYPE.EQ.'CONT') THEN
  334. CALL MUCHEL(ICDEP,XFTEM,ICHR1,IUN)
  335. CALL ADCHEL(ICHCR,ICHR1,ICHCR,IUN)
  336. ELSE
  337. CALL ADCHPO(ICHCR,ICDEP,ICHCR,1D0,XFTEM)
  338. ENDIF
  339. GOTO 10
  340. ENDIF
  341. *
  342. IF (KCHAR.NE.0 ) SEGDES MCHARG
  343. *
  344. RETURN
  345. END
  346.  
  347.  
  348.  

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