C LSIGM1 SOURCE CHAT 11/03/16 21:27:05 6902 SUBROUTINE LSIGM1(IPMAIL,LRE,NSTRS,NBPGAC,MELE,MELEM,IPCHE1, &IPMITC,NFOR,IVAFOR,ISOUS,ISOU1,IMMD,NNUMS) C======================================================================C C C C CALCUL DES FORCES AUX NOEUDS DUE AUX PRECONTRAINTES C C C C C C INPUT: C C C C IPMAIL Pointeur sur un segment MELEME tube beton C LRE Nombre de ddl dans la matrice de rigidite C C NSTRS Nombre de composante de contraintes/deformations C C NBPGAC Nombre de points d'integration pour les contraintes C C MELE Numero de l'element fini C C MELEM identificateur cable normal on circonferentiel C C IVASTR pointeur sur un segment MPTVAL contenant les C C les melvals de contraintes (cables) C C IPMITC Pointeur sur un segment MINTE (CABLE) C C NFOR Nombre de composantes de forces C C C C OUTPUT: C C C C IVAFOR pointeur sur un segment MPTVAL contenant les C C les melvals de forces C C C C G. L. JIANG / remanié JM BAZE 09/97 C C======================================================================C C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE -INC CCREEL *- C SEGMENT WRK1 REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB) REAL*8 XEC(3,2),QSIG(6),XX(3,2),SHPC(6,20,5),SGA(3,5,5) REAL*8 XTR(5),shpk(6,20,5),qqq(3) ENDSEGMENT segment wrk2 integer iv(10) endsegment C SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT C SEGMENT NNUM INTEGER NNM(NBN,NBELE),NBEM(2,NBELE) ENDSEGMENT C C DIMENSION XEC(3,2),QSIG(6),XX(3,2),SHPC(6,20,5),SGA(3,5,5), C & IV(10),XTR(5),shpk(6,20,5),qqq(3) C C NSTRS=0 MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) NNUM=NNUMS SEGACT NNUM NBN=NNM(/1) NBELE=NNM(/2) MINTE=IPMITC SEGACT MINTE NBPGAC=POIGAU(/1) NBBB=NBNN MCHELM=IPCHE1 SEGACT MCHELM MCHAML=ICHAML(ISOU1) SEGACT MCHAML NSTRS=IELVAL(/1) SEGINI WRK1 DO 5001 I=1,NBPGAC 5001 QSIG(I)=QSIGAU(I) C NHRM=NIFOUR segini wrk2 C NJS=IELVAL(/1) DO 2014 IS=1,NJS 2014 IV(IS)=IELVAL(IS) C C --- SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS C NBNO=NBNN NBBB=NBNN mptval=ivafor DO 3005 IC=1,NBELE IF(NBEM(2,IC).NE.ISOUS) GOTO 3005 C --- IB: LE NUMERO D'ELEMENT BETON CONTENANT LE SEGMENT DU CABLE IC IB=NBEM(1,IC) C --- MISE A 0 DES FORCES do 5 i=1,lre XFORC(i) = 0.D0 5 continue C C --- CABLES NON-CIRCONFERENTIELS C IF(MELEM.NE.95) THEN C C --- ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB C C write(6,*) 'cable ', ic ,nnm(1,ic),nnm(2,ic) C write(6,*) 'beton ', ib , 'noeuds' ,(NUM(j,IB),j=1,NUM(/1)) CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) CALL DOXE(XCOOR,IDIM,nbn ,NNM,IC,XEC) CALL SHPCAB(NBPGAC,XE,XEC,MELE,NBNN,IDIM,QSIG,SHPC,XX,SGA,1) C --- BOUCLE SUR LES POINTS DE GAUSS DO 5004 IGAU=1,NBPGAC C C --- ON CHERCHE LES CONTRAINTES C DO 6004 ICOMP=1,NSTRS MELVAL=IV(ICOMP) SEGACT MELVAL IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IC ,VELCHE(/2)) XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 6004 CONTINUE C write(6,*) ' les contraintes generalisees' C write(6,6789) (XSTRS(ICOMP),icomp=1,NSTRS ) 6789 format (2E12.5) C C * ID0=3 * IF(IDIM.EQ.3) ID0=4 * DJ=SGA(1,5,IGAU) do 100 ii=1,nbnn mw=(ii-1)*idim c --- block ii ff=0.d0 do 20 ilin=1,idim ff=ff + shpc(ilin+1,ii,igau)*sga(ilin,3,igau)*xstrs(1) 20 continue do 21 ilin =1,idim 21 xforc(mw+ilin) = xforc(mw+ilin) + ff*sga(ilin,4,igau) 100 continue 5004 CONTINUE 3333 FORMAT(6E12.5) C DO 6032 MQ=1,LRE C XFOR(MQ,IB)=XFOR(MQ,IB)+XFORC(MQ) C 6032 continue C write(6,*) ' element beton ' ,ib ,' cable ', ic C write(6,6799) (xforc(i),i=1,lre) * 3005 CONTINUE 6799 format(3E12.5,4X,3E12.5) END IF C C --- CABLES CIRCONFERENTIELS C IF(MELEM.EQ.95) THEN DO 213 JWQ=1,5 213 XTR(JWQ)=0.D0 C C --- ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IC C write(6,*) 'cable ', ic , 'noeuds' , nnm(1,IC) C write(6,*) 'beton ', ib , 'noeuds' ,(NUM(j,IB),j=1,NUM(/1)) CALL DOXE(XCOOR,IDIM,nbn ,NNM,IC,XEC) CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE ) C write(6,*) 'cable' , (xec(i,1),i=1,idim) C write(6,4444) ((xe(i,j),i=1,idim),j=1,nbnn) 4444 format( 3E12.5) C CALL SHPCAB(1,XE,XEC,MELE,NBNN,IDIM,QSIG,SHPC,XX,SGA,1) call qsijs(XE,MELE,NBNN,2,XEC,SHPK,QQQ,irout) C --- PRECONTRAINTE DU CABLE: PROG(MV*3) DO 7044 ICOMP=1,NSTRS MELVAL=IV(ICOMP) SEGACT MELVAL IGMN=MIN(1 ,VELCHE(/1)) IBMN=MIN(IC,VELCHE(/2)) XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 7044 CONTINUE ff= xstrs(1)*2.D0*XPI C write (6,*) ' force generalisee' , ff , xec(1,1) do 110 ii=1,nbnn * write(6,*) ' shpc et ff ' ,shpc(1,ii,1) * write(6,*) ' shpk ' ,shpk(1,ii,1) mw=(ii-1)*idim+1 * do 121 ilin =1,idim xforc(mw) = xforc(mw) + ff*shpk(1,ii,1) * 121 continue 110 continue C write(6,*) (xforc(i),i=1,lre) END IF C C --- ON RANGE XFORC DANS MELVAL C do 7004 inoe=1,nbnn mwi = (inoe-1) * nfor do 7004 icomp=1,nfor mwi = mwi+1 MELVAL=IVAL(ICOMP) velche(inoe,ib)=velche(inoe,ib)+xforc(mwi) 7004 CONTINUE 3005 continue do 7005 i =1,nfor melval=ival(i) segdes melval 7005 continue segdes NNUM,MCHAML,MCHELM SEGSUP WRK1,wrk2 END