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    CB215821  24/04/12    21:17:26     11897          
  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. -INC SMCHPOI
  29. -INC SMCHAML
  30. -INC SMMODEL
  31. -INC SMVECTE
  32. -INC SMELEME
  33. -INC SMINTE
  34. -INC SMCOORD
  35. -INC SMLMOTS
  36. *
  37.       SEGMENT NOTYPE
  38.          CHARACTER*16 TYPE(NBTYPE)
  39.       ENDSEGMENT
  40.       SEGMENT MPTVAL
  41.          INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
  42.          CHARACTER*16 TYVAL(NCOSOU)
  43.       ENDSEGMENT
  44.       SEGMENT INFO
  45.          INTEGER INFELL(JG)
  46.       ENDSEGMENT
  47.       SEGMENT IPPO(NPPO)
  48.       SEGMENT MWRK1
  49.          REAL*8 XEL(3,NBN1)
  50.       ENDSEGMENT
  51.       SEGMENT MWRK2
  52.          REAL*8 TXR(3,3,NBN1),TH(NBN1)
  53.       ENDSEGMENT
  54. *
  55.       PARAMETER (NINF = 3)
  56.       INTEGER INFOS(NINF)
  57.       DIMENSION XIGAU(3),MOCOMP(3)
  58.       CHARACTER*(NCONCH) CONM
  59.       CHARACTER*8 CMATE
  60.       CHARACTER*4 NOMVEC(6)
  61.       PARAMETER (LTIT=72)
  62.       CHARACTER*(LTIT) TITCH1
  63.       DATA NOMVEC/'VEC1','VEC2','VEC3','VEC4','VEC5','VEC6'/
  64. c       CHARACTER*4 NOMVEC(3)
  65. c       DATA NOMVEC/'SI11','SI22','SI33'/
  66.  
  67.  
  68. ************************************************************************
  69. *     Preliminaires
  70. ************************************************************************
  71.  
  72.       MVECT0 = 0
  73.       SMAX = 0.D0
  74. *
  75.       MCHELM = MCHA1
  76.       IF(ICHAML(/1).EQ.0) THEN
  77.         CALL ERREUR(472)
  78.         RETURN
  79.       ENDIF
  80. *
  81. *     Verification du support : noeuds ou pdi ?
  82. *
  83. c       write(*,*) 'MCHELM=',MCHELM
  84. c       write(*,*) 'dim de INFCHE :',INFCHE(/1),INFCHE(/2)
  85. c       write(*,*) 'INFCHE(1,:)=',(INFCHE(1,iou),iou=1,INFCHE(/2))
  86.       ISUP = INFCHE(1,6)
  87.       NSC = INFCHE(/1)
  88.       DO 50 ISC=2,NSC
  89.          ISUP1 = INFCHE(ISC,6)
  90.          IF (ISUP1.NE.ISUP) ISUP = 0
  91.  50   CONTINUE
  92. *     si ISUP = 1 : MCHAML aux noeuds
  93. *     si ISUP = 2 : MCHAML au centre de gravite
  94. *     si ISUP = 3 : MCHAML aux point d integration (rigidite)
  95. *     si ISUP = 4 : MCHAML aux point d integration (masse)
  96. *     si ISUP = 5 : MCHAML aux point d integration (stresses)
  97. *     si ISUP = 6 : MCHAML aux point d integration de T
  98. c       IF (ISUP.NE.1.AND.ISUP.NE.5.AND.ISUP.NE.6) THEN
  99.       IF (ISUP.LT.1.OR.ISUP.GT.6) THEN
  100.          write(IOIMP,*) 'vecte4: Support ISUP=',ISUP
  101.          call erreur(609)
  102.          RETURN
  103.       ENDIF
  104. c     on recupere TITCH1 dimensionné à 72 comme MOCHDE du SMCHPOI
  105.       LTIT1 = min(LTIT,TITCHE(/1))
  106.       TITCH1(1:LTIT1) = TITCHE(1:LTIT1)
  107.  
  108. *     liste des composantes
  109.       NMO0 = 0
  110.       MLMOT4 = LMOT0
  111.       SEGACT MLMOT4
  112.       NMO4 = MLMOT4.MOTS(/2)
  113.       NLIST = NMO4/idim
  114. *     le nombre de composantes fournies doit etre un multiple de idim 
  115.       IF((NLIST*IDIM).NE.NMO4) THEN
  116.         MOTERR(1:8) = 'LISTMOTS'
  117. c       L'objet %m1:8 n'a pas le bon nombre de composantes
  118.         CALL ERREUR(980)
  119. c       On attend un objet de type %M1:8 de dimension
  120.         CALL ERREUR(1018)
  121.         RETURN
  122.       ENDIF
  123. *     creation des NLIST nomid correspondants (meme role que IDVEC2)
  124. c       NBROBL = idim+1
  125.       NBROBL = idim
  126.       NBRFAC = 0
  127.       imo4=0
  128.       do ilist=1,NLIST
  129.         SEGINI NOMID
  130.         MOCOMP(ilist)=NOMID
  131. c         LESOBL(1) = NOMVEC(ilist)
  132. c         do iobl=2,NBROBL
  133.         do iobl=1,NBROBL
  134.           imo4=imo4+1
  135.           LESOBL(iobl)=MLMOT4.MOTS(imo4)
  136.         enddo
  137. c         write(6,*)'ilist,LESOBL=',ilist,' ',(LESOBL(iou),iou=1,NBROBL)
  138.       enddo
  139.       NCOMP=NBROBL
  140.  
  141. *     liste des couleurs
  142.       NMO = 0
  143.       IF (LMOT1.NE.0) THEN
  144.          MLMOTS = LMOT1
  145.          SEGACT MLMOTS
  146.          NMO = MOTS(/2)
  147.          if (NMO.ne.NLIST) then
  148.            write(ioimp,*) 'Incoherence dans la dimension de la liste',
  149.      &                    'des couleurs fournies : On l oublie.'
  150.            MLMOTS=0
  151.            LMOT1=0
  152.            NMO=0
  153.          endif
  154.       ENDIF
  155.       MMODEL = MOD1
  156.       NSOUS = KMODEL(/1)
  157.  
  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.          NFOR = FORMOD(/2)
  173.          NMAT = MATMOD(/2)
  174. *
  175.          CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  176. *
  177.          if(infmod(/1).lt.7 .OR. FORMOD(1).EQ.'DIFFUSION') then
  178. c          CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  179.            ISUP5 = MIN(ISUP,5)
  180.            CALL ELQUOI(MELE,0,ISUP5,IPINF,IMODEL)
  181.            IF (IERR.NE.0) RETURN
  182.            INFO   = IPINF
  183.            NBGS   = INFELL(4)
  184.            MFR    = INFELL(13)
  185.            MINTE  = INFELL(11)
  186.            MINTE1 = INFELL(12)
  187.            segsup info
  188.          else
  189.            NBGS   = INFELE(4)
  190.            MFR    = INFELE(13)
  191.            MINTE  = INFMOD(ISUP+2)
  192.            MINTE1 = INFMOD(8)
  193.          endif
  194. *
  195.          IPMINT = MINTE
  196.          IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN
  197.             MOTERR(1:16) = 'CARACTERISTIQUES'
  198.             CALL ERREUR(565)
  199.             RETURN
  200.          ENDIF
  201. *
  202.          CALL IDENT(IPMAIL,CONM,MCHA1,0,INFOS,IRET)
  203.          IF (IRET.EQ.0) GOTO 900
  204.          NBPGAU = POIGAU(/1)
  205.          NBN1 = NUM(/1)
  206.          NBELE1 = NUM(/2)
  207.          IF (ISUP.EQ.1) THEN 
  208.            NIPO = NBN1
  209.          ELSE
  210.            NIPO = NBPGAU
  211.          ENDIF
  212.          SEGINI MWRK1
  213.          NPPO = NIPO * NBELE1
  214.          IF (ISUP.GT.1) SEGINI IPPO
  215.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2
  216. *
  217. *        Listes de composantes attendues
  218. *
  219. c          CALL IDVEC2(IMODEL,1,IDIM,0,CMOT,MOCOMP,NCOMP,
  220. c      &               NLIST,IER1)
  221. c          IF (IER1.NE.0) THEN
  222. c             IF (IER1.EQ.1) call erreur(19)
  223. c             IF (IER1.EQ.2) THEN
  224. c                moterr(1:4) = CMOT
  225. c                call erreur(197)
  226. c             ENDIF
  227. c             RETURN
  228. c          ENDIF
  229. *
  230.          IF (NMO.NE.0) THEN
  231.          IF (LMOT1.NE.0.AND.NLIST.NE.NMO) GOTO 900
  232.          ENDIF
  233. *
  234. c          NVEC = NLIST * 2
  235.          NVEC = NLIST
  236.          ID = 1
  237.          SEGINI MVECTE
  238.  
  239. c2018    on augmente la taille de MCOORD ici
  240.          segact mcoord*mod
  241.          NBPTS1 = nbpts 
  242.          NBPTS=NBPTS1+NPPO
  243.          SEGADJ,MCOORD
  244.          NBPTS=NBPTS1
  245.  
  246. *
  247. *=======================================================================
  248. *        Boucle sur les listes de composantes
  249. *
  250.          DO 150 IC = 1,NLIST
  251. c             write(6,*) '  '
  252. c             write(6,*) '============ ISOU,IC=',ISOU,IC,' ============'
  253.  
  254.             NOMID = MOCOMP(IC)
  255.             IC2=IC
  256. c           on ecrit pas le noms des composantes, mais de la liste de composante...
  257.             NOCOVE(IC,1) = NOMVEC(IC)
  258.             IF (LMOT1.EQ.0) THEN
  259.                NOCOUL(IC) = IC+1
  260.             ELSE
  261.                ICOUL=IDCOUL+1
  262.                CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC))
  263.                NOCOUL(IC) = ICOUL-1
  264.             ENDIF
  265. c             write(6,*) 'NOCOUL=',(NOCOUL(iou),iou=1,NLIST)
  266.             IGEOV(IC) = 0
  267. *
  268. *           Creation du MCHPOI puis du MSOUPO et du MPOVAL
  269. *
  270.             NAT = 2
  271.             NSOUPO = 1
  272.             SEGINI MCHPOI
  273.             ICHPO(IC) = MCHPOI
  274.             MTYPOI = 'VECTEUR '
  275.             MOCHDE(1:LTIT1) = TITCH1(1:LTIT1)
  276.             IFOPOI = IFOUR
  277.             JATTRI(1) = 2
  278.             JATTRI(2) = 0
  279.             NC = IDIM
  280.             SEGINI MSOUPO
  281.             IPCHP(1) = MSOUPO
  282.             NOCOMP(1) = 'VECX'
  283.             NOCOMP(2) = 'VECY'
  284.             IF (IDIM.EQ.3) NOCOMP(3) = 'VECZ'
  285. *
  286.             N = NIPO * NBELE1
  287.             SEGINI MPOVAL
  288.             IPOVAL = MPOVAL
  289. *
  290.             NBNN = 1
  291.             NBELEM = N
  292.             NBSOUS = 0
  293.             NBREF = 0
  294.             SEGINI IPT1
  295.             IGEOC = IPT1
  296.             IPT1.ITYPEL = 1
  297. *
  298.             NBTYPE = 1
  299.             SEGINI NOTYPE
  300.             MOTYPE = NOTYPE
  301.             TYPE(1) = 'REAL*8'
  302.             CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC),
  303.      &                  MOTYPE,1,INFOS,3,IVACOM)
  304.             SEGSUP NOTYPE
  305.             IF (IERR.NE.0) GOTO 900
  306. *
  307. *           Cas des coques epaisses : epaisseur (excentrement)
  308. *
  309.             IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  310.                NBROBL = 1
  311.                NBRFAC = 0
  312.                SEGINI NOMID
  313.                MOEP = NOMID
  314.                LESOBL(1) = 'EPAI'
  315.                NVEC = NBROBL + NBRFAC
  316.                NBTYPE = 1
  317.                SEGINI NOTYPE
  318.                MOTYPE = NOTYPE
  319.                TYPE(1) = 'REAL*8'
  320.                CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP,
  321.      &                     MOTYPE,1,INFOS,3,IVAEP)
  322.                SEGSUP NOTYPE
  323.             ENDIF
  324. *
  325.             IPO = 0
  326. *
  327. *---------- Boucle sur les elements ------------------------------
  328. *
  329.             DO 200 IEL = 1,NBELE1
  330. *
  331. *              cas general
  332.                CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  333. *
  334. *              coques epaisses
  335.                IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  336.                   MPTVAL = IVAEP
  337.                   MELVAL=IVAL(1)
  338.                   DO 201 IP = 1,NBN1
  339.                      IPMN=MIN(IP ,VELCHE(/1))
  340.                      IEMN=MIN(IEL,VELCHE(/2))
  341.                      TH(IP)=VELCHE(IPMN,IEMN)
  342.  201              CONTINUE
  343.                   CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  344.                ENDIF
  345. *
  346. *............. Boucle sur les points supports .............
  347. *
  348.                DO 300 IPSU = 1,NIPO
  349.                   IPO = IPO + 1
  350. *
  351.                   MPTVAL = IVACOM
  352. *
  353.                   DO 350 I1 = 1,IDIM
  354.                      MELVAL = IVAL(I1)
  355.                      IPMN = MIN(IPSU,VELCHE(/1))
  356.                      IEMN = MIN(IEL ,VELCHE(/2))
  357.                      COS1 = VELCHE(IPMN,IEMN)
  358.                      VPOCHA(IPO,I1) = COS1
  359.  350              CONTINUE
  360. *
  361. c                   IF (ISUP.GE.5) THEN
  362.                   IF (ISUP.GT.1) THEN
  363. *                 1er passage : on calcule les coord du pt d integration
  364.                   IF (IC.EQ.1) THEN
  365.                      IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  366.                         Z = DZEGAU(IPSU)
  367.                         DO 400 I2 = 1,IDIM
  368.                            XIGAU(I2) = 0.D0
  369.                            DO 400 IL = 1,NBN1
  370.                               XIGAU(I2) = XIGAU(I2)+(SHPTOT(1,IL,IPSU)*
  371.      &                        XEL(I2,IL)+0.5D0*Z*TXR(I2,3,IL)*TH(IL))
  372.  400                    CONTINUE
  373.                      ELSE
  374.                         DO 410 I2 = 1,IDIM
  375.                            XIGAU(I2) = 0.D0
  376.                            DO 410 IL = 1,NBN1
  377.                               XIGAU(I2) = XIGAU(I2) +
  378.      &                        (SHPTOT(1,IL,IPSU)*XEL(I2,IL))
  379.  410                    CONTINUE
  380.                      ENDIF
  381. *
  382. *                    Le pdi est reference dans MCOORD (PROVISOIRE)
  383. c2018                      NBPTS = nbpts+1
  384.                      NBPTS=NBPTS+1
  385. c2018                     SEGADJ MCOORD
  386.                      XCOOR((NBPTS-1)*(IDIM+1)+1) = XIGAU(1)
  387.                      XCOOR((NBPTS-1)*(IDIM+1)+2) = XIGAU(2)
  388.                      IF (IDIM.EQ.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=XIGAU(3)
  389.                      XCOOR(NBPTS*(IDIM+1)) = 0.D0
  390.                      IPT1.NUM(1,IPO) = NBPTS
  391.                      IPPO(IPO) = NBPTS
  392. *                 passage suivant : on recupere les coord du pdi
  393.                   ELSE
  394.                      IPT1.NUM(1,IPO) = IPPO(IPO)
  395.                   ENDIF
  396.                   ELSE
  397.                      IPT1.NUM(1,IPO) = NUM(IPSU,IEL)
  398.                   ENDIF
  399.  300           CONTINUE
  400. *............. fin de Boucle sur les points supports ..........
  401.  200        CONTINUE
  402. *---------- Fin de Boucle sur les elements -----------------------
  403.  151        CONTINUE
  404.  150     CONTINUE
  405.  
  406. *        Fin de Boucle sur les composantes
  407. *=======================================================================
  408.  
  409.  
  410. c          IC1 = 0
  411. c          DO 500 IC2 = NLIST+1,NLIST*2
  412. c             IC1 = IC1 + 1
  413. c             NOCOVE(IC2,1) = NOMVEC(IC1)
  414. c             IF (LMOT1.EQ.0) THEN
  415. c                NOCOUL(IC2) = IC1 + 1
  416. c             ELSE
  417. c                ICOUL=IDCOUL+1
  418. c                CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC1))
  419. c                NOCOUL(IC2) = ICOUL-1
  420. c             ENDIF
  421. c             IGEOV(IC2) = 0
  422. c                MCHPOI = ICHPO(IC1)
  423. c                CALL MUCHPO(MCHPOI,-1.D0,ICHP2,1)
  424. c                ICHPO(IC2) = ICHP2
  425. c  500     CONTINUE
  426. *
  427. *        Desactivation des segments de la zone ISOU
  428. *
  429.          if(MPTVAL.gt.0) segsup,MPTVAL
  430.          SEGSUP MWRK1
  431.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2
  432.          IF (ISUP.GE.5) SEGSUP IPPO
  433. c          NCX = NLIST * 2
  434.          NCX = NLIST
  435. c          IF (CMOT.NE.'    ') NCX = 2
  436.          DO 101 IMX = 1,NCX
  437.             AMPF(IMX) = AMP
  438.  101     CONTINUE
  439.          SEGDES MVECTE
  440. *
  441.          IF (MVECT0.EQ.0) THEN
  442.             MVECT0 = MVECTE
  443. c             MVECT1 = MVECT0
  444.          ELSE
  445.             CALL FUSVEC(MVECT0,MVECTE,MVECT1)
  446.             MVECT0 = MVECT1
  447.          ENDIF
  448. c *......................................................................         
  449. c       segact,MVECT1
  450. c       DO i=1,MVECT1.ICHPO(/1)
  451. c       WRITE(IOIMP,751) MVECT1.AMPF(i),MVECT1.ICHPO(i),
  452. c      &                 NCOUL(MAX(0,MIN(NBCOUL-1,MVECT1.NOCOUL(i)))),
  453. c      &                   (MVECT1.NOCOVE(i,j),j=1,ID)
  454. c       ENDDO
  455. c  751  FORMAT(2X,G12.5,3X,I8,3X,A4,6X,A4,4X,A4,4X,A4)
  456. c *......................................................................         
  457. *
  458.  100  CONTINUE
  459. *
  460.  900  CONTINUE
  461.  
  462.       END
  463.  
  464.  
  465.  
  466.  
  467.  
  468.  
  469.  
  470.  

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