Télécharger la plaquette Cast3M


fr en

Télécharger vecte2.eso

Retour à la liste

Numérotation des lignes : 

vecte2

  1. C VECTE2    SOURCE    CB215821  24/04/12    21:17:26     11897          
  2.       SUBROUTINE VECTE2(MCHA1,MCHA2,MOD1,AMP,CMOT,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 CONTRAINTES PRINCIPALES                *
  10. *     MCHA2    MCHAML de CARACTERISTIQUES (coques epaisses)     *
  11. *     MOD1     MMODEL                                           *
  12. *     AMP      coefficient d'amplification (FLOTTANT)           *
  13. *     CMOT     composante a visualiser (MOT)                    *
  14. *     LMOT1    liste des couleurs affectees aux composantes     *
  15. *     MVECT0   pointeur sur MVECTE resultat                     *
  16. *                                                               *
  17. *     D. R.-M. mai & juin 1994                                  *
  18. *---------------------------------------------------------------*
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC CCGEOME
  23. -INC SMCHPOI
  24. -INC SMCHAML
  25. -INC SMMODEL
  26. -INC SMVECTE
  27. -INC SMELEME
  28. -INC SMINTE
  29. -INC SMCOORD
  30. -INC SMLMOTS
  31. *
  32.       SEGMENT NOTYPE
  33.          CHARACTER*16 TYPE(NBTYPE)
  34.       ENDSEGMENT
  35.       SEGMENT MPTVAL
  36.          INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
  37.          CHARACTER*16 TYVAL(NCOSOU)
  38.       ENDSEGMENT
  39.       SEGMENT INFO
  40.          INTEGER INFELL(JG)
  41.       ENDSEGMENT
  42.       SEGMENT IPPO(NPPO)
  43.       SEGMENT MWRK1
  44.          REAL*8 XEL(3,NBN1)
  45.       ENDSEGMENT
  46.       SEGMENT MWRK2
  47.          REAL*8 TXR(3,3,NBN1),TH(NBN1)
  48.       ENDSEGMENT
  49. *
  50.       PARAMETER (NINF = 3)
  51.       INTEGER INFOS(NINF)
  52.       DIMENSION XIGAU(3),MOCOMP(3)
  53.       CHARACTER*(NCONCH) CONM
  54.       CHARACTER*8   CMATE
  55.  
  56.       CHARACTER*(*) CMOT
  57. *
  58.       MVECT0 = 0
  59.       SMAX = 0.D0
  60. *
  61.       MCHELM = MCHA1
  62.       SEGACT MCHELM
  63. *
  64. *     Verification du support : noeuds ou pdi ?
  65. *
  66.       ISUP = INFCHE(1,6)
  67.       NSC = INFCHE(/1)
  68.       DO 50 ISC=2,NSC
  69.          ISUP1 = INFCHE(ISC,6)
  70.          IF (ISUP1.NE.ISUP) ISUP = 0
  71.  50   CONTINUE
  72. *     si ISUP = 1 : MCHAML aux noeuds
  73. *     si ISUP = 5 : MCHAML aux pdi
  74.       IF (ISUP.NE.1.AND.ISUP.NE.5) THEN
  75.          call erreur(609)
  76.          SEGDES MCHELM
  77.          RETURN
  78.       ENDIF
  79. *
  80.       NMO = 0
  81.       IF (LMOT1.NE.0) THEN
  82.          MLMOTS = LMOT1
  83.          SEGACT MLMOTS
  84.          NMO = MOTS(/2)
  85.       ENDIF
  86. *
  87.       MMODEL = MOD1
  88.       SEGACT MMODEL
  89.       NSOUS = KMODEL(/1)
  90. *
  91. *     Boucle sur les zones du MCHAML
  92. *
  93.       DO 100 ISOU = 1,NSOUS
  94.          IVACOM = 0
  95.          IVAEP  = 0
  96.          IMODEL = KMODEL(ISOU)
  97.          SEGACT IMODEL
  98.          IPMAIL = IMAMOD
  99.          CONM = CONMOD
  100.          MELE = NEFMOD
  101.          MELEME = IMAMOD
  102.          NFOR = FORMOD(/2)
  103.          NMAT = MATMOD(/2)
  104. *
  105.          CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  106. *
  107.          if(infmod(/1).lt.7) then
  108.          CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  109.          IF (IERR.NE.0) THEN
  110.             SEGDES IMODEL,MMODEL,MCHELM
  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. *
  126.          IPMINT = MINTE
  127.          IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN
  128.             MOTERR(1:16) = 'CARACTERISTIQUES'
  129.             CALL ERREUR(565)
  130.             SEGDES IMODEL,MMODEL,MCHELM
  131.             RETURN
  132.          ENDIF
  133.          IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGACT MINTE1
  134. *
  135.          CALL IDENT(IPMAIL,CONM,MCHA1,0,INFOS,IRET)
  136.          IF (IRET.EQ.0) GOTO 900
  137. *
  138.          SEGACT MINTE
  139.          NBPGAU = POIGAU(/1)
  140.          SEGACT MELEME
  141.          NBN1 = NUM(/1)
  142.          NBELE1 = NUM(/2)
  143.          IF (ISUP.EQ.1) NIPO = NBN1
  144.          IF (ISUP.EQ.5) NIPO = NBPGAU
  145.          SEGINI MWRK1
  146.          NPPO = NIPO * NBELE1
  147.          IF (ISUP.EQ.5) SEGINI IPPO
  148.          IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGINI MWRK2
  149. *
  150. *        Listes de composantes attendues
  151. *
  152.          CALL IDVEC2(IMODEL,1,IDIM,0,CMOT,MOCOMP,NCOMP,
  153.      &               NLIST,IER1)
  154.          IF (IER1.NE.0) THEN
  155.             IF (IER1.EQ.1) call erreur(19)
  156.             IF (IER1.EQ.2) THEN
  157.                moterr(1:4) = CMOT
  158.                call erreur(197)
  159.             ENDIF
  160.             SEGDES IMODEL,MMODEL,MCHELM
  161.             RETURN
  162.          ENDIF
  163. *
  164.          IF (NMO.NE.0) THEN
  165.          IF ((CMOT.EQ.'    '.AND.LMOT1.NE.0.AND.NLIST.NE.NMO).OR.
  166.      &       (CMOT.NE.'    '.AND.NMO.NE.1)) GOTO 900
  167.          ENDIF
  168. *
  169.          IF (CMOT.EQ.'    ') THEN
  170.             NVEC = NLIST * 2
  171.          ELSE
  172.             NVEC = 2
  173.          ENDIF
  174.          ID = 1
  175.          SEGINI MVECTE
  176. *
  177. *        Boucle sur les composantes
  178. *
  179.          DO 150 IC = 1,NLIST
  180.             NOMID = MOCOMP(IC)
  181.             SEGACT NOMID
  182.             IF (CMOT.NE.'    '.AND.LESOBL(1).NE.CMOT) GOTO 151
  183.             IC2 = IC
  184.             IF (CMOT.EQ.LESOBL(1)) IC2 = 1
  185.             NOCOVE(IC2,1) = LESOBL(1)
  186.             IF (LMOT1.EQ.0) THEN
  187.                NOCOUL(IC2) = IC2+1
  188.             ELSE
  189.                ICOUL=IDCOUL+1
  190.                CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC2))
  191.                NOCOUL(IC2) = ICOUL-1
  192.             ENDIF
  193.             IGEOV(IC2) = 0
  194. *
  195. *           Creation du MCHPOI puis du MSOUPO et du MPOVAL
  196. *
  197.             NAT = 2
  198.             NSOUPO = 1
  199.             SEGINI MCHPOI
  200.             ICHPO(IC2) = MCHPOI
  201.             MTYPOI = 'VECTEUR '
  202.             MOCHDE = 'CONTRAINTES PRINCIPALES'
  203.             IFOPOI = IFOUR
  204.             JATTRI(1) = 2
  205.             JATTRI(2) = 0
  206.             NC = IDIM + 1
  207.             SEGINI MSOUPO
  208.             IPCHP(1) = MSOUPO
  209.             NOCOMP(1) = 'SIPX'
  210.             NOCOMP(2) = 'SIPY'
  211.             IF (IDIM.EQ.3) NOCOMP(3) = 'SIPZ'
  212.             NOCOMP(IDIM+1) = 'SIGN'
  213. *
  214.             N = NIPO * NBELE1
  215.             SEGINI MPOVAL
  216.             IPOVAL = MPOVAL
  217. *
  218.             NBNN = 1
  219.             NBELEM = N
  220.             NBSOUS = 0
  221.             NBREF = 0
  222.             SEGINI IPT1
  223.             IGEOC = IPT1
  224.             IPT1.ITYPEL = 1
  225. *
  226.             NBTYPE = 1
  227.             SEGINI NOTYPE
  228.             MOTYPE = NOTYPE
  229.             TYPE(1) = 'REAL*8'
  230.             CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC),
  231.      &                  MOTYPE,1,INFOS,3,IVACOM)
  232.             SEGSUP NOTYPE
  233.             IF (IERR.NE.0) GOTO 900
  234. *
  235. *           Cas des coques epaisses : epaisseur (excentrement)
  236. *
  237.             IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN
  238.                NBROBL = 1
  239.                NBRFAC = 0
  240.                SEGINI NOMID
  241.                MOEP = NOMID
  242.                LESOBL(1) = 'EPAI'
  243.                NVEC = NBROBL + NBRFAC
  244.                NBTYPE = 1
  245.                SEGINI NOTYPE
  246.                MOTYPE = NOTYPE
  247.                TYPE(1) = 'REAL*8'
  248.                CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP,
  249.      &                     MOTYPE,1,INFOS,3,IVAEP)
  250.                SEGSUP NOTYPE
  251.             ENDIF
  252. *
  253.             IPO = 0
  254. *
  255. *           Boucle sur les elements
  256. *
  257.             DO 200 IEL = 1,NBELE1
  258. *
  259.                CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  260. *
  261.                IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN
  262.                   MPTVAL = IVAEP
  263.                   MELVAL=IVAL(1)
  264.                   DO 201 IP = 1,NBN1
  265.                      IPMN=MIN(IP ,VELCHE(/1))
  266.                      IEMN=MIN(IEL,VELCHE(/2))
  267.                      TH(IP)=VELCHE(IPMN,IEMN)
  268.  201              CONTINUE
  269.                   CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  270.                ENDIF
  271. *
  272. *              Boucle sur les points supports
  273. *
  274.                DO 300 IPSU = 1,NIPO
  275.                   IPO = IPO + 1
  276. *
  277.                   MPTVAL = IVACOM
  278.                   MELVAL = IVAL(1)
  279.                   IPMN = MIN(IPSU,VELCHE(/1))
  280.                   IEMN = MIN(IEL ,VELCHE(/2))
  281.                   SMWW = VELCHE(IPMN,IEMN)
  282.                   IF (SMWW.GE.0.D0) VPOCHA(IPO,IDIM+1) = 0.D0
  283.                   IF (SMWW.LT.0.D0) VPOCHA(IPO,IDIM+1) = 1.D0
  284.                   IF (ABS(SMWW).GT.SMAX) SMAX = ABS(SMWW)
  285. *
  286.                   DO 350 I1 = 1,IDIM
  287.                      MELVAL = IVAL(1+I1)
  288.                      IPMN = MIN(IPSU,VELCHE(/1))
  289.                      IEMN = MIN(IEL ,VELCHE(/2))
  290.                      COS1 = VELCHE(IPMN,IEMN)
  291.                      VPOCHA(IPO,I1) = SMWW * COS1
  292.  350              CONTINUE
  293. *
  294.                   IF (ISUP.EQ.5) THEN
  295.                   IF (IC2.EQ.1) THEN
  296.                      IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN
  297.                         Z = DZEGAU(IPSU)
  298.                         DO 400 I2 = 1,IDIM
  299.                            XIGAU(I2) = 0.D0
  300.                            DO 400 IL = 1,NBN1
  301.                               XIGAU(I2) = XIGAU(I2)+(SHPTOT(1,IL,IPSU)*
  302.      &                        XEL(I2,IL)+0.5D0*Z*TXR(I2,3,IL)*TH(IL))
  303.  400                    CONTINUE
  304.                      ELSE
  305.                         DO 410 I2 = 1,IDIM
  306.                            XIGAU(I2) = 0.D0
  307.                            DO 410 IL = 1,NBN1
  308.                               XIGAU(I2) = XIGAU(I2) +
  309.      &                        (SHPTOT(1,IL,IPSU)*XEL(I2,IL))
  310.  410                    CONTINUE
  311.                      ENDIF
  312. *
  313. *                    Le pdi est reference dans MCOORD (PROVISOIRE)
  314. *
  315.                      segact mcoord*mod
  316.                      nbpts=nbpts+1
  317.                      SEGADJ MCOORD
  318.                      XCOOR((NBPTS-1)*(IDIM+1)+1) = XIGAU(1)
  319.                      XCOOR((NBPTS-1)*(IDIM+1)+2) = XIGAU(2)
  320.                      IF (IDIM.EQ.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=XIGAU(3)
  321.                      XCOOR(NBPTS*(IDIM+1)) = 0.D0
  322.                      IPT1.NUM(1,IPO) = NBPTS
  323.                      IPPO(IPO) = NBPTS
  324.                   ELSE
  325.                      IPT1.NUM(1,IPO) = IPPO(IPO)
  326.                   ENDIF
  327.                   ELSE
  328.                      IPT1.NUM(1,IPO) = NUM(IPSU,IEL)
  329.                   ENDIF
  330.  300           CONTINUE
  331.  200        CONTINUE
  332.             SEGDES MPOVAL,MSOUPO,MCHPOI,IPT1
  333.  151        SEGDES NOMID
  334.  150     CONTINUE
  335. *
  336.          IC1 = 0
  337.          DO 500 IC2 = NLIST+1,NLIST*2
  338.             IC1 = IC1 + 1
  339.             NOMID = MOCOMP(IC1)
  340.             SEGACT NOMID
  341.             IF (CMOT.NE.'    '.AND.CMOT.NE.LESOBL(1)) GOTO 501
  342.             IF (CMOT.EQ.LESOBL(1)) THEN
  343.                IC3 = 2
  344.                IC1 = 1
  345.                MCHPOI = ICHPO(1)
  346.             ELSE
  347.                IC3 = IC2
  348.                MCHPOI = ICHPO(IC1)
  349.             ENDIF
  350.             NOCOVE(IC3,1) = LESOBL(1)
  351.             IF (LMOT1.EQ.0) THEN
  352.                NOCOUL(IC3) = IC1 + 1
  353.             ELSE
  354.                ICOUL=IDCOUL+1
  355.                CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC1))
  356.                NOCOUL(IC3) = ICOUL-1
  357.             ENDIF
  358.             IGEOV(IC3) = 0
  359.             CALL MUCHPO(MCHPOI,-1.D0,ICHP2,1)
  360.             ICHPO(IC3) = ICHP2
  361.  501        SEGDES NOMID
  362.  500     CONTINUE
  363. *
  364. *        Desactivation des segments de la zone ISOU
  365. *
  366.          SEGDES IMODEL,MINTE,MELEME
  367.          IF (MFR.EQ.5) SEGDES MINTE1
  368.          DO 105 I0 = 1,NCOMP
  369.             IF (IVAL(I0).NE.0) THEN
  370.                MELVAL = IVAL(I0)
  371.                SEGDES,MELVAL
  372.             ENDIF
  373.  105     CONTINUE
  374.          SEGSUP MPTVAL,MWRK1
  375.          IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGSUP MWRK2
  376.          IF (ISUP.EQ.5) SEGSUP IPPO
  377.          NCX = NLIST * 2
  378.          IF (CMOT.NE.'    ') NCX = 2
  379.          DO 101 IMX = 1,NCX
  380.             AMPF(IMX) = AMP
  381.  101     CONTINUE
  382.          SEGDES MVECTE
  383. *
  384.          IF (MVECT0.EQ.0) THEN
  385.             MVECT0 = MVECTE
  386.          ELSE
  387.             CALL FUSVEC(MVECT0,MVECTE,MVECT1)
  388.             MVECT0 = MVECT1
  389.          ENDIF
  390. *
  391.  100  CONTINUE
  392.       SEGDES MMODEL,MCHELM
  393.       IF (LMOT1.NE.0) SEGDES MLMOTS
  394.       RETURN
  395. *
  396.  900  CONTINUE
  397. *
  398.       RETURN
  399.       END
  400.  
  401.  
  402.  
  403.  

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