1 : C CHASPG SOURCE CHAT 11/03/16 21:16:55 6902 2 : SUBROUTINE CHASPG(IPMODL,IPOI1,IPOI2,IRET,IPLAC) 3 : C--------------------------------------------------------------------- 4 : C 5 : C ENTREES: 6 : C 7 : C IPMODL Pointeur sur un MMODEL de type NAVIER_STOKES 8 : C IPOI1 Pointeur sur un MCHAML 9 : C IPLAC Indique le type de support demandé : 10 : C 1 scalaire aux NOEUDS 11 : C 2 scalaire au CENTRE DE GRAVITE 12 : C 3 scalaire aux points d'integration de la RAIDEUR 13 : C 4 scalaire aux points d'integration de la MASSE 14 : C 5 scalaire aux points de CONTRAINTES 15 : C 6 (utilisé dans le cas de la thermique) 16 : C 7 SPG : FACE 17 : C 8 SPG : CENTREP1 18 : C 9 SPG : MSOMMET 19 : C TYPPROJ Mot designant le type transformation autre-->sommet 20 : C INTERP pour interpolation 21 : C PROJEC pour projection 22 : C 23 : C SORTIE: 24 : C 25 : C IPOI2 Pointeur sur un MCHAML 26 : C IRET =0 Si tout est ok 27 : C Sinon contient le numero d'erreur 28 : C 29 : C A.BLEYER le 22/01/2004 30 : C 31 : C--------------------------------------------------------------------- 32 : IMPLICIT REAL*8(A-H,O-Z) 33 : -INC CCOPTIO 34 : -INC SMMODEL 35 : -INC SMCHAML 36 : -INC SMELEME 37 : -INC SMINTE 38 : -INC SMCOORD 39 : LOGICAL FLAG1 40 : CHARACTER*8 CHARIN 41 : PARAMETER (NSPG = 9) 42 : CHARACTER*8 LSPG(NSPG) 43 : C 44 : SEGMENT SWORK 45 : REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2) 46 : REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN) 47 : ENDSEGMENT 48 : * 49 : * NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2 50 : * N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS 51 : * 52 : SEGMENT INFO 53 : INTEGER INFELL(JG) 54 : ENDSEGMENT 55 : 56 : POINTEUR INFO1.INFO,INFO2.INFO 57 : C 58 : IRET=0 59 : 60 : LSPG(1)='NOEUD' 61 : LSPG(2)='GRAVITE' 62 : LSPG(3)='RIGIDITE' 63 : LSPG(4)='MASSE' 64 : LSPG(5)='STRESSES' 65 : LSPG(6)='THERMIQU' 66 : LSPG(7)='FACE' 67 : LSPG(8)='P1CENTRE' 68 : LSPG(9)='MSOMMET' 69 : 70 : C 71 : C ACTIVATION DU MODELE 72 : C 73 : MMODEL=IPMODL 73 : CALL LEKMOD(MMODEL,IDOMA,INEFMD) 74 : SEGACT MMODEL 75 : NSOUS1=KMODEL(/1) 76 : C 77 : C ACTIVATION DES MCHELM 78 : C 79 : MCHEL1 =IPOI1 80 : SEGACT MCHEL1 81 : NSOUS=MCHEL1.ICHAML(/1) 82 : IF(NSOUS.GT.NSOUS1)THEN 83 : IRET=553 84 : SEGDES MMODEL,MCHEL1 85 : RETURN 86 : ENDIF 87 : N1=NSOUS 88 : L1=MCHEL1.TITCHE(/1) 89 : N3=MCHEL1.INFCHE(/2) 90 : NINF=N3 91 : IF (N3.LT.6) N3=6 92 : SEGINI MCHELM 93 : TITCHE=MCHEL1.TITCHE 94 : IFOCHE=IFOUR 95 : IPOI2=MCHELM 96 : C 97 : C ON BOUCLE SUR LES SOUS-ZONES DU MCHAML 98 : C 99 : NTEL=0 100 : KK1=0 101 : DO 100 ISOUS=1,NSOUS 102 : * 103 : CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) 104 : DO 191 IP=1,NINF 105 : INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP) 106 : 191 CONTINUE 107 : MINTE1=MCHEL1.INFCHE(ISOUS,4) 108 : IPLAC1=MCHEL1.INFCHE(ISOUS,6) 109 : 110 : IMODEL=KMODEL(ISOUS) 111 : SEGACT IMODEL 112 : IPMAIL=IMAMOD 113 : MELE=NEFMOD 114 : 115 : IF (IPLAC1.EQ.IPLAC) THEN 116 : SEGDES MMODEL,MCHEL1,MCHELM,IMODEL 117 : IPOI2=IPOI1 118 : RETURN 119 : ELSEIF (IPLAC1.EQ.1.AND.IPLAC1.NE.IPLAC) THEN 120 : IF (IPLAC.EQ.2) THEN 120 : CALL LEKTAB(IDOMA,'MAILLAGE',IPT1) 121 : ELSEIF(IPLAC.EQ.8) THEN 122 : IF (MELE.GE.223.AND.MELE.LE.236) THEN 122 : CALL LEKTAB(IDOMA,'MACRO1',IPT1) 123 : ELSE 123 : CALL LEKTAB(IDOMA,'MAILLAGE',IPT1) 124 : ENDIF 124 : CALL LEKTAB(IDOMA,'ELTP1NC',IPT2) 125 : KK1=1 126 : ELSEIF(IPLAC.EQ.9) THEN 127 : IF (MELE.GE.223.AND.MELE.LE.236) THEN 127 : CALL LEKTAB(IDOMA,'MACRO1',IPT1) 128 : ELSE 128 : CALL LEKTAB(IDOMA,'MAILLAGE',IPT1) 129 : ENDIF 130 : ENDIF 131 : ELSEIF (IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN 132 : IF (MELE.GE.223.AND.MELE.LE.236) THEN 132 : CALL LEKTAB(IDOMA,'MACRO1',IPT1) 133 : ELSE 133 : CALL LEKTAB(IDOMA,'MAILLAGE',IPT1) 134 : ENDIF 135 : ELSEIF (IPLAC1.NE.1.AND.IPLAC.NE.1) THEN 136 : WRITE(6,*)'Le SPG origine',LSPG(IPLAC1),'n''est pas compatible' 137 : WRITE(6,*)'avec ',LSPG(IPLAC) 138 : WRITE(6,*)'Seul le SPG SOMMET cible est authorisé !!!' 139 : SEGDES MMODEL,MCHEL1,MCHELM,IMODEL 140 : RETURN 141 : ENDIF 142 : 143 : SEGACT IPT1 144 : IF(NSOUS.NE.1) THEN 145 : MELEME=IPT1.LISOUS(ISOUS) 146 : SEGACT MELEME 147 : ELSE 148 : MELEME=IPT1 149 : ENDIF 150 : 151 : IMACHE(ISOUS)=MELEME 152 : C 153 : C MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE 154 : C 155 : info=0 156 : if(infmod(/1).lt.2+iplac) then 156 : CALL ELQUOI(MELE,0,IPLAC,IPTR2,IMODEL) 157 : IF ( IERR .NE. 0) GOTO 665 158 : INFO=IPTR2 159 : MELGEO=INFELL(14) 160 : MINTE=INFELL(11) 161 : ELSE 162 : MINTE=infmod(2+iplac) 163 : MELGEO=INFELE(14) 164 : ENDIF 165 : 166 : INFCHE(ISOUS,4)=MINTE 167 : IF(IPLAC.EQ.1)INFCHE(ISOUS,4)=0 168 : INFCHE(ISOUS,6)=IPLAC 169 : C 170 : C ON RECUPERE LE NOMBRE D ELEMENTS 171 : C 172 : NBNN =NUM(/1) 173 : NEL =NUM(/2) 174 : C WRITE(6,*)'NBNN=',NBNN,'NEL=',NEL 175 : C 176 : C ON RECUPERE LE NOMBRE DE POINTS SUPPORT 177 : C NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU 178 : C 179 : INFO1=0 180 : IF(MINTE1.EQ.0)THEN 181 : if(infmod(/1).lt.2+iplac1) then 181 : CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL) 182 : INFO1=IPTR2 183 : MINTE1=INFO1.INFELL(11) 184 : ELSE 185 : minte1=infmod(2+iplac1) 186 : endif 187 : ENDIF 188 : SEGACT MINTE1 189 : NBN1=MINTE1.SHPTOT(/2) 190 : 191 : SEGACT MINTE 192 : NBN2=SHPTOT(/2) 193 : IF(IPLAC.EQ.2) NBN2=1 194 : 195 : C WRITE(6,*)'NBN1=',NBN1,'NBN2=',NBN2 196 : SEGINI SWORK 197 : C 198 : C CREATION DU MCHAML 199 : C 200 : MCHAM1=MCHEL1.ICHAML(ISOUS) 201 : SEGACT MCHAM1 202 : N2=MCHAM1.NOMCHE(/2) 203 : SEGINI MCHAML 204 : ICHAML(ISOUS)=MCHAML 205 : C 206 : C BOUCLE SUR LES COMPOSANTES 207 : C 208 : DO 180 ICOMP=1,N2 209 : C 210 : NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP) 211 : TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP) 212 : C 213 : MELVA1=MCHAM1.IELVAL(ICOMP) 214 : SEGACT MELVA1 215 : * 216 : * RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire 217 : * 218 : N1PTE1=MELVA1.VELCHE(/1) 219 : N1EL1 =MELVA1.VELCHE(/2) 220 : 221 : N1PTEL=NBN2 222 : N1EL =NEL 223 : * 224 : N2PTEL=0 225 : N2EL=0 226 : 227 : SEGINI MELVAL 228 : IELVAL(ICOMP)=MELVAL 229 : * 230 : * TRAITEMENT IMMEDIAT SI CHAMP ORIGINEL CONSTANT 231 : * 232 : IF(N1PTE1.EQ.1) THEN 233 : DO 4120 IEL=1,N1EL 234 : DO 4120 INO=1,NBN2 235 : VELCHE(INO,IEL)=MELVA1.VELCHE(1,IEL) 236 : 4120 CONTINUE 237 : * 238 : ELSE 239 : DO 3120 IEL=1,NEL 240 : DO 3121 IGAU=1,NBN1 241 : VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL) 242 : 3121 CONTINUE 243 : C 244 : C LE CHAMELEM 1 EST AUX NOEUDS ET ON VEUT CHANGER DE SPG 245 : C 246 : IF(IPLAC1.EQ.1) THEN 246 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) 246 : CALL QUEDIM(MELGEO,KERRE) 246 : CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN, 247 : > SWORK,1,KERRE) 248 : IF(KERRE.NE.0) THEN 249 : IRET=KERRE 250 : SEGDES MELVA1,MELEME,IMODEL,MCHAM1 251 : SEGSUP SWORK,MCHAML,MELVAL 252 : GO TO 665 253 : ENDIF 254 : * 255 : DO 3122 IGAU=1,NBN2 256 : VELCHE(IGAU,IEL)=VAL2(IGAU) 257 : 3122 CONTINUE 258 : C 259 : C PASSAGE D'UN SPG QUELCONQUE VERS UN CHAMELEM AUX NOEUDS 260 : C 261 : ELSEIF(IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN 261 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) 261 : CALL QUEDIM(MELGEO,KERRE) 261 : CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN, 262 : > SWORK,2,KERRE) 263 : IF(KERRE.NE.0) THEN 264 : IRET=KERRE 265 : SEGDES MELVA1,MELEME,IMODEL,MCHAM1 266 : SEGSUP SWORK,MCHAML,MELVAL 267 : GO TO 665 268 : ENDIF 269 : * 270 : DO 3123 IGAU=1,NBN2 271 : VELCHE(IGAU,IEL)=VAL2(IGAU) 272 : 3123 CONTINUE 273 : ENDIF 274 : 3120 CONTINUE 275 : NTEL=NTEL+NEL 276 : ENDIF 277 : SEGDES MELVAL,MELVA1 278 : 180 CONTINUE 279 : SEGSUP SWORK 280 : SEGDES MCHAML,MCHAM1,IMODEL,IPT1 281 : * 282 : IF(INFO.ne.0)SEGSUP INFO 283 : IF (MINTE.NE.0) SEGDES MINTE 284 : IF (MINTE1.NE.0) SEGDES MINTE1 285 : IF (INFO1.NE.0) SEGSUP INFO1 286 : IF (NSOUS.NE.1) SEGDES MELEME 287 : 288 : 100 CONTINUE 289 : 665 CONTINUE 290 : SEGDES MCHELM,MCHEL1 291 : SEGDES MMODEL 292 : 666 CONTINUE 293 : RETURN 294 : END 295 : 296 : 297 : 298 : 299 :
© Cast3M 2003 - All rights reserved.
Disclaimer