Télécharger la plaquette Cast3M


fr en

Télécharger projrg.eso

Retour à la liste

Numérotation des lignes : 

projrg

  1. C PROJRG    SOURCE    PV090527  26/04/30    21:16:00     12529          
  2.       SUBROUTINE PROJRG(MRIGID,MTAB1,ITAB2,POS,RI1,RI2)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. *
  6. ***********************************************************
  7. *     PROJECTION D'UNE MATRICE SUR UNE BASE DE MODES      *
  8. * _______________________________________________________ *
  9. *                                                         *
  10. *    CREATION : Nicolas BENECH (11 Avril 1995)            *
  11. *    MODIFICATIONS :                                      *
  12. *    -18/11/2010 Benoit PRABEL : AMELIORATION PERFORMANCE *
  13. *    -30/07/2014 Benoit PRABEL : ajout modes statiques    *
  14. *                                + matrices de relations  *
  15. *    -18/11/2015 BP : calcul nbre de modes (pas a priori) *
  16. * _______________________________________________________ *
  17. *                                                         *
  18. *     MODULE(S) APPELANT(S) : PJBA                        *
  19. *                                                         *
  20. *     MODULE(S) APPELE(S) : ACCTAB, YTMX                  *
  21. *                           mucpri, corrsp, xty           *
  22. * _______________________________________________________ *
  23. *                                                         *
  24. *    EN ENTREE :                                          *
  25. *        MRIGID : Matrice a projeter                      *
  26. *        MTAB1  : Base de modes, reels ou complexes       *
  27. *        'REEL' : indique que l'on utilise le produit     *
  28. *                 scalaire reel (pas de conjugaison)      *
  29. *        ITAB2  : Base de modes liaisons statiques        *
  30. *                                                         *
  31. *    EN SORTIE :                                          *
  32. *        RI1 : Matrice projetee (partie reelle)           *
  33. *        RI2 : Matrice projetee (partie imaginaire)       *
  34. * _______________________________________________________ *
  35. *                                                         *
  36. *    REMARQUE :                                           *
  37. *         L'operation realisee est :                      *
  38. *                (MTAB1)t . MRIGID. MTAB1                 *
  39. *  Dans le cas complexe, la transposition est accompagnee *
  40. *   de la conjugaison (si REEL n'est pas mentionne).      *
  41. *         L'operation realisee est :                      *
  42. ***********************************************************
  43. *
  44.  
  45. -INC PPARAM
  46. -INC CCOPTIO
  47. -INC SMCHPOI
  48. -INC SMELEME
  49. -INC SMLCHPO
  50. -INC SMRIGID
  51. -INC SMCOORD
  52. -INC SMTABLE
  53. -INC SMLMOTS
  54.       pointeur IPLMOX.mlmots, IPLMOY.mlmots
  55.       pointeur DES5.DESCR
  56. *
  57. * Declarations
  58. *
  59.       REAL*8 XVAL, RMAX
  60.       CHARACTER*8 LETYPE
  61.       CHARACTER*8  TYPMOD,TYPRET,CHARRE
  62.       LOGICAL MODCOM
  63.       INTEGER I, J, NBMOD, POS, IREEL, IVALRE, IOBRE, isym
  64.       REAL*8 XVALRE
  65.       LOGICAL LOGRE
  66.       CHARACTER*4  MO5
  67.  
  68.  
  69. ***********************************************************
  70. *     INITIALISATIONS
  71. ***********************************************************
  72. *
  73.       MODCOM = .FALSE.
  74.       RI2 = 0
  75. *     par defaut, on considere le vrai produit scalaire avec le conjugué
  76. *     transposé y^H.M.x ,  mais avec POS=1, on prend seulement y^T.M.x
  77.       IREEL = -1
  78.       IF(POS.EQ.1) IREEL = 1
  79. *
  80. *     recup de MTYMAT + symetrie / antisymetrie de la matrice a projeter
  81.       segact,MRIGID
  82.       LETYPE = MRIGID.MTYMAT
  83.       NRIGEL=IRIGEL(/2)
  84.       isym=IRIGEL(7,1)
  85.       if(NRIGEL.le.1) goto 09
  86.       do iel=2,NRIGEL
  87.         if (isym.ne.IRIGEL(7,iel)) then
  88.           isym=2
  89.           goto 09
  90.         endif
  91.       enddo
  92.  09   CONTINUE
  93.  
  94.  
  95. ***********************************************************
  96. *     ON SEPARE LA RIGIDITE EN 2 :
  97. *           - RI4: partie rigidite "pure"
  98. *           - RI5: partie relation cinematique
  99. *     On ne traite que l'1 des 2 (RI4 par défaut)
  100. ***********************************************************
  101.       IPRIG0 = MRIGID
  102.       jmax  = IRIGEL(/1)
  103.       NRIG0 = NRIGEL
  104.       segini,RI4,RI5
  105.       RI4.IFORIG = MRIGID.IFORIG
  106.       RI4.MTYMAT = LETYPE
  107.       RI5.IFORIG = MRIGID.IFORIG
  108.       RI5.MTYMAT = LETYPE
  109.       nel4 = 0
  110.       nel5 = 0
  111.       iel4 = 0
  112.       iel5 = 0
  113.       do 1 iel=1,NRIGEL
  114.          MELEME=IRIGEL(1,iel)
  115.          segact,MELEME
  116. c  rem : on teste ITYPEL,
  117. c        mais on pourrait aussi tester LX comme dans SEPA.eso
  118.          IF(ITYPEL.EQ.22) THEN
  119.            nel5 = 1
  120.            iel5 = iel5 + 1
  121.            RI5.COERIG(iel5)=COERIG(iel)
  122.            do j=1,jmax
  123.              RI5.IRIGEL(j,iel5)=IRIGEL(j,iel)
  124.            enddo
  125.          ELSE
  126.            nel4=1
  127.            iel4 = iel4 + 1
  128.            RI4.COERIG(iel4)=COERIG(iel)
  129.            do j=1,jmax
  130.              RI4.IRIGEL(j,iel4)=IRIGEL(j,iel)
  131.            enddo
  132.          ENDIF
  133.          segdes,MELEME
  134.  1    continue
  135.       segdes,MRIGID
  136.       NRIGEL=iel5
  137.       segadj,RI5
  138.       NRIGEL=iel4
  139.       segadj,RI4
  140.  
  141.  
  142. ***********************************************************
  143. *     CREATION DE LA RIGIDITE CALCULEE
  144. ***********************************************************
  145. c       IF(ITAB2.EQ.0) THEN
  146. c         NRIGEL=nel4+nel5
  147.       IF(ITAB2.EQ.0.and.nel4.eq.0) THEN
  148.         NRIGEL=nel5
  149.       ELSE
  150. c      +en presence de Table de liaison statiques,
  151. c       on ne traite pas les relations cinematiques
  152. *      +si RI4 et Ri5, On ne traite que l'1 des 2 (RI4 par défaut)
  153.         NRIGEL=nel4
  154.       ENDIF
  155.       SEGINI,RI1
  156.       RI1.MTYMAT = LETYPE
  157.       RI1.IFORIG = IFOUR
  158.       RI1.IMGEO1 = 0
  159.       RI1.IMGEO2 = 0
  160.       IRI1=0
  161.  
  162.  
  163. ************************************************************
  164. *     TRAITEMENT DES MODES
  165. *     + on prepare les MELEME + DESCR de sortie
  166. ***********************************************************
  167.  
  168. ***** BASE MODALE *****
  169.  
  170.       LETYPE = ' '
  171.       CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'MODES',.TRUE.,0,
  172.      &           'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,MTAB2)
  173.       IF (IERR.NE.0) RETURN
  174.  
  175. c c     longueur a priori
  176. c       SEGACT, MTAB2
  177. c       NBMOD = MTAB2.MLOTAB-2
  178. c       SEGDES, MTAB2
  179. c     remplace par le calcul du vrai nombre de modes
  180.       NBMOD = 0
  181.  11   CONTINUE
  182.       NBMOD = NBMOD + 1
  183.       TYPRET = ' '
  184.       ITMOD=0
  185.       CALL ACCTAB(MTAB2,'ENTIER',NBMOD,0.0D0,' ',.TRUE.,0,
  186.      &            TYPRET,IVALRE,XVALRE,CHARRE,LOGRE,ITMOD)
  187.       IF(IERR.NE.0) RETURN
  188.       IF(TYPRET.EQ.'TABLE   ' .AND. ITMOD.NE.0) GOTO 11
  189.       NBMOD = NBMOD - 1
  190.       if(iimpi.ge.333) write(ioimp,*) 'nombre de modes=',NBMOD
  191.  
  192. *
  193.       N1 = NBMOD
  194.       SEGINI, MLCHP1, MLCHP2
  195. *
  196. * Constitution du maillage support et du segment descriptif
  197. *
  198.       NBNN = NBMOD
  199.       NBELEM = 1
  200.       NBSOUS = 0
  201.       NBREF = 0
  202.       SEGINI, MELEME
  203. * rem : ce itypel est faux, mais on arrive a vivre avec !
  204.       ITYPEL = 1
  205. *
  206.       NLIGRD=NBMOD
  207.       NLIGRP=NBMOD
  208.       nelrig=1
  209.       SEGINI,DESCR
  210. *
  211.       DO 10, I=1, NBMOD
  212.          IPT1 = 0
  213. *
  214.          CALL ACCTAB(MTAB2,'ENTIER',I,0.0D0,' ',.TRUE.,0,
  215.      &              'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,MTAB3)
  216.          IF (IERR.NE.0) RETURN
  217.          CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
  218.      &               'MOT',IVALRE,XVALRE,TYPMOD,LOGRE,IOBRE)
  219. *
  220. *  Le calcul est impossible :
  221. *
  222.          IF (TYPMOD.EQ.'MODE_ANN') THEN
  223.            IF (LETYPE.NE.'ANNULE') THEN
  224.              WRITE (*,*) 'Calcul impossible : modes annules !!!'
  225.              LETYPE = 'ANNULE'
  226.            ENDIF
  227.            GOTO 5
  228.          ENDIF
  229. *
  230. *  Cas reel ou cas complexe ?
  231. *
  232.          IF (TYPMOD .EQ. 'MODE_COM') THEN
  233.            MODCOM=.TRUE.
  234.            CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
  235.      &         .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPOI)
  236.            MLCHP1.ICHPOI(I) = MCHPOI
  237.            CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  238.            CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE',
  239.      &            .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPOI)
  240.            MLCHP2.ICHPOI(I) = MCHPOI
  241.            CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  242.          ELSE
  243.            MODCOM = .FALSE.
  244.            CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE',.TRUE.,0,
  245.      &                  'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPOI)
  246.            IF (IERR.NE.0) RETURN
  247.            MLCHP1.ICHPOI(I) = MCHPOI
  248.            CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  249.          ENDIF
  250. *
  251.          CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,
  252.      &              'POINT',IVALRE,XVALRE,CHARRE,LOGRE,IPT1)
  253.          IF (IERR.NE.0) RETURN
  254. *
  255.  5       MELEME.NUM(I,1)=IPT1
  256. *
  257.          DESCR.LISINC(I) = 'ALFA'
  258.          DESCR.LISDUA(I) = 'FALF'
  259.          DESCR.NOELEP(I) = I
  260.          DESCR.NOELED(I) = I
  261. *
  262.  10   CONTINUE
  263.  
  264.  
  265. ***** BASE LIAISONS STATIQUES *****
  266.  
  267.       IF(ITAB2.EQ.0) GOTO 19
  268.  
  269.       NBMOD1=NBMOD
  270.       MTAB2=ITAB2
  271.       SEGACT, MTAB2
  272. c c     longueur a priori
  273. c       NBMOD2 = MTAB2.MLOTAB-1
  274. c     remplace par le calcul du vrai nombre de solutions statiques
  275.       NBMOD2 = 0
  276.  13   NBMOD2 = NBMOD2 + 1
  277.       TYPRET = ' '
  278.       ITMOD=0
  279.       CALL ACCTAB(MTAB2,'ENTIER',NBMOD2,0.0D0,' ',.TRUE.,0,
  280.      &            TYPRET,IVALRE,XVALRE,CHARRE,LOGRE,ITMOD)
  281.       IF(IERR.NE.0) RETURN
  282.       IF(TYPRET.EQ.'TABLE   ' .AND. ITMOD.NE.0) GOTO 13
  283.       NBMOD2 = NBMOD2 - 1
  284.       if(iimpi.ge.333) write(ioimp,*) 'nombre de sol statiques=',NBMOD2
  285.  
  286.       NBMOD = NBMOD1 + NBMOD2
  287.       N1    =NBMOD
  288.       NBNN  =NBMOD
  289.       NLIGRD=NBMOD
  290.       NLIGRP=NBMOD
  291.       SEGADJ,MLCHP1,MLCHP2,MELEME,DESCR
  292.  
  293.       ITOT=NBMOD1
  294.  
  295.       DO 12, I=1,NBMOD2
  296.  
  297.  
  298.          CALL ACCTAB(MTAB2,'ENTIER',I,0.0D0,' ',.TRUE.,0,
  299.      &              'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,MTAB3)
  300.          IF (IERR.NE.0) RETURN
  301.  
  302. c        ici, on a une solution statique
  303.          ITOT=ITOT+1
  304.  
  305. c        DEFORMEE
  306. c        modes statiques reels seulement !
  307.          CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE',.TRUE.,0,
  308.      &                  'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPOI)
  309.          IF (IERR.NE.0) RETURN
  310.          MLCHP1.ICHPOI(ITOT) = MCHPOI
  311.          CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  312.  
  313. c        POINT_REPERE
  314.          CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,
  315.      &              'POINT',IVALRE,XVALRE,CHARRE,LOGRE,IPT1)
  316.          IF (IERR.NE.0) RETURN
  317.          MELEME.NUM(ITOT,1)=IPT1
  318.  
  319. c        DESCR
  320.          DESCR.LISINC(ITOT) = 'BETA'
  321.          DESCR.LISDUA(ITOT) = 'FBET'
  322.          DESCR.NOELEP(ITOT) = ITOT
  323.          DESCR.NOELED(ITOT) = ITOT
  324.  
  325.  12   CONTINUE
  326.  
  327.       SEGDES, MTAB2
  328.  
  329. ***** FIN DE TRAITEMENT DES BASES (MODALES ET STATIQUES) *****
  330.  
  331.  19   CONTINUE
  332.       SEGDES, DESCR
  333.       SEGDES, MELEME
  334. *
  335. * Constitution des segments XMATRI
  336. *
  337.       NLIGRD=NBMOD
  338.       NLIGRP=NBMOD
  339. *
  340.       IF (LETYPE .EQ. 'ANNULE') THEN
  341.         rigrel=0
  342.         SEGINI, XMATR1
  343.         IF (MODCOM) THEN
  344.           rigrel=0
  345.           SEGINI, XMATR2
  346.           SEGDES, XMATR2
  347.         ENDIF
  348.         SEGDES, XMATR1
  349.         GOTO 55
  350.       ENDIF
  351.  
  352.  
  353. ***********************************************************
  354. *     ON PROJETTE LA RIGIDITE "PURE" RI4
  355. ***********************************************************
  356.  
  357.       IF(iel4.eq.0) GOTO 100
  358.       MRIGID=RI4
  359. *
  360. * Cas reel
  361. *
  362.       rigrel=0
  363.       SEGINI, XMATR1
  364.       if (isym.eq.0) then
  365.           DO 20 J=1, NBMOD
  366.             MCHPO2 = MLCHP1.ICHPOI(J)
  367.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  368.             DO I=J, NBMOD
  369.               MCHPO1 = MLCHP1.ICHPOI(I)
  370.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  371.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  372.               XMATR1.RE(I,J,1)=XVAL
  373.               XMATR1.RE(J,I,1)=XVAL
  374.              ENDDO
  375.             segsup,IPLMOX,IPLMOY
  376.             segsup,MCHPO3
  377.             MCHPO3=0
  378.  20       CONTINUE
  379.       elseif (isym.eq.1) then
  380.           DO 21 J=1, NBMOD
  381.             XMATR1.RE(J,J,1)=0.D0
  382.             if(J.ge.NBMOD) goto 21
  383.             MCHPO2 = MLCHP1.ICHPOI(J)
  384.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  385.             JP1=J+1
  386.             DO I=JP1, NBMOD
  387.               MCHPO1 = MLCHP1.ICHPOI(I)
  388.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  389.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  390.               XMATR1.RE(I,J,1)=XVAL
  391.               XMATR1.RE(J,I,1)=-1.D0*XVAL
  392.             ENDDO
  393.             segsup,IPLMOX,IPLMOY
  394.             segsup,MCHPO3
  395.  21       CONTINUE
  396.       else
  397.           DO 22, J=1, NBMOD
  398.             MCHPO2 = MLCHP1.ICHPOI(J)
  399.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  400.             DO I=1, NBMOD
  401.               MCHPO1 = MLCHP1.ICHPOI(I)
  402.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  403.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  404.               XMATR1.RE(I,J,1)=XVAL
  405.             ENDDO
  406.             segsup,IPLMOX,IPLMOY
  407.             segsup,MCHPO3
  408.  22       CONTINUE
  409.       endif
  410. *
  411. * Cas complexe : calcul de termes complementaires
  412. *
  413.       IF (MODCOM) THEN
  414. c         partie reelle = phiR_i^T.M.phiR_j +/-  phiI_i^T.M. phiI_j
  415.           DO 30, J=1, NBMOD
  416.             MCHPO2 = MLCHP2.ICHPOI(J)
  417.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  418.             DO I=1, NBMOD
  419.               MCHPO1 = MLCHP2.ICHPOI(I)
  420.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  421.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  422.               XMATR1.RE(I,J,1)=XMATR1.RE(I,J,1)-IREEL*XVAL
  423.             ENDDO
  424.             segsup,IPLMOX,IPLMOY
  425.             segsup,MCHPO3
  426.  30       CONTINUE
  427. *         2eme matrice (=partie imaginaire)
  428. c         partie imaginaire = phiR_i^T.M.phiI_j -/+  phiI_i^T.M. phiR_j
  429.           rigrel=0
  430.           SEGINI,XMATR2
  431.           DO 40, J=1, NBMOD
  432.             MCHPO2 = MLCHP2.ICHPOI(J)
  433.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  434.             DO I=1, NBMOD
  435.               MCHPO1 = MLCHP1.ICHPOI(I)
  436.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  437.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  438.               XMATR2.RE(I,J,1)=XVAL
  439.             ENDDO
  440.             segsup,IPLMOX,IPLMOY
  441.             segsup,MCHPO3
  442.  40       CONTINUE
  443.           DO 50, J=1, NBMOD
  444.             MCHPO2 = MLCHP1.ICHPOI(J)
  445.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  446.             DO I=1, NBMOD
  447.               MCHPO1 = MLCHP2.ICHPOI(I)
  448.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  449.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  450.               XMATR2.RE(I,J,1)=XMATR2.RE(I,J,1)+IREEL*XVAL
  451.             ENDDO
  452.             segsup,IPLMOX,IPLMOY
  453.             segsup,MCHPO3
  454.  50       CONTINUE
  455.           SEGDES,XMATR2
  456.       ENDIF
  457. *
  458.  55   NELRIG = 1
  459.  
  460. *     Stockage dans la rigidite calculee
  461.       IRI1=IRI1+1
  462.         RI1.COERIG(IRI1) = 1.D0
  463.         RI1.IRIGEL(1,IRI1) = MELEME
  464.         RI1.IRIGEL(2,IRI1) = 0
  465.         RI1.IRIGEL(3,IRI1) = DESCR
  466.         RI1.IRIGEL(4,IRI1) = xMATR1
  467.         RI1.IRIGEL(5,IRI1) = NIFOUR
  468.         RI1.IRIGEL(6,IRI1) = 0
  469.         RI1.IRIGEL(7,IRI1) = isym
  470.         xmatr1.symre=isym
  471.       SEGDES,XMATR1
  472.         RI1.IRIGEL(8,IRI1) = 0
  473.       IF (MODCOM) THEN
  474.         RI1.IRIGEL(7,1) = 2
  475.         SEGINI, RI2 = RI1
  476.           RI2.IRIGEL(4,IRI1) = xMATR2
  477.         SEGDES, RI2
  478.       ELSE
  479.         RI2 = 0
  480.       ENDIF
  481.  
  482. *     Travail termine pour RI4.
  483.  
  484. *     si RI4 et RI5 : On ne traite que l'1 des 2 (RI4 par défaut)
  485.       IF(iel5.ne.0) THEN
  486.         IF(IIMPI.ne.0) THEN
  487.           WRITE(IOIMP,*) 'Présence de rigidites pures ',
  488.      &                   'et de relations cinematiques :'
  489.           WRITE(IOIMP,*) 'On ne traite pas les relations cinematiques !'
  490.         ENDIF
  491.         GOTO 900
  492.       ENDIF
  493.  
  494.  100  CONTINUE
  495.       SEGSUP,RI4
  496.  
  497.  
  498. ***********************************************************
  499. *     ON PROJETTE LES RELATIONS CINEMATIQUES RI5
  500. *     rem : cela conduit a construire n rigidites-"relation"
  501. *           de taille m*m -> pas forcement interessant...
  502. ***********************************************************
  503.  
  504.       IF(iel5.eq.0) GOTO 900
  505.       IF(ITAB2.NE.0) THEN
  506.         WRITE(IOIMP,*) 'La syntaxe utilisee ne traite pas',
  507.      &                ' les relations cinematiques !'
  508.         GOTO 900
  509.       ENDIF
  510.  
  511. c     Calcul de la projection d'une relation cinematique sur base modale
  512.  
  513. *     recup de la matrice d entree
  514.       NRIGEL=RI5.IRIGEL(/2)
  515. *     DES2 = DESCR de sortie
  516.       NLIGRD=NBMOD+1
  517.       NLIGRP=NBMOD+1
  518.       SEGINI,DES2
  519.       DES2.LISINC(1)='LX'
  520.       DES2.LISDUA(1)='FLX'
  521.       DES2.NOELEP(1)=1
  522.       DES2.NOELED(1)=1
  523.       do i=2,NLIGRD
  524.        DES2.LISINC(i)='ALFA'
  525.        DES2.LISDUA(i)='FALF'
  526.        DES2.NOELEP(i)=i
  527.        DES2.NOELED(i)=i
  528.       enddo
  529.       SEGDES,DES2
  530. *     maillage de sortie
  531.       NBNN   = NBMOD+1
  532.       NBELEM = NRIGEL
  533.       NBSOUS = 0
  534.       NBREF  = 0
  535.       SEGINI,IPT2
  536.       IPT2.ITYPEL = 22
  537. *     XMATR3 de sortie
  538.       NELRIG =NRIGEL
  539.       rigrel=0
  540.       SEGINI,XMATR3
  541.  
  542. *     on branche et on remplit RI1
  543.       IRI1 = IRI1 + 1
  544.       RI1.COERIG(IRI1) = 1.D0
  545.       RI1.IRIGEL(1,IRI1) = IPT2
  546.       RI1.IRIGEL(3,IRI1) = DES2
  547.       RI1.IRIGEL(4,IRI1) = XMATR3
  548.       RI1.IRIGEL(5,IRI1) = RI5.IRIGEL(5,IRI1)
  549.       RI1.IRIGEL(7,IRI1) = 0
  550.       xmatr3.symre=0
  551.  
  552.       SEGACT, MELEME
  553.  
  554. * --- Boucle sur les sous rigidites ---
  555.       iel2=0
  556.       DO 101 irig5=1,NRIGEL
  557.  
  558. *       recup de la sous matrice d entree
  559. c         xcoe5 = RI5.COERIG(irig5) =1 normalement !
  560.         IPT5  = RI5.IRIGEL(1,irig5)
  561.         DES5  = RI5.IRIGEL(3,irig5)
  562.         XMATR5= RI5.IRIGEL(4,irig5)
  563.         segact,IPT5,DES5,XMATR5
  564.         NBEL5 = IPT5.NUM(/2)
  565.         nddl5 = XMATR5.RE(/2)
  566.  
  567. c    -- boucle sur les matrices elementaires --
  568.         DO 102 iel5=1,NBEL5
  569.  
  570. *         traitement de la sous matrice de sortie
  571.           iel2 = iel2 + 1
  572.           if(iel2.gt.NBELEM) then
  573.             NBELEM=NBELEM+1
  574.             segadj,IPT2
  575.             NELRIG=NELRIG+1
  576.             segadj,XMATR3
  577.           endif
  578. c         recopie du LX
  579.           IPT2.NUM(1,iel2) = IPT5.NUM(1,iel5)
  580.  
  581. c         boucle sur les modes
  582.           DO 110 j=1,NBMOD
  583.  
  584. c           point repere des modes et chpoint de deformee modale
  585.             IPT2.NUM(j+1,iel2) = NUM(j,1)
  586.             IPHI = MLCHP1.ICHPOI(j)
  587.             XVALj = 0.d0
  588.  
  589. c           boucle sur les ddls (non LX) de la relation en entree
  590.             DO 120 k=2,nddl5
  591.  
  592.               X5k = XMATR5.RE(1,k,iel5)
  593. c             XPHIk = valeur de la jeme deformee modale au ddl u_k
  594.               IP5 = DES5.NOELEP(k)
  595.               IP5 = IPT5.NUM(IP5,iel5)
  596.               MO5 = DES5.LISINC(k)
  597.               CALL EXTRA9(IPHI,IP5,MO5,0,.FALSE.,XPHIk,IRET)
  598.               XVALj = XVALj + X5k*XPHIk
  599.  
  600.  120       CONTINUE
  601.  
  602.            XMATR3.RE(1,J+1,iel2) = XVALj
  603.            XMATR3.RE(J+1,1,iel2) = XVALj
  604.  
  605.  110    CONTINUE
  606.  
  607.  102    CONTINUE
  608.         SEGDES,IPT5,DES5,XMATR5
  609.  
  610.  101  CONTINUE
  611.  
  612.       SEGDES,MELEME
  613.       SEGDES,IPT2,XMATR3
  614.  
  615.  
  616.  
  617. ***********************************************************
  618. *     MENAGE AVANT DE QUITTER
  619. ***********************************************************
  620.  900  CONTINUE
  621.       SEGSUP,MLCHP1,MLCHP2
  622.       SEGSUP,RI5
  623.       SEGDES,RI1
  624.       IF(RI2.NE.0) SEGDES,RI2
  625.  
  626.       if(iimpi.ge.333) write(ioimp,*) 'RI1,RI2=',RI1,RI2
  627.  
  628.       RETURN
  629.       END
  630.  
  631.  
  632.  
  633.  
  634.  
  635.  
  636.  
  637.  
  638.  
  639.  
  640.  
  641.  
  642.  
  643.  
  644.  
  645.  
  646.  
  647.  
  648.  
  649.  
  650.  
  651.  
  652.  
  653.  

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