1 : C PSACCE SOURCE CHAT 05/01/13 02:36:56 5004
2 : SUBROUTINE PSACCE(IRAID,IMASS,IMAIL,MTRAV,DIR, ICHP1)
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8(A-H,O-Z)
5 : ************************************************************************
6 : *
7 : * P S A C C E
8 : * -----------
9 : *
10 : * FONCTION:
11 : * ---------
12 : *
13 : * calcule le pseudo-mode en d{placement pour une acc{l{ration
14 : * sismique d'ensemble.
15 : *
16 : * MODULES UTILISES:
17 : * -----------------
18 : *
19 : -INC CCOPTIO
20 : -INC CCREEL
21 : -INC SMCHPOI
22 : *
23 : * PARAMETRES: (e)=entr{e (s)=sortie
24 : * -----------
25 : *
26 : * IRAID (e) pointeur sur la matrice K de la structure.
27 : * IMASS (e) pointeur sur la matrice M de la stuctureE.
28 : * IMAIL (e) pointeur sur le maillage de la structure.
29 : * MTRAV (e) pointeur sur les modes de la structure.
30 : * DIR (e) direction de l'excitation sismique.
31 : * ICHP1 (s) pointeur sur le pseudo-mode en d{placement.
32 : *
33 : CHARACTER*2 DIR
34 : SEGMENT MTRAV
35 : REAL*8 FREQ(NBMODE),MN(NBMODE),MW2(NBMODE),
36 : & QX(NBMODE),QY(NBMODE),QZ(NBMODE)
37 : INTEGER DEPL(NBMODE)
38 : ENDSEGMENT
39 : *
40 : *
41 : * AUTEUR, DATE DE CREATION:
42 : * -------------------------
43 : *
44 : * Lionel VIVAN Juillet 1988
45 : *
46 : ************************************************************************
47 : *
48 : SEGMENT PSTRA
49 : REAL*8 QSMW2(NBMODE)
50 : ENDSEGMENT
51 : *
52 : ICHP1 = 0
53 : SEGACT MTRAV
54 : NBMODE = FREQ(/1)
55 : SEGINI PSTRA
56 : IF (DIR .EQ. 'UX') THEN
57 : DO 4 I = 1,NBMODE
58 : QSMW2(I) = -1.D0 * QX(I) / MW2(I)
59 : 4 CONTINUE
60 : ELSE IF (DIR .EQ. 'UY') THEN
61 : DO 6 I = 1,NBMODE
62 : QSMW2(I) = -1.D0 * QY(I) / MW2(I)
63 : 6 CONTINUE
64 : ELSE
65 : DO 8 I = 1,NBMODE
66 : QSMW2(I) = -1.D0 * QZ(I) / MW2(I)
67 : 8 CONTINUE
68 : ENDIF
69 : *
70 : * r{solution du syst}me statique
71 : *
72 : * est-on en axisym{trique ?
73 : *
74 : IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
75 : IF (DIR .EQ. 'UX') THEN
75 : CALL ECRREE(1.D0)
75 : CALL ECRCHA('UT')
75 : CALL ECRREE(-1.D0)
75 : CALL ECRCHA('UR')
75 : CALL ECRENT(2)
75 : CALL ECROBJ('MAILLAGE',IMAIL)
75 : CALL MANUCH
76 : IF (IERR.NE.0) RETURN
76 : CALL LIROBJ('CHPOINT ',ICHPT,1,IRETOU)
77 : IF (IERR.NE.0) RETURN
78 : ELSE IF (DIR .EQ. 'UY') THEN
78 : CALL ECRREE(-1.D0)
78 : CALL ECRCHA('UT')
78 : CALL ECRREE(-1.D0)
78 : CALL ECRCHA('UR')
78 : CALL ECRENT(2)
78 : CALL ECROBJ('MAILLAGE',IMAIL)
78 : CALL MANUCH
79 : IF (IERR.NE.0) RETURN
79 : CALL LIROBJ('CHPOINT ',ICHPT,1,IRETOU)
80 : IF (IERR.NE.0) RETURN
81 : ELSE
81 : CALL ECRREE(-1.D0)
81 : CALL ECRCHA('UZ')
81 : CALL ECRENT(1)
81 : CALL ECROBJ('MAILLAGE',IMAIL)
81 : CALL MANUCH
82 : IF (IERR.NE.0) RETURN
82 : CALL LIROBJ('CHPOINT ',ICHPT,1,IRETOU)
83 : IF (IERR.NE.0) RETURN
84 : ENDIF
85 : *
86 : MCHPOI = ICHPT
87 : SEGACT MCHPOI
88 : IFOPOI = IFOUR
89 : NS = IPCHP(/1)
90 : DO 10 I = 1,NS
91 : MSOUPO = IPCHP(I)
92 : SEGACT MSOUPO
93 : NC = NOHARM(/1)
94 : DO 20 IC = 1,NC
95 : IF (IFOUR .EQ. 1) THEN
96 : IF (DIR .EQ. 'UX') THEN
97 : NOHARM(IC) = 1
98 : ELSE IF (DIR .EQ. 'UY') THEN
99 : NOHARM(IC) = -1
100 : ELSE
101 : NOHARM(IC) = 0
102 : ENDIF
103 : ELSE
104 : NOHARM(IC) = 0
105 : ENDIF
106 : 20 CONTINUE
107 : SEGDES MSOUPO
108 : 10 CONTINUE
109 : SEGDES MCHPOI
110 : ELSE
110 : CALL ECRREE(-1.D0)
110 : CALL ECRCHA(DIR)
110 : CALL ECRENT(1)
110 : CALL ECROBJ('MAILLAGE',IMAIL)
110 : CALL MANUCH
111 : IF (IERR.NE.0) RETURN
111 : CALL LIROBJ('CHPOINT ',ICHPT,1,IRETOU)
112 : IF (IERR.NE.0) RETURN
113 : ENDIF
114 : *
114 : CALL MUCPRI(ICHPT,IMASS,ICHP2)
115 : IF (IERR.NE.0) RETURN
116 : *
116 : CALL ECROBJ('CHPOINT ',ICHP2)
116 : CALL ECROBJ('RIGIDITE',IRAID)
116 : CALL RESOU
117 : IF (IERR.NE.0) RETURN
117 : CALL LIROBJ('CHPOINT ',ICHPST,1,IRETOU)
118 : IF (IERR.NE.0) RETURN
119 : *
120 : * r{solution du syst}me dynamique
121 : *
122 : DO 30 ID = 1,NBMODE
123 : XFLOT = QSMW2(ID)
124 : IPHI = DEPL(ID)
125 : IF (ID .EQ. 1) THEN
125 : CALL MUCHPO(IPHI,XFLOT,ICHPDY,1)
126 : IF (IERR.NE.0) RETURN
127 : ELSE
127 : CALL ADCHPO(ICHPDY,IPHI,ICHP3,1D0,XFLOT)
128 : IF (IERR.NE.0) RETURN
128 : CALL DECHPO(ICHPDY)
129 : IF (IERR.NE.0) RETURN
130 : ICHPDY = ICHP3
131 : ENDIF
132 : 30 CONTINUE
133 : *
134 : * calcul du pseudo-mode
135 : *
135 : CALL ADCHPO(ICHPST,ICHPDY,ICHP1,1D0,-1D0)
136 : IF (IERR.NE.0) RETURN
137 : *
138 : * destruction
139 : *
139 : CALL DECHPO(ICHPST)
140 : IF (IERR.NE.0) RETURN
140 : CALL DECHPO(ICHPDY)
141 : IF (IERR.NE.0) RETURN
141 : CALL DECHPO(ICHPT)
142 : IF (IERR.NE.0) RETURN
143 : *
144 : SEGSUP PSTRA
145 : SEGDES MTRAV
146 : *
147 : END
148 :
149 :
150 :
© Cast3M 2003 - All rights reserved.
Disclaimer