C BSIGM1 SOURCE CHAT 11/03/16 21:15:48 6902 SUBROUTINE BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR, & IPMINT,IVACAR,IPORE,LHOOK,NFOR,IVAFOR,ADPG,BDPG,CDPG & , IIPDPG,NCAR1) *---------------------------------------------------------------------- * ______________________________ * * | | * * | CALCUL DES FORCES AUX NOEUDS| * * |______________________________| * * * * massif, poreux, incompressibles * * * *---------------------------------------------------------------------* * * * ENTREES : * * ________ * * * * IPMAIL Pointeur sur un segment MELEME ACTIF E/S * * LRE Nombre de ddl dans la matrice de rigidite * * NSTRS Nombre de composante de contraintes/deformations * * NBPGAU Nombre de points d'integration pour les contraintes * * MELE Numero de l'element fini * * MFR Numero de la formulation * * IVASTR pointeur sur un segment MPTVAL contenant les * * les melvals de contraints * * IPMINT Pointeur sur un segment MINTE ACTIF E/S * * IVACAR pointeur sur un segment MPTVAL de caracteristiques * * IPORE Nombre de fonctions de forme * * LHOOK Taille de la matrice de hooke * * NFOR Nombre de composantes de forces * * * * SORTIES : * * ________ * * * * IVAFOR pointeur sur un segment MPTVAL contenant les * * les melvals de forces * * * * ADPG forces aux noeud support des * * BDPG deformations planes generalisees * * CDPG * * * *---------------------------------------------------------------------* IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC CCREEL -INC CCHAMP -INC CCGEOME -INC SMCHAML -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE C SEGMENT MWRK1 REAL*8 XFORC(LRE), XFINC(LRE),XSTRS(NSTRS), XE(3,NBBB) REAL*8 SHPWRK(6,NBNO), BGENE(LHOOK,LRE) ENDSEGMENT * SEGMENT MWRK3 REAL*8 BPSS(3,3),XEL(3,NBBB) ENDSEGMENT * SEGMENT MWRK5 REAL*8 XGENE(NSTN,LRN) ENDSEGMENT * segment mwrk67 real*8 valcar(nca1) endsegment * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * CHARACTER*8 CMATE,CELEM DIMENSION A(4,60),BB(3,60),xatef1(3,3) logical drend * MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * IDECAP=0 NHRM=NIFOUR IELE=NUMGEO(MELE) * MINTE=IPMINT 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 GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99, 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99, 4,99,99,79,79, 4 79,79,79,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 5 99,99,99,99,99,99,99,80,80,80, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 6 4, 4),MELE * IF (MELE.EQ.183.OR.MELE.EQ.184.OR. . MELE.EQ.193.OR.MELE.EQ.194) GOTO 4 IF(MELE.GE.173.AND.MELE.LE.182) GO TO 173 * GOTO 99 C_______________________________________________________________________ C C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET ELEMENTS INCOMPRESSIBLES C_______________________________________________________________________ C 4 CONTINUE DIM3=1.D0 NBNO=NBNN NBBB=NBNN C C INTRODUCTION DES COORD DU POINT AUTOUR DUQUEL SE FAIT LE C MOUVEMENT DE LA SECTION EN DEFO PLANE GENERALISEE C Pas de rotation en 1D C ET INITIALISATION DES FORCES AU NOEUD SUPPORT DE LA DEFO C PLANE GENERALISEE C ADPG=XZero BDPG=XZero CDPG=XZero IF (IFOUR.EQ.-3)THEN IP=IIPDPG IREF=(IP-1)*(IDIM+1) XDPGE=XCOOR(IREF+1) YDPGE=XCOOR(IREF+2) ELSE XDPGE=XZero YDPGE=XZero ENDIF C SEGINI MWRK1 mwrk67=0 DO 3004 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 0 DES FORCES C CALL ZERO(XFINC,1,LRE) C C CALCUL DES COEFF DE MODIFICATION DE LA MATRICE B-BARRE (INCOMPRES) C IF (MFR.EQ.31) THEN CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU, 1 POIGAU,QSIGAU,ETAGAU,DZEGAU,NSTRS, 2 LRE,IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE) ENDIF C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 5004 IGAU=1,NBPGAU C C RECUPERATION DE L'EPAISSEUR C IF (IFOUR.EQ.-2)THEN MPTVAL=IVACAR IF (IVACAR.NE.0) THEN MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) DIM3=VELCHE(IGMN,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF ENDIF * CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3, 2 XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) IF (DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 9904 ENDIF IF (DJAC.LT.0.D0) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) C En cas d'elements incompressibles : BGENE selon la methode B-BARRE IF (MFR.EQ.31) THEN CALL BBAR(IGAU,NBPGAU, POIGAU,QSIGAU,ETAGAU,DZEGAU, & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE) ENDIF C C ON CHERCHE LES CONTRAINTES C MPTVAL=IVASTR DO 6004 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 6004 CONTINUE C C CALCUL DE B*SIGMA C * initialise CALL ZERO(XFORC,1,LRE) * contribution point d integration CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC) * matrice d'efficacite drend = .false. MPTVAL=IVACAR IF (IVACAR.GT.0) THEN segact mptval nca1 = ival(/1) if (mwrk67.eq.0) segini mwrk67 if (nca1.ne.valcar(/1)) segadj mwrk67 celem = 'MASSIF ' IF(IVAL(NCAR1).GT.0.OR.IVAL(NCAR1+1).GT.0) THEN DO 9008 IM= 1,IVAL(/1) IF (IVAL(IM).GT.0) THEN MELVAL=IVAL(IM) IF (TYVAL(IM).EQ.'REAL*8') THEN IBMN=MIN(IB ,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) VALCAR(IM)=VELCHE(IGMN,IBMN) ELSE IBMN=MIN(IB ,IELCHE(/2)) IGMN=MIN(IGAU,IELCHE(/1)) VALCAR(IM)=IELCHE(IGMN,IBMN) ENDIF ELSE VALCAR(IM)=0.D0 ENDIF 9008 CONTINUE nstep = 2 if (ifour.eq.2) nstep = 3 if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then drend = .true. do i = 1,nstep do j = 1, nstep xatef1(i,j) = 0.d0 enddo xatef1(i,i) = valcar(ncar1) enddo endif if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then drend = .false. do i = 1,nstep do j = 1, nstep xatef1(i,j) = 0.d0 enddo xatef1(1,1) = valcar(ncar1+7) xatef1(2,2) = valcar(ncar1+8) if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9) enddo endif call effi3(valcar,tyval,nca1,ncar1,xforc,lre,ib,igau,xatef1, & nstep,drend,celem) ENDIF ENDIF * stocke do ii = 1,LRE xfinc(ii) = xfinc(ii) + xforc(ii) enddo * 5004 CONTINUE IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) GOTO 9904 ENDIF C C EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE C ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT C AU NOEUD NSDPGE C NFOFO=NFOR IF (IFOUR.EQ.-3) THEN NFOFO=NFOR-3 ADPG=ADPG+XFINC(NBNN*NFOFO+1) BDPG=BDPG+XFINC(NBNN*NFOFO+2) CDPG=CDPG+XFINC(NBNN*NFOFO+3) ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ.9.OR. . IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN NFOFO=NFOR-1 ADPG=ADPG+XFINC(NBNN*NFOFO+1) ELSE IF (IFOUR.EQ.11) THEN NFOFO=NFOR-2 ADPG=ADPG+XFINC(NBNN*NFOFO+1) BDPG=BDPG+XFINC(NBNN*NFOFO+2) ENDIF C C ON RANGE XFORC DANS MELVAL C IE=0 MPTVAL=IVAFOR DO 7004 IGAU=1,NBNN DO 7004 ICOMP=1,NFOFO IE=IE+1 MELVAL=IVAL(ICOMP) IBMN=MIN(IB ,VELCHE(/2)) VELCHE(IGAU,IBMN)=XFINC(IE) 7004 CONTINUE 3004 CONTINUE 9904 CONTINUE SEGSUP MWRK1 if (mwrk67.ne.0) segsup mwrk67 GOTO 510 C__________________________________________________________________ C_______________________________________________________________________ C C MILIEUX POREUX C_______________________________________________________________________ C 79 CONTINUE C C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS C NBNO = NOMBRE DE FONCTIONS DE FORME C DIM3=1.D0 NBNO=IPORE NBBB=NBNN LRN = NBNO-NBBB LRB=LRE-LRN * NSTN=1 SEGINI MWRK1,MWRK5 C DO 3079 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 0 DES FORCES C CALL ZERO(XFORC,1,LRE) C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 5079 IGAU=1,NBPGAU C C RECUPERATION DE L'EPAISSEUR C IF (IFOUR.EQ.-2)THEN MPTVAL=IVACAR IF (IVACAR.NE.0) THEN MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) DIM3=VELCHE(IGMN,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF ENDIF C CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM, . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1) IF (DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 9979 ENDIF IF(DJAC.LT.0.) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) C C ON CHERCHE LES CONTRAINTES C MPTVAL=IVASTR DO 6079 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 6079 CONTINUE C C CALCUL DE B*SIGMA C CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC) * ON AJOUTE LES TERMES EN FP * SIGNE - POUR ETRE COHERENT AVEC RIGI * r_z = XSTRS(NSTRS)*DJAC DO 6179 J=1,LRN JJ=LRB+J XFORC(JJ)=XFORC(JJ) - r_z*XGENE(1,J) 6179 CONTINUE * 5079 CONTINUE IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) GOTO 9979 ENDIF C C ON RANGE XFORC DANS MELVAL C D'ABORD LES FORCES PUIS LES DEBITS C IE=0 MPTVAL=IVAFOR DO 7079 IGAU=1,NBNN DO 7079 ICOMP=1,NFOR-1 IE=IE+1 MELVAL=IVAL(ICOMP) VELCHE(IGAU,IB)=XFORC(IE) 7079 CONTINUE * DO 7179 IGAU=1,NBSOM(IELE) IE=IE+1 MELVAL=IVAL(NFOR) IGAV = IBSOM(NSPOS(IELE)+IGAU-1) VELCHE(IGAV,IB)=XFORC(IE) 7179 CONTINUE * 3079 CONTINUE 9979 CONTINUE SEGSUP MWRK1,MWRK5 GOTO 510 C_______________________________________________________________________ C__________________________________________________________________ C C MILIEUX POREUX - SUITE C_______________________________________________________________________ C 173 CONTINUE C C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS C NBNO = NOMBRE DE FONCTIONS DE FORME C DIM3=1.D0 NBNO=IPORE NBBB=NBNN IF(MELE.GE.173.AND.MELE.LE.177) THEN IDECAP = 2 ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN IDECAP = 3 ENDIF * NSTN=IDECAP LPP = NBNO-NBBB LRN=IDECAP*LPP LRB=LRE-LRN SEGINI MWRK1,MWRK5 C DO 3173 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 0 DES FORCES C CALL ZERO(XFORC,1,LRE) C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 5173 IGAU=1,NBPGAU C C RECUPERATION DE L'EPAISSEUR C IF (IFOUR.EQ.-2)THEN MPTVAL=IVACAR IF (IVACAR.NE.0) THEN MELVAL=IVAL(1) IF (MELVAL.NE.0) THEN IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) DIM3=VELCHE(IGMN,IBMN) ELSE DIM3=1.D0 ENDIF ENDIF ENDIF C CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM, & DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,1) IF (DJAC.EQ.0.D0) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 99173 ENDIF IF(DJAC.LT.0.) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) C C ON CHERCHE LES CONTRAINTES C MPTVAL=IVASTR DO 6173 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 6173 CONTINUE C C CALCUL DE B*SIGMA C CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC) * * ON AJOUTE LES TERMES EN FP * SIGNE - POUR ETRE COHERENT AVEC RIGI * DO 6273 IPR=1,IDECAP IPR1=(IPR-1)*LPP IPR2=NSTRS-IDECAP+IPR r_z = XSTRS(IPR2) * DJAC DO 6373 J=1,LPP JJ=LRB+IPR1+J XFORC(JJ)=XFORC(JJ)- r_z * XGENE(IPR,IPR1+J) 6373 CONTINUE 6273 CONTINUE * 5173 CONTINUE IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) GOTO 99173 ENDIF C C ON RANGE XFORC DANS MELVAL C D'ABORD LES FORCES PUIS LES DEBITS C IE=0 MPTVAL=IVAFOR DO 7173 IGAU=1,NBNN DO 7173 ICOMP=1,NFOR-IDECAP IE=IE+1 MELVAL=IVAL(ICOMP) VELCHE(IGAU,IB)=XFORC(IE) 7173 CONTINUE * DO 7273 IPR=1,IDECAP IPR1=NFOR-IDECAP+IPR DO 7373 IGAU=1,NBSOM(IELE) IE=IE+1 MELVAL=IVAL(IPR1) IGAV = IBSOM(NSPOS(IELE)+IGAU-1) VELCHE(IGAV,IB)=XFORC(IE) 7373 CONTINUE 7273 CONTINUE * 3173 CONTINUE * 99173 CONTINUE SEGSUP MWRK1,MWRK5 GOTO 510 C__________________________________________________________________ C_______________________________________________________________________ C C JOINTS EN FORMULATION MILIEUX POREUX C_______________________________________________________________________ C 80 CONTINUE C C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS C NBNO = NOMBRE DE FONCTIONS DE FORME C NBNO=IPORE NBBB=NBNN LRN=(NBNO-NBBB)*3/2 LRB=LRE-LRN NSTN=1 NFAC=(3*NBBB-NBNO)/2 NMIL=LRN-NBSOM(IELE) SEGINI MWRK1,MWRK3,MWRK5 I195=0 I259=0 C DO 3080 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 CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES C CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS) C C MISE A 0 DES FORCES C CALL ZERO(XFORC,1,LRE) C C BOUCLE SUR LES POINTS DE GAUSS C ISDJC=0 DO 5080 IGAU=1,NBPGAU C CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL, . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1) IF (DJAC.EQ.0.) THEN INTERR(1)=IB CALL ERREUR(259) GOTO 9980 ENDIF IF(DJAC.LT.0.) ISDJC=ISDJC+1 DJAC=ABS(DJAC)*POIGAU(IGAU) C C ON CHERCHE LES CONTRAINTES C MPTVAL=IVASTR DO 6080 ICOMP=1,NSTRS MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 6080 CONTINUE C C CALCUL DE B*SIGMA C CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC) * * ON AJOUTE LES TERMES EN FP * SIGNE - POUR ETRE COHERENT AVEC RIGI * r_z = XSTRS(NSTRS)*DJAC DO 6180 J=1,LRN JJ=LRB+J XFORC(JJ)=XFORC(JJ)-XGENE(1,J)*r_z 6180 CONTINUE 5080 CONTINUE IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) GOTO 9980 ENDIF C C ON RANGE XFORC DANS MELVAL C D'ABORD LES FORCES PUIS LES DEBITS C IE=0 MPTVAL=IVAFOR DO 7080 IGAU=1,NFAC DO 7080 ICOMP=1,NFOR-1 IE=IE+1 MELVAL=IVAL(ICOMP) VELCHE(IGAU,IB)=XFORC(IE) 7080 CONTINUE * * debits ( d'abord sommets puis mileux des cotes ad-hoc ) * MELVAL=IVAL(NFOR) DO 7180 IGAU=1,NBSOM(IELE) IE=IE+1 IGAV = IBSOM(NSPOS(IELE)+IGAU-1) C* VELCHE(IGAV,IB)=XFORC(IE)*0.D0 VELCHE(IGAV,IB)=0.D0 7180 CONTINUE * DO 7181 IGAU=1,NMIL IE=IE+1 IGAV = NBBB - NMIL +IGAU VELCHE(IGAV,IB)=XFORC(IE) 7181 CONTINUE * 3080 CONTINUE 9980 CONTINUE SEGSUP MWRK1,MWRK3,MWRK5 GOTO 510 C 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='BSIGMA' CALL ERREUR(86) C 510 CONTINUE RETURN END