1 : C KTAPER SOURCE CHAT 11/03/16 21:26:54 6902 2 : 3 : SUBROUTINE KTAPER(IPMOD0,IPCHE1,IPCHE2,C1,C2,IKTSYM, IPRIGI) 4 : 5 : ************************************************************************ 6 : * Entrees : 7 : * --------- 8 : * IPMODL pointeur sur un MMODEL 9 : * IPCHE1 pointeur sur le MCHAML decrivant l etat a t 10 : * IPCHE2 pointeur sur le MCHAML decrivant l etat a t+dt 11 : * C1 flottant 12 : * coefficient de perturbation de l increment de deformation 13 : * C2 flottant 14 : * perturbation minimale 15 : * IKTSYM =1 si matrice symetrique en sortie, =0 sinon 16 : * 17 : * Sortie : 18 : * -------- 19 : * IPRIGI pointeur sur l'objet de type RIGIDITE 20 : * =0 en cas d'erreur 21 : ************************************************************************ 22 : * 23 : IMPLICIT INTEGER(I-N) 24 : IMPLICIT REAL*8(A-H,O-Z) 25 : * 26 : -INC CCOPTIO 27 : -INC CCHAMP 28 : 29 : -INC SMCHAML 30 : -INC SMCOORD 31 : -INC SMELEME 32 : -INC SMINTE 33 : -INC SMLMOTS 34 : -INC SMMODEL 35 : -INC SMRIGID 36 : 37 : SEGMENT INFO 38 : INTEGER INFELL(JG) 39 : ENDSEGMENT 40 : 41 : SEGMENT NOTYPE 42 : CHARACTER*16 TYPE(NBTYPE) 43 : ENDSEGMENT 44 : 45 : SEGMENT MPTVAL 46 : INTEGER IPOS(NS) ,NSOF(NS) 47 : INTEGER IVAL(NCOSOU) 48 : CHARACTER*16 TYVAL(NCOSOU) 49 : ENDSEGMENT 50 : 51 : SEGMENT MWRK1 52 : REAL*8 DDHOOK(LHOOK,LHOOK) 53 : REAL*8 REL(LRE,LRE), XE(3,NBBB) 54 : REAL*8 SHPWRK(6,NBBB), BGENE(LHOOK,LRE) 55 : ENDSEGMENT 56 : 57 : * SEGMENT MWRK2 58 : * REAL*8 DDHOOK(LHOOK,LHOOK,NBPGW2,NBELW2) 59 : * ENDSEGMENT 60 : 61 : * INTTYP definit le type de points d integration utilise 62 : PARAMETER ( INTTYP=3 ) 63 : 64 : CHARACTER*(NCONCH) CONM 65 : CHARACTER*(8) MOCOMP 66 : 67 : PARAMETER (NINF=3) 68 : INTEGER INFOS(NINF) 69 : DIMENSION A(4,60),BB(3,60) 70 : 71 : LOGICAL BSUPDP,BSUPFO,BSUPCO,BSUPDE,BDPGE,BDIM3 72 : LOGICAL BDEL,BDUNI,B3EL,B3UNI 73 : LOGICAL BCEL(12),BCUNI(12) 74 : 75 : *======================================================================= 76 : *= 1 = INITIALISATIONS ET VERIFICATIONS = 77 : *======================================================================= 78 : IPRIGI = 0 79 : KERRE = 0 80 : IPMODU = 0 81 : MODEFU = 0 82 : MODIM3 = 0 83 : MOTYPE = 0 84 : 85 : * Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX") 85 : CALL PIMODL(IPMOD0,IPMODL) 86 : IF (IPMODL.EQ.0) RETURN 87 : * Reduction des champs sur le MODEL IPMOD0 87 : CALL REDUAF(IPCHE1,IPMOD0,IPCH_Z,0,IRET,KERRE) 87 : IF (IRET.NE.1) CALL ERREUR(KERRE) 88 : IF (IERR.NE.0) GOTO 9000 89 : IPCHE1=IPCH_Z 89 : CALL REDUAF(IPCHE2,IPMOD0,IPCH_Z,0,IRET,KERRE) 89 : IF (IRET.NE.1) CALL ERREUR(KERRE) 90 : IF (IERR.NE.0) GOTO 9000 91 : IPCHE2=IPCH_Z 92 : 93 : * Activation du modele 94 : MMODEL = IPMODL 95 : SEGACT,MMODEL 96 : NSOUS = KMODEL(/1) 97 : * Initialisation de la rigidite TANGENTE 98 : NRIGEL = NSOUS 99 : SEGINI,MRIGID 100 : IPRIGI = MRIGID 101 : MTYMAT = 'RIGIDITE' 102 : ICHOLE = 0 103 : IMGEO1 = 0 104 : IMGEO2 = 0 105 : ISUPEQ = 0 106 : IFORIG = IFOUR 107 : 108 : * Modele unitaire contenant successivement chaque sous-modele de IPMODL 109 : N1 = 1 110 : SEGINI,MMODE1 111 : IPMODU = MMODE1 112 : * Quelques segments utiles par la suite 113 : NBROBL = 1 114 : NBRFAC = 0 115 : SEGINI,NOMID 116 : MODEFU = NOMID 117 : NBROBL = 0 118 : NBRFAC = 1 119 : SEGINI,NOMID 120 : LESFAC(1) = 'DIM3' 121 : MODIM3 = NOMID 122 : NBTYPE = 1 123 : SEGINI,NOTYPE 124 : MOTYPE = NOTYPE 125 : TYPE(1) = 'REAL*8' 126 : * Initialisation du point autour duquel se fait le mouvement 127 : * en deformation plane generalisee 128 : IF (IFOUR.EQ.-3) THEN 129 : NDPGE = 3 130 : BDPGE = .TRUE. 131 : ELSE IF (IFOUR.EQ.11) THEN 132 : NDPGE = 2 133 : BDPGE = .TRUE. 134 : ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ. 9.OR. 135 : & IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN 136 : NDPGE = 1 137 : BDPGE = .TRUE. 138 : ELSE 139 : NDPGE = 0 140 : BDPGE = .FALSE. 141 : ENDIF 142 : 143 : *======================================================================= 144 : *= 2 = BOUCLE SUR CHAQUE SOUS-MODELE A PERTURBER (Etiquette 100) = 145 : *======================================================================= 146 : DO 100 ISOUS = 1, NSOUS 147 : * 148 : SEGACT,MMODE1*MOD 149 : IMODEL = KMODEL(ISOUS) 150 : MMODE1.KMODEL(1) = IMODEL 151 : *----------------------------------------------------------------------- 152 : *- 2.1 - Initialisations associees au sous-modele ISOUS - 153 : *----------------------------------------------------------------------- 154 : IPDSCR = 0 155 : IPMADG = 0 156 : IPMATR = 0 157 : IPCONF = 0 158 : IPDIM3 = 0 159 : LISCON = 0 160 : LISDEF = 0 161 : MOCARA = 0 162 : MOCONT = 0 163 : MODEFO = 0 164 : MODEPL = 0 165 : MOFORC = 0 166 : BDIM3 = .FALSE. 167 : *----------------------------------------------------------------------- 168 : *- 2.2 - Reduction des champs sur le sous-modele ISOUS (MMODEL IPMODU) - 169 : *----------------------------------------------------------------------- 170 : * write(ioimp,*) '1er redu sur IPMODU',ISOUS,IMODEL 170 : CALL REDUAF(IPCHE1,IPMODU,IPCHE1U,0,IRET,KERRE) 170 : IF (IRET.NE.1) CALL ERREUR(KERRE) 171 : IF (IERR.NE.0) GOTO 110 172 : * write(ioimp,*) '2e redu sur IPMODU',ISOUS,IMODEL 172 : CALL REDUAF(IPCHE2,IPMODU,IPCHE2U,0,IRET,KERRE) 172 : IF (IRET.NE.1) CALL ERREUR(KERRE) 173 : IF (IERR.NE.0) GOTO 110 174 : *----------------------------------------------------------------------- 175 : *- 2.3 - Recuperation d'informations sur le sous-modele ISOUS - 176 : *----------------------------------------------------------------------- 177 : SEGACT,IMODEL 178 : IPMAIL = IMAMOD 179 : MELE = NEFMOD 180 : CONM = CONMOD 181 : * Quelques informations liees a l'EF du sous-modele (MELE) 182 : IF (INFMOD(/1).LT.2+INTTYP) THEN 182 : CALL ELQUOI(MELE,0,INTTYP,IPINF,IMODEL) 183 : INFO = IPINF 184 : NBPGAU = INFELL(6) 185 : LRE = INFELL(9) 186 : LHOOK = INFELL(10) 187 : MFR = INFELL(13) 188 : IPMINT = INFELL(11) 189 : SEGSUP,INFO 190 : ELSE 191 : NBPGAU = INFELE(6) 192 : LRE = INFELE(9) 193 : LHOOK = INFELE(10) 194 : MFR = INFELE(13) 195 : IPMINT = INFMOD(5) 196 : ENDIF 197 : MINTE = IPMINT 198 : SEGACT,MINTE 199 : * Point support des deformations planes generalisees 200 : IF (BDPGE) THEN 201 : IREF = (IPDPGE-1)*(IDIM+1) 202 : XDPGE = XCOOR(IREF+1) 203 : YDPGE = XCOOR(IREF+2) 204 : ELSE 205 : XDPGE = 0.D0 206 : YDPGE = 0.D0 207 : ENDIF 208 : * Recherche des noms d'inconnues primales 209 : IF (LNOMID(1).NE.0) THEN 210 : BSUPDP = .FALSE. 211 : MODEPL = LNOMID(1) 212 : ELSE 213 : BSUPDP = .TRUE. 213 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,NFAC) 214 : ENDIF 215 : NOMID = MODEPL 216 : SEGACT,NOMID 217 : NDEPL = LESOBL(/2) 218 : * Recherche des noms d'inconnues duales 219 : IF (LNOMID(2).NE.0) THEN 220 : BSUPFO = .FALSE. 221 : MOFORC = LNOMID(2) 222 : ELSE 223 : BSUPFO = .TRUE. 223 : CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NFAC) 224 : ENDIF 225 : NOMID = MOFORC 226 : SEGACT,NOMID 227 : NFORC = LESOBL(/2) 228 : * Recherche des composantes du champ de contraintes 229 : IF (LNOMID(4).NE.0) THEN 230 : BSUPCO = .FALSE. 231 : MOCONT = LNOMID(4) 232 : ELSE 233 : BSUPCO = .TRUE. 233 : CALL IDCONT(IMODEL,IFOUR,MOCONT,NSTRS,NFAC) 234 : ENDIF 235 : NOMID = MOCONT 236 : SEGACT,NOMID 237 : NSTRS = LESOBL(/2) 238 : NFAC = LESFAC(/2) 239 : NBCONT = NSTRS 240 : *AV cas ou NFAC non nul ! 241 : *AV NBCONT = NSTRS + NFAC 242 : * Creation d'une liste de mots des composantes de contraintes 243 : JGN = LESOBL(/1) 244 : JGM = NBCONT 245 : SEGINI,MLMOTS 246 : DO i = 1, NSTRS 247 : MOTS(i) = LESOBL(i) 248 : ENDDO 249 : *AV IF (NFAC.NE.0) THEN 250 : *AV DO i = 1, NFAC 251 : *AV MOTS(NSTRS+i) = LESFAC(i) 252 : *AV ENDDO 253 : *AV ENDIF 254 : LISCON = MLMOTS 255 : * Recherche des composantes obligatoires du champ de deformations 256 : IF (LNOMID(5).NE.0) THEN 257 : BSUPDE = .FALSE. 258 : MODEFO = LNOMID(5) 259 : ELSE 260 : BSUPDE = .TRUE. 260 : CALL IDDEFO(IMODEL,IFOUR,MODEFO,NBDEFO,NFAC) 261 : ENDIF 262 : NOMID = MODEFO 263 : SEGACT,NOMID 264 : NDEFO = LESOBL(/2) 265 : NFAC = LESFAC(/2) 266 : NBDEFO = NDEFO 267 : *AV cas ou NFAC non nul ! 268 : *AV NBDEFO = NDEFO + NFAC 269 : * Creation d'une liste de mots des composantes de contraintes 270 : JGN = LESOBL(/1) 271 : JGM = NBDEFO 272 : SEGINI,MLMOTS 273 : DO i = 1, NDEFO 274 : MOTS(i) = LESOBL(i) 275 : ENDDO 276 : *AV IF (NFAC.NE.0) THEN 277 : *AV DO i = 1, NFAC 278 : *AV MOTS(NDEFO+i) = LESFAC(i) 279 : *AV ENDDO 280 : *AV ENDIF 281 : LISDEF = MLMOTS 282 : * Petite verification 283 : IF ((NDEPL.EQ.0).OR.(NFORC.EQ.0).OR.(NDEPL.NE.NFORC).OR. 284 : & (NBDEFO.EQ.0).OR.(NBCONT.EQ.0).OR.(NBDEFO.NE.NBCONT)) THEN 285 : KERRE = 5 286 : GOTO 120 287 : ENDIF 288 : *----------------------------------------------------------------------- 289 : *- 2.4 - Matrice de RIGIDITE de la sous-zone ISOUS - 290 : *----------------------------------------------------------------------- 291 : * Segment DESCR 292 : MELEME=IPMAIL 293 : SEGACT,MELEME 294 : * Modification du MELEME contenu dans segment DESCRipteur 295 : IF (BDPGE) THEN 296 : IPT1 = IPMAIL 297 : NBNN = IPT1.NUM(/1)+1 298 : NBELEM = IPT1.NUM(/2) 299 : NBREF = 0 300 : NBSOUS = 0 301 : SEGINI,MELEME 302 : DO i = 1, NBELEM 303 : DO j = 1, NBNN-1 304 : NUM(j,i) = IPT1.NUM(j,i) 305 : ENDDO 306 : NUM(NBNN,i) = IPDPGE 307 : ENDDO 308 : ITYPEL = 28 309 : ICOLOR = IPT1.ICOLOR 310 : SEGDES,MELEME 311 : ELSE 312 : NBNN=NUM(/1) 313 : NBELEM=NUM(/2) 314 : ENDIF 315 : IPMADG=MELEME 316 : IF (BDPGE) THEN 317 : NCOMP = NDEPL-NDPGE 318 : NBNNS = NBNN-1 319 : ELSE 320 : NCOMP = NDEPL 321 : NBNNS = NBNN 322 : ENDIF 323 : IF (NBNNS*NCOMP .GT. LRE) THEN 324 : * Erreur dans les dimensions de DESCR 325 : KERRE = 717 326 : GOTO 120 327 : ENDIF 328 : * Remplissage du segment DESCRipteur 329 : NLIGRP = LRE 330 : NLIGRD = LRE 331 : SEGINI,DESCR 332 : IDDL = 1 333 : DO IPT = 1, NBNNS 334 : DO ICOMP = 1, NCOMP 335 : NOMID = MODEPL 336 : LISINC(IDDL) = LESOBL(ICOMP) 337 : NOMID = MOFORC 338 : LISDUA(IDDL) = LESOBL(ICOMP) 339 : NOELEP(IDDL) = IPT 340 : NOELED(IDDL) = IPT 341 : IDDL = IDDL+1 342 : ENDDO 343 : ENDDO 344 : IF (BDPGE) THEN 345 : DO ICOMP = (NDPGE-1),0,-1 346 : NOMID = MODEPL 347 : LISINC(IDDL) = LESOBL(NDEPL-ICOMP) 348 : NOMID = MOFORC 349 : LISDUA(IDDL) = LESOBL(NFORC-ICOMP) 350 : NOELEP(IDDL) = NBNN 351 : NOELED(IDDL) = NBNN 352 : IDDL = IDDL+1 353 : ENDDO 354 : ENDIF 355 : SEGDES,DESCR 356 : IPDSCR = DESCR 357 : * Initialisation du segment XMATRI 358 : NLIGRD = LRE 359 : NLIGRP = LRE 360 : NELRIG = NBELEM 361 : SEGINI,XMATRI 362 : IPMATR = XMATRI 363 : * Remplissage du segment MRIGID 364 : COERIG(ISOUS) = 1.D0 365 : IRIGEL(1,ISOUS) = IPMADG 366 : * IRIGEL(2,ISOUS) = 0 367 : IRIGEL(3,ISOUS) = IPDSCR 368 : IRIGEL(4,ISOUS) = IPMATR 369 : IRIGEL(5,ISOUS) = NIFOUR 370 : * IRIGEL(6,ISOUS) = 0 371 : * Pas de symetrie de la matrice de rigidite (sauf si demande) 372 : IRIGEL(7,ISOUS) = 2*(1-IKTSYM) 373 : * IRIGEL(8,ISOUS) = 0 374 : *----------------------------------------------------------------------- 375 : *- 2.5 - Recuperation des contraintes finales (reference) - 376 : *----------------------------------------------------------------------- 376 : CALL ECROBJ('MCHAML',IPCHE2U) 376 : CALL ECROBJ('LISTMOTS',LISCON) 376 : CALL EXCOMP 377 : IF (IERR.NE.0) GOTO 130 377 : CALL LIROBJ('MCHAML',IPCONF,1,IRET) 378 : IF (IERR.NE.0) GOTO 130 379 : * Verification du support pour les contraintes finales (IPCONF) 379 : CALL QUESUP(IPMODU,IPCONF,INTTYP,0,ISUPCH,IRET) 380 : IF (ISUPCH.GT.1) THEN 381 : KERRE = 609 382 : GOTO 130 383 : ENDIF 384 : *----------------------------------------------------------------------- 385 : *- 2.6 - Recuperation eventuelle de l'epaisseur DIM3 - 386 : *----------------------------------------------------------------------- 387 : MELVA3 = 0 388 : DIM3 = 1. 389 : MOCOMP = 'DIM3' 389 : CALL EXISCO('MCHAML ',IPCHE2U,MOCOMP,BDIM3) 390 : IF (BDIM3) THEN 390 : CALL EXCOC1(IPCHE2U,MOCOMP,IPDIM3,MOCOMP,1) 391 : * Verification du support pour DIM3 (IPDIM3) 391 : CALL QUESUP(IPMODU,IPDIM3,INTTYP,0,ISUPD3,IRET) 392 : IF (ISUPD3.GT.1) THEN 393 : KERRE = 609 394 : GOTO 130 395 : ENDIF 396 : ENDIF 397 : *----------------------------------------------------------------------- 398 : *- 2.7 - Boucle de CALCUL DE LA PERTURBATION sur chaque composante - 399 : *----------------------------------------------------------------------- 400 : DO 200 ICOMP = 1, NBDEFO 401 : * 402 : *- 2.7.1 - Recuperation de la composante de deformation a perturber 403 : MLMOTS = LISDEF 404 : MOCOMP = MOTS(ICOMP) 405 : NOMID = MODEFU 406 : SEGACT,NOMID*MOD 407 : LESOBL(1) = MOCOMP 408 : *- 2.7.2 - Quelques initialisations 409 : IPCHF2U = 0 410 : IPCHP2U = 0 411 : IPCOPE = 0 412 : IPDEFI = 0 413 : IPDEFF = 0 414 : IPPERT = 0 415 : IVACON = 0 416 : IVADEF = 0 417 : IVADM3 = 0 418 : MWRK1 = 0 419 : *- 2.7.3 - Calcul de l'increment de deformation pour la composante ICOMP 419 : CALL EXCOC1(IPCHE1U,MOCOMP,IPDEFI,MOCOMP,0) 420 : IF (IERR.NE.0) GOTO 210 420 : CALL EXCOC1(IPCHE2U,MOCOMP,IPDEFF,MOCOMP,0) 421 : IF (IERR.NE.0) GOTO 210 421 : CALL ADCHEL(IPDEFF,IPDEFI,IPPERT,-1) 422 : * Verification du support pour la perturbation 422 : CALL QUESUP(IPMODU,IPPERT,INTTYP,0,ISUPDE,IRET) 423 : IF (ISUPDE.GT.1) THEN 423 : CALL ERREUR(609) 424 : GOTO 210 425 : ENDIF 426 : *- 2.7.4 - Calcul de la perturbation sur la composante ICOMP (IPPERT) 427 : * IncDef = Def_Fin - Def_Ini 428 : * La perturbation vaut MAX(c1*ABS(IncDef),c2)*SIGNE(IncDEF) 429 : MCHELM = IPPERT 430 : N1 = ICHAML(/1) 431 : DO i1 = 1, N1 432 : MCHAML = ICHAML(i1) 433 : SEGACT,MCHAML 434 : if (ielval(/1).ne.1) then 435 : write(ioimp,*) 'nb composantes different de 1 !' 435 : call erreur(2) 436 : goto 210 437 : endif 438 : if (typche(1).ne.'REAL*8') then 439 : moterr(1:16) = typche(1) 440 : moterr(17:20) = nomche(1)(1:4) 441 : moterr(21:36) = 'DEFORMATION' 441 : call erreur(552) 442 : goto 210 443 : endif 444 : MELVAL = IELVAL(1) 445 : SEGACT,MELVAL*MOD 446 : N1PTEL = VELCHE(/1) 447 : N1EL = VELCHE(/2) 448 : DO IEL = 1, N1EL 449 : DO IPT = 1, N1PTEL 450 : V1 = C1 * VELCHE(IPT,IEL) 451 : IF (V1.GE.0.) THEN 452 : VELCHE(IPT,IEL) = MAX(V1,C2) 453 : ELSE 454 : VELCHE(IPT,IEL) = MIN(V1,-C2) 455 : ENDIF 456 : ENDDO 457 : ENDDO 458 : * SEGDES,MELVAL,MCHAML 459 : ENDDO 460 : * SEGDES,MCHELM 461 : *- 2.7.5 - Deformations finales perturbees pour appel a COMP 461 : CALL ADCHEL(IPCHE2U,IPPERT,IPCHF2U,1) 462 : *- 2.7.6 - Appel a COMP pour obtenir l'etat final perturbe 462 : CALL ECROBJ('MCHAML ',IPCHF2U) 462 : CALL ECROBJ('MCHAML ',IPCHE1U) 462 : CALL ECROBJ('MMODEL ',IPMODU) 462 : CALL COML 463 : IF (IERR.NE.0) GOTO 210 463 : CALL LIROBJ('MCHAML ',IPCHP2U,1,IRET) 464 : IF (IERR.NE.0) GOTO 210 465 : *- 2.7.7 - Recuperation du champ de contraintes finales perturbees 465 : CALL ECROBJ('MCHAML',IPCHP2U) 465 : CALL ECROBJ('LISTMOTS',LISCON) 465 : CALL EXCOMP 466 : IF (IERR.NE.0) GOTO 210 466 : CALL LIROBJ('MCHAML',IPCONP,1,IRET) 467 : IF (IERR.NE.0) GOTO 210 468 : *- 2.7.8 - Calcul de l'increment de contraintes du a la perturbation 468 : CALL ADCHEL(IPCONP,IPCONF,IPCOPE,-1) 468 : CALL QUESUP(IPMODU,IPCOPE,INTTYP,0,ISUPCO,IRET) 469 : IF (ISUPCO.GT.1) THEN 469 : CALL ERREUR(609) 470 : GOTO 210 471 : ENDIF 472 : *- 2.7.9 - Quelques informations necessaires 472 : CALL IDENT(IPMAIL,CONM,IPCOPE,IPPERT,INFOS,IRET) 473 : IF (IRET.EQ.0) GOTO 210 474 : MELEME = IPMAIL 475 : SEGACT,MELEME 476 : NBNN = NUM(/1) 477 : NBELEM = NUM(/2) 478 : *- 2.7.10 - Recuperation de l'epaisseur (fait une seule fois) (IVADM3) 479 : IF (BDIM3 .AND. ICOMP.EQ.1) THEN 479 : CALL KOMCHA(IPDIM3,IPMAIL,CONM,MODIM3,MOTYPE,0,INFOS,NINF, 480 : & IVADM3) 481 : IF (IERR.NE.0) GOTO 220 482 : IF (ISUPD3.EQ.1) THEN 482 : CALL VALCHE(IVADM3,1,IPMINT,0) 483 : IF (IERR.NE.0) THEN 484 : ISUPD3 = 0 485 : GOTO 220 486 : ENDIF 487 : ENDIF 488 : MPTVAL = IVADM3 489 : MELVA3 = IVAL(1) 490 : * Determination du type de champ d'epaisseur 'DIM3' : 491 : * champ constant par element (B3EL) ou uniforme (B3UNI) 492 : IF (MELVA3.NE.0) THEN 493 : B3EL = .FALSE. 494 : B3UNI = .FALSE. 495 : N1PTEL = MELVA3.VELCHE(/1) 496 : N1EL = MELVA3.VELCHE(/2) 497 : IF (N1PTEL.NE.NBPGAU) THEN 498 : IF (N1PTEL.NE.1) THEN 498 : CALL ERREUR(21) 499 : GOTO 220 500 : ENDIF 501 : B3EL = .TRUE. 502 : ENDIF 503 : IF (N1EL.NE.NBELEM) THEN 504 : IF (N1EL.NE.1) THEN 504 : CALL ERREUR(21) 505 : GOTO 220 506 : ENDIF 507 : B3UNI = .TRUE. 508 : ENDIF 509 : ENDIF 510 : ENDIF 511 : *- 2.7.11 - Recuperation de la deformation perturbee (IVADEF) 511 : CALL KOMCHA(IPPERT,IPMAIL,CONM,MODEFU,MOTYPE,1,INFOS,NINF, 512 : & IVADEF) 513 : IF (IERR.NE.0) GOTO 220 514 : IF (ISUPDE.EQ.1) THEN 514 : CALL VALCHE(IVADEF,1,IPMINT,0) 515 : IF (IERR.NE.0) THEN 516 : ISUPDE = 0 517 : GOTO 220 518 : ENDIF 519 : ENDIF 520 : * Determination du type de la perturbation : 521 : * champ constant par element (BDEL) ou uniforme (BDUNI) 522 : MPTVAL = IVADEF 523 : MELVA2 = IVAL(1) 524 : N1PTEL = MELVA2.VELCHE(/1) 525 : N1EL = MELVA2.VELCHE(/2) 526 : BDEL = .FALSE. 527 : BDUNI = .FALSE. 528 : IF (N1PTEL.NE.NBPGAU) THEN 529 : BDEL = .TRUE. 530 : IF (N1PTEL.NE.1) THEN 530 : CALL ERREUR(21) 531 : GOTO 220 532 : ENDIF 533 : ENDIF 534 : IF (N1EL.NE.NBELEM) THEN 535 : BDUNI = .TRUE. 536 : IF (N1EL.NE.1) THEN 536 : CALL ERREUR(21) 537 : GOTO 220 538 : ENDIF 539 : ENDIF 540 : *- 2.7.12 - Recuperation de l'increment de contraintes (IVACON) 540 : CALL KOMCHA(IPCOPE,IPMAIL,CONM,MOCONT,MOTYPE,1,INFOS,NINF, 541 : & IVACON) 542 : IF (IERR.NE.0) GOTO 220 543 : IF (ISUPCO.EQ.1) THEN 543 : CALL VALCHE(IVACON,NBCONT,IPMINT,0) 544 : IF (IERR.NE.0) THEN 545 : ISUPCO = 0 546 : GOTO 220 547 : ENDIF 548 : ENDIF 549 : * Determination du type de chaque composante des contraintes : 550 : * champ constant par element (BCEL(i)) ou uniforme (BCUNI(i)) 551 : MPTVAL = IVACON 552 : DO i = 1, NBCONT 553 : BCEL(i) = .FALSE. 554 : BCUNI(i) = .FALSE. 555 : MELVAL = IVAL(i) 556 : N1PTEL = VELCHE(/1) 557 : N1EL = VELCHE(/2) 558 : IF (N1PTEL.NE.NBPGAU) THEN 559 : BCEL(i) = .TRUE. 560 : IF (N1PTEL.NE.1) THEN 560 : CALL ERREUR(21) 561 : GOTO 220 562 : ENDIF 563 : ENDIF 564 : IF (N1EL.NE.NBELEM) THEN 565 : BCUNI(i) = .TRUE. 566 : IF (N1EL.NE.1) THEN 566 : CALL ERREUR(21) 567 : GOTO 220 568 : ENDIF 569 : ENDIF 570 : ENDDO 571 : *- 2.7.13 - Activation & initialisation de quelques segments 572 : NHRM = NIFOUR 573 : * SEGACT,MELEME 574 : * SEGACT,MINTE 575 : NBBB = NBNN 576 : SEGINI,MWRK1 576 : * CALL ZERO(DDHOOK,LHOOK,LHOOK) 577 : MPTVAL = IVACON 578 : * 579 : *- 2.7.14 - Boucle sur les ELEMENTs : mise a jour matrice REL(.,.,IEL) 580 : *----------------------------------------------------------------------- 581 : DO 300 IEL = 1, NBELEM 582 : * Remise a zero de REL 582 : CALL ZERO(REL,LRE,LRE) 583 : * Coordonnees des noeuds de l element 583 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) 584 : * Calcul des coeff de modification de la matrice B-BARRE 585 : * (Uniquement en cas d'elements incompressibles) 586 : IF (MFR.EQ.31) THEN 586 : CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU, 587 : & POIGAU,QSIGAU,ETAGAU,DZEGAU,NBCONT,LRE, 588 : & IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE) 589 : ENDIF 590 : * Champs uniformes ? 591 : IF (BDUNI) THEN 592 : IBD = 1 593 : ELSE 594 : IBD = IEL 595 : ENDIF 596 : IF (BDIM3) THEN 597 : IF (B3UNI) THEN 598 : IB3 = 1 599 : ELSE 600 : IB3 = IEL 601 : ENDIF 602 : ENDIF 603 : ISDJC=0 604 : * Boucle sur les POINTS d'INTEGRATION 605 : *-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - 606 : DO 400 IGAU = 1, NBPGAU 607 : * Calcul de B et du jacobien 608 : IF (MELVA3.NE.0) THEN 609 : IF (B3EL) THEN 610 : DIM3 = MELVA3.VELCHE(1,IB3) 611 : ELSE 612 : DIM3 = MELVA3.VELCHE(IGAU,IB3) 613 : ENDIF 614 : ENDIF 615 : IF (MELE.NE.28.AND.MELE.NE.45) THEN 615 : CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 616 : & MELE,MFR,NBNN,LRE,IFOUR,NBCONT,NHRM,DIM3, 617 : & XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 618 : ELSE 618 : CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 619 : & MELE,MFR,NBNN,LRE,IFOUR,NBCONT,NHRM,DIM3, 620 : & XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 621 : ENDIF 622 : IF (DJAC.EQ.0.) THEN 623 : INTERR(1) = IEL 623 : CALL ERREUR(259) 624 : GOTO 220 625 : ENDIF 626 : IF (DJAC.LT.0.) ISDJC=ISDJC+1 627 : DJAC = ABS(DJAC)*POIGAU(IGAU) 628 : * En cas d'elements incompressibles : BGENE selon la methode B-BARRE 629 : IF (MFR.EQ.31) THEN 629 : CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 630 : & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE) 631 : ENDIF 632 : * Perturbation constante par element ou uniforme 633 : IF (BDEL) THEN 634 : IGAUD = 1 635 : ELSE 636 : IGAUD = IGAU 637 : ENDIF 638 : * Pour chaque composante des contraintes : 639 : DO i = 1, NBCONT 640 : MELVAL = IVAL(i) 641 : * Contrainte constante par element ou uniforme 642 : IF (BCEL(i)) THEN 643 : IGAUC = 1 644 : ELSE 645 : IGAUC = IGAU 646 : ENDIF 647 : IF (BCUNI(i)) THEN 648 : IBC = 1 649 : ELSE 650 : IBC = IEL 651 : ENDIF 652 : * Calcul de DDHOOK(i) = (cont pert - fin) / defo pert 653 : DDHOOK(i,ICOMP) = 654 : & VELCHE(IGAUC,IBC) / MELVA2.VELCHE(IGAUD,IBD) 655 : ENDDO 656 : * Calcul de BDB par appel a DBDSTS : cas non symetrique 657 : *AV? appel a EFFI2 dans RIGI. EFFI2 MODIFIE REL 657 : CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NBCONT,REL) 658 : * 659 : 400 CONTINUE 660 : * Fin de la Boucle sur les POINTS d'INTEGRATION (etiquette 400) 661 : *-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - 662 : * Changement de signe du jacobien dans l element ? 663 : IF ((ISDJC.NE.0).AND.(ISDJC.NE.NBPGAU)) THEN 664 : INTERR(1) = IEL 664 : CALL ERREUR(195) 665 : GOTO 220 666 : ENDIF 667 : * Mise a jour de la matrice de rigidite elementaire RE 668 : IF (IKTSYM.EQ.0) THEN 669 : DO i = 1, LRE 670 : DO j = 1, LRE 671 : RE(i,j,IEL) = RE(i,j,IEL) + REL(i,j) 672 : ENDDO 673 : ENDDO 674 : ELSE 675 : DO i = 1, LRE 676 : DO j = 1, i 677 : RE(i,j,IEL) = RE(i,j,IEL) + 0.5 * (REL(i,j)+REL(j,i)) 678 : RE(j,i,IEL) = RE(i,j,IEL) 679 : ENDDO 680 : ENDDO 681 : ENDIF 682 : 300 CONTINUE 683 : *- Fin de la boucle sur les ELEMENTs (Etiquette 300) 684 : *----------------------------------------------------------------------- 685 : *- 2.7.15 - Menage : Desactivation-Destruction de segments 686 : 220 CONTINUE 687 : IF (ISUPCO.EQ.1) THEN 687 : CALL DTMVAL(IVACON,3) 688 : ELSE 688 : CALL DTMVAL(IVACON,1) 689 : ENDIF 690 : IF (ISUPDE.EQ.1) THEN 690 : CALL DTMVAL(IVADEF,3) 691 : ELSE 691 : CALL DTMVAL(IVADEF,1) 692 : ENDIF 693 : IF (BDIM3) THEN 694 : IF (ICOMP.EQ.NBDEFO .OR. IERR.NE.0) THEN 695 : IF (ISUPD3.EQ.1) THEN 695 : CALL DTMVAL(IVADM3,3) 696 : ELSE 696 : CALL DTMVAL(IVADM3,1) 697 : ENDIF 698 : ENDIF 699 : ENDIF 700 : IF (MWRK1.NE.0) SEGSUP,MWRK1 701 : MELEME = IPMAIL 702 : SEGDES,MELEME 703 : 210 CONTINUE 703 : IF (IPDEFI.NE.0) CALL DTCHAM(IPDEFI) 703 : IF (IPDEFF.NE.0) CALL DTCHAM(IPDEFF) 703 : IF (IPPERT.NE.0) CALL DTCHAM(IPPERT) 703 : IF (IPCONP.NE.0) CALL DTCHAM(IPCONP) 703 : IF (IPCOPE.NE.0) CALL DTCHAM(IPCOPE) 704 : IF (IERR.NE.0) GOTO 130 705 : * 706 : 200 CONTINUE 707 : *- Fin de la boucle de CALCUL DE LA PERTURBATION (Etiquette 200) 708 : *----------------------------------------------------------------------- 709 : *- 2.8 - Menage : Desactivation-Suppression de segments... - 710 : *----------------------------------------------------------------------- 711 : 130 CONTINUE 712 : SEGDES,DESCR 713 : SEGDES,XMATRI 713 : IF (IPCONF.NE.0) CALL DTCHAM(IPCONF) 713 : IF (IPDIM3.NE.0) CALL DTCHAM(IPDIM3) 714 : 120 CONTINUE 715 : NOMID = MODEPL 716 : IF (BSUPDP) THEN 717 : SEGSUP,NOMID 718 : ELSE 719 : SEGDES,NOMID 720 : ENDIF 721 : NOMID = MOFORC 722 : IF (BSUPFO) THEN 723 : SEGSUP,NOMID 724 : ELSE 725 : SEGDES,NOMID 726 : ENDIF 727 : NOMID = MOCONT 728 : IF (BSUPCO) THEN 729 : SEGSUP,NOMID 730 : ELSE 731 : SEGDES,NOMID 732 : ENDIF 733 : MLMOTS = LISCON 734 : SEGSUP,MLMOTS 735 : NOMID = MODEFO 736 : IF (BSUPDE) THEN 737 : SEGSUP,NOMID 738 : ELSE 739 : SEGDES,NOMID 740 : ENDIF 741 : MLMOTS = LISDEF 742 : SEGSUP,MLMOTS 743 : SEGDES,MINTE 744 : * Fin du traitement en cas d'erreur 745 : 110 CONTINUE 746 : IF (IERR.NE.0 .OR. KERRE.NE.0) THEN 747 : IF (IPDSCR.NE.0) SEGSUP,DESCR 748 : IF (IPMATR.NE.0) SEGSUP,XMATRI 748 : IF (KERRE.NE.0) CALL ERREUR(KERRE) 749 : GOTO 9000 750 : ENDIF 751 : *======================================================================= 752 : 100 CONTINUE 753 : *======================================================================= 754 : 755 : *======================================================================= 756 : *= 3 = FIN DU TRAITEMENT (MENAGE...) = 757 : *======================================================================= 758 : 9000 CONTINUE 759 : * Suppression du modele "deroule" 760 : MMODEL = IPMODL 761 : DO i = 1, NSOUS 762 : IMODEL = KMODEL(i) 763 : SEGDES,IMODEL 764 : ENDDO 765 : SEGSUP,MMODEL 766 : * Suppresion du modele unitaire 767 : IF (IPMODU.NE.0) SEGSUP,MMODE1 768 : * Suppressions des "petits segments" 769 : IF (MODEFU.NE.0) THEN 770 : NOMID = MODEFU 771 : SEGSUP,NOMID 772 : ENDIF 773 : IF (MODIM3.NE.0) THEN 774 : NOMID = MODIM3 775 : SEGSUP,NOMID 776 : ENDIF 777 : IF (MOTYPE.NE.0) SEGSUP,NOTYPE 778 : * Envoi de la matrice de rigidite (sauf erreur) 779 : IF (IERR.NE.0) THEN 780 : IF (IPRIGI.NE.0) SEGSUP,MRIGID 781 : IPRIGI = 0 782 : ELSE 783 : SEGDES,MRIGID 783 : CALL REPART(MRIGID) 784 : ENDIF 785 : * 786 : RETURN 787 : END 788 : 789 : 790 :
© Cast3M 2003 - All rights reserved.
Disclaimer