Esope source files

   1 : C AMOR2     SOURCE    FANDEUR   10/08/31    21:15:10     6735           
   2 :       SUBROUTINE AMOR2(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
   3 :      &  IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT,
   4 :      &  IPORE,NDDL,IPMATR,IIPDPG,NCAR1)
   5 : *---------------------------------------------------------------------*
   6 : *        _________________________________________                    *
   7 : *        |                                       |                    *
   8 : *        |  CALCUL DE LA MATRICE D AMORTISSEMENT |                    *
   9 : *        |_______________________________________|                    *
  10 : *                                                                     *
  11 : *        massif                                                       *
  12 : *                                                                     *
  13 : *---------------------------------------------------------------------*
  14 : *                                                                     *
  15 : *   ENTREES :                                                         *
  16 : *   ________                                                          *
  17 : *                                                                     *
  18 : *        MATE     Numero du materiau                                  *
  19 : *        MELE     Numero de l'element fini                            *
  20 : *        IPMAIL   Pointeur sur un segment  MELEME                     *
  21 : *        IPMINT   Pointeur sur un segment MINTE                       *
  22 : *        NBPGAU   Nombre de point d'integration pour la rigidite      *
  23 : *        LRE      Nombre de ddl dans la matrice de rigidite           *
  24 : *        NSTRS    Nombre de composante de contraintes/deformations    *
  25 : *        IVAMAT   Pointeur sur un segment MPTVAL pour le materiau ou  *
  26 : *                 pour une matrice de hooke                           *
  27 : *        IVACAR   Pointeur sur un segment MPTVAL de caractéristiques  *
  28 : *        CMATE    Nom du materiau                                     *
  29 : *        MFR      Numero de la formulation element fini               *
  30 : *        NBGMAT   Taille maxi des melval du materiau (pt de gauss)    *
  31 : *        NELMAT   Taille maxi des melval du materiau (No d'element)   *
  32 : *        IMAT     (2 il y a une matrice de HOOKE,1 non  )             *
  33 : *        NMATT    Nombre de composante de materiau (IMAT=1)           *
  34 : *        LHOOK    Dimension de la matrice de Hooke                    *
  35 : *        IPORE    Nombre de fonctions de forme                        *
  36 : *        NDDL     Nombre de degre de liberte                          *
  37 : *                                                                     *
  38 : *   SORTIES :                                                         *
  39 : *   ________                                                          *
  40 : *                                                                     *
  41 : *        IPMATR   pointeur sur la rigidite de la sous-zone            *
  42 : *                                                                     *
  43 : *---------------------------------------------------------------------*
  44 :       IMPLICIT INTEGER(I-N)
  45 :       IMPLICIT REAL*8(A-H,O-Z)
  46 : *
  47 : -INC CCOPTIO
  48 : -INC CCHAMP
  49 : -INC CCREEL
  50 : -INC SMCHAML
  51 : -INC SMINTE
  52 : -INC SMELEME
  53 : -INC SMRIGID
  54 : -INC SMCOORD
  55 : -INC SMLREEL
  56 : *
  57 :       SEGMENT,MWRK1
  58 :        REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK)
  59 :        REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB)
  60 :       ENDSEGMENT
  61 : *
  62 :       SEGMENT,MWRK2
  63 :        REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  64 :       ENDSEGMENT
  65 : *
  66 :       SEGMENT,MWRK8
  67 :        REAL*8 XLOC(IDIM,IDIM),XGLOB(IDIM,IDIM),TXR(IDIM,IDIM)
  68 :        REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK)
  69 :        ENDSEGMENT
  70 : *
  71 :       SEGMENT,MVELCH
  72 :          REAL*8 VALMAT(NV1)
  73 :       ENDSEGMENT
  74 : *
  75 :       segment,mwrk67
  76 :          real*8 valcar(nca1)
  77 :       endsegment
  78 : *
  79 :       SEGMENT MPTVAL
  80 :         INTEGER IPOS(NS)    ,NSOF(NS)
  81 :         INTEGER      IVAL(NCOSOU)
  82 :         CHARACTER*16 TYVAL(NCOSOU)
  83 :       ENDSEGMENT
  84 : *
  85 :       CHARACTER*8 CMATE,CELEM
  86 : 
  87 :       DIMENSION A(4,60),BB(3,60),xatef1(3,3)
  88 :       logical drend,BDPGE
  89 : *
  90 : *      WRITE (*,*) 'Entrée dans AMOR2.'
  91 : C*?      SEGACT MCOORD
  92 :       MELEME=IPMAIL
  93 :       NBNN=NUM(/1)
  94 :       NBELEM=NUM(/2)
  95 : *
  96 :       NV1=NMATT
  97 :       SEGINI,MVELCH
  98 : *
  99 :       XMATRI=IPMATR
 100 :       NLIGRP=LRE
 101 :       NLIGRD=LRE
 102 : *
 103 : *     INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
 104 : *     DE LA SECTION EN DEFO PLANE GENERALISEE
 105 : *     En 1D : pas de rotation
 106 :       IF (IFOUR.EQ.-3) THEN
 107 :         BDPGE=.TRUE.
 108 :         IREF=(IIPDPG-1)*(IDIM+1)
 109 :         XDPGE=XCOOR(IREF+1)
 110 :         YDPGE=XCOOR(IREF+2)
 111 :       ELSE IF ((IFOUR.GE.7.AND.IFOUR.LE.11).OR.IFOUR.EQ.14) THEN
 112 :         BDPGE=.TRUE.
 113 :         XDPGE=XZero
 114 :         YDPGE=XZero
 115 :       ELSE
 116 :         BDPGE=.FALSE.
 117 :         XDPGE=0.D0
 118 :         YDPGE=0.D0
 119 :       ENDIF
 120 : *
 121 :       NHRM=NIFOUR
 122 : *
 123 :       MINTE=IPMINT
 124 : C_______________________________________________________________________
 125 : C
 126 : C     NUMERO DES ETIQUETTES      :
 127 : C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
 128 : C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
 129 : C     5  CONTINUE
 130 : C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
 131 : C     44 CONTINUE
 132 : C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
 133 : C_______________________________________________________________________
 134 : C
 135 :       GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
 136 :      1      99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
 137 :      2      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
 138 :      3      99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99, 4,99,99,99,99,
 139 :      4      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
 140 :      5      99,99,99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
 141 :      6       4, 4),MELE
 142 : *
 143 :       IF (MELE.EQ.183.OR.MELE.EQ.184.OR.
 144 :      .    MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
 145 : 
 146 :       GOTO 99
 147 : C_______________________________________________________________________
 148 : C
 149 : C     SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET ELEMENTS INCOMPRESSIBLES
 150 : C_______________________________________________________________________
 151 : C
 152 :    4  CONTINUE
 153 :       DIM3=1.D0
 154 :       IRTD=1
 155 : *
 156 : *  CAS  ORTHOTROPE ( 2)  ANISOTROPE ( 3) UNIDIRECTIONNEL (4)
 157 : *
 158 :       IPMIN2=0
 159 :       IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
 160 :      1      .AND.IMAT.EQ.1)THEN
 161 : *  RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE
 162 : *  L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
 163 :         NLG=NUMGEO(MELE)
 163 :         CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1)
 164 :         MINTE2=IPMIN2
 165 :         SEGACT MINTE2
 166 :         SEGINI,MWRK8
 167 :       ENDIF
 168 :       NBNO=NBNN
 169 :       NBBB=NBNN
 170 :       SEGINI,MWRK1,MWRK2
 171 : 
 172 :       DO 3004  IB=1,NBELEM
 173 : C
 174 : C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
 175 : C
 175 :       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
 176 : C
 177 : C     CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE ,
 178 : C     ANISOTROPE  ET UNIDIRECTIONNEL
 179 : C
 180 : C*      IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
 181 : C*     1      .AND.IMAT.EQ.1)THEN
 182 :       IF (IPMIN2.NE.0) THEN
 183 :         NBSH=MINTE2.SHPTOT(/2)
 183 :         CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
 184 :         if (nbsh.eq.-1) then
 184 :          call erreur(525)
 185 :          GOTO 4999
 186 :         endif
 187 :       ENDIF
 188 : C
 188 :       CALL ZERO (RINT,LRE,LRE)
 189 : C
 190 : C     CALCUL DES COEFF DE MODIFICATION DE LA MATRICE B-BARRE
 191 : C     (Uniquement en cas d'elements incompressibles)
 192 :       IF (MFR.EQ.31) THEN
 193 : *        WRITE (*,*) 'Appel de BBCALC - IFOUR = ',IFOUR
 193 :         CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,POIGAU,
 194 :      1              QSIGAU,ETAGAU,DZEGAU,NSTRS,
 195 :      2              LRE,IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE)
 196 :       ENDIF
 197 : C
 198 : C     BOUCLE SUR LES POINTS DE GAUSS
 199 : C
 200 :       ISDJC=0
 201 :       DO 4004  IGAU=1,NBPGAU
 202 : C
 203 : C   RECUPERATION DE L'EPAISSEUR
 204 : C
 205 :       IF (IFOUR.EQ.-2)THEN
 206 :         MPTVAL=IVACAR
 207 :         IF (IVACAR.NE.0) THEN
 208 :          MELVAL=IVAL(1)
 209 :          IF (MELVAL.NE.0) THEN
 210 :           IGMN=MIN(IGAU,VELCHE(/1))
 211 :           IBMN=MIN(IB,VELCHE(/2))
 212 :           DIM3=VELCHE(IGMN,IBMN)
 213 :          ELSE
 214 :           DIM3=1.D0
 215 :          ENDIF
 216 :         ENDIF
 217 :       ENDIF
 218 : *
 218 :       CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
 219 :      1            MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE,
 220 :      2            SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
 221 :       IF (DJAC.EQ.0.D0) THEN
 222 :         INTERR(1)=IB
 222 :         CALL ERREUR(259)
 223 :         GOTO 4999
 224 :       ENDIF
 225 :       IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
 226 :       DJAC=ABS(DJAC)*POIGAU(IGAU)
 227 : 
 228 : C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
 229 :       IF (MFR.EQ.31) THEN
 229 :         CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
 230 :      &            MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
 231 :       ENDIF
 232 : C
 233 :       MPTVAL=IVAMAT
 234 :       IF(IMAT.EQ.2) THEN
 235 :         MELVAL=IVAL(1)
 236 :         IBMN=MIN(IB  ,IELCHE(/2))
 237 :         IGMN=MIN(IGAU,IELCHE(/1))
 238 :         MLREEL=IELCHE(IGMN,IBMN)
 239 :         SEGACT MLREEL
 240 :         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
 240 :      1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
 241 :         SEGDES MLREEL
 242 :       ELSE IF (IMAT.EQ.1) THEN
 243 :         DO 9004 IM=1,NMATT
 244 :           IF (IVAL(IM).NE.0) THEN
 245 :             MELVAL=IVAL(IM)
 246 :             IBMN=MIN(IB  ,VELCHE(/2))
 247 :             IGMN=MIN(IGAU,VELCHE(/1))
 248 :             VALMAT(IM)=VELCHE(IGMN,IBMN)
 249 :           ELSE
 250 :             VALMAT(IM)=0.D0
 251 :           ENDIF
 252 :  9004   CONTINUE
 253 :          IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN
 254 :          IF (IGAU.LE.NBGMAT)
 254 :      1   CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
 255 :      2               ROTH,DDHOOK,LHOOK,1,IRTD)
 256 :         ELSE
 257 :          IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
 257 :      1   CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
 258 :         ENDIF
 259 :         IF (IRTD.EQ.0) THEN
 260 :           MOTERR(1:8)=CMATE
 261 :           MOTERR(9:16)=NOMFR(MFR/2+1)
 262 :           INTERR(1)=IFOUR
 262 :           CALL ERREUR(81)
 263 :           GOTO 510
 264 :         ENDIF
 265 :       ENDIF
 266 : C
 267 : C    CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL
 268 : C                  /MASSIF ------------ PRODUIT PAR BLOC
 269 : C
 270 : * initialise
 270 :       CALL ZERO (REL,LRE,LRE)
 271 : * calcul rigidite elementaire
 272 : C**   IF (IFOUR.EQ.-3) THEN
 273 :       IF (BDPGE) THEN
 273 :        CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
 274 :       ELSE
 274 :        CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE,
 275 :      1    IGAU,IMAT,0.D0)
 276 :       ENDIF
 277 : * matrice d'efficacite
 278 :         drend = .false.
 279 :         MPTVAL=IVACAR
 280 :         IF (IVACAR.GT.0) THEN
 281 :          segact mptval
 282 :          nca1 = ival(/1) 
 283 :          segini,mwrk67
 284 :          celem = 'MASSIF  '
 285 :          IF(IVAL(NCAR1).GT.0.OR.IVAL(NCAR1+1).GT.0) THEN
 286 :           DO 9008 IM= 1,IVAL(/1)
 287 :           IF (IVAL(IM).GT.0) THEN
 288 :             MELVAL=IVAL(IM)
 289 :             IF (TYVAL(IM).EQ.'REAL*8') THEN 
 290 :               IBMN=MIN(IB  ,VELCHE(/2))
 291 :               IGMN=MIN(IGAU,VELCHE(/1))
 292 :               VALCAR(IM)=VELCHE(IGMN,IBMN)
 293 :             ELSE
 294 :               IBMN=MIN(IB  ,IELCHE(/2))
 295 :               IGMN=MIN(IGAU,IELCHE(/1))
 296 :               VALCAR(IM)=IELCHE(IGMN,IBMN)
 297 :             ENDIF
 298 :           ELSE
 299 :             VALCAR(IM)=0.D0
 300 :           ENDIF
 301 :  9008    CONTINUE
 302 :         nstep = 2
 303 :         if (ifour.eq.2) nstep = 3
 304 :         if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then
 305 :            drend = .true.
 306 :            do i = 1,nstep
 307 :             do j = 1, nstep
 308 :               xatef1(i,j) = 0.d0
 309 :             enddo
 310 :             xatef1(i,i) = valcar(ncar1)
 311 :           enddo
 312 :         endif
 313 :         if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then
 314 :           drend = .false.
 315 :           do i = 1,nstep
 316 :             do j = 1, nstep
 317 :               xatef1(i,j) = 0.d0
 318 :             enddo
 319 :             xatef1(1,1) = valcar(ncar1+7)
 320 :             xatef1(2,2) = valcar(ncar1+8)
 321 :             if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
 322 :           enddo
 323 :         endif
 323 :         call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1,
 324 :      & nstep,drend,celem)
 325 :         ENDIF
 326 :       ENDIF
 327 : *  stocke 
 328 :        do ii = 1,LRE
 329 :          do jj = 1,LRE
 330 :            rint(ii,jj) = rint(ii,jj) + rel(ii,jj) 
 331 :          enddo
 332 :        enddo
 333 : *
 334 :  4004 CONTINUE
 335 : C
 336 :       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
 337 :         INTERR(1) = IB
 337 :         CALL ERREUR(195)
 338 :         GOTO 4999
 339 :       ENDIF
 340 : C
 341 : C     REMPLISSAGE DE XMATRI
 342 : C
 342 : c      CALL REMPMT(RINT,LRE,RE)
 343 : C+DC
 344 : C       IF (ICAS.NE.3) THEN
 345 :         DO 4100 IAK=1,LRE 
 346 :          DO 4100 IBK=1,LRE      
 347 :           RE(IAK,IBK,IB)=RINT(IAK,IBK)
 348 :  4100   CONTINUE
 349 : C       ELSE
 350 : C        DO 4110 IAK=1,LRE/2 
 351 : C         DO 4110 IBK=1,LRE/2      
 352 : C          IF 
 353 : C          RE(2*IAK-1,2*IBK-1)=RINT(IAK,IBK)
 354 : C 4110   CONTINUE
 355 : C       ENDIF                                                        
 356 :  3004 CONTINUE
 357 : 
 358 : C Fin du traitement - Menage
 359 :  4999 CONTINUE
 360 :       IF (IPMIN2.NE.0) THEN
 361 : C*    IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
 362 : C*   1      .AND.IMAT.EQ.1)THEN
 363 :        SEGDES MINTE2
 364 :        SEGSUP,MWRK8
 365 :       ENDIF
 366 :       SEGSUP,MWRK1,MWRK2
 367 :       GOTO 510
 368 : *
 369 :    99 CONTINUE
 370 :       MOTERR(1:4)=NOMTP(MELE)
 371 :       MOTERR(5:12)='AMOR2   '
 371 :       CALL ERREUR(86)
 372 : *
 373 :   510 CONTINUE
 374 :       SEGSUP,MVELCH
 375 : *     SEGDES XMATRI
 376 : *      WRITE (*,*) 'Sortie de AMOR2.'
 377 :       RETURN
 378 :       END
 379 : 
 380 :