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    CB215821  25/04/23    21:15:34     12247          
  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.         SEGINI, XMATR1
  342.         IF (MODCOM) THEN
  343.           SEGINI, XMATR2
  344.           SEGDES, XMATR2
  345.         ENDIF
  346.         SEGDES, XMATR1
  347.         GOTO 55
  348.       ENDIF
  349.  
  350.  
  351. ***********************************************************
  352. *     ON PROJETTE LA RIGIDITE "PURE" RI4
  353. ***********************************************************
  354.  
  355.       IF(iel4.eq.0) GOTO 100
  356.       MRIGID=RI4
  357. *
  358. * Cas reel
  359. *
  360.       SEGINI, XMATR1
  361.       if (isym.eq.0) then
  362.           DO 20 J=1, NBMOD
  363.             MCHPO2 = MLCHP1.ICHPOI(J)
  364.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  365.             DO I=J, NBMOD
  366.               MCHPO1 = MLCHP1.ICHPOI(I)
  367.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  368.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  369.               XMATR1.RE(I,J,1)=XVAL
  370.               XMATR1.RE(J,I,1)=XVAL
  371.              ENDDO
  372.             segsup,IPLMOX,IPLMOY
  373.             segsup,MCHPO3
  374.             MCHPO3=0
  375.  20       CONTINUE
  376.       elseif (isym.eq.1) then
  377.           DO 21 J=1, NBMOD
  378.             XMATR1.RE(J,J,1)=0.D0
  379.             if(J.ge.NBMOD) goto 21
  380.             MCHPO2 = MLCHP1.ICHPOI(J)
  381.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  382.             JP1=J+1
  383.             DO I=JP1, NBMOD
  384.               MCHPO1 = MLCHP1.ICHPOI(I)
  385.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  386.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  387.               XMATR1.RE(I,J,1)=XVAL
  388.               XMATR1.RE(J,I,1)=-1.D0*XVAL
  389.             ENDDO
  390.             segsup,IPLMOX,IPLMOY
  391.             segsup,MCHPO3
  392.  21       CONTINUE
  393.       else
  394.           DO 22, J=1, NBMOD
  395.             MCHPO2 = MLCHP1.ICHPOI(J)
  396.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  397.             DO I=1, NBMOD
  398.               MCHPO1 = MLCHP1.ICHPOI(I)
  399.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  400.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  401.               XMATR1.RE(I,J,1)=XVAL
  402.             ENDDO
  403.             segsup,IPLMOX,IPLMOY
  404.             segsup,MCHPO3
  405.  22       CONTINUE
  406.       endif
  407. *
  408. * Cas complexe : calcul de termes complementaires
  409. *
  410.       IF (MODCOM) THEN
  411. c         partie reelle = phiR_i^T.M.phiR_j +/-  phiI_i^T.M. phiI_j
  412.           DO 30, J=1, NBMOD
  413.             MCHPO2 = MLCHP2.ICHPOI(J)
  414.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  415.             DO I=1, NBMOD
  416.               MCHPO1 = MLCHP2.ICHPOI(I)
  417.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  418.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  419.               XMATR1.RE(I,J,1)=XMATR1.RE(I,J,1)-IREEL*XVAL
  420.             ENDDO
  421.             segsup,IPLMOX,IPLMOY
  422.             segsup,MCHPO3
  423.  30       CONTINUE
  424. *         2eme matrice (=partie imaginaire)
  425. c         partie imaginaire = phiR_i^T.M.phiI_j -/+  phiI_i^T.M. phiR_j
  426.           SEGINI,XMATR2
  427.           DO 40, J=1, NBMOD
  428.             MCHPO2 = MLCHP2.ICHPOI(J)
  429.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  430.             DO I=1, NBMOD
  431.               MCHPO1 = MLCHP1.ICHPOI(I)
  432.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  433.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  434.               XMATR2.RE(I,J,1)=XVAL
  435.             ENDDO
  436.             segsup,IPLMOX,IPLMOY
  437.             segsup,MCHPO3
  438.  40       CONTINUE
  439.           DO 50, J=1, NBMOD
  440.             MCHPO2 = MLCHP1.ICHPOI(J)
  441.             CALL MUCPRI(MCHPO2,MRIGID,MCHPO3)
  442.             DO I=1, NBMOD
  443.               MCHPO1 = MLCHP2.ICHPOI(I)
  444.               CALL CORRSP(MRIGID,MCHPO1,MCHPO3,IPLMOX,IPLMOY)
  445.               CALL XTY1(MCHPO1,MCHPO3,IPLMOX,IPLMOY,XVAL)
  446.               XMATR2.RE(I,J,1)=XMATR2.RE(I,J,1)+IREEL*XVAL
  447.             ENDDO
  448.             segsup,IPLMOX,IPLMOY
  449.             segsup,MCHPO3
  450.  50       CONTINUE
  451.           SEGDES,XMATR2
  452.       ENDIF
  453. *
  454.  55   NELRIG = 1
  455.  
  456. *     Stockage dans la rigidite calculee
  457.       IRI1=IRI1+1
  458.         RI1.COERIG(IRI1) = 1.D0
  459.         RI1.IRIGEL(1,IRI1) = MELEME
  460.         RI1.IRIGEL(2,IRI1) = 0
  461.         RI1.IRIGEL(3,IRI1) = DESCR
  462.         RI1.IRIGEL(4,IRI1) = xMATR1
  463.         RI1.IRIGEL(5,IRI1) = NIFOUR
  464.         RI1.IRIGEL(6,IRI1) = 0
  465.         RI1.IRIGEL(7,IRI1) = isym
  466.         xmatr1.symre=isym
  467.       SEGDES,XMATR1
  468.         RI1.IRIGEL(8,IRI1) = 0
  469.       IF (MODCOM) THEN
  470.         RI1.IRIGEL(7,1) = 2
  471.         SEGINI, RI2 = RI1
  472.           RI2.IRIGEL(4,IRI1) = xMATR2
  473.         SEGDES, RI2
  474.       ELSE
  475.         RI2 = 0
  476.       ENDIF
  477.  
  478. *     Travail termine pour RI4.
  479.  
  480. *     si RI4 et RI5 : On ne traite que l'1 des 2 (RI4 par défaut)
  481.       IF(iel5.ne.0) THEN
  482.         IF(IIMPI.ne.0) THEN
  483.           WRITE(IOIMP,*) 'Présence de rigidites pures ',
  484.      &                   'et de relations cinematiques :'
  485.           WRITE(IOIMP,*) 'On ne traite pas les relations cinematiques !'
  486.         ENDIF
  487.         GOTO 900
  488.       ENDIF
  489.  
  490.  100  CONTINUE
  491.       SEGSUP,RI4
  492.  
  493.  
  494. ***********************************************************
  495. *     ON PROJETTE LES RELATIONS CINEMATIQUES RI5
  496. *     rem : cela conduit a construire n rigidites-"relation"
  497. *           de taille m*m -> pas forcement interessant...
  498. ***********************************************************
  499.  
  500.       IF(iel5.eq.0) GOTO 900
  501.       IF(ITAB2.NE.0) THEN
  502.         WRITE(IOIMP,*) 'La syntaxe utilisee ne traite pas',
  503.      &                ' les relations cinematiques !'
  504.         GOTO 900
  505.       ENDIF
  506.  
  507. c     Calcul de la projection d'une relation cinematique sur base modale
  508.  
  509. *     recup de la matrice d entree
  510.       NRIGEL=RI5.IRIGEL(/2)
  511. *     DES2 = DESCR de sortie
  512.       NLIGRD=NBMOD+1
  513.       NLIGRP=NBMOD+1
  514.       SEGINI,DES2
  515.       DES2.LISINC(1)='LX'
  516.       DES2.LISDUA(1)='FLX'
  517.       DES2.NOELEP(1)=1
  518.       DES2.NOELED(1)=1
  519.       do i=2,NLIGRD
  520.        DES2.LISINC(i)='ALFA'
  521.        DES2.LISDUA(i)='FALF'
  522.        DES2.NOELEP(i)=i
  523.        DES2.NOELED(i)=i
  524.       enddo
  525.       SEGDES,DES2
  526. *     maillage de sortie
  527.       NBNN   = NBMOD+1
  528.       NBELEM = NRIGEL
  529.       NBSOUS = 0
  530.       NBREF  = 0
  531.       SEGINI,IPT2
  532.       IPT2.ITYPEL = 22
  533. *     XMATR3 de sortie
  534.       NELRIG =NRIGEL
  535.       SEGINI,XMATR3
  536.  
  537. *     on branche et on remplit RI1
  538.       IRI1 = IRI1 + 1
  539.       RI1.COERIG(IRI1) = 1.D0
  540.       RI1.IRIGEL(1,IRI1) = IPT2
  541.       RI1.IRIGEL(3,IRI1) = DES2
  542.       RI1.IRIGEL(4,IRI1) = XMATR3
  543.       RI1.IRIGEL(5,IRI1) = RI5.IRIGEL(5,IRI1)
  544.       RI1.IRIGEL(7,IRI1) = 0
  545.       xmatr3.symre=0
  546.  
  547.       SEGACT, MELEME
  548.  
  549. * --- Boucle sur les sous rigidites ---
  550.       iel2=0
  551.       DO 101 irig5=1,NRIGEL
  552.  
  553. *       recup de la sous matrice d entree
  554. c         xcoe5 = RI5.COERIG(irig5) =1 normalement !
  555.         IPT5  = RI5.IRIGEL(1,irig5)
  556.         DES5  = RI5.IRIGEL(3,irig5)
  557.         XMATR5= RI5.IRIGEL(4,irig5)
  558.         segact,IPT5,DES5,XMATR5
  559.         NBEL5 = IPT5.NUM(/2)
  560.         nddl5 = XMATR5.RE(/2)
  561.  
  562. c    -- boucle sur les matrices elementaires --
  563.         DO 102 iel5=1,NBEL5
  564.  
  565. *         traitement de la sous matrice de sortie
  566.           iel2 = iel2 + 1
  567.           if(iel2.gt.NBELEM) then
  568.             NBELEM=NBELEM+1
  569.             segadj,IPT2
  570.             NELRIG=NELRIG+1
  571.             segadj,XMATR3
  572.           endif
  573. c         recopie du LX
  574.           IPT2.NUM(1,iel2) = IPT5.NUM(1,iel5)
  575.  
  576. c         boucle sur les modes
  577.           DO 110 j=1,NBMOD
  578.  
  579. c           point repere des modes et chpoint de deformee modale
  580.             IPT2.NUM(j+1,iel2) = NUM(j,1)
  581.             IPHI = MLCHP1.ICHPOI(j)
  582.             XVALj = 0.d0
  583.  
  584. c           boucle sur les ddls (non LX) de la relation en entree
  585.             DO 120 k=2,nddl5
  586.  
  587.               X5k = XMATR5.RE(1,k,iel5)
  588. c             XPHIk = valeur de la jeme deformee modale au ddl u_k
  589.               IP5 = DES5.NOELEP(k)
  590.               IP5 = IPT5.NUM(IP5,iel5)
  591.               MO5 = DES5.LISINC(k)
  592.               CALL EXTRA9(IPHI,IP5,MO5,0,.FALSE.,XPHIk,IRET)
  593.               XVALj = XVALj + X5k*XPHIk
  594.  
  595.  120       CONTINUE
  596.  
  597.            XMATR3.RE(1,J+1,iel2) = XVALj
  598.            XMATR3.RE(J+1,1,iel2) = XVALj
  599.  
  600.  110    CONTINUE
  601.  
  602.  102    CONTINUE
  603.         SEGDES,IPT5,DES5,XMATR5
  604.  
  605.  101  CONTINUE
  606.  
  607.       SEGDES,MELEME
  608.       SEGDES,IPT2,XMATR3
  609.  
  610.  
  611.  
  612. ***********************************************************
  613. *     MENAGE AVANT DE QUITTER
  614. ***********************************************************
  615.  900  CONTINUE
  616.       SEGSUP,MLCHP1,MLCHP2
  617.       SEGSUP,RI5
  618.       SEGDES,RI1
  619.       IF(RI2.NE.0) SEGDES,RI2
  620.  
  621.       if(iimpi.ge.333) write(ioimp,*) 'RI1,RI2=',RI1,RI2
  622.  
  623.       RETURN
  624.       END
  625.  
  626.  
  627.  
  628.  
  629.  
  630.  
  631.  
  632.  
  633.  
  634.  
  635.  
  636.  
  637.  
  638.  
  639.  
  640.  
  641.  
  642.  
  643.  
  644.  
  645.  
  646.  

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