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

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