Télécharger la plaquette Cast3M


fr en

Télécharger vecte3.eso

Retour à la liste

Numérotation des lignes : 

vecte3

  1. C VECTE3    SOURCE    OF166741  25/02/21    21:19:05     12166          
  2.  
  3. *---------------------------------------------------------------*
  4. *     Creation d'un MVECTE a partir d'un MCHAML en vue          *
  5. *     d'un trace avec des petites fleches                       *
  6. *                                                               *
  7. *     MCHA1    MCHAML de VARIables INTERnes                     *
  8. *     MCHA2    MCHAML de CARACTERISTIQUES (coques epaisses)     *
  9. *     MOD1     MMODEL                                           *
  10. *     AMP      coefficient d'amplification (FLOTTANT)           *
  11. *     LMOT1    liste des couleurs affectees aux composantes     *
  12. *     MVECT0   pointeur sur MVECTE resultat                     *
  13. *                                                               *
  14. *     D. R.-M. mai & juin 1994                                  *
  15. *     D. R.-M. juillet 1995 --> massifs isotropes 3D            *
  16. *                               coques 2D et 3D                 *
  17. *---------------------------------------------------------------*
  18.       SUBROUTINE VECTE3(MCHA1,MCHA2,MOD1,AMP,LMOT1,MVECT0)
  19.  
  20.       IMPLICIT INTEGER(I-N)
  21.       IMPLICIT REAL*8(A-H,O-Z)
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC CCGEOME
  26.  
  27. -INC SMCHPOI
  28. -INC SMCHAML
  29. -INC SMMODEL
  30. -INC SMVECTE
  31. -INC SMELEME
  32. -INC SMINTE
  33. -INC SMCOORD
  34. -INC SMLMOTS
  35.  
  36. -INC TMPTVAL
  37.  
  38.       SEGMENT NOTYPE
  39.         CHARACTER*16 TYPE(NBTYPE)
  40.       ENDSEGMENT
  41.       SEGMENT IPPO(NPPO)
  42.       SEGMENT MWRK1
  43.         REAL*8 XEL(3,NBN1),XEL2(3,NBN1)
  44.       ENDSEGMENT
  45.       SEGMENT MWRK2
  46.         REAL*8 TXR(3,3,NBN1),TH(NBN1)
  47.       ENDSEGMENT
  48.  
  49. *     NOMFIS
  50.       PARAMETER (NINF = 3, XEPS = 1.D-6)
  51.       INTEGER INFOS(NINF)
  52.       DIMENSION XIGAU(3),MOCOMP(3),BPSS(3,3),APSS(3,3)
  53.       DIMENSION U1(3),U2(3),U3(3),W1(3),W2(3)
  54.       CHARACTER*(NCONCH) CONM
  55.       CHARACTER*4 CMOT, NOMFIS(3)
  56.       DATA NOMFIS(1),NOMFIS(2),NOMFIS(3)
  57.      &     /'FIS1','FIS2','FIS3'/
  58.  
  59.       MVECT0 = 0
  60.  
  61.       IDIMP1 = IDIM + 1
  62.  
  63.       MCHELM = MCHA1
  64.       NSC = INFCHE(/1)
  65.       IF (NSC.EQ.0) THEN
  66.         write(ioimp,*) 'MCHELM (MCHA1) VIDE'
  67.         call erreur(21)
  68.         return
  69.       ENDIF
  70. *   Verification du support : noeuds ou pdi ?
  71.       ISUP = INFCHE(1,6)
  72.       DO 50 ISC = 2, NSC
  73.         ISUP1 = INFCHE(ISC,6)
  74.         IF (ISUP1.NE.ISUP) ISUP = 0
  75.  50   CONTINUE
  76. *     si ISUP = 1 : MCHAML aux noeuds
  77. *     si ISUP = 5 : MCHAML aux pdi
  78.       IF (ISUP.NE.1.AND.ISUP.NE.5) THEN
  79.         call erreur(609)
  80.         RETURN
  81.       ENDIF
  82.  
  83.       NMO = 0
  84.       IF (LMOT1.NE.0) THEN
  85.         MLMOTS = LMOT1
  86.         SEGACT MLMOTS
  87.         NMO = MOTS(/2)
  88.       ENDIF
  89.  
  90.       MMODEL = MOD1
  91.       NSOUS = KMODEL(/1)
  92.  
  93.       nbtype = 1
  94.       SEGINI,notype
  95.       notype.TYPE(1) = 'REAL*8'
  96.       MOTYR8 = notype
  97.  
  98.       SEGACT,mcoord*MOD
  99.  
  100. *  Boucle (100) sur les zones du MCHAML
  101.  
  102.       DO 100 ISOU = 1,NSOUS
  103.  
  104.         IVACOM = 0
  105.         MELVEP = 0
  106.  
  107.         IMODEL = KMODEL(ISOU)
  108.  
  109.         CONM = CONMOD
  110.         MELE = NEFMOD
  111.  
  112.         IPMAIL = IMAMOD
  113.         MELEME = IMAMOD
  114.         NBN1   = meleme.NUM(/1)
  115.         NBELE1 = meleme.NUM(/2)
  116.  
  117.         CALL IDENT(IPMAIL,CONM,MCHA1,0,INFOS,IRET)
  118.         IF (IRET.EQ.0) GOTO 900
  119.  
  120.         if (infmod(/1).lt.7) then
  121.           write(ioimp,*) 'VECTE3 : infmod(/1) < 7'
  122.           call erreur(5)
  123.         endif
  124.  
  125.         NBGS   = INFELE(4)
  126.         MFR    = INFELE(13)
  127.         MINTE  = INFMOD(7)
  128.         MINTE1 = INFELE(12)
  129. c*        MINTE1 = INFMOD(8)
  130.         IPMINT = MINTE
  131.  
  132.         IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN
  133.           MOTERR(1:16) = 'CARACTERISTIQUES'
  134.           CALL ERREUR(565)
  135.           GOTO 900
  136.         ENDIF
  137.  
  138.         IF3 = 0
  139.         IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  140.           IF3 = 1
  141.         ELSE IF (MFR.EQ.1) THEN
  142.           IF (IDIM.EQ.3) IF3 = 2
  143.           IF (IDIM.EQ.2) IF3 = 3
  144.         ELSE
  145.           call erreur(19)
  146.           GOTO 900
  147.         ENDIF
  148.  
  149. *     Listes de composantes attendues -> NORMALE a la fissure
  150.         CMOT = '    '
  151.         CALL IDVEC2(IMODEL,2,IDIM,IF3,CMOT,MOCOMP,NCOMP,
  152.      &               NLIST,IER1)
  153.         IF (IER1.NE.0) GOTO 900
  154.         IF (NMO.NE.0.AND.NLIST.NE.NMO) GOTO 900
  155.  
  156.         NBPGAU = POIGAU(/1)
  157.         IF (ISUP.EQ.1) NIPO = NBN1
  158.         IF (ISUP.EQ.5) NIPO = NBPGAU
  159.         NPPO = NIPO * NBELE1
  160.  
  161.         SEGINI MWRK1
  162.         IF (ISUP.EQ.5) THEN
  163.           SEGINI IPPO
  164.           NBPTS5 = NBPTS
  165.           NBPTS  = NBPTS + NPPO
  166.           SEGADJ,MCOORD
  167.           IF (MFR.EQ.5) SEGINI MWRK2
  168.         ENDIF
  169.  
  170.         NVEC = NLIST * 2
  171.         ID = 1
  172.         SEGINI MVECTE
  173.         DO i = 1, NVEC
  174.           IGEOV(i) = 0
  175.           AMPF(i)  = AMP
  176.         ENDDO
  177.  
  178. *    Cas des coques epaisses : epaisseur (excentrement)
  179.         IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN
  180.           NBROBL = 1
  181.           NBRFAC = 0
  182.           SEGINI,nomid
  183.           LESOBL(1) = 'EPAI'
  184.           MOEP = nomid
  185.           CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP,
  186.      &                MOTYR8,1,INFOS,3,IVAEP)
  187.           SEGSUP,nomid
  188.           IF (IERR.NE.0) GOTO 900
  189.           mptval = IVAEP
  190.           MELVEP = mptval.IVAL(1)
  191.           SEGSUP,mptval
  192.         ENDIF
  193.  
  194. *        Boucle sur les composantes
  195.  
  196.         DO 150 IC = 1,NLIST
  197.  
  198.           NOMID = MOCOMP(IC)
  199.  
  200.           NOCOVE(IC,1) = NOMFIS(IC)
  201.           IF (LMOT1.EQ.0) THEN
  202.             NOCOUL(IC) = IC+1
  203.           ELSE
  204.             ICOUL=IDCOUL+1
  205.             CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC))
  206.             NOCOUL(IC) = ICOUL-1
  207.           ENDIF
  208.           IGEOV(IC) = 0
  209.  
  210. *       Creation du MCHPOI puis du MSOUPO et du MPOVAL
  211.           NAT = 2
  212.           NSOUPO = 1
  213.           SEGINI MCHPOI
  214.           ICHPO(IC) = MCHPOI
  215.           MTYPOI = 'VECTEUR '
  216.           MOCHDE = 'CONTRAINTES PRINCIPALES'
  217.           IFOPOI = IFOUR
  218.           JATTRI(1) = 2
  219.           JATTRI(2) = 0
  220.           NC = IDIM
  221.           SEGINI MSOUPO
  222.           IPCHP(1) = MSOUPO
  223.           NOCOMP(1) = 'FISX'
  224.           NOCOMP(2) = 'FISY'
  225.           IF (IDIM.EQ.3) NOCOMP(3) = 'FISZ'
  226.  
  227.           N = NIPO * NBELE1
  228.           SEGINI MPOVAL
  229.           IPOVAL = MPOVAL
  230.  
  231.           NBNN = 1
  232.           NBELEM = N
  233.           NBSOUS = 0
  234.           NBREF = 0
  235.           SEGINI IPT1
  236.           IGEOC = IPT1
  237.           IPT1.ITYPEL = 1
  238.  
  239.           CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC),
  240.      &                MOTYR8,1,INFOS,3,IVACOM)
  241.           IF (IERR.NE.0) GOTO 900
  242.           MPTVAL = IVACOM
  243.  
  244.           IPO = 0
  245.  
  246. *       Boucle sur les elements
  247.  
  248.           DO 200 IEL = 1,NBELE1
  249.  
  250. *         cas general
  251.             CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  252.  
  253. *         coques epaisses
  254. c*            IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN
  255.             IF (MELVEP.NE.0) THEN
  256.               MELVAL = MELVEP
  257.               DO IP = 1,NBN1
  258.                 IPMN=MIN(IP ,VELCHE(/1))
  259.                 IEMN=MIN(IEL,VELCHE(/2))
  260.                 TH(IP)=VELCHE(IPMN,IEMN)
  261.               ENDDO
  262.               CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  263.             ENDIF
  264.             IF (MELE.EQ.49) THEN
  265.               CALL CQ4LOC (XEL,XEL2,BPSS,IRRT,0)
  266.             ELSE IF (MELE.EQ.93.OR.MFR.EQ.3) THEN
  267.               CALL VPAST(XEL,BPSS)
  268.             ENDIF
  269.  
  270. *         Boucle sur les points supports
  271.  
  272.             MPTVAL = IVACOM
  273.  
  274.             DO 300 IPSU = 1,NIPO
  275.               IPO = IPO + 1
  276.               XFISS = 1.D0
  277.               MELVAL = IVAL(1)
  278.               IPMN = MIN(IPSU,VELCHE(/1))
  279.               IEMN = MIN(IEL ,VELCHE(/2))
  280.               U3(1) = VELCHE(IPMN,IEMN)
  281.               MELVAL = IVAL(2)
  282.               IPMN = MIN(IPSU,VELCHE(/1))
  283.               IEMN = MIN(IEL ,VELCHE(/2))
  284.               U3(2) = VELCHE(IPMN,IEMN)
  285.               IF (IF3.EQ.2) THEN
  286.                 MELVAL = IVAL(3)
  287.                 IPMN = MIN(IPSU,VELCHE(/1))
  288.                 IEMN = MIN(IEL ,VELCHE(/2))
  289.                 U3(3) = VELCHE(IPMN,IEMN)
  290.               ELSE
  291.                 U3(3) = 0.D0
  292.               ENDIF
  293.               CALL NORME(U3,XU3)
  294.               IF (XU3.LT.XEPS) THEN
  295.                 UV11 = 0.D0
  296.                 UV12 = 0.D0
  297.                 UV13 = 0.D0
  298.                 GOTO 123
  299.               ENDIF
  300. *             a verifier dans le cas des coques
  301.               IF (IF3.EQ.1) THEN
  302.                 VF1X = -1.D0 * XFISS * U3(2)
  303.                 VF1Y = XFISS * U3(1)
  304.          APSS(1,1)=BPSS(2,2)*BPSS(3,3)-BPSS(3,2)*BPSS(2,3)
  305.          APSS(2,1)=BPSS(3,1)*BPSS(2,3)-BPSS(2,1)*BPSS(3,3)
  306.          APSS(3,1)=BPSS(2,1)*BPSS(3,2)-BPSS(3,1)*BPSS(2,2)
  307.          APSS(1,2)=BPSS(3,2)*BPSS(1,3)-BPSS(1,2)*BPSS(3,3)
  308.          APSS(2,2)=BPSS(1,1)*BPSS(3,3)-BPSS(3,1)*BPSS(1,3)
  309.          APSS(3,2)=BPSS(3,1)*BPSS(1,2)-BPSS(1,1)*BPSS(3,2)
  310.                 UV11=APSS(1,1)*VF1X+APSS(1,2)*VF1Y
  311.                 UV12=APSS(2,1)*VF1X+APSS(2,2)*VF1Y
  312.                 UV13=APSS(3,1)*VF1X+APSS(3,2)*VF1Y
  313.               ELSE IF (IF3.EQ.3) THEN
  314.                 IF (ABS(U3(2)).LT.XEPS) THEN
  315.                   VF1X = 0.D0
  316.                   VF1Y = 1.D0 * XFISS
  317.                 ELSE IF (ABS(U3(1)).LT.XEPS) THEN
  318.                   VF1X = 1.D0 * XFISS
  319.                   VF1Y = 0.D0
  320.                 ELSE
  321.                   VF1X = -1.D0 * XFISS * U3(2)
  322.                   VF1Y = XFISS * U3(1)
  323.                 ENDIF
  324.                 UV11 = VF1X
  325.                 UV12 = VF1Y
  326.               ELSE IF (IF3.EQ.2) THEN
  327.                 UV11 = U3(1)
  328.                 UV12 = U3(2)
  329.                 UV13 = U3(3)
  330.               ENDIF
  331.  123          CONTINUE
  332.  
  333.               VPOCHA(IPO,1) = UV11
  334.               VPOCHA(IPO,2) = UV12
  335.               IF (IF3.EQ.1.OR.IF3.EQ.2) VPOCHA(IPO,3) = UV13
  336.  
  337.               IF (ISUP.EQ.5) THEN
  338.                 IF (IC.EQ.1) THEN
  339.                   IF (MFR.EQ.5) THEN
  340.                     Z = 0.5D0 * DZEGAU(IPSU)
  341.                     DO I2 = 1,IDIM
  342.                       r_z = 0.D0
  343.                       DO IL = 1,NBN1
  344.                         r_z = r_z + (SHPTOT(1,IL,IPSU)*
  345.      &                       XEL(I2,IL)+TXR(I2,3,IL)*TH(IL))
  346.                       ENDDO
  347.                       XIGAU(I2) = r_z
  348.                     ENDDO
  349.                   ELSE
  350.                     DO I2 = 1,IDIM
  351.                       r_z = 0.D0
  352.                       DO IL = 1,NBN1
  353.                         r_z = r_z + (SHPTOT(1,IL,IPSU)*XEL(I2,IL))
  354.                       ENDDO
  355.                       XIGAU(I2) = r_z
  356.                     ENDDO
  357.                   ENDIF
  358. *               Le pdi est reference dans MCOORD (PROVISOIRE)
  359.                   IREF = NBPTS5 + IPO
  360.                   IPPO(IPO) = IREF
  361.                   IPT1.NUM(1,IPO) = IREF
  362.                   IREF = (IREF-1)*IDIMP1
  363.                   XCOOR(IREF+1) = XIGAU(1)
  364.                   XCOOR(IREF+2) = XIGAU(2)
  365.                   IF (IDIM.EQ.3) XCOOR(IREF+3) = XIGAU(3)
  366.                   XCOOR(IREF+IDIMP1) = 0.D0
  367.                 ELSE
  368.                   IPT1.NUM(1,IPO) = IPPO(IPO)
  369.                 ENDIF
  370.               ELSE
  371.                 IPT1.NUM(1,IPO) = NUM(IPSU,IEL)
  372.               ENDIF
  373.  300        CONTINUE
  374.  200      CONTINUE
  375.  
  376.  151      CONTINUE
  377.  150    CONTINUE
  378.  
  379.         IC1 = 0
  380.         DO IC2 = NLIST+1,NLIST*2
  381.           IC1 = IC1 + 1
  382.           NOCOVE(IC2,1) = NOMFIS(IC1)
  383.           IF (LMOT1.EQ.0) THEN
  384.             NOCOUL(IC2) = IC1 + 1
  385.           ELSE
  386.             ICOUL=IDCOUL+1
  387.             CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC1))
  388.             NOCOUL(IC2) = ICOUL-1
  389.           ENDIF
  390.           IGEOV(IC2) = 0
  391.           MCHPOI = ICHPO(IC1)
  392.           CALL MUCHPO(MCHPOI,-1.D0,ICHP2,1)
  393.           ICHPO(IC2) = ICHP2
  394.         ENDDO
  395.  
  396. *     Desactivation des segments de la zone ISOU
  397.         SEGSUP MPTVAL,MWRK1
  398.         IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGSUP MWRK2
  399.         IF (ISUP.EQ.5) SEGSUP IPPO
  400.         DO i = 1, 3
  401.           nomid = MOCOMP(i)
  402.           IF (nomid.NE.0) SEGSUP,nomid
  403.         ENDDO
  404.  
  405.         IF (MVECT0.EQ.0) THEN
  406.           MVECT0 = MVECTE
  407.         ELSE
  408.           CALL FUSVEC(MVECT0,MVECTE,MVECT1)
  409.           MVECT0 = MVECT1
  410.         ENDIF
  411.  
  412.  100  CONTINUE
  413.  
  414.  900  CONTINUE
  415.       IF (LMOT1.NE.0) SEGDES,MLMOTS
  416.       notype = MOTYR8
  417.       SEGSUP,notype
  418.  
  419.       SEGACT,mcoord*NOMOD
  420.  
  421. c      RETURN
  422.       END
  423.  
  424.  
  425.  
  426.  

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