Télécharger devps2.eso

Retour à la liste

Numérotation des lignes :

  1. C DEVPS2 SOURCE CHAT 05/01/12 22:47:08 5004
  2. SUBROUTINE DEVPS2(ICHAR1,KTLIAB,KTNUM,KTPHI,KTFEX,REPRIS,ITPS,
  3. & IBAS,NUMBAS)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. *--------------------------------------------------------------------*
  7. * *
  8. * Opérateur DYNE : algorithme de Fu - de Vogelaere *
  9. * ________________________________________________ *
  10. * *
  11. * Remplissage du tableau FEXPSM, repr{sentant les pseudo-modes *
  12. * aux points de liaison. *
  13. * *
  14. * Paramètres: *
  15. * *
  16. * e ITCHAR Table représentant les chargements *
  17. * e ITBAS Table représentant la base modale *
  18. * e KTLIAB Segment contenant les liaisons sur base B *
  19. * e KTNUM Segment contenant les paramètres numériques *
  20. * e KTPHI Segment des déformées modales *
  21. * es KTFEX Segment contenant les chargements libres *
  22. * e REPRIS Logique indiquant si le calcul est en reprise *
  23. * e ITPS Table contenant les pseudo-modes *
  24. * e IBAS Table contenant les modes *
  25. * e NUMBAS numéro de la sous base *
  26. * *
  27. * Auteur, date de création: *
  28. * *
  29. * Lionel VIVAN, le 10 avril 1990 *
  30. * *
  31. *--------------------------------------------------------------------*
  32. *
  33. -INC CCOPTIO
  34. -INC SMCHARG
  35. -INC SMLREEL
  36. -INC SMCHPOI
  37. *
  38. * FEXPSM(.,.,1,.) valeur au pas m
  39. * FEXPSM(.,.,2,.) valeur au pas m - 1/2
  40. *
  41. SEGMENT,MTNUM
  42. REAL*8 XDT(NPC1),XTEMPS(NPC1)
  43. ENDSEGMENT
  44. SEGMENT,MTFEX
  45. REAL*8 FEXA(NPFEXA,NPC1,2)
  46. REAL*8 FEXPSM(NPLB,NPC1,2,IDIMB)
  47. REAL*8 FTEXB(NPLB,NPC1,2,IDIM)
  48. INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB)
  49. ENDSEGMENT
  50. SEGMENT,MTPHI
  51. INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB)
  52. INTEGER IAROTA(NSB)
  53. REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB)
  54. ENDSEGMENT
  55. SEGMENT,MTLIAB
  56. INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  57. REAL*8 XPALB(NLIAB,NXPALB)
  58. REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  59. ENDSEGMENT
  60. SEGMENT,MTRAV
  61. REAL*8 FTCHG(NPC2)
  62. ENDSEGMENT
  63. *
  64. LOGICAL L0,L1,REPRIS
  65. CHARACTER*4 NOMAXI(6),NOMTRI(6),COMP
  66. CHARACTER*8 TYPRET,CHARRE
  67. CHARACTER*40 CMOT
  68. PARAMETER ( TOLER = 1.E-6 )
  69. *
  70. DATA NOMAXI/'UR ','UZ ','UT ','RR ','RZ ','RT '/
  71. DATA NOMTRI/'UX ','UY ','UZ ','RX ','RY ','RZ '/
  72. *
  73. MTNUM = KTNUM
  74. MTFEX = KTFEX
  75. MTPHI = KTPHI
  76. MTLIAB = KTLIAB
  77. NPC1 = XDT(/1)
  78. NPLB = IBASB(/1)
  79. NSB = XPHILB(/1)
  80. IDIMB = XPHILB(/4)
  81. MCHARG = ICHAR1
  82. SEGACT,MCHARG
  83. NCHAR = KCHARG(/1)
  84. *
  85. * Boucle sur les pseudo-modes
  86. *
  87. IPS = 0
  88. 10 CONTINUE
  89. IPS = IPS + 1
  90. TYPRET = ' '
  91. CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
  92. & TYPRET,I1,X1,CHARRE,L1,ITPM)
  93. IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
  94. CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  95. & 'MOT',I1,X1,CMOT,L1,IP1)
  96. IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
  97. CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
  98. & 'CHPOINT',I1,X1,CHARRE,L1,ICHBA)
  99. *
  100. * boucle sur les chargements {l{mentaires
  101. *
  102. DO 20 ICHAR=1,NCHAR
  103. ICHARG = KCHARG(ICHAR)
  104. SEGACT,ICHARG
  105. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  106. &.OR.CHALIE(ICHAR).NE.'LIE ') THEN
  107. SEGDES ICHARG
  108. GOTO 20
  109. ENDIF
  110. IF (ICHBA.EQ.ICHPO1) GOTO 120
  111. 20 CONTINUE
  112. * end do
  113. * on n'a pas trouv{ le chargement
  114. INTERR(1) = IPS
  115. CALL ERREUR(428)
  116. GOTO 10
  117. *
  118. 120 CONTINUE
  119. IF (IIMPI.EQ.333) THEN
  120. WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS
  121. WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
  122. WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR
  123. ENDIF
  124. MLR1 = ICHPO2
  125. MLR2 = ICHPO3
  126. CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  127. IF (IERR.NE.0) RETURN
  128. MTRAV = KTRAV
  129. SEGDES ICHARG
  130. *
  131. * boucle sur les points de liaison
  132. *
  133. DO 30 IPL = 1,NPLB
  134. IB = IBASB(IPL)
  135. IF (IB.EQ.NUMBAS) THEN
  136. IPTL = JPLIB(IPL)
  137. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  138. & 'CHPOINT',I1,X1,' ',L1,ICHPS)
  139. DO 40 ID = 1,IDIMB
  140. IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  141. COMP = NOMAXI(ID)
  142. ELSE
  143. COMP = NOMTRI(ID)
  144. ENDIF
  145. CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
  146. IF (KERRE.EQ.0) THEN
  147. DO 50 IT=1,NPC1
  148. NP = 2 * IT
  149. FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  150. & ( XVAL * FTCHG(NP) )
  151. NI = NP - 1
  152. FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  153. & ( XVAL * FTCHG(NI) )
  154. 50 CONTINUE
  155. * end do
  156. ENDIF
  157. 40 CONTINUE
  158. * end do
  159. ENDIF
  160. 30 CONTINUE
  161. * end do
  162. SEGSUP MTRAV
  163. GOTO 10
  164. ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
  165. CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
  166. & 'ENTIER',IENT,X1,' ',L1,IP1)
  167. CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
  168. & 'TABLE',I1,X1,' ',L1,ITMK)
  169. CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
  170. & L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
  171. CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
  172. & 'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
  173. *
  174. * boucle sur les chargements {l{mentaires
  175. *
  176. DO 24 ICHAR=1,NCHAR
  177. ICHARG = KCHARG(ICHAR)
  178. SEGACT,ICHARG
  179. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  180. & .OR.CHALIE(ICHAR).NE.'LIE ') THEN
  181. SEGDES ICHARG
  182. GOTO 24
  183. ENDIF
  184. MCHPOI = ICHPO1
  185. SEGACT MCHPOI
  186. MSOUPO = IPCHP(1)
  187. SEGDES MCHPOI
  188. SEGACT MSOUPO
  189. MPOVAL = IPOVAL
  190. SEGDES MSOUPO
  191. SEGACT MPOVAL
  192. QXYZ = VPOCHA(1,1)
  193. SEGDES MPOVAL
  194. EPS = ABS(QXYZ + XQXYZ)
  195. IF (EPS.LT.TOLER) GOTO 124
  196. 24 CONTINUE
  197. * end do
  198. * on n'a pas trouv{ le chargement
  199. INTERR(1) = IPS
  200. CALL ERREUR(428)
  201. GOTO 10
  202. *
  203. 124 CONTINUE
  204. IF (IIMPI.EQ.333) THEN
  205. WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS
  206. WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
  207. WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR
  208. ENDIF
  209. MLR1 = ICHPO2
  210. MLR2 = ICHPO3
  211. CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  212. IF (IERR.NE.0) RETURN
  213. MTRAV = KTRAV
  214. SEGDES ICHARG
  215. *
  216. * boucle sur les points de liaison
  217. *
  218. DO 32 IPL = 1,NPLB
  219. IB = IBASB(IPL)
  220. IF (IB.EQ.NUMBAS) THEN
  221. IPTL = JPLIB(IPL)
  222. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  223. & 'CHPOINT',I1,X1,' ',L1,ICHPS)
  224. DO 42 ID = 1,IDIMB
  225. IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  226. COMP = NOMAXI(ID)
  227. ELSE
  228. COMP = NOMTRI(ID)
  229. ENDIF
  230. CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
  231. IF (KERRE.EQ.0) THEN
  232. DO 52 IT=1,NPC1
  233. NP = 2 * IT
  234. FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  235. & ( XVAL * FTCHG(NP) )
  236. NI = NP - 1
  237. FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  238. & ( XVAL * FTCHG(NI) )
  239. 52 CONTINUE
  240. * end do
  241. ENDIF
  242. 42 CONTINUE
  243. ENDIF
  244. * end do
  245. 32 CONTINUE
  246. * end do
  247. SEGSUP MTRAV
  248. GOTO 10
  249. ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
  250. CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
  251. & 'CHPOINT',I1,X1,' ',L1,ICHBA)
  252. *
  253. * boucle sur les chargements {l{mentaires
  254. *
  255. DO 28 ICHAR=1,NCHAR
  256. ICHARG = KCHARG(ICHAR)
  257. SEGACT,ICHARG
  258. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  259. & .OR.CHALIE(ICHAR).NE.'LIE ') THEN
  260. SEGDES ICHARG
  261. GOTO 28
  262. ENDIF
  263. IF (ICHBA.EQ.ICHPO1) GOTO 128
  264. 28 CONTINUE
  265. * end do
  266. * on n'a pas trouv{ le chargement
  267. INTERR(1) = IPS
  268. CALL ERREUR(428)
  269. GOTO 10
  270. *
  271. 128 CONTINUE
  272. IF (IIMPI.EQ.333) THEN
  273. WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS
  274. WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
  275. WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR
  276. ENDIF
  277. MLR1 = ICHPO2
  278. MLR2 = ICHPO3
  279. CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  280. IF (IERR.NE.0) RETURN
  281. MTRAV = KTRAV
  282. SEGDES ICHARG
  283. *
  284. * boucle sur les points de liaison
  285. *
  286. DO 34 IPL = 1,NPLB
  287. IB = IBASB(IPL)
  288. IF (IB.EQ.NUMBAS) THEN
  289. IPTL = JPLIB(IPL)
  290. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  291. & 'CHPOINT',I1,X1,' ',L1,ICHPS)
  292. DO 44 ID = 1,IDIMB
  293. IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  294. COMP = NOMAXI(ID)
  295. ELSE
  296. COMP = NOMTRI(ID)
  297. ENDIF
  298. CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
  299. IF (KERRE.EQ.0) THEN
  300. DO 54 IT=1,NPC1
  301. NP = 2 * IT
  302. FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  303. & ( XVAL * FTCHG(NP) )
  304. NI = NP - 1
  305. FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  306. & ( XVAL * FTCHG(NI) )
  307. 54 CONTINUE
  308. * end do
  309. ENDIF
  310. 44 CONTINUE
  311. * end do
  312. ENDIF
  313. 34 CONTINUE
  314. * end do
  315. SEGSUP MTRAV
  316. GOTO 10
  317. ENDIF
  318. ENDIF
  319. SEGDES MCHARG
  320. *
  321. END
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  

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