Télécharger devps2.eso

Retour à la liste

Numérotation des lignes :

  1. C DEVPS2 SOURCE BP208322 18/12/20 21:15:37 10048
  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, representant 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. ************************************************************************
  86. * BOUCLE SUR LES PSEUDO-MODES
  87. ************************************************************************
  88. *
  89. IPS = 0
  90. 10 CONTINUE
  91. IPS = IPS + 1
  92. TYPRET = ' '
  93. CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
  94. & TYPRET,I1,X1,CHARRE,L1,ITPM)
  95. IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
  96. CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  97. & 'MOT',I1,X1,CMOT,L1,IP1)
  98.  
  99. ******** CAS D'UN PSEUDO MODE DE SOUSTYPE : 'PSMO_FORC' ****************
  100. IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
  101.  
  102. CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
  103. & 'CHPOINT',I1,X1,CHARRE,L1,ICHBA)
  104. *
  105. *---------- boucle sur les chargements elementaires ------------------ *
  106. * jusqu'a trouver celui qui correspond au pseudo mode
  107. DO 20 ICHAR=1,NCHAR
  108. ICHARG = KCHARG(ICHAR)
  109. SEGACT,ICHARG
  110. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  111. & .OR.CHALIE(ICHAR).NE.'LIE ') THEN
  112. SEGDES ICHARG
  113. GOTO 20
  114. ENDIF
  115. c test sur le pointeur du CHPOINT definissant le pseudo-mode
  116. IF (ICHBA.EQ.ICHPO1) GOTO 120
  117. 20 CONTINUE
  118. * --- on n'a pas trouve le chargement : erreur ! ---
  119. INTERR(1) = IPS
  120. CALL ERREUR(428)
  121. GOTO 10
  122. * --- on a trouve le chargement : on continue ---
  123. 120 CONTINUE
  124. IF (IIMPI.EQ.333) THEN
  125. WRITE(IOIMP,*)'DEVPSM : pseudo-mode numero ',IPS
  126. WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
  127. WRITE(IOIMP,*)'DEVPSM : numero ',ICHAR
  128. ENDIF
  129.  
  130. *---------- interpolation de f(t) ------------------ *
  131. MLR1 = ICHPO2
  132. MLR2 = ICHPO3
  133. CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  134. IF (IERR.NE.0) RETURN
  135. MTRAV = KTRAV
  136. SEGDES ICHARG
  137. *
  138. *---------- boucle sur les points de liaison ------------------ *
  139. DO 30 IPL = 1,NPLB
  140. IB = IBASB(IPL)
  141. IF (IB.EQ.NUMBAS) THEN
  142. IPTL = JPLIB(IPL)
  143. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  144. & 'CHPOINT',I1,X1,' ',L1,ICHPS)
  145. DO 40 ID = 1,IDIMB
  146. IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  147. COMP = NOMAXI(ID)
  148. ELSE
  149. COMP = NOMTRI(ID)
  150. ENDIF
  151. CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
  152. IF (KERRE.EQ.0) THEN
  153. DO 50 IT=1,NPC1
  154. NP = 2 * IT
  155. FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  156. & ( XVAL * FTCHG(NP) )
  157. NI = NP - 1
  158. FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  159. & ( XVAL * FTCHG(NI) )
  160. 50 CONTINUE
  161. ENDIF
  162. 40 CONTINUE
  163. ENDIF
  164. 30 CONTINUE
  165. *---------- fin de boucle sur les points de liaison ------------------ *
  166.  
  167. SEGSUP MTRAV
  168. c ON PASSE AU PSEUDO-MODE SUIVANT
  169. GOTO 10
  170.  
  171.  
  172. ******** CAS D'UN PSEUDO MODE DE SOUSTYPE : 'PSMO_SEIS' ****************
  173. ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
  174.  
  175. CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
  176. & 'ENTIER',IENT,X1,' ',L1,IP1)
  177. CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
  178. & 'TABLE',I1,X1,' ',L1,ITMK)
  179. CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
  180. & L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
  181. CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
  182. & 'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
  183. *
  184. *---------- boucle sur les chargements elementaires ------------------ *
  185. * jusqu'a trouver celui qui correspond au pseudo mode
  186. DO 24 ICHAR=1,NCHAR
  187. ICHARG = KCHARG(ICHAR)
  188. SEGACT,ICHARG
  189. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  190. & .OR.CHALIE(ICHAR).NE.'LIE ') THEN
  191. SEGDES ICHARG
  192. GOTO 24
  193. ENDIF
  194. MCHPOI = ICHPO1
  195. SEGACT MCHPOI
  196. MSOUPO = IPCHP(1)
  197. SEGDES MCHPOI
  198. SEGACT MSOUPO
  199. MPOVAL = IPOVAL
  200. SEGDES MSOUPO
  201. SEGACT MPOVAL
  202. QXYZ = VPOCHA(1,1)
  203. SEGDES MPOVAL
  204. EPS = ABS(QXYZ + XQXYZ)
  205. c test sur l'unique valeur du CHPOINT definissant le pseudo-mode
  206. IF (EPS.LT.TOLER) GOTO 124
  207. 24 CONTINUE
  208. * --- on n'a pas trouve le chargement : erreur ! ---
  209. INTERR(1) = IPS
  210. CALL ERREUR(428)
  211. GOTO 10
  212. * --- on a trouve le chargement : on continue ---
  213. 124 CONTINUE
  214. IF (IIMPI.EQ.333) THEN
  215. WRITE(IOIMP,*)'DEVPSM : pseudo-mode numero ',IPS
  216. WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
  217. WRITE(IOIMP,*)'DEVPSM : numero ',ICHAR
  218. ENDIF
  219.  
  220. *---------- interpolation de f(t) ------------------ *
  221. MLR1 = ICHPO2
  222. MLR2 = ICHPO3
  223. CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  224. IF (IERR.NE.0) RETURN
  225. MTRAV = KTRAV
  226. SEGDES ICHARG
  227. *
  228. *---------- boucle sur les points de liaison ------------------ *
  229. DO 32 IPL = 1,NPLB
  230. IB = IBASB(IPL)
  231. IF (IB.EQ.NUMBAS) THEN
  232. IPTL = JPLIB(IPL)
  233. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  234. & 'CHPOINT',I1,X1,' ',L1,ICHPS)
  235. DO 42 ID = 1,IDIMB
  236. IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  237. COMP = NOMAXI(ID)
  238. ELSE
  239. COMP = NOMTRI(ID)
  240. ENDIF
  241. CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
  242. IF (KERRE.EQ.0) THEN
  243. DO 52 IT=1,NPC1
  244. NP = 2 * IT
  245. FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  246. & ( XVAL * FTCHG(NP) )
  247. NI = NP - 1
  248. FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  249. & ( XVAL * FTCHG(NI) )
  250. 52 CONTINUE
  251. ENDIF
  252. 42 CONTINUE
  253. ENDIF
  254. 32 CONTINUE
  255. *---------- fin de boucle sur les points de liaison ------------------ *
  256.  
  257. SEGSUP MTRAV
  258. c ON PASSE AU PSEUDO-MODE SUIVANT
  259. GOTO 10
  260.  
  261. ******** CAS D'UN PSEUDO MODE DE SOUSTYPE : 'PSMO_DEPL' ****************
  262. ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
  263.  
  264. CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
  265. & 'CHPOINT',I1,X1,' ',L1,ICHBA)
  266. *
  267. *---------- boucle sur les chargements elementaires ------------------ *
  268. * jusqu'a trouver celui qui correspond au pseudo mode
  269. DO 28 ICHAR=1,NCHAR
  270. ICHARG = KCHARG(ICHAR)
  271. SEGACT,ICHARG
  272. IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  273. & .OR.CHALIE(ICHAR).NE.'LIE ') THEN
  274. SEGDES ICHARG
  275. GOTO 28
  276. ENDIF
  277. c test sur le pointeur du CHPOINT definissant le pseudo-mode
  278. IF (ICHBA.EQ.ICHPO1) GOTO 128
  279. 28 CONTINUE
  280. * --- on n'a pas trouve le chargement : erreur ! ---
  281. INTERR(1) = IPS
  282. CALL ERREUR(428)
  283. GOTO 10
  284. * --- on a trouve le chargement : on continue ---
  285. 128 CONTINUE
  286. IF (IIMPI.EQ.333) THEN
  287. WRITE(IOIMP,*)'DEVPSM : pseudo-mode numero ',IPS
  288. WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
  289. WRITE(IOIMP,*)'DEVPSM : numero ',ICHAR
  290. ENDIF
  291.  
  292. *---------- interpolation de f(t) ------------------ *
  293. MLR1 = ICHPO2
  294. MLR2 = ICHPO3
  295. CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  296. IF (IERR.NE.0) RETURN
  297. MTRAV = KTRAV
  298. SEGDES ICHARG
  299. *
  300. *---------- boucle sur les points de liaison ------------------ *
  301. DO 34 IPL = 1,NPLB
  302. IB = IBASB(IPL)
  303. IF (IB.EQ.NUMBAS) THEN
  304. IPTL = JPLIB(IPL)
  305. CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  306. & 'CHPOINT',I1,X1,' ',L1,ICHPS)
  307. DO 44 ID = 1,IDIMB
  308. IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  309. COMP = NOMAXI(ID)
  310. ELSE
  311. COMP = NOMTRI(ID)
  312. ENDIF
  313. CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
  314. IF (KERRE.EQ.0) THEN
  315. DO 54 IT=1,NPC1
  316. NP = 2 * IT
  317. FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  318. & ( XVAL * FTCHG(NP) )
  319. NI = NP - 1
  320. FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  321. & ( XVAL * FTCHG(NI) )
  322. 54 CONTINUE
  323. ENDIF
  324. 44 CONTINUE
  325. ENDIF
  326. 34 CONTINUE
  327. *---------- fin de boucle sur les points de liaison ------------------ *
  328.  
  329. SEGSUP MTRAV
  330. c ON PASSE AU PSEUDO-MODE SUIVANT
  331. GOTO 10
  332.  
  333. ENDIF
  334. ******** FIN DISTINCTION ENTRE LES SOUSTYPE DES PSEUDO MODE ************
  335.  
  336. ENDIF
  337. SEGDES MCHARG
  338. *
  339. END
  340.  
  341.  
  342.  
  343.  
  344.  
  345.  
  346.  

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