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

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