1 : C PSEVRC SOURCE FANDEUR 10/12/14 21:18:59 6812
2 : SUBROUTINE PSEVRC(ICONT,ITPS,IBAS,IBOO,IPX,KCHAR)
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8(A-H,O-Z)
5 :
6 : *--------------------------------------------------------------------*
7 : * *
8 : * Prise en compte des pseudo-modes pour une recombinaison. *
9 : * *
10 : * Param}tres: *
11 : * *
12 : * e ICONT recombinaison d'un d{placement ( ICONT = 0 ) *
13 : * recombinaison d'une contrainte ( ICONT = 1 ) *
14 : * recombinaison d'une r{action ( ICONT = 2 ) *
15 : * e ITPS table repr{sentant les pseudo-modes *
16 : * e IBAS table repr{sentant la base modale *
17 : * es IBOO segment des points en recombinaison *
18 : * e IPX listreel des temps de recombinaison *
19 : * e KCHAR chargement de la structure *
20 : * *
21 : * Auteur, date de cr{ation: *
22 : * *
23 : * Lionel VIVAN, le 2 mai 1990. *
24 : * *
25 : *--------------------------------------------------------------------*
26 : * *
27 : -INC CCOPTIO
28 : -INC SMCHARG
29 : -INC SMCHPOI
30 : -INC SMLREEL
31 : *
32 : SEGMENT NUMOO
33 : INTEGER NUMO(N),KLIST(N)
34 : CHARACTER*4 NUDDL(N)
35 : ENDSEGMENT
36 : LOGICAL L0,L1
37 : CHARACTER*4 COMP
38 : CHARACTER*8 TYPRET,CHARRE
39 : CHARACTER*40 CMOT
40 : PARAMETER (TOLER = 1.D-6)
41 : *
42 : NUMOO = IBOO
43 : SEGACT NUMOO
44 : NP = NUMO(/1)
45 : DO 2 I = 1,NP
46 : MLREE3 = KLIST(I)
47 : SEGACT MLREE3*MOD
48 : 2 CONTINUE
49 : *
50 : MLREEL= IPX
51 : SEGACT MLREEL
52 : LDIM = PROG(/1)
53 : *
54 : MCHARG = KCHAR
55 : SEGACT MCHARG
56 : NCHAR = KCHARG(/1)
57 : *
58 : * Boucle sur les pseudo-modes
59 : *
60 : IPS = 0
61 : 10 CONTINUE
62 : IPS = IPS + 1
63 : TYPRET = ' '
63 : CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
64 : & TYPRET,I1,X1,CHARRE,L1,ITPM)
65 : IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
65 : CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
66 : & 'MOT',I1,X1,CMOT,L1,IP1)
67 : IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
67 : CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
68 : & 'CHPOINT',I1,X1,' ',L1,ICHBB)
69 : *
70 : * boucle sur les chargements {l{mentaires
71 : *
72 : DO 20 ICHA =1,NCHAR
73 : ICHARG = KCHARG(ICHA)
74 : SEGACT ICHARG
75 : IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
76 : & .OR.CHALIE(ICHA).NE.'LIE ') THEN
77 : SEGDES ICHARG
78 : GOTO 20
79 : ENDIF
80 : IF (ICHBB.EQ.ICHPO1) GOTO 100
81 : 20 CONTINUE
82 : * end do
83 : * on n'a pas trouv{ le chargement
84 : INTERR(1) = IPS
84 : CALL ERREUR(428)
85 : SEGDES ICHARG
86 : GOTO 10
87 : ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
87 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
88 : & 'ENTIER',IENT,X1,' ',L1,IP1)
88 : CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
89 : & 'TABLE',I1,X1,' ',L1,ITMK)
89 : CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
90 : & L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
90 : CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
91 : & 'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
92 : *
93 : * boucle sur les chargements {l{mentaires
94 : *
95 : DO 30 ICHA =1,NCHAR
96 : ICHARG = KCHARG(ICHA)
97 : SEGACT ICHARG
98 : IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
99 : & .OR.CHALIE(ICHA).NE.'LIE ') THEN
100 : SEGDES ICHARG
101 : GOTO 30
102 : ENDIF
103 : MCHPOI = ICHPO1
104 : SEGACT MCHPOI
105 : MSOUPO = IPCHP(1)
106 : SEGDES MCHPOI
107 : SEGACT MSOUPO
108 : MPOVAL = IPOVAL
109 : SEGDES MSOUPO
110 : SEGACT MPOVAL
111 : QXYZ = VPOCHA(1,1)
112 : SEGDES MPOVAL
113 : EPS = ABS(QXYZ + XQXYZ)
114 : IF (EPS.LT.TOLER) GOTO 100
115 : 30 CONTINUE
116 : * end do
117 : * on n'a pas trouv{ le chargement
118 : INTERR(1) = IPS
118 : CALL ERREUR(428)
119 : SEGDES ICHARG
120 : GOTO 10
121 : ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
121 : CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
122 : & 'CHPOINT',I1,X1,' ',L1,ICHBB)
123 : *
124 : * boucle sur les chargements {l{mentaires
125 : *
126 : DO 40 ICHA =1,NCHAR
127 : ICHARG = KCHARG(ICHA)
128 : SEGACT ICHARG
129 : IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
130 : & .OR.CHALIE(ICHA).NE.'LIE ') THEN
131 : SEGDES ICHARG
132 : GOTO 40
133 : ENDIF
134 : IF (ICHBB.EQ.ICHPO1) GOTO 100
135 : 40 CONTINUE
136 : * end do
137 : * on n'a pas trouv{ le chargement
138 : INTERR(1) = IPS
138 : CALL ERREUR(428)
139 : SEGDES ICHARG
140 : GOTO 10
141 : ENDIF
142 : *
143 : 100 CONTINUE
144 : ICDEP = 0
145 : IF (ICONT.EQ.0) THEN
145 : CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
146 : & 'CHPOINT',I1,X1,' ',L1,ICDEP)
147 : ELSE IF (ICONT.EQ.1) THEN
147 : CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
148 : & 'MCHAML ',I1,X1,' ',L1,ICHAM1)
149 : C* Manque le passage en MCHAML aux noeuds avec le modele !!!
149 : C* CALL CHASUP(IPMODL,ICHAM1,ICHAM2,IRETOU,1)
150 : C* IF (IRETOU.EQ.0) THEN
151 : C* INTERR(1) = IPS
151 : C* CALL ERREUR(___)
152 : C* SEGDES ICHARG
153 : C* GOTO 10
154 : C* ENDIF
154 : C* CALL CHAMPO(ICHAM2,2,ICDEP,IRETOU)
154 : CALL CHAMPO(ICHAM1,2,ICDEP,IRETOU)
155 : IF (IRETOU.EQ.0) THEN
156 : INTERR(1) = IPS
156 : CALL ERREUR(428)
157 : SEGDES ICHARG
158 : GOTO 10
159 : ENDIF
160 : ELSE IF (ICONT.EQ.2) THEN
160 : CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
161 : & 'CHPOINT',I1,X1,' ',L1,ICDEP)
162 : ENDIF
163 : MLREE1 = ICHPO2
164 : SEGACT MLREE1
165 : NF = MLREE1.PROG(/1)
166 : MLREE2 = ICHPO3
167 : SEGACT MLREE2
168 : IF (IIMPI.EQ.1804) THEN
169 : WRITE(IOIMP,*)'PSEVRC : pseudo-mode num{ro ',IPS
170 : WRITE(IOIMP,*)'PSEVRC : chargement ',KCHAR
171 : WRITE(IOIMP,*)'PSEVRC : num{ro ',ICHA
172 : ENDIF
173 : N1 = 1
174 : N2 = 2
175 : DO 110 IT = 1,LDIM
176 : XTEMP = PROG(IT)
176 : CALL INTLIN(XTEMP,ICHPO2,ICHPO3,NF,N1,N2,XFTEM,IRETOU)
177 : IF (IRETOU.EQ.0) THEN
178 : INTERR(1) = IPS
178 : CALL ERREUR(428)
179 : SEGDES MLREE1
180 : SEGDES MLREE2
181 : SEGDES ICHARG
182 : GOTO 10
183 : ENDIF
184 : IF (IIMPI.EQ.1804) THEN
185 : WRITE(IOIMP,*)'PSEVRC : temps ',XTEMP
186 : WRITE(IOIMP,*)'PSEVRC : f(t) ',XFTEM
187 : ENDIF
188 : *
189 : DO 120 IP = 1,NP
190 : IPOIN = NUMO(IP)
191 : COMP = NUDDL(IP)
191 : CALL EXTRA9(ICDEP,IPOIN,COMP,KERRE,XFLOT)
192 : IF (KERRE.NE.0) THEN
193 : INTERR(1) = IPS
193 : CALL ERREUR(428)
194 : SEGDES MLREE1
195 : SEGDES MLREE2
196 : SEGDES ICHARG
197 : GOTO 10
198 : ENDIF
199 : XVAL = XFLOT * XFTEM
200 : IF (IIMPI.EQ.1804) THEN
201 : WRITE(IOIMP,*)'PSEVRC : au point ',IPOIN
202 : WRITE(IOIMP,*)'PSEVRC : de composante ',COMP
203 : WRITE(IOIMP,*)'PSEVRC : valeur calcul{e ',XVAL
204 : ENDIF
205 : MLREE3 = KLIST(IP)
206 : MLREE3.PROG(IT) = MLREE3.PROG(IT) + XVAL
207 : 120 CONTINUE
208 : 110 CONTINUE
209 : SEGDES MLREE1
210 : SEGDES MLREE2
211 : SEGDES ICHARG
212 : GOTO 10
213 : ENDIF
214 : *
215 : SEGDES MCHARG
216 : SEGDES MLREEL
217 : DO 4 I = 1,NP
218 : MLREE3 = KLIST(I)
219 : SEGDES MLREE3
220 : 4 CONTINUE
221 : IBOO = NUMOO
222 : *
223 : IF (ICONT.EQ.1) THEN
224 : MCHPO1 = ICDEP
225 : SEGSUP MCHPO1
226 : ENDIF
227 : *
228 : RETURN
229 : END
230 :
231 :
© Cast3M 2003 - All rights reserved.
Disclaimer