Télécharger la plaquette Cast3M


fr en

Télécharger vecte.eso

Retour à la liste

Numérotation des lignes : 

vecte

  1. C VECTE     SOURCE    OF166741  24/09/27    21:15:28     12018          
  2.  
  3. C-------------------------------------------------------------------------
  4. C
  5. C    Opérateur VECTEUR
  6. C    -----------------
  7. C
  8. C    VEC1 = VECT | CHPO1 (FLOT1) (|    'DEPL'  |  'FORC'   |)  (COUL1) ;
  9. C                |               (|         LMOT1          |)
  10. C                |               (| MOT1 MOT2 (MOT3 si 3D) |)
  11. C                |
  12. C                | CHAM1 (CHAM2) MOD1 (FLOT1) (MOCOMP1) (LISMO1) ;
  13. c                |
  14. c                | CHAM1         MOD1 (FLOT1)   LCOMP1  (LISMO1);
  15. C
  16. C    Objet :
  17. C    _______
  18. C
  19. C    L'opérateur VECT construit un objet de type VECTEUR à partir :
  20. C       - des composantes d'un champ de vecteurs,
  21. C       - d'un champ par éléments de contraintes principales,
  22. C       - d'un champ par éléments de variables internes.
  23. C
  24. C-------------------------------------------------------------------------
  25. C
  26. C     VERIFICATION DE L'EXISTENCE D UN VECTEUR
  27. C
  28. C-------------------------------------------------------------------------
  29. C
  30. C    PM, 20/03/2007 : prise en compte de la couleur COUL1
  31. C    BP, 04/05/2012 : ajout syntaxe 3 (appel a vecte4)
  32. C
  33. C-------------------------------------------------------------------------
  34.       SUBROUTINE VECTE
  35.  
  36.       IMPLICIT INTEGER(I-N)
  37.       IMPLICIT REAL*8 (A-H,O-Z)
  38.  
  39. -INC PPARAM
  40. -INC CCOPTIO
  41. -INC CCGEOME
  42. -INC CCREEL
  43.  
  44. -INC SMCHPOI
  45. -INC SMVECTE
  46. -INC SMELEME
  47. -INC SMCHAML
  48. -INC SMCOORD
  49. -INC SMLMOTS
  50.  
  51.       CHARACTER*(LOCOMP) NV(3),NOC,CMOT
  52.       REAL*8      AMP,xmin,xmax,ymin,ymax,zmin,zmax,vmin,vmax
  53.       LOGICAL     LSUPR
  54.  
  55.       CHARACTER*4 MOTVEC(2)
  56.       DATA        MOTVEC/ 'DEPL','FORC'/
  57.  
  58.       CHARACTER*(LOCOMP) NU(3)
  59.       DATA        NU/'UX  ','UY  ','UZ  '/
  60.  
  61.       segact,mcoord
  62.  
  63.       CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)
  64.       IF (IRETOU .EQ. 1) CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  65.       IF (IERR.NE.0) RETURN
  66.  
  67. *     Cas du CHAMELEM
  68. *     --------------
  69.  
  70.       IF (IRETOU.EQ.0) THEN
  71. *        Lecture d'un CHAMELEM obligatoirement
  72. *        de CONTRAINTES PRINCIPALES ou de VARIABLES INTERNES
  73.          CALL LIROBJ('MCHAML  ',MCHA1,1,IRET)
  74.          CALL ACTOBJ('MCHAML  ',MCHA1,1)
  75.          IF (IERR.NE.0) RETURN
  76.  
  77.          MCHELM = MCHA1
  78.          ICAS = 0
  79.          IF (TITCHE.EQ.'CONTRAINTES PRINCIPALES'  .OR.
  80.      &       titche.eq.'DEFORMATIONS PRINCIPALE'  .or.
  81.      &       TITCHE.EQ.'DEFORMATIONS PRINCIPALES') ICAS = 1
  82.          IF (TITCHE.EQ.'VARINTER' .OR.
  83.      &       TITCHE.EQ.'VARIABLES INTERNES')      ICAS = 2
  84. c          write(*,*) 'ICAS=',ICAS
  85.          IF (ICAS.EQ.0) THEN
  86.            ICAS = 3
  87. c          Lecture obligatoire des composantes a afficher
  88.            LMOT0 = 0
  89.            CALL LIROBJ('LISTMOTS',LMOT0,0,IRET)
  90.            IF (IRET.EQ.0) THEN
  91.              moterr = 'LES COMPOSANTES SONT OBLIGATOIRES POUR LES '//
  92.      &                'CHAMPS DE TYPE AUTRE QUE "CONTRAINTES '//
  93.      &                'PRINCIPALES", "DEFORMATIONS PRINCIPALES" OU '//
  94.      &                '"VARIABLES INTERNES"'
  95.              CALL ERREUR(-385)
  96. *           L'objet de type %m1:8 n'a pas le bon sous-type
  97.              MOTERR(1:8) = 'CHAMELEM'
  98.              CALL ERREUR(302)
  99.              RETURN
  100.            ENDIF
  101.          ENDIF
  102.  
  103. *        Lecture éventuelle d'un CHAMELEM de caractéristiques
  104.          MCHA2 = 0
  105.          CALL LIROBJ('MCHAML  ',MCHA2,0,IRET)
  106.          IF (IERR.NE.0) RETURN
  107.          IF (IRET.EQ.1) THEN
  108.             CALL ACTOBJ('MCHAML  ',MCHA2,1)
  109.             IF (IERR.NE.0) RETURN
  110.             MCHELM = MCHA2
  111.             IF (TITCHE.NE.'CARACTERISTIQUES') THEN
  112.                MOTERR(1:16) = 'CARACTERISTIQUES'
  113.                CALL ERREUR(565)
  114.                RETURN
  115.             ENDIF
  116.          ENDIF
  117.  
  118. *        Lecture du modèle
  119.          CALL LIROBJ('MMODEL  ',MOD1,1,IRET)
  120.          CALL ACTOBJ('MMODEL  ',MOD1,1)
  121.          IF (IERR.NE.0) RETURN
  122.          IPIN=MCHA1
  123.          CALL REDUAF(IPIN,MOD1,MCHA1,0,IR,KER)
  124.          IF(IR   .NE. 1) CALL ERREUR(KER)
  125.          IF(IERR .NE. 0) RETURN
  126.          IF (MCHA2 .NE. 0) THEN
  127.            IPIN=MCHA2
  128.            CALL REDUAF(IPIN,MOD1,MCHA2,0,IR,KER)
  129.            IF(IR   .NE. 1) CALL ERREUR(KER)
  130.            IF(IERR .NE. 0) RETURN
  131.          ENDIF
  132.  
  133. *        Lecture du coefficient d'amplification optionnel
  134.          AMP=1.D0
  135.          CALL LIRREE(AMP,0,IRETOU)
  136.          IF (IERR.NE.0) RETURN
  137.  
  138. *        Lecture éventuelle de la composante à conserver
  139.          IF (ICAS.EQ.1) THEN
  140.             CMOT = '    '
  141.             CALL LIRCHA(CMOT,0,IRETOU)
  142.             IF (IERR.NE.0) RETURN
  143.          ENDIF
  144.  
  145. *        Lecture de la liste des couleurs à employer pour chaque composante
  146.          LMOT1 = 0
  147.          CALL LIROBJ('LISTMOTS',LMOT1,0,IRET)
  148.          IF (IERR.NE.0) RETURN
  149.  
  150. *        Création des vecteurs suivant les cas
  151.          IF (ICAS.EQ.1)
  152.      &     CALL VECTE2(MCHA1,MCHA2,MOD1,AMP,CMOT,LMOT1,MVECTE)
  153.          IF (ICAS.EQ.2)
  154.      &     CALL VECTE3(MCHA1,MCHA2,MOD1,AMP,LMOT1,MVECTE)
  155.          IF (ICAS.EQ.3)
  156.      &     CALL VECTE4(MCHA1,MCHA2,MOD1,AMP,LMOT0,LMOT1,MVECTE)
  157.          IF (IERR.NE.0) RETURN
  158.  
  159.          CALL ECROBJ ('VECTEUR ',MVECTE)
  160.          RETURN
  161.       ENDIF
  162.  
  163. *     Cas du CHPOINT
  164. *     --------------
  165.  
  166. *--   Détermination de MLMOT1, listmots des composantes à prendre en compte
  167. *     On essaie de lire les mot clés 'DEPL' 'FORC'
  168.       CALL LIRMOT(MOTVEC,2,IMOT,0)
  169.       IF (IMOT.NE.0) THEN
  170.          CALL IDCOMP(MOTVEC(IMOT),MLMOT1)
  171.          IF (IERR.NE.0) RETURN
  172.          IRETOU=1
  173.          LSUPR=.TRUE.
  174.       ELSE
  175. *        sinon on cherche un listmots de composantes
  176.          CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
  177.          LSUPR=.FALSE.
  178.       ENDIF
  179.  
  180.       IF (IRETOU.NE.0) THEN
  181.          SEGACT MLMOT1
  182.  
  183. *        Verification du nombre de composantes
  184.          NM=MLMOT1.MOTS(/2)
  185.          IF (NM.LT.IDIM) THEN
  186. *           routine %m1:8 : On voulait un %m9:16 à %i1 composantes au lieu de %i2 .
  187.             MOTERR(1:8)='VECTE   '
  188.             MOTERR(9:16)='LISTMOTS'
  189.             INTERR(1)=IDIM
  190.             INTERR(2)=NM
  191.             CALL ERREUR(699)
  192.             RETURN
  193.          ENDIF
  194.  
  195. *        Stockage dans la table NV
  196.          DO K=1,IDIM
  197.             NV(K)=MLMOT1.MOTS(K)
  198.          ENDDO
  199.  
  200.          IF (LSUPR) THEN
  201.             SEGSUP MLMOT1
  202.          ELSE
  203.             SEGDES MLMOT1
  204.          ENDIF
  205.       ELSE
  206. *        Si pas de listmots (implicite ou explicite),
  207. *        on lit autant de mots que la dimension
  208.          KOK=0
  209.          DO 9 K=1,IDIM
  210.             CALL LIRCHA(CMOT,0,IRETOU)
  211.             IF (IRETOU.NE.0) THEN
  212.                KOK=K
  213.                NV(K)=CMOT
  214.             ENDIF
  215.  9       CONTINUE
  216.  
  217.          IF (KOK.GT.0 .AND. KOK.LT.IDIM) THEN
  218. *           Si le nombre de composantes est insuffisant, c'est qu'elles
  219. *           n'étaient en fait pas données. On réécrit les mots lus
  220. *           abusivement pour usage ultérieur
  221.             DO K=1,KOK
  222.                CMOT=NV(K)
  223.                CALL ECRCHA(CMOT)
  224.             ENDDO
  225.          ENDIF
  226.       ENDIF
  227.  
  228. *     Et enfin, si aucune spécification, on prend les composantes par
  229. *     défaut dans la table NU.
  230.       IF (IRETOU.EQ.0) THEN
  231.          DO 8 L=1,IDIM
  232.             NV(L)=NU(L)
  233.    8     CONTINUE
  234.       ENDIF
  235.       IF (IERR.NE.0) RETURN
  236.  
  237. *--   Lecture de la couleur (valeur par défaut sinon)
  238.       CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  239.       IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  240.       ICOUL=ICOUL-1
  241.  
  242.       AMP=-xsgran
  243.       CALL LIRREE(AMP,0,IRETOU)
  244.       NVEC=1
  245.       ID=IDIM
  246.       SEGINI MVECTE
  247.       IGEOV(NVEC)=0
  248.       ICHPO(NVEC)=MCHPOI
  249.       AMPF(NVEC)=AMP
  250.       NOCOUL(NVEC)=ICOUL
  251.       DO 14 ID=1,IDIM
  252.        NOCOVE(NVEC,ID)=NV(ID)
  253.   14  CONTINUE
  254. * Amplification automatique on calcul le coeff
  255.       if (iretou.eq.0) then
  256.        idimp1 = idim+1
  257.        xmin=xsgran
  258.        ymin=xsgran
  259.        zmin=xsgran
  260.        vmax=-xsgran
  261.        xmax=-xsgran
  262.        ymax=-xsgran
  263.        zmax=-xsgran
  264.        do 50 i=1,ipchp(/1)
  265.         msoupo=ipchp(i)
  266.         meleme=igeoc
  267.         mpoval=ipoval
  268.  
  269.         if (idim.eq.3) then
  270.           do j=1,num(/2)
  271.             ip=idimp1*(num(1,j)-1)
  272.             xmin=min(xcoor(ip+1),xmin)
  273.             xmax=max(xcoor(ip+1),xmax)
  274.             ymin=min(xcoor(ip+2),ymin)
  275.             ymax=max(xcoor(ip+2),ymax)
  276.             zmin=min(xcoor(ip+3),zmin)
  277.             zmax=max(xcoor(ip+3),zmax)
  278.           enddo
  279.         else if (idim.eq.2) then
  280.           do j=1,num(/2)
  281.             ip=idimp1*(num(1,j)-1)
  282.             xmin=min(xcoor(ip+1),xmin)
  283.             xmax=max(xcoor(ip+1),xmax)
  284.             ymin=min(xcoor(ip+2),ymin)
  285.             ymax=max(xcoor(ip+2),ymax)
  286.           enddo
  287.         else
  288. **      else if (idim.eq.1) then
  289.           do j=1,num(/2)
  290.             ip=idimp1*(num(1,j)-1)
  291.             xmin=min(xcoor(ip+1),xmin)
  292.             xmax=max(xcoor(ip+1),xmax)
  293.           enddo
  294.         endif
  295.         do 62 ic=1,vpocha(/2)
  296.          do 63 iv=1,idim
  297.           if (nv(iv).ne.nocomp(ic)) goto 63
  298.           do 64 j=1,vpocha(/1)
  299.            vmax=max(vmax,abs(vpocha(j,ic)))
  300.   64      continue
  301.   63     continue
  302.   62    continue
  303.   50   continue
  304.  
  305. *       if (vmax.le.0.) vmax=1.
  306.        if (vmax.le.xpetit) vmax=1.d0
  307.        if (.not.(vmax.lt.xsgran)) vmax=xsgran
  308.        ampf(nvec)=max(ampf(nvec),(xmax-xmin)/(vmax*10))
  309.        if (idim.ge.2) then
  310.          ampf(nvec)=max(ampf(nvec),(ymax-ymin)/(vmax*10))
  311.          if (idim.ge.3)
  312.      &     ampf(nvec)=max(ampf(nvec),(zmax-zmin)/(vmax*10))
  313.        endif
  314.       endif
  315.  
  316.       SEGDES MVECTE
  317.       CALL ECROBJ ('VECTEUR ',MVECTE)
  318.  
  319. c      RETURN
  320.       END
  321.  
  322.  
  323.  

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