Télécharger la plaquette Cast3M


fr en

Télécharger vecte4.eso

Retour à la liste

Numérotation des lignes : 

vecte4

  1. C VECTE4    SOURCE    OF166741  26/06/04    21:15:49     12563          
  2. C
  3.       SUBROUTINE VECTE4(MCHA1,MCHA2,MOD1,AMP,LMOT0,LMOT1,MVECT0)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8(A-H,O-Z)
  6. *---------------------------------------------------------------*
  7. *     Creation d'un MVECTE a partir d'un MCHAML en vue          *
  8. *     d'un trace avec des petites fleches                       *
  9. *     Largement inspiré de  VECTE2                              *
  10. *                                                               *
  11. *     MCHA1    MCHAML                                           *
  12. *     MCHA2    MCHAML de CARACTERISTIQUES (coques epaisses)     *
  13. *     MOD1     MMODEL                                           *
  14. *     AMP      coefficient d'amplification (FLOTTANT)           *
  15. *     LMOT0    liste des composantes a visualiser               *
  16. *     LMOT1    liste des couleurs affectees aux composantes     *
  17. *     MVECT0   pointeur sur MVECTE resultat                     *
  18. *                                                               *
  19. *     CREATION , MODIFICATIONS :                                *
  20. *     + Benoit Prabel,  01/03/2012                              *
  21. *     + Benoit Prabel,  19/06/2013 : on remplace les "ISUP.EQ.5"*
  22. *                                    par des "ISUP.GE.5" ...    *
  23. *---------------------------------------------------------------*
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC CCGEOME
  28.  
  29. -INC SMCOORD
  30. -INC SMCHPOI
  31. -INC SMCHAML
  32. -INC SMMODEL
  33. -INC SMVECTE
  34. -INC SMELEME
  35. -INC SMINTE
  36. -INC SMLMOTS
  37.  
  38. -INC TMPTVAL
  39.  
  40.       SEGMENT NOTYPE
  41.          CHARACTER*16 TYPE(NBTYPE)
  42.       ENDSEGMENT
  43.       SEGMENT IPPO(NPPO)
  44.       SEGMENT MWRK1
  45.          REAL*8 XEL(3,NBN1)
  46.       ENDSEGMENT
  47.       SEGMENT MWRK2
  48.          REAL*8 TXR(3,3,NBN1),TH(NBN1)
  49.       ENDSEGMENT
  50.  
  51.       PARAMETER (NINF = 3)
  52.       INTEGER INFOS(NINF)
  53.       DIMENSION XIGAU(3),MOCOMP(3)
  54.       CHARACTER*(NCONCH) CONM
  55.       CHARACTER*4 NOMVEC(6)
  56.       PARAMETER (LTIT=72)
  57.       CHARACTER*(LTIT) TITCH1
  58.       DATA NOMVEC/'VEC1','VEC2','VEC3','VEC4','VEC5','VEC6'/
  59.  
  60. ************************************************************************
  61. *     Preliminaires
  62. ************************************************************************
  63.  
  64.       MVECT0 = 0
  65.  
  66.       IDIMP1 = IDIM + 1
  67.       XIGAU(1) = 0.D0
  68.       XIGAU(2) = 0.D0
  69.       XIGAU(3) = 0.D0
  70.  
  71.       MCHELM = MCHA1
  72.       IF(ICHAML(/1).EQ.0) THEN
  73.         CALL ERREUR(472)
  74.         RETURN
  75.       ENDIF
  76. *
  77. *     Verification du support : noeuds ou pdi ?
  78. *
  79. c       write(*,*) 'MCHELM=',MCHELM
  80. c       write(*,*) 'dim de INFCHE :',INFCHE(/1),INFCHE(/2)
  81. c       write(*,*) 'INFCHE(1,:)=',(INFCHE(1,iou),iou=1,INFCHE(/2))
  82.       ISUP = INFCHE(1,6)
  83.       NSC = INFCHE(/1)
  84.       DO 50 ISC=2,NSC
  85.          ISUP1 = INFCHE(ISC,6)
  86.          IF (ISUP1.NE.ISUP) ISUP = 0
  87.  50   CONTINUE
  88. *     si ISUP = 1 : MCHAML aux noeuds
  89. *     si ISUP = 2 : MCHAML au centre de gravite
  90. *     si ISUP = 3 : MCHAML aux point d integration (rigidite)
  91. *     si ISUP = 4 : MCHAML aux point d integration (masse)
  92. *     si ISUP = 5 : MCHAML aux point d integration (stresses)
  93. *     si ISUP = 6 : MCHAML aux point d integration de T
  94. c       IF (ISUP.NE.1.AND.ISUP.NE.5.AND.ISUP.NE.6) THEN
  95.       IF (ISUP.LT.1.OR.ISUP.GT.6) THEN
  96.          write(IOIMP,*) 'vecte4: Support ISUP=',ISUP
  97.          call erreur(609)
  98.          RETURN
  99.       ENDIF
  100. c     on recupere TITCH1 dimensionné à 72 comme MOCHDE du SMCHPOI
  101.       LTIT1 = min(LTIT,TITCHE(/1))
  102.       TITCH1(1:LTIT1) = TITCHE(1:LTIT1)
  103.  
  104. *     liste des composantes
  105.       NMO0 = 0
  106.       MLMOT4 = LMOT0
  107.       SEGACT MLMOT4
  108.       NMO4 = MLMOT4.MOTS(/2)
  109.       NLIST = NMO4/idim
  110. *     le nombre de composantes fournies doit etre un multiple de idim
  111.       IF((NLIST*IDIM).NE.NMO4) THEN
  112.         MOTERR(1:8) = 'LISTMOTS'
  113. c       L'objet %m1:8 n'a pas le bon nombre de composantes
  114.         CALL ERREUR(980)
  115. c       On attend un objet de type %M1:8 de dimension
  116.         CALL ERREUR(1018)
  117.         RETURN
  118.       ENDIF
  119. *     creation des NLIST nomid correspondants (meme role que IDVEC2)
  120.       NBROBL = IDIM
  121.       NBRFAC = 0
  122.       imo4=0
  123.       do ilist=1,NLIST
  124.         SEGINI NOMID
  125.         MOCOMP(ilist)=NOMID
  126. c         LESOBL(1) = NOMVEC(ilist)
  127. c         do iobl=2,NBROBL
  128.         do iobl=1,NBROBL
  129.           imo4=imo4+1
  130.           LESOBL(iobl)=MLMOT4.MOTS(imo4)
  131.         enddo
  132. c         write(6,*)'ilist,LESOBL=',ilist,' ',(LESOBL(iou),iou=1,NBROBL)
  133.       enddo
  134.       NCOMP=NBROBL
  135.  
  136. *     liste des couleurs
  137.       NMO = 0
  138.       IF (LMOT1.NE.0) THEN
  139.          MLMOTS = LMOT1
  140.          SEGACT MLMOTS
  141.          NMO = MOTS(/2)
  142.          if (NMO.ne.NLIST) then
  143.            write(ioimp,*) 'Incoherence dans la dimension de la liste',
  144.      &                    'des couleurs fournies : On l oublie.'
  145.            MLMOTS=0
  146.            LMOT1=0
  147.            NMO=0
  148.          endif
  149.       ENDIF
  150.       MMODEL = MOD1
  151.       NSOUS = KMODEL(/1)
  152.  
  153. * Segment "utile" :
  154.       NBTYPE = 1
  155.       SEGINI,NOTYPE
  156.       notype.TYPE(1) = 'REAL*8'
  157.       MOTYR8 = notype
  158.  
  159. ************************************************************************
  160. *     Boucle sur les zones du MODELE
  161. ************************************************************************
  162.  
  163.       DO 100 ISOU = 1,NSOUS
  164.  
  165.          IVACOM = 0
  166.          IVAEP  = 0
  167.          IMODEL = KMODEL(ISOU)
  168.          IPMAIL = IMAMOD
  169.          CONM = CONMOD
  170.          MELE = NEFMOD
  171.          MELEME = IMAMOD
  172.          NBGS   = INFELE(4)
  173.          MFR    = INFELE(13)
  174.  
  175.          IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN
  176.            MOTERR(1:16) = 'CARACTERISTIQUES'
  177.            CALL ERREUR(565)
  178.            GOTO 900
  179.          ENDIF
  180. *
  181.          ISUP5=ISUP
  182.          IF (ISUP5.EQ.6) ISUP5=3
  183. *
  184.          MINTE  = INFMOD(ISUP5+2)
  185.          MINTE1 = INFMOD(3)
  186. *
  187.          CALL IDENT(IPMAIL,CONM,MCHA1,0,INFOS,IRET)
  188.          IF (IRET.EQ.0) GOTO 900
  189.          NBPGAU = POIGAU(/1)
  190.          NBN1 = NUM(/1)
  191.          NBELE1 = NUM(/2)
  192.          IF (ISUP.EQ.1) THEN
  193.            NIPO = NBN1
  194.          ELSE
  195.            NIPO = NBPGAU
  196.          ENDIF
  197.          SEGINI MWRK1
  198.          NPPO = NIPO * NBELE1
  199.          IF (ISUP.GT.1) SEGINI IPPO
  200.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2
  201.  
  202.          IF (NMO.NE.0) THEN
  203.            IF (LMOT1.NE.0.AND.NLIST.NE.NMO) GOTO 900
  204.          ENDIF
  205.  
  206. c          NVEC = NLIST * 2
  207.          NVEC = NLIST
  208.          ID = 1
  209.          SEGINI MVECTE
  210.  
  211. c2018    on augmente la taille de MCOORD ici
  212.          segact mcoord*mod
  213.          NBPTS1 = nbpts
  214.          NBPTS=NBPTS1+NPPO
  215.          SEGADJ,MCOORD
  216.          NBPTS=NBPTS1
  217.  
  218. *=======================================================================
  219. *        Boucle sur les listes de composantes
  220. *
  221.          DO 150 IC = 1,NLIST
  222. c             write(6,*) '  '
  223. c             write(6,*) '============ ISOU,IC=',ISOU,IC,' ============'
  224.  
  225.             NOMID = MOCOMP(IC)
  226.             IC2=IC
  227. c           on n'ecrit pas le nom des composantes, mais de la liste de composantes...
  228.             NOCOVE(IC,1) = NOMVEC(IC)
  229.             IF (LMOT1.EQ.0) THEN
  230.                NOCOUL(IC) = IC+1
  231.             ELSE
  232.                ICOUL=IDCOUL+1
  233.                CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC))
  234.                NOCOUL(IC) = ICOUL-1
  235.             ENDIF
  236. c             write(6,*) 'NOCOUL=',(NOCOUL(iou),iou=1,NLIST)
  237.             IGEOV(IC) = 0
  238. *
  239. *           Creation du MCHPOI puis du MSOUPO et du MPOVAL
  240. *
  241.             NAT = 2
  242.             NSOUPO = 1
  243.             SEGINI MCHPOI
  244.             ICHPO(IC) = MCHPOI
  245.             MTYPOI = 'VECTEUR '
  246.             MOCHDE(1:LTIT1) = TITCH1(1:LTIT1)
  247.             IFOPOI = IFOUR
  248.             JATTRI(1) = 2
  249.             JATTRI(2) = 0
  250.             NC = IDIM
  251.             SEGINI MSOUPO
  252.             IPCHP(1) = MSOUPO
  253.             NOCOMP(1) = 'VECX'
  254.             NOCOMP(2) = 'VECY'
  255.             IF (IDIM.EQ.3) NOCOMP(3) = 'VECZ'
  256. *
  257.             N = NIPO * NBELE1
  258.             SEGINI MPOVAL
  259.             IPOVAL = MPOVAL
  260. *
  261.             NBNN = 1
  262.             NBELEM = N
  263.             NBSOUS = 0
  264.             NBREF = 0
  265.             SEGINI IPT1
  266.             IGEOC = IPT1
  267.             IPT1.ITYPEL = 1
  268. *
  269.             CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC),
  270.      &                  MOTYR8,1,INFOS,3,IVACOM)
  271.             IF (IERR.NE.0) GOTO 900
  272. *
  273. *           Cas des coques epaisses : epaisseur (excentrement)
  274. *
  275.             IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  276.                NBROBL = 1
  277.                NBRFAC = 0
  278.                SEGINI NOMID
  279.                MOEP = NOMID
  280.                LESOBL(1) = 'EPAI'
  281.                NVEC = NBROBL + NBRFAC
  282.                CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP,
  283.      &                     MOTYR8,1,INFOS,3,IVAEP)
  284.             ENDIF
  285. *
  286.             IPO = 0
  287. *
  288. *---------- Boucle sur les elements ------------------------------
  289. *
  290.             DO 200 IEL = 1,NBELE1
  291. *
  292. *              cas general
  293.                CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  294. *
  295. *              coques epaisses
  296.                IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  297.                   MPTVAL = IVAEP
  298.                   MELVAL=IVAL(1)
  299.                   DO 201 IP = 1,NBN1
  300.                      IPMN=MIN(IP ,VELCHE(/1))
  301.                      IEMN=MIN(IEL,VELCHE(/2))
  302.                      TH(IP)=VELCHE(IPMN,IEMN)
  303.  201              CONTINUE
  304.                   CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  305.                ENDIF
  306. *
  307. *............. Boucle sur les points supports .............
  308. *
  309.                DO 300 IPSU = 1,NIPO
  310.                   IPO = IPO + 1
  311. *
  312.                   MPTVAL = IVACOM
  313. *
  314.                   DO 350 I1 = 1,IDIM
  315.                      MELVAL = IVAL(I1)
  316.                      IPMN = MIN(IPSU,VELCHE(/1))
  317.                      IEMN = MIN(IEL ,VELCHE(/2))
  318.                      COS1 = VELCHE(IPMN,IEMN)
  319.                      VPOCHA(IPO,I1) = COS1
  320.  350              CONTINUE
  321. *
  322. c                   IF (ISUP.GE.5) THEN
  323.                   IF (ISUP.GT.1) THEN
  324. *                 1er passage : on calcule les coord du pt d integration
  325.                   IF (IC.EQ.1) THEN
  326.                      IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  327.                         Z = 0.5D0 * DZEGAU(IPSU)
  328.                         DO 399 I2 = 1,IDIM
  329.                            r_z = 0.D0
  330.                            DO 400 IL = 1,NBN1
  331.                               r_z = r_z + (SHPTOT(1,IL,IPSU)*
  332.      &                        XEL(I2,IL)+ Z*TXR(I2,3,IL)*TH(IL))
  333.  400                       CONTINUE
  334.                            XIGAU(I2) = r_z
  335.  399                    CONTINUE
  336.                      ELSE
  337.                         DO 409 I2 = 1,IDIM
  338.                            r_z = 0.D0
  339.                            DO 410 IL = 1,NBN1
  340.                               r_z = r_z + SHPTOT(1,IL,IPSU)*XEL(I2,IL)
  341.  410                       CONTINUE
  342.                            XIGAU(I2) = r_z
  343.  409                    CONTINUE
  344.                      ENDIF
  345. *
  346. *                    Le pdi est reference dans MCOORD (PROVISOIRE)
  347.                      NBPTS = NBPTS+1
  348.                      IREF = (NBPTS-1) * IDIMP1
  349.                      XCOOR(IREF+1) = XIGAU(1)
  350.                      XCOOR(IREF+2) = XIGAU(2)
  351.                      XCOOR(IREF+3) = XIGAU(3)
  352.                      XCOOR(IREF+IDIMP1) = 0.D0
  353.                      IPT1.NUM(1,IPO) = NBPTS
  354.                      IPPO(IPO) = NBPTS
  355. *                 passage suivant : on recupere les coord du pdi
  356.                   ELSE
  357.                      IPT1.NUM(1,IPO) = IPPO(IPO)
  358.                   ENDIF
  359.                   ELSE
  360.                      IPT1.NUM(1,IPO) = NUM(IPSU,IEL)
  361.                   ENDIF
  362.  300           CONTINUE
  363. *............. fin de Boucle sur les points supports ..........
  364.  200        CONTINUE
  365. *---------- Fin de Boucle sur les elements -----------------------
  366.  150     CONTINUE
  367.  
  368. *        Fin de Boucle sur les composantes
  369. *=======================================================================
  370. *
  371. *        Desactivation des segments de la zone ISOU
  372. *
  373.          if (MPTVAL.gt.0) segsup,MPTVAL
  374.          SEGSUP MWRK1
  375.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2
  376.          IF (ISUP.GE.5) SEGSUP IPPO
  377. c          NCX = NLIST * 2
  378.          NCX = NLIST
  379. c          IF (CMOT.NE.'    ') NCX = 2
  380.          DO 101 IMX = 1,NCX
  381.             AMPF(IMX) = AMP
  382.  101     CONTINUE
  383.          SEGDES MVECTE
  384. *
  385.          IF (MVECT0.EQ.0) THEN
  386.             MVECT0 = MVECTE
  387. c             MVECT1 = MVECT0
  388.          ELSE
  389.             CALL FUSVEC(MVECT0,MVECTE,MVECT1)
  390.             MVECT0 = MVECT1
  391.          ENDIF
  392. c *......................................................................
  393. c       segact,MVECT1
  394. c       DO i=1,MVECT1.ICHPO(/1)
  395. c       WRITE(IOIMP,751) MVECT1.AMPF(i),MVECT1.ICHPO(i),
  396. c      &                 NCOUL(MAX(0,MIN(NBCOUL-1,MVECT1.NOCOUL(i)))),
  397. c      &                   (MVECT1.NOCOVE(i,j),j=1,ID)
  398. c       ENDDO
  399. c  751  FORMAT(2X,G12.5,3X,I8,3X,A4,6X,A4,4X,A4,4X,A4)
  400. c *......................................................................
  401. *
  402.  100  CONTINUE
  403.  
  404.  900  CONTINUE
  405.       notype = MOTYR8
  406.       SEGSUP,NOTYPE
  407.  
  408.       RETURN
  409.       END
  410.  
  411.  
  412.  

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