Télécharger la plaquette Cast3M


fr en

Télécharger projta.eso

Retour à la liste

Numérotation des lignes : 

projta

  1. C PROJTA    SOURCE    CB215821  20/11/25    13:37:19     10792          
  2.       SUBROUTINE PROJTA(IP1,IPMOD,IPSTA,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. ************************************************************************
  6. *                                                                      *
  7. *     PROJECTION DU CHAMP IP1 SUR LES ELEMENTS DE LA BASE MODALE IP2   *
  8. *                                                                      *
  9. *     PARAMETRES:                                                      *
  10. *                                                                      *
  11. * E   IP1     chpoint second membre                                    *
  12. * E   IPMOD   table des modes de sous-type base_de_modes               *
  13. * E   IPSTA   table des modes de sous-type liaisons_statiques          *
  14. * S   IRET    chpoint resultat                                         *
  15. *                                                                      *
  16. *     REMARQUES:                                                       *
  17. *                                                                      *
  18. *     ce sous-programme est une copie de projba                        *
  19. *     ce sous-programme est appele par pjba, psmo, copba4              *
  20. *                                                                      *
  21. *     AUTEUR, DATE DE CREATION : lionel vivan, aout 1990               *
  22. *     MODIFS : ajout des liaisons statiques (BP, 05/08/2014)           *
  23. *              amelioration compatibilite   (BP, 2015-09-24)           *
  24. *                                                                      *
  25. ************************************************************************
  26. *
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC CCGEOME
  31. -INC CCREEL
  32. -INC SMCHPOI
  33. -INC SMELEME
  34. -INC CCHAMP
  35. *
  36.       SEGMENT ICPR(nbpts)
  37.       SEGMENT IINC
  38.        CHARACTER*(LOCOMP) CIINC(0)
  39.       ENDSEGMENT
  40.       SEGMENT IINC2
  41.        CHARACTER*(LOCOMP) CIINC2(NNI1)
  42.       ENDSEGMENT
  43.       SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA
  44.       SEGMENT IPB(IPR1)
  45.       SEGMENT MCONTR(NNI1,IPR1)
  46.       LOGICAL L0,L1
  47.       CHARACTER*(LOCOMP) IDDL
  48.       CHARACTER*8 TYPRET,CHARRE
  49.       CHARACTER*15 MODEFO
  50.       DATA KZERO/0/
  51. *
  52.       IRET = 0
  53.  
  54. ***** s'agit-il d'un second membre de type deplacement impose ? *****
  55. *
  56. *     deplacement impose => idepi=1
  57. *     force imposee      => idepi=0
  58.       IDEPI =  0
  59. *     idepi = -1
  60.       KDEPI =  0
  61.       MCHPOI = IP1
  62.       IF (MTYPOI.EQ.'FLX     ') IDEPI = 1
  63. * bp: ce test ne semble pas tres robuste... --> a revisiter + tard...
  64. *     if(mtypoi(1).eq.moforc(1).and.mtypoi(2).eq.moforc(2)) idepi=0
  65. *     if (idepi.lt.0) then
  66. *        moterr(1:8) = 'chpoint'
  67. *        call erreur(302)
  68. *        return
  69. *     endif
  70.  
  71. *
  72. ***** etalpr de IP1 : chpoint 2nd membre F *****
  73. *
  74.       CALL ETALPR(IP1,KIINC,KICPR,KCONTR)
  75.       IF(IERR.NE.0) RETURN
  76. *     on recupere le MCONTR
  77.       MCONTR = KCONTR
  78.       SEGACT MCONTR
  79.       NNI1 = MCONTR(/1)
  80.       IPR1 = MCONTR(/2)
  81. *     on cree 2 MVA : KMVA pour les X_i et KMVB pour F
  82.       SEGINI MVA
  83.       KMVA = MVA
  84.       SEGINI MVA
  85.       KMVB = MVA
  86. c *     on cree un IPB pour les X_i
  87. c       SEGINI IPB
  88. c       KIPB = IPB
  89. c       SEGDES IPB
  90.  
  91. *     on remplit le MVA de KMVB avec les valeurs de F:
  92. *     on etale F dans KMVB
  93.       CALL ETALCH(IP1,KIINC,KICPR,KCONTR,KMVB,KZERO,NPR2,1)
  94.  
  95. *     fabrication de la liste des inconnues primales IINC2
  96. *     correspondant aux duales IINC
  97.       IINC = KIINC
  98.       SEGINI IINC2
  99.       DO 6 I = 1,NNI1
  100.          IDDL = CIINC(I)
  101.          DO 7 J = 1,LNOMDD
  102.             IF(IDDL.NE.NOMDU(J)) GOTO 7
  103.             CIINC2(I) = NOMDD(J)
  104.             GOTO 6
  105.  7       CONTINUE
  106.          MOTERR = IDDL
  107.          CALL ERREUR(108)
  108. *        on ne trouve pas iddl dans CCHAMP
  109.          RETURN
  110.  6    CONTINUE
  111.       KIINC2 = IINC2
  112. *
  113. *
  114. ***** on initialise le chpoint de sortie *****
  115. *
  116.       if (IPSTA.gt.0) then
  117.         NSOUPO = 2
  118.       else
  119.         NSOUPO = 1
  120.       endif
  121.       NAT=1
  122.       SEGINI,MCHPOI
  123.       IRET = MCHPOI
  124.       MTYPOI = '        '
  125.       MOCHDE=' J''AI ETE FABRIQUE PAR PJBA'
  126.       IFOPOI = IFOUR
  127. *     champ de force nodal: nature discrete
  128.       JATTRI(1)=2
  129.  
  130. *---- boucle sur ISOUPO (=sur les composantes FALF et FBET) ----
  131.       DO 100 ISOUPO=1,NSOUPO
  132.  
  133.       if(ISOUPO.eq.1) then
  134.         IP2 = IPMOD
  135.         MODEFO(1:15) = 'DEFORMEE_MODALE'
  136.       else
  137.         IP2 = IPSTA
  138.         MODEFO(1:15) = 'DEFORMEE'
  139.       endif
  140.       if(iimpi.ge.333) write(ioimp,*) ISOUPO,IP2,MODEFO
  141.  
  142. *
  143. ***** on compte le nombre de modes *****
  144.       LDEPL = 0
  145.  10   CONTINUE
  146.       LDEPL = LDEPL + 1
  147.       TYPRET = ' '
  148.       CALL ACCTAB(IP2,'ENTIER',LDEPL,X0,' ',L0,IP0,
  149.      &                TYPRET,I1,X1,CHARRE,L1,ITMOD)
  150.       IF(IERR.NE.0) RETURN
  151.       IF (TYPRET.EQ.'TABLE   ' .AND. ITMOD.NE.0) GOTO 10
  152.       LDEPL = LDEPL - 1
  153.       if(iimpi.ge.333) write(ioimp,*) 'nombre de modes=',LDEPL
  154.  
  155. ***** on initialise le MSOUPO du chpoint de sortie *****
  156.       NC = 1
  157.       SEGINI,MSOUPO
  158.       IPCHP(ISOUPO)  = MSOUPO
  159.       if(ISOUPO.eq.1) then
  160.         NOCOMP(1) = 'FALF'
  161.       else
  162.         NOCOMP(1) = 'FBET'
  163.       endif
  164.       NOHARM(1) = NIFOUR
  165.       N = LDEPL
  166.       SEGINI MPOVAL
  167.       IPOVAL = MPOVAL
  168. *
  169.       NBNN = 1
  170.       NBELEM = LDEPL
  171.       NBSOUS = 0
  172.       NBREF = 0
  173.       SEGINI MELEME
  174.       IGEOC = MELEME
  175.       ITYPEL = 1
  176. *
  177. ***** boucle sur les chpoints de deformee X_i *****
  178. *
  179.       DO 11 IM = 1,LDEPL
  180.  
  181. *        recup du i eme mode (indice IM)
  182.          CALL ACCTAB(IP2,'ENTIER',IM,X0,' ',L0,IP0,
  183.      &                   'TABLE',I1,X1,'  ',L1,ITMOD)
  184.          IF(IERR.NE.0) RETURN
  185.  
  186. *        recup du point repere
  187.          CALL ACCTAB(ITMOD,'MOT',I0,X0,'POINT_REPERE',L0,IP0,
  188.      &                     'POINT',I1,X1,'  ',L1,IPTR)
  189.          IF(IERR.NE.0) RETURN
  190. *        + ecriture du point dans le maillage du chpoint projete
  191.          NUM(1,IM) = IPTR
  192.          ICOLOR(IM) = IDCOUL
  193.  
  194. *        recup de la deformee X_i (chpoint IPP1)
  195.          CALL ACCTAB(ITMOD,'MOT',I0,X0,MODEFO,L0,IP0,
  196.      &                     'CHPOINT',I1,X1,'  ',L1,IPP1)
  197.          IF(IERR.NE.0) RETURN
  198.          CALL ACTOBJ('CHPOINT ',IPP1,1)
  199.  
  200. *        Calcul effectif du terme F^T * X_i
  201.          XRET = 0.D0
  202.  
  203. *       -force imposee      => idepi=0
  204.          IF (IDEPI.NE.1) THEN
  205. *           on etale X_i dans KMVA
  206. *           selon le format defini par KIINC2, KICPR et KCONTR
  207.             CALL ETALCH(IPP1,KIINC2,KICPR,KCONTR,KMVA,KZERO,IBID,0)
  208.             IF (IERR.NE.0) RETURN
  209. *
  210.             MVA = KMVA
  211. c             IPB = KIPB
  212.             MVA1 = KMVB
  213. *           boucle sur les elements definis par F
  214.             DO 80 J1 = 1,NPR2
  215. c                JJ1 = IPB(J1)
  216.                DO 80 I1 = 1,NNI1
  217. c                   XRET = XRET + VA(I1,JJ1) * MVA1.VA(I1,JJ1)
  218.                   XRET = XRET + VA(I1,J1) * MVA1.VA(I1,J1)
  219.  80         CONTINUE
  220.  
  221. *       -deplacement impose => idepi=1
  222.          ELSE
  223.             CALL ACCTAB(ITMOD,'MOT',I0,X0,'FREQUENCE',L0,IP0,
  224.      &                        'FLOTTANT',I1,X1,'  ',L1,IP1)
  225.              IF(IERR.NE.0) RETURN
  226.              OM = X1
  227.              OM = 2.D0 * XPI * OM
  228.              OM = OM * OM
  229.              XRET = -XRET / OM
  230. *bp          XRET vaut toujours 0 !?!?!
  231.          ENDIF
  232.          VPOCHA(IM,1) = XRET
  233.  
  234.  11   CONTINUE
  235. *
  236.  
  237.  100  continue
  238. *---- fin de boucle sur ISOUPO (=sur les composantes FALF et FBET) ----
  239.  
  240.       SEGSUP MVA,MVA1
  241. c       SEGSUP,IPB
  242.       ICPR = KICPR
  243.       SEGSUP ICPR,IINC,IINC2
  244. *
  245.  
  246.       IF (IDEPI.NE.KDEPI) THEN
  247. ***      la base ne contient pas la solution statique necessaire au
  248. ***      calcul de la reponse au deplacement impose
  249.          CALL ERREUR(303)
  250.          CALL ECRCHA('GEOM')
  251.          CALL DTCHPO(MCHPOI)
  252.          IRET = 0
  253.       ENDIF
  254. *
  255.       END
  256.  
  257.  
  258.  
  259.  
  260.  

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