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    MB234859  25/09/08    21:16:15     12358          
  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 = INFMOD(3)
  129.         IPMINT = MINTE
  130.  
  131.         IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN
  132.           MOTERR(1:16) = 'CARACTERISTIQUES'
  133.           CALL ERREUR(565)
  134.           GOTO 900
  135.         ENDIF
  136.  
  137.         IF3 = 0
  138.         IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  139.           IF3 = 1
  140.         ELSE IF (MFR.EQ.1) THEN
  141.           IF (IDIM.EQ.3) IF3 = 2
  142.           IF (IDIM.EQ.2) IF3 = 3
  143.         ELSE
  144.           call erreur(19)
  145.           GOTO 900
  146.         ENDIF
  147.  
  148. *     Listes de composantes attendues -> NORMALE a la fissure
  149.         CMOT = '    '
  150.         CALL IDVEC2(IMODEL,2,IDIM,IF3,CMOT,MOCOMP,NCOMP,
  151.      &               NLIST,IER1)
  152.         IF (IER1.NE.0) GOTO 900
  153.         IF (NMO.NE.0.AND.NLIST.NE.NMO) GOTO 900
  154.  
  155.         NBPGAU = POIGAU(/1)
  156.         IF (ISUP.EQ.1) NIPO = NBN1
  157.         IF (ISUP.EQ.5) NIPO = NBPGAU
  158.         NPPO = NIPO * NBELE1
  159.  
  160.         SEGINI MWRK1
  161.         IF (ISUP.EQ.5) THEN
  162.           SEGINI IPPO
  163.           NBPTS5 = NBPTS
  164.           NBPTS  = NBPTS + NPPO
  165.           SEGADJ,MCOORD
  166.           IF (MFR.EQ.5) SEGINI MWRK2
  167.         ENDIF
  168.  
  169.         NVEC = NLIST * 2
  170.         ID = 1
  171.         SEGINI MVECTE
  172.         DO i = 1, NVEC
  173.           IGEOV(i) = 0
  174.           AMPF(i)  = AMP
  175.         ENDDO
  176.  
  177. *    Cas des coques epaisses : epaisseur (excentrement)
  178.         IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN
  179.           NBROBL = 1
  180.           NBRFAC = 0
  181.           SEGINI,nomid
  182.           LESOBL(1) = 'EPAI'
  183.           MOEP = nomid
  184.           CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP,
  185.      &                MOTYR8,1,INFOS,3,IVAEP)
  186.           SEGSUP,nomid
  187.           IF (IERR.NE.0) GOTO 900
  188.           mptval = IVAEP
  189.           MELVEP = mptval.IVAL(1)
  190.           SEGSUP,mptval
  191.         ENDIF
  192.  
  193. *        Boucle sur les composantes
  194.  
  195.         DO 150 IC = 1,NLIST
  196.  
  197.           NOMID = MOCOMP(IC)
  198.  
  199.           NOCOVE(IC,1) = NOMFIS(IC)
  200.           IF (LMOT1.EQ.0) THEN
  201.             NOCOUL(IC) = IC+1
  202.           ELSE
  203.             ICOUL=IDCOUL+1
  204.             CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC))
  205.             NOCOUL(IC) = ICOUL-1
  206.           ENDIF
  207.           IGEOV(IC) = 0
  208.  
  209. *       Creation du MCHPOI puis du MSOUPO et du MPOVAL
  210.           NAT = 2
  211.           NSOUPO = 1
  212.           SEGINI MCHPOI
  213.           ICHPO(IC) = MCHPOI
  214.           MTYPOI = 'VECTEUR '
  215.           MOCHDE = 'CONTRAINTES PRINCIPALES'
  216.           IFOPOI = IFOUR
  217.           JATTRI(1) = 2
  218.           JATTRI(2) = 0
  219.           NC = IDIM
  220.           SEGINI MSOUPO
  221.           IPCHP(1) = MSOUPO
  222.           NOCOMP(1) = 'FISX'
  223.           NOCOMP(2) = 'FISY'
  224.           IF (IDIM.EQ.3) NOCOMP(3) = 'FISZ'
  225.  
  226.           N = NIPO * NBELE1
  227.           SEGINI MPOVAL
  228.           IPOVAL = MPOVAL
  229.  
  230.           NBNN = 1
  231.           NBELEM = N
  232.           NBSOUS = 0
  233.           NBREF = 0
  234.           SEGINI IPT1
  235.           IGEOC = IPT1
  236.           IPT1.ITYPEL = 1
  237.  
  238.           CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC),
  239.      &                MOTYR8,1,INFOS,3,IVACOM)
  240.           IF (IERR.NE.0) GOTO 900
  241.           MPTVAL = IVACOM
  242.  
  243.           IPO = 0
  244.  
  245. *       Boucle sur les elements
  246.  
  247.           DO 200 IEL = 1,NBELE1
  248.  
  249. *         cas general
  250.             CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  251.  
  252. *         coques epaisses
  253. c*            IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN
  254.             IF (MELVEP.NE.0) THEN
  255.               MELVAL = MELVEP
  256.               DO IP = 1,NBN1
  257.                 IPMN=MIN(IP ,VELCHE(/1))
  258.                 IEMN=MIN(IEL,VELCHE(/2))
  259.                 TH(IP)=VELCHE(IPMN,IEMN)
  260.               ENDDO
  261.               CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  262.             ENDIF
  263.             IF (MELE.EQ.49) THEN
  264.               CALL CQ4LOC (XEL,XEL2,BPSS,IRRT,0)
  265.             ELSE IF (MELE.EQ.93.OR.MFR.EQ.3) THEN
  266.               CALL VPAST(XEL,BPSS)
  267.             ENDIF
  268.  
  269. *         Boucle sur les points supports
  270.  
  271.             MPTVAL = IVACOM
  272.  
  273.             DO 300 IPSU = 1,NIPO
  274.               IPO = IPO + 1
  275.               XFISS = 1.D0
  276.               MELVAL = IVAL(1)
  277.               IPMN = MIN(IPSU,VELCHE(/1))
  278.               IEMN = MIN(IEL ,VELCHE(/2))
  279.               U3(1) = VELCHE(IPMN,IEMN)
  280.               MELVAL = IVAL(2)
  281.               IPMN = MIN(IPSU,VELCHE(/1))
  282.               IEMN = MIN(IEL ,VELCHE(/2))
  283.               U3(2) = VELCHE(IPMN,IEMN)
  284.               IF (IF3.EQ.2) THEN
  285.                 MELVAL = IVAL(3)
  286.                 IPMN = MIN(IPSU,VELCHE(/1))
  287.                 IEMN = MIN(IEL ,VELCHE(/2))
  288.                 U3(3) = VELCHE(IPMN,IEMN)
  289.               ELSE
  290.                 U3(3) = 0.D0
  291.               ENDIF
  292.               CALL NORME(U3,XU3)
  293.               IF (XU3.LT.XEPS) THEN
  294.                 UV11 = 0.D0
  295.                 UV12 = 0.D0
  296.                 UV13 = 0.D0
  297.                 GOTO 123
  298.               ENDIF
  299. *             a verifier dans le cas des coques
  300.               IF (IF3.EQ.1) THEN
  301.                 VF1X = -1.D0 * XFISS * U3(2)
  302.                 VF1Y = XFISS * U3(1)
  303.          APSS(1,1)=BPSS(2,2)*BPSS(3,3)-BPSS(3,2)*BPSS(2,3)
  304.          APSS(2,1)=BPSS(3,1)*BPSS(2,3)-BPSS(2,1)*BPSS(3,3)
  305.          APSS(3,1)=BPSS(2,1)*BPSS(3,2)-BPSS(3,1)*BPSS(2,2)
  306.          APSS(1,2)=BPSS(3,2)*BPSS(1,3)-BPSS(1,2)*BPSS(3,3)
  307.          APSS(2,2)=BPSS(1,1)*BPSS(3,3)-BPSS(3,1)*BPSS(1,3)
  308.          APSS(3,2)=BPSS(3,1)*BPSS(1,2)-BPSS(1,1)*BPSS(3,2)
  309.                 UV11=APSS(1,1)*VF1X+APSS(1,2)*VF1Y
  310.                 UV12=APSS(2,1)*VF1X+APSS(2,2)*VF1Y
  311.                 UV13=APSS(3,1)*VF1X+APSS(3,2)*VF1Y
  312.               ELSE IF (IF3.EQ.3) THEN
  313.                 IF (ABS(U3(2)).LT.XEPS) THEN
  314.                   VF1X = 0.D0
  315.                   VF1Y = 1.D0 * XFISS
  316.                 ELSE IF (ABS(U3(1)).LT.XEPS) THEN
  317.                   VF1X = 1.D0 * XFISS
  318.                   VF1Y = 0.D0
  319.                 ELSE
  320.                   VF1X = -1.D0 * XFISS * U3(2)
  321.                   VF1Y = XFISS * U3(1)
  322.                 ENDIF
  323.                 UV11 = VF1X
  324.                 UV12 = VF1Y
  325.               ELSE IF (IF3.EQ.2) THEN
  326.                 UV11 = U3(1)
  327.                 UV12 = U3(2)
  328.                 UV13 = U3(3)
  329.               ENDIF
  330.  123          CONTINUE
  331.  
  332.               VPOCHA(IPO,1) = UV11
  333.               VPOCHA(IPO,2) = UV12
  334.               IF (IF3.EQ.1.OR.IF3.EQ.2) VPOCHA(IPO,3) = UV13
  335.  
  336.               IF (ISUP.EQ.5) THEN
  337.                 IF (IC.EQ.1) THEN
  338.                   IF (MFR.EQ.5) THEN
  339.                     Z = 0.5D0 * DZEGAU(IPSU)
  340.                     DO I2 = 1,IDIM
  341.                       r_z = 0.D0
  342.                       DO IL = 1,NBN1
  343.                         r_z = r_z + (SHPTOT(1,IL,IPSU)*
  344.      &                       XEL(I2,IL)+TXR(I2,3,IL)*TH(IL))
  345.                       ENDDO
  346.                       XIGAU(I2) = r_z
  347.                     ENDDO
  348.                   ELSE
  349.                     DO I2 = 1,IDIM
  350.                       r_z = 0.D0
  351.                       DO IL = 1,NBN1
  352.                         r_z = r_z + (SHPTOT(1,IL,IPSU)*XEL(I2,IL))
  353.                       ENDDO
  354.                       XIGAU(I2) = r_z
  355.                     ENDDO
  356.                   ENDIF
  357. *               Le pdi est reference dans MCOORD (PROVISOIRE)
  358.                   IREF = NBPTS5 + IPO
  359.                   IPPO(IPO) = IREF
  360.                   IPT1.NUM(1,IPO) = IREF
  361.                   IREF = (IREF-1)*IDIMP1
  362.                   XCOOR(IREF+1) = XIGAU(1)
  363.                   XCOOR(IREF+2) = XIGAU(2)
  364.                   IF (IDIM.EQ.3) XCOOR(IREF+3) = XIGAU(3)
  365.                   XCOOR(IREF+IDIMP1) = 0.D0
  366.                 ELSE
  367.                   IPT1.NUM(1,IPO) = IPPO(IPO)
  368.                 ENDIF
  369.               ELSE
  370.                 IPT1.NUM(1,IPO) = NUM(IPSU,IEL)
  371.               ENDIF
  372.  300        CONTINUE
  373.  200      CONTINUE
  374.  
  375.  151      CONTINUE
  376.  150    CONTINUE
  377.  
  378.         IC1 = 0
  379.         DO IC2 = NLIST+1,NLIST*2
  380.           IC1 = IC1 + 1
  381.           NOCOVE(IC2,1) = NOMFIS(IC1)
  382.           IF (LMOT1.EQ.0) THEN
  383.             NOCOUL(IC2) = IC1 + 1
  384.           ELSE
  385.             ICOUL=IDCOUL+1
  386.             CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC1))
  387.             NOCOUL(IC2) = ICOUL-1
  388.           ENDIF
  389.           IGEOV(IC2) = 0
  390.           MCHPOI = ICHPO(IC1)
  391.           CALL MUCHPO(MCHPOI,-1.D0,ICHP2,1)
  392.           ICHPO(IC2) = ICHP2
  393.         ENDDO
  394.  
  395. *     Desactivation des segments de la zone ISOU
  396.         SEGSUP MPTVAL,MWRK1
  397.         IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGSUP MWRK2
  398.         IF (ISUP.EQ.5) SEGSUP IPPO
  399.         DO i = 1, 3
  400.           nomid = MOCOMP(i)
  401.           IF (nomid.NE.0) SEGSUP,nomid
  402.         ENDDO
  403.  
  404.         IF (MVECT0.EQ.0) THEN
  405.           MVECT0 = MVECTE
  406.         ELSE
  407.           CALL FUSVEC(MVECT0,MVECTE,MVECT1)
  408.           MVECT0 = MVECT1
  409.         ENDIF
  410.  
  411.  100  CONTINUE
  412.  
  413.  900  CONTINUE
  414.       IF (LMOT1.NE.0) SEGDES,MLMOTS
  415.       notype = MOTYR8
  416.       SEGSUP,notype
  417.  
  418.       SEGACT,mcoord*NOMOD
  419.  
  420. c      RETURN
  421.       END
  422.  
  423.  
  424.  
  425.  
  426.  

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