Esope source files

   1 : C LSIGM1    SOURCE    CHAT      11/03/16    21:27:05     6902           
   2 :       SUBROUTINE LSIGM1(IPMAIL,LRE,NSTRS,NBPGAC,MELE,MELEM,IPCHE1,
   3 :      &IPMITC,NFOR,IVAFOR,ISOUS,ISOU1,IMMD,NNUMS)
   4 : C======================================================================C
   5 : C                                                                      C
   6 : C         CALCUL DES FORCES AUX NOEUDS DUE AUX PRECONTRAINTES          C
   7 : C                                                                      C
   8 : C                                                                      C
   9 : C     INPUT:                                                           C
  10 : C                                                                      C
  11 : C         IPMAIL   Pointeur sur un segment  MELEME   tube beton
  12 : C         LRE      Nombre de ddl dans la matrice de rigidite           C
  13 : C         NSTRS    Nombre de composante de contraintes/deformations    C
  14 : C         NBPGAC   Nombre de points d'integration pour les contraintes C
  15 : C         MELE     Numero de l'element fini                            C
  16 : C         MELEM identificateur cable normal on circonferentiel         C
  17 : C         IVASTR   pointeur sur un segment MPTVAL contenant les        C
  18 : C                  les melvals de contraintes  (cables)                C
  19 : C         IPMITC   Pointeur sur un segment MINTE (CABLE)               C
  20 : C         NFOR     Nombre de composantes de forces                     C
  21 : C                                                                      C
  22 : C     OUTPUT:                                                          C
  23 : C                                                                      C
  24 : C         IVAFOR   pointeur sur un segment MPTVAL contenant les        C
  25 : C                  les melvals de forces                               C
  26 : C                                                                      C
  27 : C     G. L. JIANG    / remanié JM BAZE  09/97                                                  C
  28 : C======================================================================C
  29 : C
  30 :       IMPLICIT INTEGER(I-N)
  31 :       IMPLICIT REAL*8(A-H,O-Z)
  32 : C
  33 : -INC CCOPTIO
  34 : -INC CCHAMP
  35 : -INC SMCHAML
  36 : -INC SMCHPOI
  37 : -INC SMELEME
  38 : -INC SMCOORD
  39 : -INC SMMODEL
  40 : -INC SMINTE
  41 : -INC CCREEL
  42 : *- 
  43 : C
  44 :       SEGMENT WRK1
  45 :        REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB)
  46 :        REAL*8 XEC(3,2),QSIG(6),XX(3,2),SHPC(6,20,5),SGA(3,5,5)
  47 :        REAL*8 XTR(5),shpk(6,20,5),qqq(3)
  48 :       ENDSEGMENT
  49 :       segment wrk2
  50 :       integer iv(10)
  51 :       endsegment
  52 : C
  53 :       SEGMENT MPTVAL
  54 :         INTEGER IPOS(NS)    ,NSOF(NS)
  55 :         INTEGER      IVAL(NCOSOU)
  56 :         CHARACTER*16 TYVAL(NCOSOU)
  57 :       ENDSEGMENT
  58 : C
  59 :       SEGMENT NNUM
  60 :         INTEGER NNM(NBN,NBELE),NBEM(2,NBELE)
  61 :       ENDSEGMENT
  62 : C
  63 : C      DIMENSION XEC(3,2),QSIG(6),XX(3,2),SHPC(6,20,5),SGA(3,5,5),
  64 : C     &          IV(10),XTR(5),shpk(6,20,5),qqq(3)
  65 : C
  66 : C
  67 :       NSTRS=0
  68 :       MELEME=IPMAIL
  69 :       NBNN=NUM(/1)
  70 :       NBELEM=NUM(/2)
  71 :       NNUM=NNUMS
  72 :       SEGACT NNUM
  73 :       NBN=NNM(/1)
  74 :       NBELE=NNM(/2)
  75 :       MINTE=IPMITC
  76 :       SEGACT MINTE
  77 :       NBPGAC=POIGAU(/1)
  78 :       NBBB=NBNN
  79 :       MCHELM=IPCHE1
  80 :       SEGACT MCHELM
  81 :       MCHAML=ICHAML(ISOU1)
  82 :       SEGACT MCHAML
  83 :       NSTRS=IELVAL(/1)
  84 :       SEGINI WRK1
  85 :       DO 5001 I=1,NBPGAC
  86 :  5001 QSIG(I)=QSIGAU(I)
  87 : C
  88 :       NHRM=NIFOUR
  89 :       segini wrk2
  90 : C
  91 :       NJS=IELVAL(/1)
  92 :       DO 2014 IS=1,NJS
  93 : 2014  IV(IS)=IELVAL(IS)
  94 : C
  95 : C --- SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS
  96 : C
  97 :       NBNO=NBNN
  98 :       NBBB=NBNN
  99 : 
 100 :       mptval=ivafor
 101 : 
 102 : 
 103 : 
 104 :       DO 3005 IC=1,NBELE
 105 :       IF(NBEM(2,IC).NE.ISOUS) GOTO 3005
 106 : C --- IB: LE NUMERO D'ELEMENT BETON CONTENANT LE SEGMENT DU CABLE IC
 107 :       IB=NBEM(1,IC)
 108 : C --- MISE A 0 DES FORCES
 109 : 
 110 :       do 5 i=1,lre
 111 :       XFORC(i) = 0.D0
 112 :  5    continue
 113 : C
 114 : C --- CABLES NON-CIRCONFERENTIELS
 115 : C
 116 :       IF(MELEM.NE.95) THEN
 117 : 
 118 : C
 119 : C --- ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
 120 : 
 121 : 
 122 : C
 123 : C      write(6,*) 'cable ', ic ,nnm(1,ic),nnm(2,ic)
 124 : C      write(6,*) 'beton ', ib , 'noeuds' ,(NUM(j,IB),j=1,NUM(/1))
 124 :       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
 124 :       CALL DOXE(XCOOR,IDIM,nbn   ,NNM,IC,XEC)
 124 :       CALL SHPCAB(NBPGAC,XE,XEC,MELE,NBNN,IDIM,QSIG,SHPC,XX,SGA,1)
 125 : 
 126 : 
 127 : 
 128 : 
 129 : 
 130 : C --- BOUCLE SUR LES POINTS DE GAUSS
 131 :       DO 5004 IGAU=1,NBPGAC
 132 : C
 133 : C --- ON CHERCHE LES CONTRAINTES
 134 : C
 135 :       DO 6004 ICOMP=1,NSTRS
 136 :         MELVAL=IV(ICOMP)
 137 :         SEGACT MELVAL
 138 :         IGMN=MIN(IGAU,VELCHE(/1))
 139 :         IBMN=MIN(IC  ,VELCHE(/2))
 140 :         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
 141 :  6004 CONTINUE
 142 : C      write(6,*)  ' les contraintes generalisees'
 143 : C      write(6,6789) (XSTRS(ICOMP),icomp=1,NSTRS )
 144 : 6789  format (2E12.5)
 145 : C
 146 : C
 147 : 
 148 : *      ID0=3
 149 : *      IF(IDIM.EQ.3) ID0=4
 150 : *      DJ=SGA(1,5,IGAU)
 151 : 
 152 :       do 100 ii=1,nbnn
 153 :       mw=(ii-1)*idim
 154 : c --- block ii
 155 :       ff=0.d0
 156 :       do 20 ilin=1,idim
 157 :       ff=ff + shpc(ilin+1,ii,igau)*sga(ilin,3,igau)*xstrs(1)
 158 :   20  continue
 159 :       do 21 ilin =1,idim
 160 :   21  xforc(mw+ilin) = xforc(mw+ilin) + ff*sga(ilin,4,igau)
 161 :  100  continue
 162 : 
 163 :  5004 CONTINUE
 164 : 
 165 :  3333 FORMAT(6E12.5)
 166 : 
 167 : C      DO 6032 MQ=1,LRE
 168 : C      XFOR(MQ,IB)=XFOR(MQ,IB)+XFORC(MQ)
 169 : C 6032 continue
 170 : C      write(6,*) ' element beton ' ,ib ,' cable ', ic
 171 : C       write(6,6799) (xforc(i),i=1,lre)
 172 : * 3005 CONTINUE
 173 : 6799  format(3E12.5,4X,3E12.5)
 174 :       END IF
 175 : C
 176 : C --- CABLES CIRCONFERENTIELS
 177 : C
 178 :       IF(MELEM.EQ.95) THEN
 179 :       DO 213 JWQ=1,5
 180 :   213 XTR(JWQ)=0.D0
 181 : C
 182 : C --- ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IC
 183 : C      write(6,*) 'cable ', ic , 'noeuds' , nnm(1,IC)
 184 : C      write(6,*) 'beton ', ib , 'noeuds' ,(NUM(j,IB),j=1,NUM(/1))
 185 : 
 185 :       CALL DOXE(XCOOR,IDIM,nbn ,NNM,IC,XEC)
 185 :       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE )
 186 : C      write(6,*) 'cable' , (xec(i,1),i=1,idim)
 187 : C      write(6,4444) ((xe(i,j),i=1,idim),j=1,nbnn)
 188 : 4444  format( 3E12.5)
 188 : C      CALL SHPCAB(1,XE,XEC,MELE,NBNN,IDIM,QSIG,SHPC,XX,SGA,1)
 188 :       call qsijs(XE,MELE,NBNN,2,XEC,SHPK,QQQ,irout)
 189 : C --- PRECONTRAINTE DU CABLE: PROG(MV*3)
 190 : 
 191 :       DO 7044 ICOMP=1,NSTRS
 192 :         MELVAL=IV(ICOMP)
 193 :         SEGACT MELVAL
 194 :         IGMN=MIN(1 ,VELCHE(/1))
 195 :         IBMN=MIN(IC,VELCHE(/2))
 196 :         XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
 197 :  7044 CONTINUE
 198 : 
 199 :       ff= xstrs(1)*2.D0*XPI
 200 : 
 201 : C      write (6,*) ' force generalisee' , ff , xec(1,1)
 202 :       do 110 ii=1,nbnn
 203 : *      write(6,*) ' shpc et ff ' ,shpc(1,ii,1)
 204 : *      write(6,*) ' shpk ' ,shpk(1,ii,1)
 205 :       mw=(ii-1)*idim+1
 206 : *      do 121 ilin =1,idim
 207 :        xforc(mw) = xforc(mw) + ff*shpk(1,ii,1)
 208 : *  121  continue
 209 :  110  continue
 210 : 
 211 : C      write(6,*) (xforc(i),i=1,lre)
 212 :       END IF
 213 : 
 214 : 
 215 : C
 216 : C --- ON RANGE XFORC DANS MELVAL
 217 : C
 218 : 
 219 :       do 7004 inoe=1,nbnn
 220 :       mwi = (inoe-1) * nfor
 221 :       do 7004 icomp=1,nfor
 222 :       mwi = mwi+1
 223 :       MELVAL=IVAL(ICOMP)
 224 :       velche(inoe,ib)=velche(inoe,ib)+xforc(mwi)
 225 :  7004 CONTINUE
 226 : 
 227 :  3005 continue
 228 :       do 7005 i =1,nfor
 229 :       melval=ival(i)
 230 :       segdes melval
 231 : 7005  continue
 232 :       segdes NNUM,MCHAML,MCHELM
 233 :       SEGSUP WRK1,wrk2
 234 : 
 235 :       END
 236 : 
 237 : 
 238 : 
 239 : 
 240 : 
 241 :  
 242 :  
 243 :  
 244 :  
 245 :  
 246 :  
 247 :  
 248 :  
 249 :  
 250 :  
 251 :  
 252 :