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

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