C BSIGM3 SOURCE AM 13/12/16 21:15:04 7825 SUBROUTINE BSIGM3(IPMAIL,LRE,NSTRS,LW,IVACAR,NCARR,IVECT, & MELE,CMATE,IVASTR,ISOUS,NBPGAU,NBPTEL,IPMINT,NFOR,IVAFOR & ,ADPG,BDPG,CDPG,IIPDPG,IVAMAT,NMATT,MFR) *---------------------------------------------------------------------- * _______________________________ * * | | * * | calcul des forces aux noeuds| * * |______________________________| * * * * poutre,tuyau,linespring,tuyau fissure,barre,cerce,tuyo * * poutre de timoschenko,shb8,joi1,zone_cohesive * * *---------------------------------------------------------------------* * * * entrees : * * ________ * * * * ipmail pointeur sur un segment meleme * * lre nombre de ddl dans la matrice de rigidite * * nstrs nombre de composante de contraintes/deformations * * lw dimension du tableau de travail de l'element * * ivacar pointeur sur les chamelems de caracteristiques géo. * * ncarr nombre de caracteristiques geometriques * * ivamat pointeur sur les chamelems de caracteristiques mat. * * nmatt nombre de caracteristiques matériau * * ivect flag indiquant si on a entree les axes locaux * * mele numero de l'element fini * * ivastr pointeur sur un segment mptval contenant les * * les melvals de contraints * * isous numero de la sous-zone * * nbpgau nombre de points d'integration pour les contraintes * * nbptel nombre de points par element * * ipmint pointeur sur un segment minte * * nfor nombre de composantes de forces * * * * sorties : * * ________ * * * * ivafor pointeur sur un segment mptval contenant les * * les melvals de forces * * * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * * -INC CCOPTIO -INC CCHAMP -INC CCREEL -INC SMCHAML -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE -INC SMLMOTS c SEGMENT WRK1 REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB) ENDSEGMENT * SEGMENT WRK2 REAL*8 SHPWRK(6,NBNN), BGENE(NSTRS,LRE) ENDSEGMENT * SEGMENT WRK3 REAL*8 WORK(LW) ENDSEGMENT * SEGMENT WRK4 REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE) ENDSEGMENT * SEGMENT WRK5 REAL*8 XGENE(NSTN,LRN) ENDSEGMENT * segment pour shb8 SEGMENT WRK7 REAL*8 PROPEL(24),D(3) REAL*8 rel(24,24),work1(30) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT POINTEUR MPTVA1.MPTVAL,MPTVA2.MPTVAL * CHARACTER*4 lesinc(7),lesdua(7) DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/ DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/ CHARACTER*8 CMATE logical dcmat2 dcmat2 = .false. MELEME=IPMAIL SEGACT MELEME NBNN=NUM(/1) NBELEM=NUM(/2) * * introduction des coord du point autour duquel se fait le * mouvement de la section en defo plane generalisee * et initialisation des forces au noeud support de la defo * plane generalisee * ADPG=0.D0 BDPG=0.D0 CDPG=0.D0 IF (IFOUR.EQ.-3)THEN IP=IIPDPG SEGACT MCOORD IREF=(IP-1)*(IDIM+1) XDPGE=XCOOR(IREF+1) YDPGE=XCOOR(IREF+2) ELSE XDPGE=0.D0 YDPGE=0.D0 ENDIF * NHRM=NIFOUR MINTE=IPMINT * if (CMATE.EQ.'IMPELAST'.OR.CMATE.EQ.'IMPVOIGT' &.OR.CMATE.EQ.'IMPMAXWE'.or.CMATE.EQ.'IMPCOMPL') goto 45 c_______________________________________________________________________ c_______________________________________________________________________ c c numero des etiquettes : c etiquettes de 1 a 98 pour traitement specifique a l element c dans la zone specifique a chaque element commencant par : c 5 continue c element 5 etiquettes 1005 2005 3005 4005 ... c 44 continue c element 44 etiquettes 1044 2044 3044 4044 ... c_______________________________________________________________________ c IF (MELE.LE.100) &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 1 99,99,99,99,99,99,99,99,29,30,99,99,99,99,99,99,99,99,99,99, 2 99,29,43,99,45,46,99,99,99,30,99,99,99,99,99,99,99,99,99,99, 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 4 99,99,99,29,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99 5 ),MELE IF (MELE.LE.200) &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 1 99,99,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 3 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 4 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 5 34),MELE-100 IF (MELE.LE.300) &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 3 260,34,34,34,34,265,266,266,266),MELE-200 c 34 CONTINUE GOTO 99 c_______________________________________________________________________ c_______________________________________________________________________ c c elements poutre et poutre de timoschenko c_______________________________________________________________________ c 29 CONTINUE NBBB=NBNN SEGINI WRK1,WRK3 c DO 3029 IB=1,NBELEM c c on cherche les coordonnees des noeuds de l elementib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c il faudrait aussi modifier le vecteur local de la poutre c c c rangement des caracteristiques dans work c NCARR1=NCARR C IF((IVECT.EQ.1).AND.(IFOUR.NE.-2)) NCARR1=NCARR-1 C CALL ZERO(WORK,NCARR1,1) DO 4029 IGAU=1,NBNN MPTVAL=IVACAR DO 6029 IC=1,NCARR1 IF (IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) ELSE WORK(IC)=0.D0 ENDIF IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 6029 CONTINUE 4029 CONTINUE c c cas ou on a lu le mot vecteur c C IF (IFOUR.NE.-2) THEN C IF (IVECT.EQ.1) THEN IF (IVAL(NCARR).NE.0) THEN MELVAL=IVAL(NCARR) IBMN=MIN(IB,IELCHE(/2)) IP=IELCHE(1,IBMN) IREF=(IP-1)*(IDIM+1) DO 6129 IC=1,IDIM WORK(NCARR+IC-1)=XCOOR(IREF+IC) 6129 CONTINUE ELSE DO 6229 IC=1,IDIM WORK(NCARR+IC-1)=0.D0 6229 CONTINUE ENDIF ENDIF C ENDIF C c c c cas des tuyaux - on calcule les caracteristiques de la poutre c equivalente c IF(MELE.EQ.42) THEN CISA=WORK(4) VX =WORK(5) VY =WORK(6) VZ =WORK(7) CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,0) ENDIF IF (KERRE.EQ.77) THEN CALL ERREUR(77) GOTO 510 ENDIF c c on cherche les contraintes - c MPTVAL=IVASTR IE=9 DO 7029 IGAU=1,2 DO 7029 ICOMP=1,NSTRS IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) WORK(IE)=VELCHE(IGMN,IBMN) 7029 CONTINUE c c on calcule les forces internes c IF(MELE.EQ.84) THEN IF(CMATE.NE.'SECTION') THEN IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMBS2(XFORC,XE,WORK(10),WORK(22),KERRE) ELSE CALL TIMBSG(XFORC,WORK(7),XE,WORK(10),WORK(22),KERRE) ENDIF ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL TIMBS2(XFORC,XE,WORK(10),WORK(22),KERRE) ELSE CALL TIMBSG(XFORC,WORK(1),XE,WORK(10),WORK(22),KERRE) ENDIF ENDIF ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN CALL POUBS2(XFORC,WORK,XE,WORK(10),WORK(22),KERRE) ELSE CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE) ENDIF ENDIF IF(KERRE.EQ.0) GO TO 5029 INTERR(1)=ISOUS INTERR(2)=IB SEGSUP WRK1,WRK3 CALL ERREUR(128) GO TO 510 5029 CONTINUE c c rangement dans melval c IE=0 MPTVAL=IVAFOR DO 9029 IGAU=1,NBNN DO 9029 ICOMP=1,NFOR IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9029 CONTINUE 3029 CONTINUE SEGSUP WRK1,WRK3 GO TO 510 c_______________________________________________________________________ c c elements lisp et lism c_______________________________________________________________________ c 30 CONTINUE NBBB=NBNN NBNO=SHPTOT(/2) SEGINI WRK1,WRK3,WRK4 c DO 3030 IB=1,NBELEM c c on cherche les coordonnees des noeuds de l element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c c on cherche les contraintes c IE=0 MPTVAL=IVASTR DO 7030 IGAU=1,NBPGAU DO 7030 ICOMP=1,NSTRS IE=IE+1 MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) WORK(IE)=VELCHE(IGMN,IBMN) 7030 CONTINUE c c on cherche les caracteristiques c MPTVAL=IVACAR DO 6030 IGAU=1,NBPGAU DO 6030 ICOMP=1,NCARR IE=IE+1 MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) WORK(IE)=VELCHE(IGMN,IBMN) ELSE WORK(IE)=0.D0 ENDIF 6030 CONTINUE c c on calcule b*sigma c ICNT=NBPGAU*NSTRS+1 CALL LISPBS(WORK(1),WORK(ICNT),POIGAU,SHPTOT, 1 NBPGAU,NBNO,XE,XFOLO,BPSS,XFORC) c c rangement dans melval c IE=0 MPTVAL=IVAFOR DO 9030 IGAU=1,NBNN DO 9030 ICOMP=1,6 IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9030 CONTINUE 3030 CONTINUE SEGSUP WRK1,WRK3,WRK4 GOTO 510 c_______________________________________________________________________ c c element tuyau fissure c_______________________________________________________________________ c 43 CONTINUE NBBB=NBNN SEGINI WRK1,WRK3 c DO 3043 IB=1,NBELEM c c on cherche les contraintes c IE=0 MPTVAL=IVASTR DO 4043 IGAU=1,NBPTEL DO 4043 ICOMP=1,NSTRS IE=IE+1 MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) WORK(IE)=VELCHE(IGMN,IBMN) 4043 CONTINUE c c on cherche les caracteristiques c MPTVAL=IVACAR DO 5043 ICOMP=1,NCARR MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IBMN=MIN(IB ,VELCHE(/2)) WORK(ICOMP+8)=VELCHE(1,IBMN) ELSE WORK(ICOMP+8)=0.D0 ENDIF 5043 CONTINUE c c on calcule les forces internes c CALL TUFIBS(XFORC,WORK,WORK(9),WORK(18),KERRE) c c rangement dans melval c IE=0 MPTVAL=IVAFOR DO 6043 IGAU=1,NBNN DO 6043 ICOMP=1,NFOR IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 6043 CONTINUE 3043 CONTINUE SEGSUP WRK1,WRK3 GO TO 510 c_______________________________________________________________________ c c element point (poi1) defos planes generalisees/materiau IMPEDANCE c_______________________________________________________________________ c 45 CONTINUE NBBB=NBNN * * IF ((CMATE.EQ.'IMPELAST').OR.(CMATE.EQ.'IMPVOIGT').OR. & (CMATE.EQ.'IMPMAXWE').OR .cmate.eq.'IMPCOMPL'.or. & cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') THEN mptva1 = ivastr mptval = ivafor segact mptva1,mptval * detection impedance "sur mesure" if (ival(/1).eq.mptva1.ival(/1)*2) dcmat2 = .true. numstr = mptva1.ival(/1) do iv = 1,ival(/1) if (dcmat2) then if(iv.le.numstr) then melva1 = mptva1.ival(iv) else melva1 = mptva1.ival(iv - numstr) endif else melva1 = mptva1.ival(iv) endif melval = ival(iv) segact melva1,melval*mod DO IB=1,NBELEM DO 4145 IGAU=1,NBNN IGMN=MIN(IGAU,MELVA1.VELCHE(/1)) IBMN=MIN(IB ,MELVA1.VELCHE(/2)) valstr = MELVA1.VELCHE(IGMN,IBMN) VELCHE(IGMN,IBMN) = valstr * write(6,*) 'bs3',cmate,iv,ib,valstr,mptva1.ival(/1),ival(/1) 4145 CONTINUE ENDDO enddo GOTO 510 ENDIF * IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN GO TO 99 ENDIF * SEGINI WRK1,WRK3 c DO 3045 IB=1,NBELEM c c on cherche les coordonnees des noeuds de l element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c c mise a zero des forces internes c CALL ZERO(XFORC,1,LRE) c c on cherche l'effort c MPTVAL=IVASTR MELVAL=IVAL(1) IBMN=MIN(IB ,VELCHE(/2)) EFFORT=VELCHE(1,IBMN) c c on calcule les forces internes c CALL PO1BSG(XE,LRE,XDPGE,YDPGE,EFFORT,XFORC) ADPG=ADPG+XFORC(3) BDPG=BDPG+XFORC(4) CDPG=CDPG+XFORC(5) c c rangement dans melval c IE=0 MPTVAL=IVAFOR DO 9045 IGAU=1,NBNN DO 9045 ICOMP=1,NFOR-3 IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9045 CONTINUE 3045 CONTINUE c SEGSUP WRK1,WRK3 GO TO 510 c_______________________________________________________________________ c c elements barre et cerce c_______________________________________________________________________ c 46 CONTINUE NBBB=NBNN * IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN GO TO 99 ENDIF * SEGINI WRK1,WRK3 c DO 3046 IB=1,NBELEM c c on cherche les coordonnees des noeuds de l element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C IF(MELE.EQ.123) THEN c c on cherche l'effort c IE=0 MPTVAL=IVASTR DO 4046 IGAU=1,NBPTEL DO 4046 ICOMP=1,NSTRS IE=IE+1 MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) WORK(IE)=VELCHE(IGMN,IBMN) 4046 CONTINUE c c on calcule les forces internes c CALL BARBS3(XFORC,XE,WORK,KERRE,QSIGAU,POIGAU,NBPGAU,IB) c ELSE c c on cherche l'effort c MPTVAL=IVASTR MELVAL=IVAL(1) NPPTEL=VELCHE(/1) IF(NPPTEL.EQ.1) THEN IBMN=MIN(IB ,VELCHE(/2)) EFFORT=VELCHE(1,IBMN) ENDIF IF(NPPTEL.EQ.2) THEN IBMN=MIN(IB ,VELCHE(/2)) EFFOR1=VELCHE(1,IBMN) EFFOR2=VELCHE(2,IBMN) EFFORT=0.5D0*(EFFOR1+EFFOR2) ENDIF c c on calcule les forces internes c IF(MELE.EQ.46) CALL BARBSG(XFORC,XE,EFFORT,KERRE) IF(MELE.EQ.95) CALL CERBSG(XFORC,XE,EFFORT,KERRE) ENDIF C IF(KERRE.EQ.0) GO TO 5046 INTERR(1)=ISOUS INTERR(2)=IB SEGSUP WRK1,WRK3 IF(MELE.EQ.46) CALL ERREUR(128) IF(MELE.EQ.95) CALL ERREUR(128) GO TO 510 5046 CONTINUE c c rangement dans melval c NFOD=NFOR IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NFOD=NFOR-3 IE=0 MPTVAL=IVAFOR DO 9046 IGAU=1,NBNN DO 9046 ICOMP=1,NFOD IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9046 CONTINUE 3046 CONTINUE SEGSUP WRK1,WRK3 GO TO 510 C_______________________________________________________________________ C C ELEMENT BARRE 3D EXCENTRE (BAEX) C_______________________________________________________________________ C 124 CONTINUE NBBB=NBNN NSTN=NBNN LRN =LRE SEGINI WRK1,WRK3,WRK5 C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C KERRE=0 DO 3124 IB=1,NBELEM C C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ C MPTVAL=IVACAR DO IC=1,NCARR IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF END DO SECT=WORK(1) C C XGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE) IF(KERRE.NE.0) INTERR(1)=ISOUS IF(KERRE.NE.0) INTERR(2)=IB IF(KERRE.EQ.1) CALL ERREUR(128) C C MISE A ZERO DES FORCES INTERNES C CALL ZERO(XFORC,1,LRE) C C ON CHERCHE L'EFFORT C MPTVAL=IVASTR MELVAL=IVAL(1) NPPTEL=VELCHE(/1) IF(NPPTEL.EQ.1) THEN IBMN=MIN(IB ,VELCHE(/2)) EFFORT=VELCHE(1,IBMN) ENDIF IF(NPPTEL.EQ.2) THEN IBMN=MIN(IB ,VELCHE(/2)) EFFOR1=VELCHE(1,IBMN) EFFOR2=VELCHE(2,IBMN) EFFORT=0.5D0*(EFFOR1+EFFOR2) ENDIF CC EFFORT=SECT*EFFORT C C ON CALCULE LES FORCES INTERNES C CALL BARINT(XFORC,XGENE,EFFORT,LRE) C C RANGEMENT DANS MELVAL C IE=0 MPTVAL=IVAFOR DO 9199 IGAU=1,NBNN DO 9199 ICOMP=1,NFOR IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9199 CONTINUE 3124 CONTINUE SEGSUP WRK1,WRK3,WRK5 GO TO 510 *----------------------------------------------- * element shb8 *------------------------------------------------ 260 CONTINUE NBBB=NBNN SEGINI WRK1,WRK7 DO 3260 IB=1,NBELEM c c on cherche les coordonnees des noeuds de l element ib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c c on cherche les contraintes c IE=0 MPTVAL=IVASTR DO 7260 IGAU=1,NBPGAU DO 7260 ICOMP=1,NSTRS IE=IE+1 MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) WORK1(IE)=VELCHE(IGMN,IBMN) 7260 CONTINUE c c on cherche les materiaux c yyo=0.d0 ynu=0.d0 MPTVAL=IVAMAT segact mptval DO 6260 IGAU=1,NBPGAU DO 6260 ICOMP=1,2 MELVAL=IVAL(ICOMP) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) if(icomp.eq.1) yyo=yyo+VELCHE(IGMN,IBMN)/nbpgau if(icomp.eq.2)ynu=ynu+VELCHE(IGMN,IBMN)/nbpgau ENDIF 6260 CONTINUE c c on calcule b*sigma c d(1)=yyo d(2)=ynu d(3)=0 CALL shb8(8,XE,D,propel,work1,rel,xforc) c c rangement dans melval c IE=0 MPTVAL=IVAFOR DO 9260 IGAU=1,Nbnn DO 9260 ICOMP=1,3 IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9260 CONTINUE 3260 CONTINUE SEGSUP WRK1,WRk7 GO TO 510 C_______________________________________________________________________ C C LIA2 : element de liaison a 2 noeuds (6 ddl par C noeuds) C_______________________________________________________________________ C 125 CONTINUE NBBB=NBNN NSTN=3 LRN =3 SEGINI WRK1,WRK3,WRK5 C KERRE=0 DO 3109 IB=1,NBELEM C C MISE A ZERO DES FORCES INTERNES C CALL ZERO(XFORC,1,LRE) C MPTVAL=IVACAR DO IC=1,NCARR IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF END DO C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE) IF(KERRE.NE.0) INTERR(1)=ISOUS IF(KERRE.NE.0) INTERR(2)=IB IF(KERRE.EQ.1) CALL ERREUR(128) C C ON CHERCHE LES CONTRAINTES - C MPTVAL=IVASTR IE=0 DO 7109 IGAU=1,2 DO 7109 ICOMP=1,NSTRS IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) XSTRS(IE)=VELCHE(IGMN,IBMN) 7109 CONTINUE C C ON CALCULE LES FORCES INTERNES !!!! a ameliorer C CALL LIAINT(XSTRS,XGENE,XFORC,LRE,NSTRS) C C RANGEMENT DANS MELVAL C IE=0 MPTVAL=IVAFOR DO 9109 IGAU=1,NBNN DO 9109 ICOMP=1,NFOR IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9109 CONTINUE 3109 CONTINUE SEGSUP WRK1,WRK3,WRK5 GO TO 510 C_______________________________________________________________________ C C JOI1 : element de liaison a 2 noeuds (6 ddl par C noeuds) C_______________________________________________________________________ C 265 CONTINUE NBBB=NBNN NSTN=3 LRN =3 SEGINI WRK1,WRK3,WRK4 C KERRE=0 DO 3110 IB=1,NBELEM C C MISE A ZERO DES FORCES INTERNES C CALL ZERO(XFORC,1,LRE) C MPTVAL=IVAMAT DO IC=1,NMATT IF(IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF END DO C CALL MAPALU(NMATT,WORK,BPSS,IDIM) C C ON CHERCHE LES CONTRAINTES - C MPTVAL=IVASTR IE=0 DO 7110 ICOMP=1,NSTRS IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) XSTRS(IE)=VELCHE(1,IBMN) 7110 CONTINUE C C ON CALCULE LES FORCES INTERNES C CALL INTJOI(XSTRS,XFORC,NSTRS) C C ON PASSE LES CONTRAINTES DANS LE REPERE GLOBAL C IAW1 = 101 IAW2=IAW1+LRE CALL JOIGLV(XFORC,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM) C C RANGEMENT DANS MELVAL C IE=0 MPTVAL=IVAFOR DO 9110 IGAU=1,NBNN DO 9110 ICOMP=1,NFOR IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9110 CONTINUE 3110 CONTINUE SEGSUP WRK1,WRK3,WRK4 GO TO 510 c_______________________________________________________________________ c c element tuyo c_______________________________________________________________________ c 96 CONTINUE NBBB=NBNN SEGINI WRK1,WRK3 c DO 3096 IB=1,NBELEM c c on cherche les coordonnees des noeuds de l elementib c CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) c c il faudrait aussi modifier le vecteur local de la poutre c c c mise a zero des forces internes c CALL ZERO(XFORC,1,LRE) c c rangement des caracteristiques dans work c MPTVAL=IVACAR DO 6096 IC=1,NCARR IF (IVAL(IC).NE.0) THEN MELVAL=IVAL(IC) IBMN=MIN(IB,VELCHE(/2)) WORK(IC)=VELCHE(1,IBMN) ELSE WORK(IC)=0.D0 ENDIF 6096 CONTINUE c c cas ou on a lu le mot vecteur c IF (IVECT.EQ.1) THEN IF (IVAL(NCARR).NE.0) THEN MELVAL=IVAL(NCARR) IBMN=MIN(IB,IELCHE(/2)) IP=IELCHE(1,IBMN) IREF=(IP-1)*(IDIM+1) DO 6196 IC=1,IDIM WORK(NCARR+IC-1)=XCOOR(IREF+IC) 6196 CONTINUE ELSE DO 6296 IC=1,IDIM WORK(NCARR+IC-1)=0.D0 6296 CONTINUE ENDIF c c cas du chamelem comverti c ELSE IF (IVECT.EQ.2) THEN DO 6496 IC=1,IDIM MELVAL=IVAL(NCARR+IC-3) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) WORK(NCARR+IC-3)=VELCHE(1,IBMN) ELSE WORK(NCARR+IC-3)=0.D0 ENDIF 6496 CONTINUE ENDIF c c c cas des tuyaux - on calcule les caracteristiques de la poutre c equivalente c IF(MELE.EQ.42) THEN CISA=WORK(4) VX =WORK(5) VY =WORK(6) VZ =WORK(7) CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,0) ENDIF IF (KERRE.EQ.77) THEN CALL ERREUR(77) GOTO 510 ENDIF c c on cherche les contraintes - c MPTVAL=IVASTR IE=9 DO 7096 IGAU=1,2 DO 7096 ICOMP=1,NSTRS IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) WORK(IE)=VELCHE(IGMN,IBMN) 7096 CONTINUE c c on calcule les forces internes c CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE) IF(KERRE.EQ.0) GO TO 5096 INTERR(1)=ISOUS INTERR(2)=IB SEGSUP WRK1,WRK3 CALL ERREUR(128) GO TO 510 5096 CONTINUE c c rangement dans melval c IE=0 MPTVAL=IVAFOR DO 9096 IGAU=1,NBNN DO 9096 ICOMP=1,NFOR IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFORC(IE) 9096 CONTINUE 3096 CONTINUE SEGSUP WRK1,WRK3 GO TO 510 C_______________________________________________________________________ C C ELEMENTS ZONE_COHESIVE ZOC2,ZOC3,ZOC4 C_______________________________________________________________________ C 266 CONTINUE NDIM = 2 IF(IFOUR.GT.0) NDIM = 3 NBBB=NBNN SEGINI WRK1,WRK2,WRK4 C DO 3266 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C MISE A ZERO DES FORCES INTERNES C CALL ZERO(XFORC,1,LRE) C C BOUCLE SUR LES POINTS DE GAUSS C DO 6266 IGAU=1,NBPGAU C CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS) C CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT, . NSTRS,NBNN,LRE,MELE,SHPWRK,BGENE,DJAC,IERT) IF (IERT.NE.0) THEN INTERR(1)=IB CALL ERREUR(612) GOTO 99266 ENDIF C C ON CHERCHE LES CONTRAINTES - C MPTVAL=IVASTR DO 7266 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 7266 CONTINUE C C ON CALCULE B*EFFORTS C DJAC=DJAC*POIGAU(IGAU) CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC) 6266 CONTINUE C C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL C IE=0 MPTVAL=IVAFOR C DO 9266 NODE=1,NBNN DO 9266 ICOMP=1,NDIM IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(NODE,IBMN)=XFORC(IE) 9266 CONTINUE 3266 CONTINUE 99266 CONTINUE SEGSUP WRK1,WRK2,WRK4 GOTO 510 c_______________________________________________________________________ 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='BSIGMA' CALL ERREUR(86) * 510 CONTINUE RETURN END