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 = ' '
58 : CALL ACCTAB(ITLIA,'MOT',I0,X0,'LIAISON_B',L0,IP0,
59 : & TYPRET,I1,X1,CHARRE,L1,ITAB)
60 : IF (ITAB.NE.0 .AND. TYPRET.EQ.'TABLE ') ITLIAB = ITAB
61 : ENDIF
61 : CALL ACCTAB(IBAS,'MOT',I0,X0,'MAILLAGE',L1,IP0,
62 : & 'MAILLAGE',I1,X1,' ',L1,IMAIL)
63 : *
64 : * Boucle sur les pseudo-modes
65 : *
66 : IPS = 0
67 : 10 CONTINUE
68 : IPS = IPS + 1
69 : TYPRET = ' '
69 : CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
70 : & TYPRET,I1,X1,CHARRE,L1,ITPM)
71 : IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
71 : CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
72 : & 'MOT',I1,X1,CMOT,L1,IP1)
73 : IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
74 : IF (KCHAR.EQ.0) GOTO 10
74 : CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
75 : & 'CHPOINT',I1,X1,' ',L1,ICHBB)
76 : *
77 : * boucle sur les chargements {l{mentaires
78 : *
79 : DO 20 ICHA =1,NCHAR
80 : ICHARG = KCHARG(ICHA)
81 : SEGACT ICHARG
82 : IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
83 : & .OR.CHALIE(ICHA).NE.'LIE ') THEN
84 : SEGDES ICHARG
85 : GOTO 20
86 : ENDIF
87 : IF (ICHBB.EQ.ICHPO1) GOTO 100
88 : 20 CONTINUE
89 : * end do
90 : * on n'a pas trouv{ le chargement
91 : INTERR(1) = IPS
91 : CALL ERREUR(428)
92 : SEGDES ICHARG
93 : GOTO 10
94 : ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
95 : IF (KCHAR.EQ.0) GOTO 10
95 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
96 : & 'ENTIER',IENT,X1,' ',L1,IP1)
96 : CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
97 : & 'TABLE',I1,X1,' ',L1,ITMK)
97 : CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
98 : & 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 :
109 : SEGDES ICHARG
110 : GOTO 30
111 : ENDIF
112 : MCHPOI = ICHPO1
113 : SEGACT MCHPOI
114 : MSOUPO = IPCHP(1)
115 : SEGDES MCHPOI
116 : SEGACT MSOUPO
117 : MPOVAL = IPOVAL
118 : SEGDES MSOUPO
119 : SEGACT MPOVAL
120 : QXYZ = VPOCHA(1,1)
121 : SEGDES MPOVAL
122 : EPS = ABS(QXYZ + XQXYZ)
123 : IF (EPS.LT.TOLER) GOTO 100
124 : 30 CONTINUE
125 : * end do
126 : * on n'a pas trouv{ le chargement
127 : INTERR(1) = IPS
127 : CALL ERREUR(428)
128 : SEGDES ICHARG
129 : GOTO 10
130 : ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
131 : IF (KCHAR.EQ.0) GOTO 10
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
148 : CALL ERREUR(428)
149 : SEGDES ICHARG
150 : GOTO 10
151 : ELSE IF (CMOT(1:9).EQ.'PSMO_LIAI') THEN
152 : IF (ITLIAB.EQ.0) GOTO 10
152 : CALL ACCTAB(ITPM,'MOT',I0,X0,'POINT',L0,IP0,
153 : & 'POINT',I1,X1,' ',L1,IPTS)
154 : *
155 : * Le point appartient-il au maillage ?
156 : *
157 : MELEME = IMAIL
158 : SEGACT MELEME
159 : NBEL = NUM(/2)
160 : DO 50 IE = 1,NBEL
161 : IPTR = NUM(1,IE)
162 : IF (IPTR.EQ.IPTS) GOTO 52
163 : 50 CONTINUE
164 : * END DO
165 : SEGDES MELEME
166 : GOTO 10
167 : 52 CONTINUE
168 : SEGDES MELEME
168 : CALL ACCTAB(ITPM,'MOT',I0,X0,'NORMALE',L0,IP0,
169 : & 'POINT',I1,X1,' ',L1,NORM)
170 : *
171 : * A quelle table de liaison appartient le point ?
172 : *
173 : ITL = 0
174 : 54 CONTINUE
175 : ITL = ITL + 1
176 : TYPRET = ' '
176 : CALL ACCTAB(ITLIAB,'ENTIER',ITL,X0,' ',L0,IP0,
177 : & TYPRET,I1,X1,CHARRE,L1,ITTL)
178 : IF (ITTL.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
178 : CALL ACCTAB(ITTL,'MOT',I0,X0,'TYPE_LIAISON',L0,IP0,
179 : & 'MOT',I1,X1,CTYP,L1,IP1)
179 : CALL ACCTAB(ITTL,'MOT',I0,X0,'NORMALE',L0,IP0,
180 : & 'POINT',I1,X1,' ',L1,INOR)
181 : IF (CTYP(1:10).EQ.'POINT_PLAN') THEN
181 : CALL ACCTAB(ITTL,'MOT',I0,X0,'SUPPORT',L0,IP0,
182 : & 'POINT',I1,X1,' ',L1,IPTR)
183 : IF (IPTR.EQ.IPTS .AND. INOR.EQ.NORM) GOTO 56
184 : GOTO 54
185 : ELSE IF (CTYP(1:11).EQ.'POINT_POINT') THEN
186 : NPTA = 0
187 : NPTB = 0
187 : CALL ACCTAB(ITTL,'MOT',I0,X0,'POINT_A',L0,IP0,
188 : & 'POINT',I1,X1,' ',L1,IPTA)
189 : IF (IPTA.EQ.IPTS .AND. INOR.EQ.NORM) THEN
190 : NPTA = 1
191 : GOTO 56
192 : ENDIF
192 : CALL ACCTAB(ITTL,'MOT',I0,X0,'POINT_B',L0,IP0,
193 : & 'POINT',I1,X1,' ',L1,IPTB)
194 : IF (IPTB.EQ.IPTS .AND. INOR.EQ.NORM) THEN
195 : NPTB = 1
196 : GOTO 56
197 : ENDIF
198 : GOTO 54
199 : ELSE
200 : GOTO 54
201 : ENDIF
202 : ENDIF
203 : GOTO 10
204 : 56 CONTINUE
205 : IF (TYPE.EQ.'DEPL') THEN
205 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
206 : & 'CHPOINT',I1,X1,' ',L1,ICDEP)
207 : ELSE IF (TYPE.EQ.'REAC') THEN
207 : CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
208 : & 'CHPOINT',I1,X1,' ',L1,ICDEP)
209 : ELSE IF (TYPE.EQ.'CONT') THEN
210 : TYPRET = ' '
210 : CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
211 : & TYPRET,I1,X1,CHARRE,L1,ICDEP)
212 : ENDIF
213 : TYPRET = ' '
213 : CALL ACCTAB(ITRES,'TABLE',I0,X0,' ',L0,ITTL,
214 : & TYPRET,I1,X1,CHARRE,L1,ITRL1)
215 : IF (ITRL1.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
216 : IF (CTYP(1:10).EQ.'POINT_PLAN') THEN
217 : MADIR1 = MOTPPL(NBPP)
218 : TYPRET = ' '
218 : CALL ACCTAB(ITRL1,'MOT',I0,X0,MADIR1,L0,IP0,
219 : & TYPRET,I1,X1,CHARRE,L1,ILRX)
220 : ELSE IF (CTYP(1:11).EQ.'POINT_POINT') THEN
221 : MADIR2 = ' '
222 : IF (NPTA.EQ.1) MADIR2 = MOTPPA(NBPP)
223 : IF (NPTB.EQ.1) MADIR2 = MOTPPB(NBPP)
224 : TYPRET = ' '
224 : CALL ACCTAB(ITRL1,'MOT',I0,X0,MADIR2,L0,IP0,
225 : & TYPRET,I1,X1,CHARRE,L1,ILRX)
226 : ENDIF
227 : IF (ILRX.NE.0 .AND. TYPRET.EQ.'LISTREEL') THEN
228 : MLREEL = ILRX
229 : SEGACT MLREEL
230 : XFC = PROG(IPOS)
231 : SEGDES MLREEL
232 : IPNV = (IDIM + 1) * (INOR - 1)
233 : PS = 0.D0
234 : DO 300 ID = 1,IDIM
235 : XC = XCOOR(IPNV + ID)
236 : PS = PS + XC * XC
237 : 300 CONTINUE
238 : * END DO
239 : IF (PS.LE.XPETIT) THEN
240 : INTERR(1) = IPS
240 : CALL ERREUR(428)
241 : GOTO 10
242 : ENDIF
243 : DO 200 ID = 1,IDIM
244 : XNORM = XCOOR(IPNV + ID) / SQRT(PS)
245 : XFTEM = XFC * XNORM
246 : IF (IIMPI.EQ.1804) THEN
247 : WRITE(IOIMP,*)'PSRCD2 : pseudo-mode num{ro ',IPS
248 : WRITE(IOIMP,*)'PSRCD2 : point concern{ ',IPTS
249 : WRITE(IOIMP,*)'PSRCD2 : temps ',XTEMP
250 : WRITE(IOIMP,*)'PSRCD2 : f(t) ',XFTEM
251 : ENDIF
252 : IF (TYPE.EQ.'CONT') THEN
252 : CALL MUCHEL(ICDEP,XFTEM,ICHR1,IUN)
252 : CALL ADCHEL(ICHCR,ICHR1,ICHCR,IUN)
253 : ELSE
253 : CALL ADCHPO(ICHCR,ICDEP,ICHCR,1D0,XFTEM)
254 : ENDIF
255 : 200 CONTINUE
256 : * END DO
257 : ENDIF
258 : ENDIF
259 : GOTO 54
260 : ELSE
261 : GOTO 10
262 : ENDIF
263 : *
264 : 100 CONTINUE
265 : IF (TYPE.EQ.'DEPL') THEN
265 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
266 : & 'CHPOINT',I1,X1,' ',L1,ICDEP)
267 : ELSE IF (TYPE.EQ.'REAC') THEN
267 : CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
268 : & 'CHPOINT',I1,X1,' ',L1,ICDEP)
269 : ELSE IF (TYPE.EQ.'CONT') THEN
270 : TYPRET = ' '
270 : CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
271 : & TYPRET,I1,X1,CHARRE,L1,ICDEP)
272 : ENDIF
273 : MLREE1 = ICHPO2
274 : SEGACT MLREE1
275 : NF = MLREE1.PROG(/1)
276 : MLREE2 = ICHPO3
277 : SEGACT MLREE2
278 : N1 = 1
279 : N2 = 2
279 : CALL INTLIN(XTEMP,ICHPO2,ICHPO3,NF,N1,N2,XFTEM,IRETOU)
280 : IF (IRETOU.EQ.0) THEN
281 : INTERR(1) = IPS
281 : CALL ERREUR(428)
282 : SEGDES MLREE1
283 : SEGDES MLREE2
284 : SEGDES ICHARG
285 : GOTO 10
286 : ENDIF
287 : SEGDES MLREE1
288 : SEGDES MLREE2
289 : SEGDES ICHARG
290 : IF (IIMPI.EQ.1804) THEN
291 : WRITE(IOIMP,*)'PSRCD2 : pseudo-mode num{ro ',IPS
292 : WRITE(IOIMP,*)'PSRCD2 : chargement ',KCHAR
293 : WRITE(IOIMP,*)'PSRCD2 : num{ro ',ICHA
294 : WRITE(IOIMP,*)'PSRCD2 : temps ',XTEMP
295 : WRITE(IOIMP,*)'PSRCD2 : f(t) ',XFTEM
296 : ENDIF
297 : IF (TYPE.EQ.'CONT') THEN
297 : CALL MUCHEL(ICDEP,XFTEM,ICHR1,IUN)
297 : CALL ADCHEL(ICHCR,ICHR1,ICHCR,IUN)
298 : ELSE
298 : CALL ADCHPO(ICHCR,ICDEP,ICHCR,1D0,XFTEM)
299 : ENDIF
300 : GOTO 10
301 : ENDIF
302 : *
303 : IF (KCHAR.NE.0 ) SEGDES MCHARG
304 : *
305 : RETURN
306 : END
307 :
308 :
© Cast3M 2003 - All rights reserved.
Disclaimer