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 = ' '
90 : CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
91 : & TYPRET,I1,X1,CHARRE,L1,ITPM)
92 : IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
92 : CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
93 : & 'MOT',I1,X1,CMOT,L1,IP1)
94 : IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
94 : CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
95 : & 'CHPOINT',I1,X1,CHARRE,L1,ICHBA)
96 : *
97 : * boucle sur les chargements {l{mentaires
98 : *
99 : DO 20 ICHAR=1,NCHAR
100 : ICHARG = KCHARG(ICHAR)
101 : SEGACT,ICHARG
102 : IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
103 : &.OR.CHALIE(ICHAR).NE.'LIE ') THEN
104 : SEGDES ICHARG
105 : GOTO 20
106 : ENDIF
107 : IF (ICHBA.EQ.ICHPO1) GOTO 120
108 : 20 CONTINUE
109 : * end do
110 : * on n'a pas trouv{ le chargement
111 : INTERR(1) = IPS
111 : CALL ERREUR(428)
112 : GOTO 10
113 : *
114 : 120 CONTINUE
115 : IF (IIMPI.EQ.333) THEN
116 : WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS
117 : WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
118 : WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR
119 : ENDIF
120 : MLR1 = ICHPO2
121 : MLR2 = ICHPO3
121 : CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
122 : IF (IERR.NE.0) RETURN
123 : MTRAV = KTRAV
124 : SEGDES ICHARG
125 : *
126 : * boucle sur les points de liaison
127 : *
128 : DO 30 IPL = 1,NPLB
129 : IB = IBASB(IPL)
130 : IF (IB.EQ.NUMBAS) THEN
131 : IPTL = JPLIB(IPL)
131 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
132 : & 'CHPOINT',I1,X1,' ',L1,ICHPS)
133 : DO 40 ID = 1,IDIMB
134 : IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
135 : COMP = NOMAXI(ID)
136 : ELSE
137 : COMP = NOMTRI(ID)
138 : ENDIF
138 : CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
139 : IF (KERRE.EQ.0) THEN
140 : DO 50 IT=1,NPC1
141 : NP = 2 * IT
142 : FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
143 : & ( XVAL * FTCHG(NP) )
144 : NI = NP - 1
145 : FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
146 : & ( XVAL * FTCHG(NI) )
147 : 50 CONTINUE
148 : * end do
149 : ENDIF
150 : 40 CONTINUE
151 : * end do
152 : ENDIF
153 : 30 CONTINUE
154 : * end do
155 : SEGSUP MTRAV
156 : GOTO 10
157 : ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
157 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
158 : & 'ENTIER',IENT,X1,' ',L1,IP1)
158 : CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
159 : & 'TABLE',I1,X1,' ',L1,ITMK)
159 : CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
160 : & L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
160 : CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
161 : & 'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
162 : *
163 : * boucle sur les chargements {l{mentaires
164 : *
165 : DO 24 ICHAR=1,NCHAR
166 : ICHARG = KCHARG(ICHAR)
167 : SEGACT,ICHARG
168 : IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
169 : & .OR.CHALIE(ICHAR).NE.'LIE ') THEN
170 : SEGDES ICHARG
171 : GOTO 24
172 : ENDIF
173 : MCHPOI = ICHPO1
174 : SEGACT MCHPOI
175 : MSOUPO = IPCHP(1)
176 : SEGDES MCHPOI
177 : SEGACT MSOUPO
178 : MPOVAL = IPOVAL
179 : SEGDES MSOUPO
180 : SEGACT MPOVAL
181 : QXYZ = VPOCHA(1,1)
182 : SEGDES MPOVAL
183 : EPS = ABS(QXYZ + XQXYZ)
184 : IF (EPS.LT.TOLER) GOTO 124
185 : 24 CONTINUE
186 : * end do
187 : * on n'a pas trouv{ le chargement
188 : INTERR(1) = IPS
188 : CALL ERREUR(428)
189 : GOTO 10
190 : *
191 : 124 CONTINUE
192 : IF (IIMPI.EQ.333) THEN
193 : WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS
194 : WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
195 : WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR
196 : ENDIF
197 : MLR1 = ICHPO2
198 : MLR2 = ICHPO3
198 : CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
199 : IF (IERR.NE.0) RETURN
200 : MTRAV = KTRAV
201 : SEGDES ICHARG
202 : *
203 : * boucle sur les points de liaison
204 : *
205 : DO 32 IPL = 1,NPLB
206 : IB = IBASB(IPL)
207 : IF (IB.EQ.NUMBAS) THEN
208 : IPTL = JPLIB(IPL)
208 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
209 : & 'CHPOINT',I1,X1,' ',L1,ICHPS)
210 : DO 42 ID = 1,IDIMB
211 : IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
212 : COMP = NOMAXI(ID)
213 : ELSE
214 : COMP = NOMTRI(ID)
215 : ENDIF
215 : CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
216 : IF (KERRE.EQ.0) THEN
217 : DO 52 IT=1,NPC1
218 : NP = 2 * IT
219 : FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
220 : & ( XVAL * FTCHG(NP) )
221 : NI = NP - 1
222 : FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
223 : & ( XVAL * FTCHG(NI) )
224 : 52 CONTINUE
225 : * end do
226 : ENDIF
227 : 42 CONTINUE
228 : ENDIF
229 : * end do
230 : 32 CONTINUE
231 : * end do
232 : SEGSUP MTRAV
233 : GOTO 10
234 : ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
234 : CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
235 : & 'CHPOINT',I1,X1,' ',L1,ICHBA)
236 : *
237 : * boucle sur les chargements {l{mentaires
238 : *
239 : DO 28 ICHAR=1,NCHAR
240 : ICHARG = KCHARG(ICHAR)
241 : SEGACT,ICHARG
242 : IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
243 : & .OR.CHALIE(ICHAR).NE.'LIE ') THEN
244 : SEGDES ICHARG
245 : GOTO 28
246 : ENDIF
247 : IF (ICHBA.EQ.ICHPO1) GOTO 128
248 : 28 CONTINUE
249 : * end do
250 : * on n'a pas trouv{ le chargement
251 : INTERR(1) = IPS
251 : CALL ERREUR(428)
252 : GOTO 10
253 : *
254 : 128 CONTINUE
255 : IF (IIMPI.EQ.333) THEN
256 : WRITE(IOIMP,*)'DEVPSM : pseudo-mode num{ro ',IPS
257 : WRITE(IOIMP,*)'DEVPSM : chargement ',ICHAR1
258 : WRITE(IOIMP,*)'DEVPSM : num{ro ',ICHAR
259 : ENDIF
260 : MLR1 = ICHPO2
261 : MLR2 = ICHPO3
261 : CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
262 : IF (IERR.NE.0) RETURN
263 : MTRAV = KTRAV
264 : SEGDES ICHARG
265 : *
266 : * boucle sur les points de liaison
267 : *
268 : DO 34 IPL = 1,NPLB
269 : IB = IBASB(IPL)
270 : IF (IB.EQ.NUMBAS) THEN
271 : IPTL = JPLIB(IPL)
271 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
272 : & 'CHPOINT',I1,X1,' ',L1,ICHPS)
273 : DO 44 ID = 1,IDIMB
274 : IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
275 : COMP = NOMAXI(ID)
276 : ELSE
277 : COMP = NOMTRI(ID)
278 : ENDIF
278 : CALL EXTRA9(ICHPS,IPTL,COMP,KERRE,XVAL)
279 : IF (KERRE.EQ.0) THEN
280 : DO 54 IT=1,NPC1
281 : NP = 2 * IT
282 : FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
283 : & ( XVAL * FTCHG(NP) )
284 : NI = NP - 1
285 : FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
286 : & ( XVAL * FTCHG(NI) )
287 : 54 CONTINUE
288 : * end do
289 : ENDIF
290 : 44 CONTINUE
291 : * end do
292 : ENDIF
293 : 34 CONTINUE
294 : * end do
295 : SEGSUP MTRAV
296 : GOTO 10
297 : ENDIF
298 : ENDIF
299 : SEGDES MCHARG
300 : *
301 : END
302 :
303 :
304 :
305 :
306 :
© Cast3M 2003 - All rights reserved.
Disclaimer