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

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