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

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