1 : C VARICA SOURCE PV 13/04/12 21:16:00 7756 2 : SUBROUTINE VARICA(IPOI1,IPOI2,IPMODL,IRET,MICHE,JEMIL) 3 : *____________________________________________________________________ 4 : * 5 : * Calcul d'un champ variable appele par VARI 6 : * 7 : * ENTREES : 8 : * --------- 9 : * 10 : * IPOI1 Pointeur sur un MCHAML ou un CHPOINT 11 : * IPOI2 Pointeur sur un EVOLUTIO 12 : * IPMODL Pointeur sur un MMODEL 13 : * MICHE = 1 si on a lu un CHPOINT 14 : * JEMIL = 1 A 5 selon le support choisit 15 : * 16 : * 17 : * SORTIE : 18 : * -------- 19 : * 20 : * IRET Pointeur sur le MCHAML resultat 21 : * =0 si operation impossible 22 : * 23 : * Passage aux nouveaux CHAMELEMs par JM CAMPENON LE 05/91 24 : * 25 : *____________________________________________________________________ 26 : * 27 : IMPLICIT INTEGER(I-N) 28 : IMPLICIT REAL*8(A-H,O-Z) 29 : * 30 : -INC SMCHAML 31 : -INC SMCHPOI 32 : -INC SMMODEL 33 : -INC CCOPTIO 34 : -INC SMEVOLL 35 : -INC SMLREEL 36 : -INC SMELEME 37 : -INC SMINTE 38 : -INC SMCOORD 39 : * 40 : SEGMENT MTRAX 41 : REAL*8 XX(0) 42 : ENDSEGMENT 43 : * 44 : SEGMENT MTRAY 45 : REAL*8 YY(0) 46 : ENDSEGMENT 47 : * 48 : SEGMENT SWORK 49 : REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN) 50 : REAL*8 SHP(6,NBNN) ,XE(3,NBNN) 51 : ENDSEGMENT 52 : * 53 : SEGMENT INFO 54 : INTEGER INFELL(JG) 55 : ENDSEGMENT 56 : * 57 : CHARACTER*4 MOTREF,MOTABS 58 : * 59 : IPOIC=IPOI1 60 : * 61 : * On recupere l'objet evolution 62 : * 63 : MEVOLL=IPOI2 64 : SEGACT MEVOLL 65 : KEVOLL=IEVOLL(1) 66 : SEGACT KEVOLL 67 : MLREEL=IPROGX 68 : MLREE1=IPROGY 69 : MOTABS=NOMEVX(1:4) 70 : SEGDES KEVOLL 71 : * 72 : SEGACT MLREEL,MLREE1 73 : NBPOIX=PROG(/1) 74 : NBPOIY=MLREE1.PROG(/1) 75 : * 76 : IF(NBPOIX.NE.NBPOIY) THEN 76 : CALL ERREUR(263) 77 : SEGDES MLREEL,MLREE1 78 : SEGDES MEVOLL 79 : RETURN 80 : ENDIF 81 : * 82 : SEGINI MTRAX 83 : SEGINI MTRAY 84 : DO 695 I=1,NBPOIX 85 : XX(**)=PROG(I) 86 : 695 CONTINUE 87 : * 88 : DO 696 I=1,NBPOIY 89 : YY(**)=MLREE1.PROG(I) 90 : 696 CONTINUE 91 : * 92 : SEGDES MLREEL,MLREE1 93 : SEGDES MEVOLL 94 : * 95 : * Traitement du CHPOINT - Recherche du nombre de composantes 96 : * 97 : IF(MICHE.EQ.0) GO TO 231 98 : * 99 : IVID=1 100 : IPOI11=IPOI1 101 : MCHPO1=IPOI1 102 : SEGACT MCHPO1 103 : NSOUP1=MCHPO1.IPCHP(/1) 104 : * 105 : DO 329 IA=1,NSOUP1 106 : MSOUP1=MCHPO1.IPCHP(IA) 107 : SEGACT MSOUP1 108 : NC1=MSOUP1.NOCOMP(/2) 109 : IF(NC1.EQ.1) GO TO 321 110 : * 111 : 325 CONTINUE 112 : SEGDES MSOUP1 113 : MOTREF=MOTABS 114 : GO TO 320 115 : * 116 : 321 CONTINUE 117 : IF(IA.EQ.1) THEN 118 : MOTREF=MSOUP1.NOCOMP(1) 119 : GO TO 330 120 : ENDIF 121 : * 122 : IF(MOTREF.NE.MSOUP1.NOCOMP(1)) GOTO 325 123 : * 124 : 330 CONTINUE 125 : SEGDES MSOUP1 126 : * 127 : 329 CONTINUE 128 : * 129 : 320 CONTINUE 130 : SEGDES MCHPO1 131 : IF(MOTREF.EQ.MOTABS) THEN 132 : IVID=0 132 : CALL EXCOPP(IPOI1,MOTABS,IPOI11,'SCAL',IVID) 133 : IF(IERR.NE.0) THEN 134 : SEGSUP MTRAX,MTRAY 135 : IRET=0 136 : RETURN 137 : ENDIF 138 : ENDIF 139 : * 140 : * On convertit le CHPOINT en MCHAML 141 : * 142 : IF(MICHE.EQ.1) THEN 142 : CALL CHAME1 (0,IPMODL,IPOI11,' ',IPOIC,JEMIL) 143 : IF (IVID.EQ.0) THEN 143 : CALL DTCHPO(IPOI11) 144 : ENDIF 145 : IF (IERR.NE.0) THEN 146 : SEGSUP MTRAX,MTRAY 147 : IRET=0 148 : RETURN 149 : ENDIF 150 : ENDIF 151 : * 152 : 231 CONTINUE 153 : * 154 : MMODEL=IPMODL 155 : SEGACT MMODEL 156 : NSOUS=KMODEL(/1) 157 : * 158 : MCHEL1=IPOIC 159 : SEGACT MCHEL1 160 : NINF=MCHEL1.INFCHE(/2) 161 : * 162 : * Creation du MCHAML 163 : * 164 : N1=NSOUS 165 : N3=6 166 : L1=8 167 : SEGINI MCHELM 168 : IRET=MCHELM 169 : IFOCHE=IFOUR 170 : TITCHE='SCALAIRE' 171 : * 172 : * Boucle sur les sous zone du MCHAML 173 : * 174 : DO 100 ISOUS=1,NSOUS 175 : * 176 : IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) 177 : CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) 178 : DO 191 IP=1,NINF 179 : INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP) 180 : 191 CONTINUE 181 : * 182 : * Mise en concordance des pointeurs de maillage 183 : * 184 : MELEME=IMACHE(ISOUS) 185 : DO 150 IO=1,NSOUS 186 : IMODEL=KMODEL(IO) 187 : SEGACT IMODEL 188 : IF (IMAMOD.EQ.MELEME.AND.CONMOD.EQ.CONCHE(ISOUS)) GOTO 160 189 : SEGDES IMODEL 190 : 150 CONTINUE 190 : CALL ERREUR (472) 191 : GOTO 9910 192 : * 193 : 160 MELE=NEFMOD 194 : IPTR3=0 195 : IF (NINF.LT.4.OR.MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN 196 : * 197 : * La sous zone est aux noeuds 198 : * 199 : if(infmod(/1).lt.3) then 199 : CALL ELQUOI(MELE,0,1,IPTR3,IMODEL) 200 : IF (IERR.NE.0) GOTO 9910 201 : INFO=IPTR3 202 : MINTE1=INFELL(11) 203 : segsup info 204 : else 205 : MINTE1=INFMOD(3) 206 : endif 207 : ELSE 208 : MINTE1=MCHEL1.INFCHE(ISOUS,4) 209 : ENDIF 210 : SEGACT MINTE1 211 : * 212 : * Information sur l'element fini 213 : * 214 : * 215 : if(infmod(/1).lt.2+jemil)then 215 : CALL ELQUOI(MELE,0,JEMIL,IPTR2,IMODEL) 216 : IF (IERR.NE.0) GOTO 9920 217 : INFO=IPTR2 218 : MINTE=INFELL(11) 219 : MELGEO=INFELL(14) 220 : segsup info 221 : else 222 : MINTE=INFMOD(2+JEMIL) 223 : MELGEO=INFELE(14) 224 : endif 225 : SEGACT MINTE 226 : 227 : INFCHE(ISOUS,4)=MINTE 228 : INFCHE(ISOUS,6)=JEMIL 229 : * 230 : * On recupere le nombre de points support NBPGA1 pour l'ancien ch 231 : * NBPGAU pour le nouveau 232 : * 233 : NBPGA1 = MINTE1.SHPTOT(/3) 234 : NBPGAU = SHPTOT(/3) 235 : * 236 : * On recupere le nombre d'element 237 : * 238 : SEGACT MELEME 239 : NBNN =NUM(/1) 240 : NBELEM=NUM(/2) 241 : * 242 : NEL =NBELEM 243 : SEGINI SWORK 244 : * 245 : * Recherche de la composante 246 : * 247 : MCHAM1=MCHEL1.ICHAML(ISOUS) 248 : SEGACT MCHAM1 249 : IF (MCHAM1.IELVAL(/1).EQ.1) THEN 250 : * 251 : * pour les champ a une composante pas de verif. de MOTABS 252 : * 253 : IPLAC=1 254 : GOTO 104 255 : ENDIF 256 : * 257 : * Recherche du nom MOTABS 258 : * 258 : CALL PLACE (MCHAM1.NOMCHE,MCHAM1.NOMCHE(/2),IPLAC,MOTABS) 259 : * 260 : 104 CONTINUE 261 : IF (IPLAC.EQ.0) THEN 262 : * 263 : * On a pas trouve la composante 264 : * 265 : MOTERR(1:8)=MOTABS 265 : CALL ERREUR(243) 266 : GOTO 9930 267 : ELSE 268 : IF (MCHAM1.TYPCHE(IPLAC).NE.'REAL*8') THEN 269 : MOTERR(1:4)='VARI' 270 : MOTERR(5:8)=MCHAM1.NOMCHE(IPLAC) 270 : CALL ERREUR (335) 271 : GOTO 9930 272 : ENDIF 273 : ENDIF 274 : * 275 : * Creation du MCHAML de la sous zone 276 : * 277 : N2=1 278 : SEGINI MCHAML 279 : ICHAML(ISOUS)=MCHAML 280 : TYPCHE(1)='REAL*8' 281 : NOMCHE(1)='SCAL' 282 : MELVA1=MCHAM1.IELVAL(IPLAC) 283 : SEGACT MELVA1 284 : * 285 : * Recherche de la taille du nouveau chamelem 286 : * 287 : N1PTE1=MELVA1.VELCHE(/1) 288 : IF (N1PTE1.EQ.1) THEN 289 : N1PTEL=1 290 : ELSE 291 : N1PTEL=NBPGAU 292 : ENDIF 293 : N1EL =MELVA1.VELCHE(/2) 294 : * 295 : * Petit test de compatibilite des nombres d'elements 296 : * 297 : IF(N1EL.NE.NEL.AND.N1EL.NE.1.AND.NEL.NE.1) THEN 298 : MOTERR(1:8)='VARI' 298 : CALL ERREUR(146) 299 : GOTO 9940 300 : ENDIF 301 : * 302 : N1PAUX=N1PTE1 303 : * 304 : * Pour les COQ4, le nb de pt de GAUSS vaut 5, mais on 305 : * ne prend que les 4 premiers (le 5ieme sert uniquement 306 : * au cisaillement) 307 : * 308 : IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4 309 : * 310 : N2PTEL=0 311 : N2EL=0 312 : SEGINI MELVAL 313 : IELVAL(1)=MELVAL 314 : * 315 : * Traitement immediat si champ constant 316 : * 317 : IF(N1PTE1.EQ.1) THEN 318 : DO 4120 IEL=1,N1EL 319 : XTT1 =MELVA1.VELCHE(1,IEL) 319 : CALL VARIFO(XX,YY,NBPOIX,XTT1,YTT1,KERRE) 320 : IF(KERRE.NE.0) THEN 320 : CALL ERREUR(KERRE) 321 : GOTO 9950 322 : ENDIF 323 : VELCHE(1,IEL)= YTT1 324 : 4120 CONTINUE 325 : * 326 : ELSE 327 : * 328 : DO 3120 IEL=1,NEL 329 : DO 3121 IGAU=1,N1PTE1 330 : XTT1=MELVA1.VELCHE(IGAU,IEL) 330 : CALL VARIFO(XX,YY,NBPOIX,XTT1,YTT1,KERRE) 331 : IF(KERRE.NE.0) THEN 331 : CALL ERREUR(KERRE) 332 : GOTO 9950 333 : ENDIF 334 : VAL1(IGAU)=YTT1 335 : 3121 CONTINUE 336 : * 337 : * Meme support 338 : * 339 : IF(MINTE.EQ.MINTE1) THEN 340 : DO 3124 IGAU=1,N1PTE1 341 : VELCHE(IGAU,IEL)=VAL1(IGAU) 342 : 3124 CONTINUE 343 : GO TO 3120 344 : * 345 : * Support different 346 : * 347 : ELSE 347 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) 347 : CALL QUEDIM(MELGEO,KERRE) 347 : CALL CH1CH2 (MELE,MINTE,MINTE1,N1PTEL,N1PAUX,NBNN,SWORK, 348 : > KERRE) 349 : IF(KERRE.NE.0) THEN 349 : CALL ERREUR(KERRE) 350 : GOTO 9950 351 : ENDIF 352 : * 353 : DO 3122 IGAU=1,N1PTEL 354 : VELCHE(IGAU,IEL)=VAL2(IGAU) 355 : 3122 CONTINUE 356 : ENDIF 357 : 3120 CONTINUE 358 : * 359 : ENDIF 360 : SEGDES MELVAL,MELVA1 361 : SEGSUP SWORK 362 : SEGDES MCHAML,MCHAM1,IMODEL,MELEME 363 : * 364 : * INFO=IPTR2 365 : * SEGSUP INFO 366 : * 367 : * INFO=IPTR3 368 : * IF (INFO.NE.0) SEGSUP INFO 369 : * 370 : IF (MINTE.NE.0) SEGDES MINTE 371 : IF (MINTE1.NE.0) SEGDES MINTE1 372 : 100 CONTINUE 373 : * 374 : SEGDES MCHELM 375 : SEGDES MCHEL1 376 : SEGDES MMODEL 376 : IF(MICHE.EQ.1) CALL DTCHAM(IPOIC) 377 : SEGSUP MTRAX,MTRAY 378 : SEGDES MELEME 379 : RETURN 380 : * 381 : * Erreur dans une sous zone / desactivation et retour 382 : * 383 : 9950 CONTINUE 384 : SEGSUP MELVAL 385 : * 386 : 9940 CONTINUE 387 : SEGDES MELVA1 388 : SEGSUP MCHAML 389 : * 390 : 9930 CONTINUE 391 : SEGDES MCHAM1 392 : * INFO=IPTR2 393 : * SEGSUP INFO 394 : SEGDES MELEME 395 : SEGSUP SWORK 396 : * 397 : 9920 CONTINUE 398 : * INFO=IPTR3 399 : * IF (INFO.NE.0) SEGSUP INFO 400 : * 401 : 9910 CONTINUE 402 : IRET=0 403 : SEGDES IMODEL 404 : SEGDES MMODEL 405 : SEGDES MCHEL1 406 : SEGSUP MCHELM 407 : SEGSUP MTRAX,MTRAY 407 : IF(MICHE.EQ.1) CALL DTCHAM(IPOIC) 408 : * 409 : RETURN 410 : END 411 : 412 : 413 : 414 : 415 : 416 : 417 : 418 : 419 : 420 : 421 :
© Cast3M 2003 - All rights reserved.
Disclaimer