1 : C FSURCO SOURCE FANDEUR 12/07/18 21:15:42 7434 2 : 3 : SUBROUTINE FSURCO(IPMODL,IPCHPS,IPVECT,IPCARA, IPTFP) 4 : 5 : *_____________________________________________________________________ 6 : * 7 : * CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES 8 : * 9 : * ENTREES : 10 : * --------- 11 : * 12 : * IPMODL OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION 13 : * IPCHE1 CHPOINT CONTENANT LES VALEURS DES FORCES AUX NOEUDS 14 : * IPVECT VECTEUR INDIQUANT LA DIRECTION DANS LAQUELLE 15 : * S APPLIQUE LA FORCE SURFACIQUE 16 : * 17 : * SORTIES : 18 : * --------- 19 : * 20 : * IPTFP CHPOINT DES FORCES NODALES EQUIVALENTES 21 : * 22 : *_____________________________________________________________________ 23 : * 24 : IMPLICIT INTEGER(I-N) 25 : IMPLICIT REAL*8(A-H,O-Z) 26 : * 27 : -INC CCOPTIO 28 : -INC CCHAMP 29 : * 30 : -INC SMCOORD 31 : -INC SMELEME 32 : -INC SMMODEL 33 : -INC SMCHAML 34 : -INC SMCHPOI 35 : -INC SMINTE 36 : * 37 : SEGMENT NOTYPE 38 : CHARACTER*16 TYPE(NBTYPE) 39 : ENDSEGMENT 40 : * 41 : SEGMENT MPTVAL 42 : INTEGER IPOS(NS) ,NSOF(NS) 43 : INTEGER IVAL(NCOSOU) 44 : CHARACTER*16 TYVAL(NCOSOU) 45 : ENDSEGMENT 46 : * 47 : PARAMETER (NINF=3) 48 : INTEGER INFOS(NINF) 49 : 50 : DIMENSION V(3),ipt(3) 51 : CHARACTER*4 mfors(3) 52 : CHARACTER*(NCONCH) CONM 53 : 54 : C= LEFCOQ Liste des numeros d'elements finis COQUEs 55 : C= NEFCOQ Longueur de cette liste 56 : PARAMETER ( NEFCOQ = 8 ) 57 : DIMENSION LEFCOQ(NEFCOQ) 58 : C ============ 59 : C Elements COQUEs COQ2 COQ3 COQ6 COQ4 COQ8 DKT POI1 DST 60 : DATA LEFCOQ / 44, 27, 56, 49, 41, 28, 45, 93 / 61 : 62 : LOGICAL ltelq, lsupfo 63 : * 64 : * 0) QUELQUES INITIALISATIONS 65 : * 66 : IPTFP = 0 67 : NHRM = NIFOUR 68 : C= Composantes du CHPOINT IPCHPS a retenir (si besoin) 69 : IF (IFOMOD.EQ.2) THEN 70 : nfors = 3 71 : mfors(1) = 'FX ' 72 : mfors(2) = 'FY ' 73 : mfors(3) = 'FZ ' 74 : ELSE IF (IFOMOD.EQ.-1) THEN 75 : nfors = 2 76 : mfors(1) = 'FX ' 77 : mfors(2) = 'FY ' 78 : mfors(3) = ' ' 79 : ELSE IF (IFOMOD.EQ.0) THEN 80 : nfors = 2 81 : mfors(1) = 'FR ' 82 : mfors(2) = 'FZ ' 83 : mfors(3) = ' ' 84 : ELSE IF (IFOMOD.EQ.1) THEN 85 : nfors = 3 86 : mfors(1) = 'FR ' 87 : mfors(2) = 'FZ ' 88 : mfors(3) = 'FT ' 89 : ELSE 89 : CALL ERREUR(21) 90 : RETURN 91 : ENDIF 92 : C= Cas des modes de calculs en DEFORMATIONS GENERALISEES 93 : IF (IFOUR.EQ.-3) THEN 94 : NDPGE = 3 95 : ELSE 96 : NDPGE = 0 97 : ENDIF 98 : * 99 : IPCHMS = 0 100 : IPCHMZ = 0 101 : * 102 : * 1) ON RECUPERE LES COORDONNEES DU VECTEUR CONSTANT (SI DONNE) 103 : * 104 : V(1) = 0.D0 105 : V(2) = 0.D0 106 : V(3) = 0.D0 107 : IF (IPVECT.NE.0) THEN 108 : IREF=(IPVECT-1)*(IDIM+1) 109 : V(1)=XCOOR(IREF+1) 110 : V(2)=XCOOR(IREF+2) 111 : VN = V(1)**2 + V(2)**2 112 : IF (IDIM.GE.3) THEN 113 : V(3)=XCOOR(IREF+3) 114 : VN=VN+V(3)**2 115 : ENDIF 116 : c* VN=SQRT(VN) 117 : IF (VN.LE.0.) THEN 117 : CALL ERREUR(277) 118 : RETURN 119 : ENDIF 120 : ENDIF 121 : * 122 : * 2) VERIFICATIONS DU CHAMP DE CARACTERISTIQUES SI FOURNI 123 : * 124 : IF (IPCARA.NE.0) THEN 124 : CALL QUESUP(IPMODL,IPCARA,3,0,ISUPCA,iret) 125 : IF (ISUPCA.GT.1) RETURN 126 : ENDIF 127 : * 128 : * 3) ANALYSE DU CHPOINT DE FORCES SURFACIQUES SI DONNE 129 : * IFLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE IPMODI 130 : * ( 1 = DESTRUCTION DU MMODEL IPMODI CREE ) 131 : * 132 : IF (IPCHPS.NE.0) THEN 133 : * 134 : IFLAG = 1 135 : * 136 : * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHPOINT 137 : * CORRESPONDANT AUX SEULES COMPOSANTES RECHERCHEES (mfors) 138 : * 139 : IPGEOM = 0 140 : * 141 : MCHPOI=IPCHPS 142 : SEGACT,MCHPOI 143 : NSOUPO=IPCHP(/1) 144 : ltelq=.FALSE. 145 : DO I = 1, NSOUPO 146 : MSOUPO=IPCHP(I) 147 : SEGACT,MSOUPO 148 : NC = NOCOMP(/2) 149 : DO j = 1, NC 149 : CALL PLACE(mfors,nfors,imo,NOCOMP(j)) 150 : IF (imo.NE.0) THEN 151 : IF (IPGEOM.EQ.0) THEN 152 : IPGEOM = IGEOC 153 : ELSE 154 : IPP2 = IGEOC 154 : CALL FUSE (IPGEOM,IPP2,IPPT,ltelq) 155 : IF (IERR.NE.0) RETURN 156 : IPGEOM = IPPT 157 : ENDIF 158 : GOTO 10 159 : ENDIF 160 : ENDDO 161 : 10 CONTINUE 162 : SEGDES,MSOUPO 163 : ENDDO 164 : SEGDES,MCHPOI 165 : 166 : IF (IPGEOM.EQ.0) THEN 166 : CALL ERREUR(21) 167 : RETURN 168 : ENDIF 169 : * 170 : * ON CREE UN MODELE S'ACCROCHANT AU CHPOINT 171 : * 172 : MMODEL = IPMODL 173 : SEGACT,MMODEL 174 : NSOUS = MMODEL.KMODEL(/1) 175 : * 176 : N1 = NSOUS 177 : SEGINI,MMODE1=MMODEL 178 : IPMODI = MMODE1 179 : * 180 : * BOUCLE SUR LES SOUS ZONES GEOMETRIQUES ELEMENTAIRES 181 : * 182 : N1 = 0 183 : lzero = 0 184 : * 185 : DO 11 ISOUS = 1, NSOUS 186 : * 187 : IMODEL=KMODEL(ISOUS) 188 : SEGACT,IMODEL 189 : ITGEOM=IMAMOD 190 : SEGDES,IMODEL 191 : * 191 : CALL ECROBJ('MAILLAGE',IPGEOM) 191 : CALL ECRCHA('STRI') 191 : CALL ECRCHA('APPU') 191 : CALL ECROBJ('MAILLAGE',ITGEOM) 191 : CALL EXTREL(irr,0,ibnor) 192 : * 193 : * LE CHPOINT ET LA SOUS-ZONE N'ONT PAS D'ELEMENT EN COMMUN 194 : * 195 : IF (irr.GT.0) GOTO 11 196 : * 197 : * DEFINITION DU SOUS-MODELE ASSOCIE A L'INTERSECTION 197 : CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU) 198 : IF (IERR.NE.0) GOTO 9990 199 : * 200 : N1 = N1 + 1 201 : * 202 : * CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE 203 : * 204 : SEGINI,IMODE1=IMODEL 205 : IMODE1.IMAMOD=IPOGEO 205 : CALL INOMID(IMODE1,' ',iret,lzero,lzero,lzero,lzero) 205 : CALL PRQUOI(IMODE1) 206 : SEGDES,IMODE1 207 : MMODE1.KMODEL(N1) = IMODE1 208 : * 209 : 11 CONTINUE 210 : 211 : SEGDES,MMODEL 212 : * 213 : * LE MODELE ET LE CHPOINT SONT INCOMPATIBLES 214 : * 215 : IF (N1.EQ.0) THEN 216 : MOTERR(1:8)='MAILLAGE' 217 : MOTERR(9:16)='CHPOINT' 217 : CALL ERREUR(135) 218 : IFLAG = 0 219 : SEGSUP,MMODE1 220 : GOTO 9990 221 : ENDIF 222 : * 223 : IF (N1.NE.NSOUS) THEN 224 : SEGADJ,MMODE1 225 : ENDIF 226 : * 227 : * ON TRANSFORME LE CHPOINT DE VECTEUR EN MCHAML AUX NOEUDS 228 : * 228 : CALL CHAME1(0,IPMODI,IPCHPS,' ',IPCHMS,1) 229 : IF (IERR.NE.0) GOTO 9990 230 : 231 : MCHEL1=IPCHMS 232 : SEGACT,MCHEL1 233 : * 234 : ELSE 235 : 236 : IFLAG = 0 237 : IPMODI = IPMODL 238 : 239 : ENDIF 240 : * 241 : * ACTIVATION DU MODELE 242 : * 243 : MMODEL = IPMODI 244 : SEGACT,MMODEL 245 : NSOUS = KMODEL(/1) 246 : * 247 : * INITIALISATION DU MCHAML ELEMENTAIRE DES FORCES NODALES 248 : * 249 : N1 = NSOUS 250 : L1 = 6 251 : N3 = 6 252 : SEGINI,MCHELM 253 : IPCHMZ = MCHELM 254 : TITCHE = 'FORCES' 255 : IFOCHE = IFOUR 256 : * 257 : DO 100 ISOUS = 1, NSOUS 258 : * 259 : * ON RECUPERE L INFORMATION GENERALE 260 : * 261 : IMODEL=KMODEL(ISOUS) 262 : SEGACT,IMODEL 263 : * 264 : MOCARA = 0 265 : IVACAR = 0 266 : MOFORC = 0 267 : IVAFOR = 0 268 : * 269 : * TRAITEMENT DU MODEL 270 : * 271 : IPMAIL=IMAMOD 272 : CONM =CONMOD 273 : MELE =NEFMOD 274 : 275 : imo = 0 275 : CALL PLACE2(LEFCOQ,NEFCOQ,imo,MELE) 276 : * 277 : * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE 278 : IF (imo.EQ.0) THEN 279 : MOTERR(1:4) = NOMTP(MELE) 280 : MOTERR(5:12)='FSURCO ' 280 : CALL ERREUR(86) 281 : GOTO 9900 282 : ENDIF 283 : 284 : IF (MELE.EQ.41.OR.MELE.EQ.56) THEN 285 : IF (IPCARA.EQ.0) THEN 286 : C* Revoir l'erreur 287 : MOTERR(1:4) = NOMTP(MELE) 288 : MOTERR(5:12)='FSURCO ' 288 : CALL ERREUR(86) 289 : GOTO 9900 290 : ENDIF 291 : ENDIF 292 : * 293 : * INFORMATION SUR L ELEMENT FINI 294 : * 295 : MFR =INFELE(13) 296 : IPTINT=INFMOD(5) 297 : IPTNOE=INFMOD(8) 298 : MINTE =IPTINT 299 : IF (IPTINT.NE.0) SEGACT,MINTE 300 : IPPORE=0 301 : IF (MFR.EQ.33) IPPORE=NBNN 302 : * 303 : * CREATION DU TABLEAU INFOS 304 : * 304 : CALL IDENT(IPMAIL,CONM,IPCARA,IPCHMS,INFOS,iret) 305 : IF (iret.EQ.0) GOTO 9900 306 : * 307 : IPT(1) = 0 308 : IPT(2) = 0 309 : IPT(3) = 0 310 : IF (IPCHMS.NE.0) THEN 311 : MCHAM1 = MCHEL1.ICHAML(ISOUS) 312 : SEGACT,MCHAM1 313 : DO i = 1, MCHAM1.NOMCHE(/2) 313 : CALL PLACE(mfors,nfors,imo,MCHAM1.NOMCHE(i)) 314 : if (imo.ne.0) IPT(imo) = MCHAM1.IELVAL(i) 315 : ENDDO 316 : SEGDES,MCHAM1 317 : ENDIF 318 : * 319 : IMACHE(ISOUS)=IPMAIL 320 : CONCHE(ISOUS)=CONM 321 : INFCHE(ISOUS,1)=0 322 : INFCHE(ISOUS,2)=0 323 : INFCHE(ISOUS,3)=NHRM 324 : INFCHE(ISOUS,4)=IPTINT 325 : INFCHE(ISOUS,5)=0 326 : INFCHE(1,6)=0 327 : * 328 : MELEME=IPMAIL 329 : SEGACT,MELEME 330 : NBNN =NUM(/1) 331 : NBELEM=NUM(/2) 332 : * 333 : * RECHERCHE DES NOMS DE COMPOSANTES 334 : * 335 : IF (lnomid(2).ne.0) then 336 : lsupfo = .false. 337 : MOFORC = lnomid(2) 338 : else 339 : lsupfo = .true. 339 : CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC) 340 : endif 341 : nomid=MOFORC 342 : SEGACT,nomid 343 : nfor = lesobl(/2) 344 : nfac = 0 345 : NCOMP = NFOR - NDPGE 346 : 347 : N2 = NCOMP 348 : SEGINI,MCHAML 349 : ICHAML(ISOUS) = MCHAML 350 : NS=1 351 : NCOSOU=NCOMP 352 : SEGINI,MPTVAL 353 : IVAFOR=MPTVAL 354 : * 355 : N1EL = NBELEM 356 : IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR. 357 : & MELE.EQ.93) THEN 358 : N1PTEL = 3 359 : ELSE IF (MELE.EQ.44) THEN 360 : N1PTEL = 2 361 : ELSE IF (MELE.EQ.49 .OR. MELE.EQ.41 .OR. MELE.EQ.56) THEN 362 : N1PTEL=NBNN 363 : ENDIF 364 : N2PTEL=0 365 : N2EL =0 366 : * 367 : DO 4 ICOMP = 1, NCOMP 368 : NOMCHE(ICOMP) = LESOBL(ICOMP) 369 : TYPCHE(ICOMP)='REAL*8' 370 : SEGINI,MELVAL 371 : IELVAL(ICOMP)=MELVAL 372 : IVAL(ICOMP)=MELVAL 373 : 4 CONTINUE 374 : *_______________________________________________________________________ 375 : * 376 : * CALCUL DES FORCES NODALES EQUIVALENTES 377 : * DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS 378 : *_______________________________________________________________________ 379 : * 380 : * ELEMENTS COQ3 , DKT OU DKTC 381 : * --------------------------- 382 : IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR. 383 : & MELE.EQ.93) THEN 384 : * 384 : CALL FSCO3D(IPT,IPMAIL,IPVECT,V,IVAFOR) 385 : * 386 : * ELEMENT COQ2 387 : * ------------ 388 : ELSE IF (MELE.EQ.44) THEN 389 : * 390 : * TRAITEMENT DU CHAMP DE CARACTERISTIQUES 391 : * 392 : IF (IFOUR.EQ.-2 .AND. IPCARA.NE.0) THEN 393 : * 394 : NBROBL=0 395 : NBRFAC=1 396 : SEGINI,NOMID 397 : MOCARA=NOMID 398 : LESFAC(1)='DIM3' 399 : * 400 : NBTYPE=1 401 : SEGINI,NOTYPE 402 : MOTYPE=NOTYPE 403 : TYPE(1)='REAL*8' 404 : * 404 : CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,0, 405 : & INFOS,3,IVACAR) 406 : SEGSUP,NOTYPE 407 : IF (IERR.NE.0) GOTO 9990 408 : * 409 : IF (ISUPCA.EQ.1) THEN 410 : NCARA=NBROBL 411 : NCARF=NBRFAC 412 : NCARR=NCARA+NCARF 412 : CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE) 413 : ENDIF 414 : * 415 : ENDIF 416 : 416 : CALL FSCO2D (IPT,IPMAIL,IPVECT,V,IVAFOR,IVACAR) 417 : * 418 : * ELEMENTS COQ4 419 : * ------------- 420 : * 421 : ELSE IF (MELE.EQ.49) THEN 422 : * 422 : CALL FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR) 423 : * 424 : * ELEMENTS COQ6 OU COQ8 425 : * --------------------- 426 : * 427 : ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN 428 : *____________________________________________________________________ 429 : * 430 : * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES POUR LES COQ8 ET COQ6 431 : *____________________________________________________________________ 432 : * 433 : NBROBL=1 434 : NBRFAC=0 435 : SEGINI,NOMID 436 : MOCARA=NOMID 437 : LESOBL(1)='EPAI' 438 : * 439 : NBTYPE=1 440 : SEGINI,NOTYPE 441 : MOTYPE=NOTYPE 442 : TYPE(1)='REAL*8' 443 : * 444 : * 444 : CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) 445 : SEGSUP,NOTYPE 446 : IF (IERR.NE.0) GOTO 9990 447 : * 448 : IF (ISUPCA.EQ.1) THEN 449 : NCARA=NBROBL 450 : NCARF=NBRFAC 451 : NCARR=NCARA+NCARF 451 : CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE) 452 : ENDIF 453 : * 453 : CALL FSCOQ8(IPT,IPMAIL,IPTINT,IPVECT,V,IVACAR,IPTNOE,IVAFOR) 454 : * 455 : ENDIF 456 : * 457 : DO ICOMP = 1, NCOMP 458 : MELVAL=IELVAL(ICOMP) 459 : SEGDES,MELVAL 460 : ENDDO 461 : * 462 : IF (IPTINT.NE.0) SEGDES,MINTE 463 : SEGDES,MELEME 464 : SEGDES,IMODEL 465 : * 466 : IF (MOCARA.NE.0) THEN 467 : NOMID = MOCARA 468 : SEGSUP,NOMID 469 : IF (ISUPCA.EQ.1) THEN 469 : CALL DTMVAL(IVACAR,3) 470 : ELSE 470 : CALL DTMVAL(IVACAR,1) 471 : ENDIF 472 : ENDIF 473 : * 474 : IF (MOFORC.NE.0) THEN 475 : nomid=MOFORC 476 : SEGDES,nomid 477 : IF (lsupfo) SEGSUP,nomid 477 : CALL DTMVAL(IVAFOR,1) 478 : ENDIF 479 : * 480 : 100 CONTINUE 481 : 482 : * 483 : * ON TRANSFORME LE MCHAML EN CHPOINT 484 : * 484 : CALL CHAMPO(IPCHMZ,0,IPTFP,iret) 485 : IF (iret.EQ.0) GOTO 9990 486 : * 487 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR 488 : * 489 : 9900 CONTINUE 490 : 9990 CONTINUE 491 : SEGDES,MMODEL 492 : * 492 : IF (IFLAG.EQ.1) CALL DTMODL(IPMODI) 492 : IF (IPCHMZ.NE.0) CALL DTCHAM(IPCHMZ) 492 : IF (IPCHMS.NE.0) CALL DTCHAM(IPCHMS) 493 : * 494 : RETURN 495 : END 496 : 497 :
© Cast3M 2003 - All rights reserved.
Disclaimer