1 : C WORKP SOURCE CHAT 11/03/16 21:33:37 6902 2 : SUBROUTINE WORKP(IPMODL,IPCHE1,IPCHE2,IPCHE3,IPCHE4,IRET) 3 : ************************************************************************ 4 : * ENTREES : 5 : * IPMODL = POINTEUR SUR UN OBJET MMODEL 6 : * IPCHE1 = POINTEUR SUR UN MCHAML DE CONTRAINTES 7 : * IPCHE2 = POINTEUR SUR UN MCHAML DE GRADIENTS 8 : * IPCHE3 = POINTEUR SUR UN MCHAML DE GRADIENT DE FLEXION (CAS DES COQUES 9 : * 10 : * SORTIE : 11 : * IPCHE4 = POINTEUR SUR UN MCHAML DE DENSITE D'ENERGIE 12 : * IRET = CODE DE RETOUR = 0 ECHEC , = 1 SUCCES 13 : * 14 : * CODE DE SUO X.Z 15 : * PASSAGE AUX NOUVEAUX CHAMELEMS PAR P. DOWLATYARI AVRIL 91 16 : ************************************************************************ 17 : IMPLICIT INTEGER(I-N) 18 : IMPLICIT REAL*8(A-H,O-Z) 19 : * 20 : -INC CCOPTIO 21 : -INC CCHAMP 22 : -INC SMCHAML 23 : -INC SMCHPOI 24 : -INC SMELEME 25 : -INC SMCOORD 26 : -INC SMMODEL 27 : -INC SMINTE 28 : -INC SMLREEL 29 : C 30 : DIMENSION STRESS(8),GRADI(9),GRADF(9) 31 : * 32 : SEGMENT NOTYPE 33 : CHARACTER*16 TYPE(NBTYPE) 34 : ENDSEGMENT 35 : * 36 : SEGMENT MPTVAL 37 : INTEGER IPOS(NS) ,NSOF(NS) 38 : INTEGER IVAL(NCOSOU) 39 : CHARACTER*16 TYVAL(NCOSOU) 40 : ENDSEGMENT 41 : * 42 : PARAMETER ( NINF=3 ) 43 : INTEGER INFOS(NINF) 44 : CHARACTER*(NCONCH) CONM 45 : LOGICAL lsupgd,lsupgf,lsupco 46 : C 47 : IRET = 0 48 : IPCHE4 = 0 49 : C 50 : NHRM=NIFOUR 51 : C 52 : MCHEL1=IPCHE1 53 : SEGACT,MCHEL1 54 : MCHEL2=IPCHE2 55 : SEGACT,MCHEL2 56 : C 57 : C TEST DE COMPATIBILITE DES CHAMPS 58 : C 59 : IF((MCHEL1.TITCHE).EQ.'CONTRAINTES'.AND.(MCHEL2.TITCHE) 60 : 1 .EQ.'GRADIENT')THEN 61 : IPCONT=IPCHE1 62 : IPGRAD=IPCHE2 63 : IPGRAF=IPCHE3 64 : ELSEIF((MCHEL2.TITCHE).EQ.'CONTRAINTES'.AND.(MCHEL1.TITCHE) 65 : 1 .EQ.'GRADIENT')THEN 66 : IPCONT=IPCHE2 67 : IPGRAD=IPCHE1 68 : IPGRAF=IPCHE3 69 : ELSE 70 : MOTERR(1:19)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8) 70 : CALL ERREUR(175) 71 : SEGDES,MCHEL1,MCHEL2 72 : RETURN 73 : ENDIF 74 : SEGDES,MCHEL1,MCHEL2 75 : * 76 : * Verification du lieu support du MCHAML de CONTRAINTES 77 : * 77 : CALL QUESUP(IPMODL,IPCONT,5,0,ISUP1,IRET1) 78 : IF (ISUP1.GT.1) RETURN 79 : * 80 : * Verification du lieu support du MCHAML de GRADIENT 81 : * 82 : segact mchel1,mchel2 82 : CALL QUESUP(IPMODL,IPGRAD,5,0,ISUP2,IRET2) 83 : IF (ISUP2.GT.1) RETURN 84 : * 85 : * Verification du lieu support du MCHAML de GRADIENT DE FLEXION 86 : * 87 : IF(IPGRAF.NE.0)THEN 87 : CALL QUESUP(IPMODL,IPGRAF,5,0,ISUP3,IRET3) 88 : IF (ISUP3.GT.1) RETURN 89 : ENDIF 90 : C 91 : C ACTIVATION DU MODEL 92 : C 93 : MMODEL=IPMODL 94 : SEGACT,MMODEL 95 : NSOUS=KMODEL(/1) 96 : C 97 : C CREATION DU MCHELM 98 : C 99 : N1=NSOUS 100 : L1=8 101 : N3=6 102 : SEGINI MCHELM 103 : TITCHE='SCALAIRE' 104 : IFOCHE=IFOUR 105 : C 106 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTS SOUS-ZONES 107 : C 108 : isouss=0 109 : DO 500 ISOUS=1,NSOUS 110 : * 111 : * INITIALISATION 112 : * 113 : IVASTR=0 114 : NSTR=0 115 : IVAGRA=0 116 : NGRAD=0 117 : IVAGRF=0 118 : NGRAF=0 119 : IPMINT=0 120 : C 121 : C ON RECUPERE LES INFOS GENERALES 122 : C 123 : IMODEL=KMODEL(ISOUS) 124 : SEGACT,IMODEL 125 : MELE=NEFMOD 126 : if( mele.eq.22) then 127 : segdes imodel 128 : go to 500 129 : endif 130 : isouss=isouss+1 131 : C 132 : C TRAITEMENT DU MODELE 133 : C 134 : IPMAIL=IMAMOD 135 : MELEME=IPMAIL 136 : CONM = CONMOD 137 : C 138 : C COQUE INTEGREE OU PAS ? 139 : C 140 : IF(INFMOD(/1).NE.0)THEN 141 : NPINT=INFMOD(1) 142 : ELSE 143 : NPINT=0 144 : ENDIF 145 : C attention aux XFEM qui ne sont pas des coques! 146 : IF(MFR.eq.63) NPINT=0 147 : IF (NPINT.NE.0)THEN 147 : CALL ERREUR(615) 148 : GOTO 9991 149 : ENDIF 150 : C 151 : IMACHE(ISOUSs)=IPMAIL 152 : CONCHE(ISOUSs)=CONMOD 153 : C____________________________________________________________________ 154 : C 155 : C INFORMATION SUR L'ELEMENT FINI 156 : C____________________________________________________________________ 157 : C 157 : * CALL ELQUOI(MELE,0,5,IPINF,IMODEL) 158 : * IF (IERR.NE.0) GOTO 9991 159 : * INFO=IPINF 160 : MFR =INFELE(13) 161 : NBGS =INFELE(4) 162 : * MINTE=INFELE(11) 163 : MINTE=INFMOD(7) 164 : IPMINT=MINTE 165 : MINTE1=INFMOD(8) 166 : * SEGSUP INFO 167 : * 168 : IF (IPMINT.NE.0) SEGACT,MINTE 169 : C 170 : C CREATION DU TABLEAU INFOS 171 : C 171 : CALL IDENT(IPMAIL,CONM,IPCONT,IPGRAD,INFOS,IRTD) 172 : IF (IERR.NE.0) GOTO 9991 173 : C 174 : INFCHE(ISOUSs,1)=0 175 : INFCHE(ISOUSs,2)=0 176 : INFCHE(ISOUSs,3)=NHRM 177 : INFCHE(ISOUSs,4)=MINTE 178 : INFCHE(ISOUSs,5)=0 179 : INFCHE(ISOUSs,6)=5 180 : C 181 : C ACTIVATION DU MELEME 182 : C 183 : SEGACT MELEME 184 : NBNN =NUM(/1) 185 : NBELEM=NUM(/2) 186 : IPPORE=0 187 : IF(MFR.EQ.33) IPPORE=NBNN 188 : C____________________________________________________________________ 189 : C 190 : C RECHERCHE DES NOMS DE COMPOSANTES 191 : C____________________________________________________________________ 192 : C 193 : if(lnomid(4).ne.0) then 194 : nomid=lnomid(4) 195 : segact nomid 196 : mostrs=nomid 197 : nstr=lesobl(/2) 198 : nfac=lesfac(/2) 199 : lsupco=.false. 200 : else 201 : lsupco=.true. 201 : CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC) 202 : endif 203 : C 204 : if(lnomid(3).ne.0) then 205 : nomid=lnomid(3) 206 : segact nomid 207 : mograd=nomid 208 : ngrad=lesobl(/2) 209 : nfac=lesfac(/2) 210 : lsupgd=.false. 211 : else 212 : lsupgd=.true. 212 : CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRAD,NFAC) 213 : endif 214 : C 215 : IF(IPGRAF.NE.0) THEN 216 : if(lnomid(11).ne.0) then 217 : nomid=lnomid(11) 218 : segact nomid 219 : mograf=nomid 220 : ngraf=lesobl(/2) 221 : nfac=lesfac(/2) 222 : lsupgf=.false. 223 : else 224 : lsupgf=.true. 224 : CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC) 225 : endif 226 : ENDIF 227 : C____________________________________________________________________ 228 : C 229 : C VERIFICATION DE LEUR PRESENCE 230 : C____________________________________________________________________ 231 : C 232 : NBTYPE=1 233 : SEGINI NOTYPE 234 : MOTYPE=NOTYPE 235 : TYPE(1)='REAL*8' 236 : C 236 : CALL KOMCHA(IPCONT,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR) 237 : IF (IERR.NE.0)THEN 238 : SEGSUP NOTYPE 239 : GOTO 9990 240 : ENDIF 240 : IF (ISUP1.EQ.1) CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE) 241 : C 241 : CALL KOMCHA(IPGRAD,IPMAIL,CONM,MOGRAD,MOTYPE,1,INFOS,3,IVAGRA) 242 : SEGSUP NOTYPE 243 : IF (IERR.NE.0) GOTO 9990 243 : IF (ISUP2.EQ.1) CALL VALCHE(IVAGRA,NGRAD,IPMINT,IPPORE) 244 : C 245 : IF(MFR.EQ.3.OR.MFR.EQ.9)THEN 246 : IF(IPGRAF.NE.0)THEN 247 : NBTYPE=1 248 : SEGINI NOTYPE 249 : MOTYPE=NOTYPE 250 : TYPE(1)='REAL*8' 250 : CALL KOMCHA(IPGRAF,IPMAIL,CONM,MOGRAF,MOTYPE,1,INFOS,3,IVAGRF) 251 : SEGSUP NOTYPE 252 : IF (IERR.NE.0) GOTO 9990 252 : IF (ISUP3.EQ.1) CALL VALCHE(IVAGRF,NGRAF,IPMINT,IPPORE) 253 : C 254 : ELSE 255 : MOTERR(1:8)='CHAMELEM' 255 : CALL ERREUR(37) 256 : GO TO 9990 257 : ENDIF 258 : ENDIF 259 : C 260 : C RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER 261 : C 262 : N1PTEL=NBGS 263 : N1EL=NBELEM 264 : NBPTEL=N1PTEL 265 : NEL=N1EL 266 : C 267 : C CREATION DU MCHAML DE LA SOUS ZONE 268 : C 269 : N2=1 270 : SEGINI MCHAML 271 : ICHAML(ISOUSs)=MCHAML 272 : NOMCHE(1)='SCAL' 273 : TYPCHE(1)='REAL*8' 274 : N2PTEL=0 275 : N2EL=0 276 : SEGINI MELVAL 277 : IELVAL(1)=MELVAL 278 : C 279 : C ELEMENTS MASSIFS ET ELEMENTS COQUES EPAISSES 280 : C 281 : IF(MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.5.OR.MFR.EQ.63)THEN 282 : C 283 : C BOUCLE SUR LES ELEMENTS 284 : C 285 : DO 600 IB=1,NBELEM 286 : C 287 : C BOUCLE SUR LES POINTS DE GAUSS 288 : C 289 : DO 700 IGAU=1,NBPTEL 290 : C 291 : C ON RECUPERE LES CONTRAINTES 292 : C 292 : CALL ZERO(STRESS,8,1) 293 : MPTVAL=IVASTR 294 : DO 710 ICOMP=1,NSTR 295 : MELVAL=IVAL(ICOMP) 296 : IBMN=MIN(IB,VELCHE(/2)) 297 : IGMN=MIN(IGAU,VELCHE(/1)) 298 : STRESS(ICOMP)=VELCHE(IGMN,IBMN) 299 : 710 CONTINUE 300 : C 301 : C ON RECUPERE LES GRADIENTS 302 : C 302 : CALL ZERO(GRADI,9,1) 303 : MPTVAL=IVAGRA 304 : DO 720 ICOMP=1,NGRAD 305 : MELVAL=IVAL(ICOMP) 306 : IBMN=MIN(IB,VELCHE(/2)) 307 : IGMN=MIN(IGAU,VELCHE(/1)) 308 : GRADI(ICOMP)=VELCHE(IGMN,IBMN) 309 : 720 CONTINUE 310 : C 311 : C CALCUL DE LA DENSITE DE TRAVAIL 312 : C 313 : IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63) THEN 314 : C* <=> IF (MFR.NE.5) THEN 315 : WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+ 316 : 1 STRESS(3)*GRADI(9)+STRESS(4)*(GRADI(2)+GRADI(4))+ 317 : 2 STRESS(5)*(GRADI(3)+GRADI(7))+ 318 : 3 STRESS(6)*(GRADI(6)+GRADI(8)) 319 : ELSE 320 : WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+ 321 : 1 STRESS(3)*(GRADI(2)+GRADI(4))+ 322 : 2 STRESS(4)*(GRADI(3)+GRADI(7))+ 323 : 3 STRESS(5)*(GRADI(6)+GRADI(8)) 324 : ENDIF 325 : C 326 : C STOCKAGE 327 : C 328 : MELVAL=IELVAL(1) 329 : IBMN=MIN(IB,VELCHE(/2)) 330 : VELCHE(IGAU,IBMN)=WO 331 : C 332 : 700 CONTINUE 333 : C 334 : 600 CONTINUE 335 : C 336 : C ELEMENTS COQUES MINCES 337 : C 338 : ELSEIF(MFR.EQ.3.OR.MFR.EQ.9)THEN 339 : IF(IFOUR.EQ.2)THEN 340 : C 341 : C BOUCLE SUR LES ELEMENTS 342 : C 343 : DO 800 IB=1,NBELEM 344 : C 345 : C BOUCLE SUR LES POINTS DE GAUSS 346 : C 347 : DO 900 IGAU=1,NBPTEL 348 : C 349 : C ON RECUPERE LES CONTRAINTES 350 : C 350 : CALL ZERO(STRESS,8,1) 351 : MPTVAL=IVASTR 352 : DO 910 ICOMP=1,NSTR 353 : MELVAL=IVAL(ICOMP) 354 : IBMN=MIN(IB,VELCHE(/2)) 355 : IGMN=MIN(IGAU,VELCHE(/1)) 356 : STRESS(ICOMP)=VELCHE(IGMN,IBMN) 357 : 910 CONTINUE 358 : C 359 : C ON RECUPERE LES GRADIENTS 360 : C 360 : CALL ZERO(GRADI,9,1) 361 : MPTVAL=IVAGRA 362 : DO 920 ICOMP=1,NGRAD 363 : MELVAL=IVAL(ICOMP) 364 : IBMN=MIN(IB,VELCHE(/2)) 365 : IGMN=MIN(IGAU,VELCHE(/1)) 366 : GRADI(ICOMP)=VELCHE(IGMN,IBMN) 367 : 920 CONTINUE 368 : C 369 : C ON RECUPERE LES GRADIENTS DE FLEXION 370 : C 370 : CALL ZERO(GRADF,9,1) 371 : MPTVAL=IVAGRF 372 : DO 930 ICOMP=1,NGRAF 373 : MELVAL=IVAL(ICOMP) 374 : IBMN=MIN(IB,VELCHE(/2)) 375 : IGMN=MIN(IGAU,VELCHE(/1)) 376 : GRADF(ICOMP)=VELCHE(IGMN,IBMN) 377 : 930 CONTINUE 378 : C 379 : C CALCUL DE LA DENSITE DE TRAVAIL 380 : C 381 : IF(MFR.EQ.3)THEN 382 : WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+ 383 : 1 STRESS(3)*(GRADI(2)+GRADI(4))+STRESS(4)*GRADF(1)+ 384 : 2 STRESS(5)*GRADF(5)+STRESS(6)*(GRADF(2)+GRADF(4)) 385 : ELSE 386 : WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+ 387 : 1 STRESS(3)*(GRADI(2)+GRADI(4))+STRESS(4)*GRADF(1)+ 388 : 2 STRESS(5)*GRADF(5)+STRESS(6)*(GRADF(2)+GRADF(4))+ 389 : 3 STRESS(7)*(GRADI(3)+GRADI(7))+ 390 : 4 STRESS(8)*(GRADI(6)+GRADI(8)) 391 : ENDIF 392 : C 393 : C STOCKAGE 394 : C 395 : MELVAL=IELVAL(1) 396 : IBMN=MIN(IB,VELCHE(/2)) 397 : VELCHE(IGAU,IBMN)=WO 398 : C 399 : 900 CONTINUE 400 : C 401 : 800 CONTINUE 402 : C 403 : ELSE 404 : C 405 : C OPTION NON DISPONIBLE 406 : C 406 : CALL ERREUR(251) 407 : GO TO 9990 408 : ENDIF 409 : C 410 : ELSE 411 : C 412 : C OPTION NON DISPONIBLE 413 : C 413 : CALL ERREUR(251) 414 : GO TO 9990 415 : ENDIF 416 : C 417 : C DESACTIVATION DES SEGMENTS 418 : C 419 : IF(ISUP1.EQ.1)THEN 419 : CALL DTMVAL(IVASTR,3) 420 : ELSE 420 : CALL DTMVAL(IVASTR,1) 421 : ENDIF 422 : * 423 : IF(ISUP2.EQ.1)THEN 423 : CALL DTMVAL(IVAGRA,3) 424 : ELSE 424 : CALL DTMVAL(IVAGRA,1) 425 : ENDIF 426 : * 427 : IF(IPGRAF.NE.0)THEN 428 : IF(ISUP3.EQ.1)THEN 428 : CALL DTMVAL(IVAGRF,3) 429 : ELSE 429 : CALL DTMVAL(IVAGRF,1) 430 : ENDIF 431 : ENDIF 432 : * 433 : MELVAL=IELVAL(1) 434 : SEGDES,MELVAL 435 : * 436 : NOMID=MOSTRS 437 : if(lsupco)SEGSUP NOMID 438 : NOMID=MOGRAD 439 : if(lsupgd)SEGSUP NOMID 440 : IF(IPGRAF.NE.0)THEN 441 : NOMID=MOGRAF 442 : if(lsupgf)SEGSUP NOMID 443 : ENDIF 444 : * 445 : IF (IPMINT.NE.0) SEGDES,MINTE 446 : SEGDES,IMODEL,MELEME 447 : SEGDES,MCHAML 448 : * 449 : 500 CONTINUE 450 : if( n1.ne.isouss) then 451 : n1=isouss 452 : segadj mchelm 453 : endif 454 : SEGDES,MMODEL,MCHELM 455 : IRET = 1 456 : IPCHE4 = MCHELM 457 : * 458 : RETURN 459 : * 460 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR 461 : * 462 : 9990 CONTINUE 463 : * 464 : IF(ISUP1.EQ.1)THEN 464 : CALL DTMVAL(IVASTR,3) 465 : ELSE 465 : CALL DTMVAL(IVASTR,1) 466 : ENDIF 467 : * 468 : IF(ISUP2.EQ.1)THEN 468 : CALL DTMVAL(IVAGRA,3) 469 : ELSE 469 : CALL DTMVAL(IVAGRA,1) 470 : ENDIF 471 : * 472 : IF(IPGRAF.NE.0)THEN 473 : IF(ISUP3.EQ.1)THEN 473 : CALL DTMVAL(IVAGRF,3) 474 : ELSE 474 : CALL DTMVAL(IVAGRF,1) 475 : ENDIF 476 : ENDIF 477 : IF(IELVAL(1).NE.0)THEN 478 : MELVAL=IELVAL(1) 479 : SEGSUP,MELVAL 480 : ENDIF 481 : * 482 : IF(NSTR.NE.0)THEN 483 : NOMID=MOSTRS 484 : if(lsupco)SEGSUP NOMID 485 : ENDIF 486 : * 487 : IF(NGRAD.NE.0)THEN 488 : NOMID=MOGRAD 489 : if(lsupgd)SEGSUP NOMID 490 : ENDIF 491 : * 492 : IF(NGRAF.NE.0)THEN 493 : NOMID=MOGRAF 494 : if(lsupgf)SEGSUP NOMID 495 : ENDIF 496 : * 497 : IF(ICHAML(ISOUSs).NE.0)SEGSUP,MCHAML 498 : ISOU=ISOUS-1 499 : IF(ISOU.GE.1)THEN 500 : DO 9996 IO=1,ISOU 501 : MCHAML=ICHAML(ISOU) 502 : SEGACT,MCHAML 503 : MELVAL=IELVAL(1) 504 : SEGSUP,MELVAL 505 : SEGSUP,MCHAML 506 : 9996 CONTINUE 507 : ENDIF 508 : * 509 : 9991 CONTINUE 510 : SEGDES MELEME 511 : IF (IPMINT.NE.0) SEGDES,MINTE 512 : SEGDES IMODEL 513 : SEGDES MMODEL 514 : SEGSUP,MCHELM 515 : * 516 : IRET = 0 517 : IPCHE4 = 0 518 : * 519 : RETURN 520 : END 521 : 522 : 523 :
© Cast3M 2003 - All rights reserved.
Disclaimer