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

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