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/30    21:15:15     12373          
  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. *
  169.          ISUP5=ISUP
  170.          IF (ISUP5.EQ.6) ISUP5=3
  171. *
  172.          MINTE  = INFMOD(ISUP5+2)
  173.          MINTE1 = INFMOD(3)
  174.          IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN
  175.             MOTERR(1:16) = 'CARACTERISTIQUES'
  176.             CALL ERREUR(565)
  177.             RETURN
  178.          ENDIF
  179. *
  180.          CALL IDENT(IPMAIL,CONM,MCHA1,0,INFOS,IRET)
  181.          IF (IRET.EQ.0) GOTO 900
  182.          NBPGAU = POIGAU(/1)
  183.          NBN1 = NUM(/1)
  184.          NBELE1 = NUM(/2)
  185.          IF (ISUP.EQ.1) THEN
  186.            NIPO = NBN1
  187.          ELSE
  188.            NIPO = NBPGAU
  189.          ENDIF
  190.          SEGINI MWRK1
  191.          NPPO = NIPO * NBELE1
  192.          IF (ISUP.GT.1) SEGINI IPPO
  193.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2
  194. *
  195. *        Listes de composantes attendues
  196. *
  197. c          CALL IDVEC2(IMODEL,1,IDIM,0,CMOT,MOCOMP,NCOMP,
  198. c      &               NLIST,IER1)
  199. c          IF (IER1.NE.0) THEN
  200. c             IF (IER1.EQ.1) call erreur(19)
  201. c             IF (IER1.EQ.2) THEN
  202. c                moterr(1:4) = CMOT
  203. c                call erreur(197)
  204. c             ENDIF
  205. c             RETURN
  206. c          ENDIF
  207. *
  208.          IF (NMO.NE.0) THEN
  209.          IF (LMOT1.NE.0.AND.NLIST.NE.NMO) GOTO 900
  210.          ENDIF
  211. *
  212. c          NVEC = NLIST * 2
  213.          NVEC = NLIST
  214.          ID = 1
  215.          SEGINI MVECTE
  216.  
  217. c2018    on augmente la taille de MCOORD ici
  218.          segact mcoord*mod
  219.          NBPTS1 = nbpts
  220.          NBPTS=NBPTS1+NPPO
  221.          SEGADJ,MCOORD
  222.          NBPTS=NBPTS1
  223.  
  224. *
  225. *=======================================================================
  226. *        Boucle sur les listes de composantes
  227. *
  228.          DO 150 IC = 1,NLIST
  229. c             write(6,*) '  '
  230. c             write(6,*) '============ ISOU,IC=',ISOU,IC,' ============'
  231.  
  232.             NOMID = MOCOMP(IC)
  233.             IC2=IC
  234. c           on ecrit pas le noms des composantes, mais de la liste de composante...
  235.             NOCOVE(IC,1) = NOMVEC(IC)
  236.             IF (LMOT1.EQ.0) THEN
  237.                NOCOUL(IC) = IC+1
  238.             ELSE
  239.                ICOUL=IDCOUL+1
  240.                CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC))
  241.                NOCOUL(IC) = ICOUL-1
  242.             ENDIF
  243. c             write(6,*) 'NOCOUL=',(NOCOUL(iou),iou=1,NLIST)
  244.             IGEOV(IC) = 0
  245. *
  246. *           Creation du MCHPOI puis du MSOUPO et du MPOVAL
  247. *
  248.             NAT = 2
  249.             NSOUPO = 1
  250.             SEGINI MCHPOI
  251.             ICHPO(IC) = MCHPOI
  252.             MTYPOI = 'VECTEUR '
  253.             MOCHDE(1:LTIT1) = TITCH1(1:LTIT1)
  254.             IFOPOI = IFOUR
  255.             JATTRI(1) = 2
  256.             JATTRI(2) = 0
  257.             NC = IDIM
  258.             SEGINI MSOUPO
  259.             IPCHP(1) = MSOUPO
  260.             NOCOMP(1) = 'VECX'
  261.             NOCOMP(2) = 'VECY'
  262.             IF (IDIM.EQ.3) NOCOMP(3) = 'VECZ'
  263. *
  264.             N = NIPO * NBELE1
  265.             SEGINI MPOVAL
  266.             IPOVAL = MPOVAL
  267. *
  268.             NBNN = 1
  269.             NBELEM = N
  270.             NBSOUS = 0
  271.             NBREF = 0
  272.             SEGINI IPT1
  273.             IGEOC = IPT1
  274.             IPT1.ITYPEL = 1
  275. *
  276.             NBTYPE = 1
  277.             SEGINI NOTYPE
  278.             MOTYPE = NOTYPE
  279.             TYPE(1) = 'REAL*8'
  280.             CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC),
  281.      &                  MOTYPE,1,INFOS,3,IVACOM)
  282.             SEGSUP NOTYPE
  283.             IF (IERR.NE.0) GOTO 900
  284. *
  285. *           Cas des coques epaisses : epaisseur (excentrement)
  286. *
  287.             IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  288.                NBROBL = 1
  289.                NBRFAC = 0
  290.                SEGINI NOMID
  291.                MOEP = NOMID
  292.                LESOBL(1) = 'EPAI'
  293.                NVEC = NBROBL + NBRFAC
  294.                NBTYPE = 1
  295.                SEGINI NOTYPE
  296.                MOTYPE = NOTYPE
  297.                TYPE(1) = 'REAL*8'
  298.                CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP,
  299.      &                     MOTYPE,1,INFOS,3,IVAEP)
  300.                SEGSUP NOTYPE
  301.             ENDIF
  302. *
  303.             IPO = 0
  304. *
  305. *---------- Boucle sur les elements ------------------------------
  306. *
  307.             DO 200 IEL = 1,NBELE1
  308. *
  309. *              cas general
  310.                CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  311. *
  312. *              coques epaisses
  313.                IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  314.                   MPTVAL = IVAEP
  315.                   MELVAL=IVAL(1)
  316.                   DO 201 IP = 1,NBN1
  317.                      IPMN=MIN(IP ,VELCHE(/1))
  318.                      IEMN=MIN(IEL,VELCHE(/2))
  319.                      TH(IP)=VELCHE(IPMN,IEMN)
  320.  201              CONTINUE
  321.                   CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  322.                ENDIF
  323. *
  324. *............. Boucle sur les points supports .............
  325. *
  326.                DO 300 IPSU = 1,NIPO
  327.                   IPO = IPO + 1
  328. *
  329.                   MPTVAL = IVACOM
  330. *
  331.                   DO 350 I1 = 1,IDIM
  332.                      MELVAL = IVAL(I1)
  333.                      IPMN = MIN(IPSU,VELCHE(/1))
  334.                      IEMN = MIN(IEL ,VELCHE(/2))
  335.                      COS1 = VELCHE(IPMN,IEMN)
  336.                      VPOCHA(IPO,I1) = COS1
  337.  350              CONTINUE
  338. *
  339. c                   IF (ISUP.GE.5) THEN
  340.                   IF (ISUP.GT.1) THEN
  341. *                 1er passage : on calcule les coord du pt d integration
  342.                   IF (IC.EQ.1) THEN
  343.                      IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  344.                         Z = DZEGAU(IPSU)
  345.                         DO 399 I2 = 1,IDIM
  346.                            XIGAU(I2) = 0.D0
  347.                            DO 400 IL = 1,NBN1
  348.                               XIGAU(I2) = XIGAU(I2)+(SHPTOT(1,IL,IPSU)*
  349.      &                        XEL(I2,IL)+0.5D0*Z*TXR(I2,3,IL)*TH(IL))
  350.  400                    CONTINUE
  351.  399                    CONTINUE
  352.                      ELSE
  353.                         DO 409 I2 = 1,IDIM
  354.                            XIGAU(I2) = 0.D0
  355.                            DO 410 IL = 1,NBN1
  356.                               XIGAU(I2) = XIGAU(I2) +
  357.      &                        (SHPTOT(1,IL,IPSU)*XEL(I2,IL))
  358.  410                    CONTINUE
  359.  409                    CONTINUE
  360.                      ENDIF
  361. *
  362. *                    Le pdi est reference dans MCOORD (PROVISOIRE)
  363. c2018                      NBPTS = nbpts+1
  364.                      NBPTS=NBPTS+1
  365. c2018                     SEGADJ MCOORD
  366.                      XCOOR((NBPTS-1)*(IDIM+1)+1) = XIGAU(1)
  367.                      XCOOR((NBPTS-1)*(IDIM+1)+2) = XIGAU(2)
  368.                      IF (IDIM.EQ.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=XIGAU(3)
  369.                      XCOOR(NBPTS*(IDIM+1)) = 0.D0
  370.                      IPT1.NUM(1,IPO) = NBPTS
  371.                      IPPO(IPO) = NBPTS
  372. *                 passage suivant : on recupere les coord du pdi
  373.                   ELSE
  374.                      IPT1.NUM(1,IPO) = IPPO(IPO)
  375.                   ENDIF
  376.                   ELSE
  377.                      IPT1.NUM(1,IPO) = NUM(IPSU,IEL)
  378.                   ENDIF
  379.  300           CONTINUE
  380. *............. fin de Boucle sur les points supports ..........
  381.  200        CONTINUE
  382. *---------- Fin de Boucle sur les elements -----------------------
  383.  150     CONTINUE
  384.  
  385. *        Fin de Boucle sur les composantes
  386. *=======================================================================
  387.  
  388. c          IC1 = 0
  389. c          DO 500 IC2 = NLIST+1,NLIST*2
  390. c             IC1 = IC1 + 1
  391. c             NOCOVE(IC2,1) = NOMVEC(IC1)
  392. c             IF (LMOT1.EQ.0) THEN
  393. c                NOCOUL(IC2) = IC1 + 1
  394. c             ELSE
  395. c                ICOUL=IDCOUL+1
  396. c                CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC1))
  397. c                NOCOUL(IC2) = ICOUL-1
  398. c             ENDIF
  399. c             IGEOV(IC2) = 0
  400. c                MCHPOI = ICHPO(IC1)
  401. c                CALL MUCHPO(MCHPOI,-1.D0,ICHP2,1)
  402. c                ICHPO(IC2) = ICHP2
  403. c  500     CONTINUE
  404. *
  405. *        Desactivation des segments de la zone ISOU
  406. *
  407.          if(MPTVAL.gt.0) segsup,MPTVAL
  408.          SEGSUP MWRK1
  409.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2
  410.          IF (ISUP.GE.5) SEGSUP IPPO
  411. c          NCX = NLIST * 2
  412.          NCX = NLIST
  413. c          IF (CMOT.NE.'    ') NCX = 2
  414.          DO 101 IMX = 1,NCX
  415.             AMPF(IMX) = AMP
  416.  101     CONTINUE
  417.          SEGDES MVECTE
  418. *
  419.          IF (MVECT0.EQ.0) THEN
  420.             MVECT0 = MVECTE
  421. c             MVECT1 = MVECT0
  422.          ELSE
  423.             CALL FUSVEC(MVECT0,MVECTE,MVECT1)
  424.             MVECT0 = MVECT1
  425.          ENDIF
  426. c *......................................................................
  427. c       segact,MVECT1
  428. c       DO i=1,MVECT1.ICHPO(/1)
  429. c       WRITE(IOIMP,751) MVECT1.AMPF(i),MVECT1.ICHPO(i),
  430. c      &                 NCOUL(MAX(0,MIN(NBCOUL-1,MVECT1.NOCOUL(i)))),
  431. c      &                   (MVECT1.NOCOVE(i,j),j=1,ID)
  432. c       ENDDO
  433. c  751  FORMAT(2X,G12.5,3X,I8,3X,A4,6X,A4,4X,A4,4X,A4)
  434. c *......................................................................
  435. *
  436.  100  CONTINUE
  437. *
  438.  900  CONTINUE
  439.  
  440.       RETURN
  441.       END
  442.  
  443.  
  444.  
  445.  
  446.  

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