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

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