Télécharger la plaquette Cast3M


fr en

Télécharger amor2.eso

Retour à la liste

Numérotation des lignes : 

amor2

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales