1 : C PROIET SOURCE GF238795 13/11/05 21:15:02 7824
2 :
3 : SUBROUTINE PROIET
4 :
5 : C--------------------------------------------------------------------
6 : C
7 : C OPERATEUR PROIET
8 : C--------------------------------------------------------------------
9 : C
10 : C
11 : C PROJECTION D'UN CHAMELEM AUX NOEUDS DUN MAILLAGE
12 : C PROJECTION ET VALEUR D'UN CHAMELEM AUX NOEUDS OU AUX
13 : C POINTS D INTEGRATION D UN MODELE POUVANT COMPORTER DES COQUES
14 : C INTEGREES (LA COMPOSANTE T SI PRESENTE SERA DECOMPOSEE
15 : C EN T TINF TSUP SI NECESSAIRE SUIVANT LA FORMULATION DE LA COQUE
16 : C PROJECTION D'UN CHAMELEM PAR MINIMISATION DE L INTEGRALE
17 : C
18 : C INT (U1i - U2i)**2 SUR LES ELEMENT RECEPTEURS
19 : C
20 : C
21 : C
22 : C - 'POLY' :
23 : C PROJECTION SUR GEO2 DES COMPOSANTES D'UN CHPOINT CHP1
24 : C DEFINI SUR GEO1 PAR UNE METHODE DE LISSAGE ( adaptee
25 : C pour des champs magnetostatique)
26 : C
27 : C SYNTAXE :
28 : C
29 : C CHPO1 = PROIET MAIL2 CHEL1
30 : C
31 : C MCHEL1 = PROIET MOD1 (CARA ) CHEL1 (MOD2)
32 : C
33 : C MCHEL1 = PROIET MOD1 CHEL1 (MOD2) (MINI (NB ))
34 : C
35 : C OBJ1 = "POLY" GEO1 GEO2 CHP1 ENT1 MOT1 ("POIDS" X1 X2)
36 : C
37 : C
38 : C ENTREE :
39 : C SANS OPTION :
40 : C MAIL2 = OBJET DE TYPE MAILLAGE.
41 : C
42 : C CHEL1 = OBJET DE TYPE MCHAML.
43 : C
44 : C MOD1 = MODELE
45 : C CARA = CARACTERISTIQUE DE LA COQUE (MCHAML) si il y a des
46 : C des sous zones coques dans le modele
47 : C
48 : C POLY :
49 : C GEO1 = OBJET DE TYPE MAILLAGE
50 : C GEO2 = OBJET DE TYPE MAILLAGE
51 : C CHP1 = OBJET DE TYPE MCHAML
52 : C ENT1 = ENTIER (PRECISE LE TYPE DE SYMETRIE)
53 : C MOT1 = MOT 'PLAN' OU 'AXIS'
54 : C POIDS = MOT FACULTATIF
55 : C
56 : C SORTIE :
57 : C
58 : C
59 : C
60 : C NORA DAVIDOVICH- 15/2/89
61 : C NOUVEAUX CHAMELEMS P DOWLATYARI OCT. 91
62 : C MODIFICATION FLEURET 01/96 - OPTION 'ARMA'
63 : C MODIFICATION VIGAN 03/97 - OPTION 'COQU'
64 : C--------------------------------------------------------------------
65 : IMPLICIT INTEGER(I-N)
66 : IMPLICIT REAL*8(A-H,O-Z)
67 : -INC CCOPTIO
68 : -INC SMCHAML
69 : -INC SMMODEL
70 : ** pile modeles elementaires
71 : segment limode(0)
72 :
73 : PARAMETER (NCLE = 7)
74 : CHARACTER*4 MOTCLE(NCLE)
75 :
76 : DATA MOTCLE /'POLY','NOEU','GRAV','RIGI','MASS','STRE','MINI'/
77 :
78 : C-----LECTURE DE L'OPTION
79 : IVAL = 0
79 : CALL LIRMOT(MOTCLE,NCLE,IVAL,0)
80 : C
81 : C-----OPTION POLY
82 : IF (IVAL.EQ.1) THEN
82 : CALL LISSAG
83 : RETURN
84 : ENDIF
85 :
86 : C- Par defaut, le support est aux noeuds
87 : IF (IVAL.EQ.0) IVAL = 2
88 :
89 : IPGEA = 0
89 : CALL LIROBJ('MAILLAGE',IPGEA,0,iretou)
90 : IF (IERR.NE.0) RETURN
91 :
92 : C- Projection d'un champ par element defini aux noeuds sur un maillage
93 : IF (IPGEA.GT.0) THEN
94 :
94 : CALL LIROBJ('MCHAML',IPCHEL,1,iretou)
95 : IF (IERR.NE.0) RETURN
96 : C Verification du support aux noeuds
96 : CALL QUESUP(0,IPCHEL,0,1,iretou,iret2)
97 : IF (iretou.GT.1) THEN
97 : CALL ERREUR(903)
98 : RETURN
99 : ENDIF
100 :
100 : CALL PRO2(IPGEA,IPCHEL,1, IPOUT,-1)
101 :
101 : IF (IERR.EQ.0) CALL ECROBJ('CHPOINT',IPOUT)
102 :
103 : RETURN
104 :
105 : C- Projection d'un champ par element aux noeuds sur le support d'un modele
106 : c* ELSE IF (IPGEA.EQ.0) THEN
107 : ELSE
107 : CALL LIROBJ('MMODEL',ipmod1,1,iretou)
108 : IF (IERR.NE.0) RETURN
108 : CALL LIROBJ('MCHAML',IPCHE1,1,iretou)
109 : IF (IERR.NE.0) RETURN
109 : CALL LIROBJ('MCHAML',IPCHE2,0,iretou)
110 : IF (IERR.NE.0) RETURN
111 :
112 : IF (IPCHE2.NE.0) THEN
113 : IPCHEL = IPCHE2
114 : IPCARA = IPCHE1
115 : ELSE
116 : IPCHEL = IPCHE1
117 : IPCARA = 0
118 : ENDIF
119 : C Cas particulier de la presence d'un champ de CARACTERISTIQUES
120 : C On permute eventuellement l'ordre mais normalement il faut respecter
121 : C l'ordre de la notice "IPCARA IPCHEL"
122 : IF (IPCARA.NE.0) THEN
123 : mchelm = IPCARA
124 : SEGACT,mchelm
125 : IF (titche(1:16).NE.'CARACTERISTIQUES') THEN
126 : c le champ de caracteristiques a peut etre ete donne en deuxieme, on
127 : c teste en inversant les deux champs par elements fournis
128 : SEGDES,mchelm
129 : IPCHEL = IPCHE1
130 : IPCARA = IPCHE2
131 :
132 : mchelm = IPCARA
133 : SEGACT,mchelm
134 : IF (titche(1:16).NE.'CARACTERISTIQUES') THEN
135 : SEGDES,mchelm
136 : MOTERR(1:16) = 'CARACTERISTIQUES'
136 : CALL ERREUR(565)
137 : ENDIF
138 : ENDIF
139 : SEGDES,mchelm
140 : IF (IERR.NE.0) RETURN
141 : ENDIF
142 : C Verification du support aux noeuds
142 : CALL QUESUP(0,IPCHEL,0,1,iretou,iret2)
143 : IF (iretou.GT.1) THEN
143 : CALL ERREUR(903)
144 : RETURN
145 : ENDIF
146 :
147 : * kich : pour MELANGE on deroule les modeles
148 : mmodel = ipmod1
149 : SEGACT,mmodel*nomod
150 : NSOUS = kmodel(/1)
151 : IF (NSOUS.LE.0) THEN
152 : SEGDES,mmodel
152 : CALL ERREUR(5)
153 : RETURN
154 : ENDIF
155 : *
156 : limode=0
157 : SEGINI,limode
158 : DO im1 = 1, NSOUS
159 : imodel = kmodel(im1)
160 : SEGACT,imodel
161 : limode(**) = imodel
162 : IF (formod(1).EQ.'MELANGE') THEN
163 : IF (matmod(1).NE.'SERIE') THEN
164 : IF (ivamod(/1).GE.1) then
165 : DO im2 = 1, ivamod(/1)
166 : IF (tymode(im2).eq.'IMODEL') then
167 : limode(**) = ivamod(im2)
168 : imodel = ivamod(im2)
169 : SEGACT,imodel
170 : ENDIF
171 : ENDDO
172 : ENDIF
173 : ENDIF
174 : ENDIF
175 : ENDDO
176 : SEGDES,mmodel
177 : *
178 : NSOUS = limode(/1)
179 : * test non redondance
180 : N1 = 1
181 : DO 10 im1 = NSOUS, 2, -1
182 : imode1 = limode(im1)
183 : DO im2 = (im1 - 1), 1, -1
184 : imode2 = limode(im2)
185 : IF (imode1.EQ.imode2) THEN
186 : limode(im1) = 0
187 : GOTO 10
188 : ELSE IF (imode1.imamod.EQ.imode2.imamod .AND.
189 : & imode1.conmod.EQ.imode2.conmod) THEN
190 : limode(im1) = 0
191 : SEGDES,imode1
192 : GOTO 10
193 : ENDIF
194 : ENDDO
195 : N1 = N1 + 1
196 : 10 CONTINUE
197 : SEGINI,mmodel
198 : im1 = 0
199 : DO im2 = 1, NSOUS
200 : imode2 = limode(im2)
201 : IF (imode2.GT.0) THEN
202 : im1 = im1 + 1
203 : kmodel(im1) = imode2
204 : ENDIF
205 : ENDDO
206 : ipmod1 = mmodel
207 : SEGSUP,limode
208 : C
209 : ISUP = 1
210 : C- Option 'MINI'
211 : IF (IVAL.EQ.7) THEN
211 : CALL PROM(ipmod1,IPCARA,IPCHEL,ISUP, IPOUT)
212 : C- Projection sur support ISUP
213 : ELSE
214 : IF (IVAL.GT.1.AND.IVAL.LT.7) ISUP = IVAL-1
214 : CALL PRON(ipmod1,IPCARA,IPCHEL,ISUP, IPOUT)
215 : ENDIF
216 :
216 : IF (IERR.EQ.0) CALL ECROBJ('MCHAML',IPOUT)
217 :
218 : ENDIF
219 :
220 : RETURN
221 : END
222 :
223 :
224 :
© Cast3M 2003 - All rights reserved.
Disclaimer