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

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