Télécharger la plaquette Cast3M


fr en

Télécharger psmo.eso

Retour à la liste

Numérotation des lignes : 

psmo

  1. C PSMO      SOURCE    CB215821  20/11/25    13:37:59     10792          
  2.       SUBROUTINE PSMO
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. ************************************************************************
  6. *
  7. *                               P S M O
  8. *                               -------
  9. *
  10. *            Sous-programme associ{ @ l'op{rateur  "PSMO"
  11. *
  12. * FONCTION:
  13. * ---------
  14. *
  15. *     L'op{rateur "PSMO" calcule les pseudo-modes en d{placement.
  16. *
  17. * PHRASE D'APPEL (EN GIBIANE):
  18. * ----------------------------
  19. *
  20. *     SOLS  =  'PSMO'  RIG  (MAS)  MOD1  (TPODI)  (CHP1  OU  LCHP1)
  21. *                      (SEISME  (UX) (UY) (UZ))  (FREQ  XFREQ)  ;
  22. *
  23. * OPERANDES ET RESULTATS:
  24. * -----------------------
  25. *
  26. *     RIG     'RIGIDITE'  matrice de rigidit{ de la structure.
  27. *     MAS     'RIGIDITE'  matrice de masse de la structure.
  28. *     MOD1    'TABLE   '  modes de la structure.
  29. *     TPODI   'TABLE   '  table de sous-type POINTS_DE_LIAISON, donnant
  30. *                         les point et normale de chaque choc.
  31. *     CHP1    'CHPOINT '  description spatiale des chargements ou des
  32. *                         supports.
  33. *     LCHP1   'LISTCHPO'  description spatiale des chargements ou des
  34. *                         supports.
  35. *     SEISME  'MOT     '  mot cl{, indique que  :
  36. *                                 - soit la structure est soumise @
  37. *                         une acc{l{ration sismique d'ensemble.
  38. *                                 - soit la structure est multisupport{e
  39. *                         avec un d{placement impos{ des supoorts.
  40. *     UX      'MOT     '  mot cl{, direction de l'excitation sismique
  41. *                         suivant X.
  42. *     UY      'MOT     '  mot cl{, direction de l'excitation sismique
  43. *                         suivant Y.
  44. *     UZ      'MOT     '  mot cl{, direction de l'excitation sismique
  45. *                         suivant Z.
  46. *     FREQ    'MOT     '  mot cl{, indique dans le cas ou la structure a
  47. *                         des modes de corps solide que l'utilisateur
  48. *                         veut imposer la fr{quence @ laquelle on
  49. *                         {tudiera la r{ponse de la structure.
  50. *     XFREQ   'FLOTTANT'  valeur de cette fr{quence.
  51. *     SOLS    'TABLE   '  objet TABLE de sous-type 'PSEUDO_MODE'
  52. *                         contenant les pseudo-modes.
  53. *
  54. * MODULES UTILISES:
  55. * -----------------
  56. *
  57.  
  58. -INC PPARAM
  59. -INC CCOPTIO
  60. -INC CCREEL
  61. *-
  62. -INC SMRIGID
  63. -INC SMATTAC
  64. -INC SMCHPOI
  65. -INC SMELEME
  66. -INC SMLCHPO
  67. -INC SMSOLUT
  68. -INC SMSTRUC
  69. *
  70. * VARIABLES:
  71. * ----------
  72. *
  73. *     DIR       : direction de l'excitation sismique.
  74. *     DIRECT(3) : tableau contenant les directions sismiques donn{es.
  75. *     CORSOL = .TRUE.  : la structure a des modes de corps solide.
  76. *     SISMIQ = .TRUE.  : excitation sismique.
  77. *     FORCON = .TRUE.  : force concentr{e.
  78. *     STRUCM = .TRUE.  : structure multisupport{e.
  79. *
  80.       PARAMETER (LSEIS=3,LOPT1=1,LOPT2=1)
  81.       CHARACTER*2 NSEISM(LSEIS),DIRECT(3),DIR
  82.       CHARACTER*4 NOPTI1(LOPT1),COMP
  83.       CHARACTER*6 NOPTI2(LOPT2)
  84.       CHARACTER*8 TYPRET,CTYP,CHARRE
  85.       CHARACTER*40 CMOT,MONMOT
  86.       LOGICAL CORSOL,SISMIQ,FORCON,STRUCM,L0,L1
  87. *
  88. *
  89. * AUTEUR, DATE DE CREATION:
  90. * -------------------------
  91. *
  92. *     Lionel VIVAN       Juillet 1988
  93. *
  94. ************************************************************************
  95. *
  96.       SEGMENT MTRAV
  97.         REAL*8 FREQ(NBMODE),MN(NBMODE),MW2(NBMODE),
  98.      &         QX(NBMODE),QY(NBMODE),QZ(NBMODE)
  99.         INTEGER DEPL(NBMODE)
  100.       ENDSEGMENT
  101. *
  102.       DATA NOPTI1/'FREQ'/
  103.       DATA NOPTI2/'SEISME'/
  104.       DATA NSEISM/'UX','UY','UZ'/
  105.       CORSOL = .FALSE.
  106.       SISMIQ = .FALSE.
  107.       FORCON = .FALSE.
  108.       STRUCM = .FALSE.
  109.       DEUXPI = 2.D0 * XPI
  110.       EPSI = 0.00001
  111.       XFREQ = 0.D0
  112.       NBCHP = 0
  113.       LCH1 = 0
  114.       ICH1 = 0
  115.       IAT1 = 0
  116.       DO 8 I =1,3
  117.          DIRECT(I) = '  '
  118. 8     CONTINUE
  119. *
  120. *     lecture des donn{es
  121. *
  122.       CALL LIRMOT(NOPTI1,LOPT1,IMOT,0)
  123.       IF (IMOT .EQ. 1) THEN
  124.          CALL LIRREE(XFREQ,1,IRETOU)
  125.          IF (XFREQ .LE. 0.D0) THEN
  126.             CALL ERREUR(21)
  127.             RETURN
  128.          ENDIF
  129.          CORSOL = .TRUE.
  130.       ENDIF
  131. *
  132.       CALL LIRMOT(NOPTI2,LOPT2,IMOT,0)
  133.       IF (IMOT .EQ. 1) THEN
  134.          SISMIQ = .TRUE.
  135.          I = 0
  136. 10       CONTINUE
  137.          CALL LIRMOT(NSEISM,LSEIS,IMOT,0)
  138.          IF (IMOT .NE. 0) THEN
  139.             IF (I .LE. 3) THEN
  140.                I = I + 1
  141.                DIRECT(I) = NSEISM(IMOT)
  142.                GOTO 10
  143.             ELSE
  144.                CALL ERREUR(21)
  145.                RETURN
  146.             ENDIF
  147.          ENDIF
  148.       ENDIF
  149. *
  150.       CALL QUETYP(CTYP,1,IRETOU)
  151.       IF (CTYP(1:8).EQ.'RIGIDITE') GOTO 2000
  152. *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*
  153. *                    version appel{e @ disparaitre
  154. *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*
  155.       CALL LIROBJ('STRUCTUR',ISTR,1,IRETOU)
  156.       IF (IERR .NE. 0) RETURN
  157. *
  158.       CALL LIROBJ('SOLUTION',IMOD,1,IRETOU)
  159.       IF (IERR .NE. 0) RETURN
  160. *
  161.       CALL LIROBJ('ATTACHE ',IATT,0,IRETOU)
  162.       IF (IRETOU .EQ. 1) THEN
  163.          IAT1 = 1
  164.       ENDIF
  165. *
  166.       CALL LIROBJ('CHPOINT ',ICHPT,0,IRETOU)
  167.       IF (IRETOU .EQ. 0) THEN
  168.          CALL LIROBJ('LISTCHPO',LCHPT,0,IRETOU)
  169.          IF (IRETOU .EQ. 1) THEN
  170.             CALL ACTOBJ('LISTCHPO',LCHPT,1)
  171.             LCH1 = 1
  172.          ENDIF
  173.       ELSE
  174.          CALL ACTOBJ('CHPOINT ',ICHPT,1)
  175.          ICH1 = 1
  176.       ENDIF
  177.       IF (ICH1 .EQ. 1) THEN
  178.          CALL ECROBJ('CHPOINT ',ICHPT)
  179.          CALL SUITE1
  180.          IF(IERR.NE.0) RETURN
  181.          CALL LIROBJ('LISTCHPO',LCHPT,1,IRETOU)
  182.          CALL ACTOBJ('LISTCHPO',LCHPT,1)
  183.          IF(IERR.NE.0) RETURN
  184.          LCH1 = 1
  185.       ENDIF
  186. *
  187.       IF (LCH1 .EQ. 1) THEN
  188.          IF ( SISMIQ ) THEN
  189.             STRUCM = .TRUE.
  190.             SISMIQ = .FALSE.
  191.          ELSE
  192.             FORCON = .TRUE.
  193.          ENDIF
  194.          CALL DIMEN2(LCHPT,NBCHP)
  195.          IF (IERR.NE.0) RETURN
  196.       ENDIF
  197. *
  198. *     RECUPERATION DE LA MATRICE K ET DE LA MATRICE M
  199. *
  200.       CALL EXTR10(ISTR,'RIGI',IRAI1)
  201.       IF (IERR.NE.0) RETURN
  202.       CALL EXTR10(ISTR,'MASS',IMAS1)
  203.       IF (IERR.NE.0) RETURN
  204. *
  205. *     REMPLISSAGE DE MTRAV
  206. *
  207.       MSOLUT = IMOD
  208.       SEGACT MSOLUT
  209.       MSOLEN = MSOLIS(4)
  210.       SEGACT MSOLEN
  211.       NBMODE = ISOLEN(/1)
  212. *
  213.       SEGINI MTRAV
  214. *
  215.       DO 1940 I = 1,NBMODE
  216.          FREQ(I) = XZERO
  217.          MN(I) = XZERO
  218.          MW2(I) = XZERO
  219.          QX(I) = XZERO
  220.          QY(I) = XZERO
  221.          QZ(I) = XZERO
  222.          DEPL(I) = 0
  223. 1940  CONTINUE
  224. *
  225.       DO 1950 IM = 1,NBMODE
  226.          MMODE = ISOLEN(IM)
  227.          SEGACT MMODE
  228.          XF = FMMODD(1)
  229.          XMN = FMMODD(2)
  230.          W2 = ( DEUXPI * XF ) ** 2
  231.          FREQ(IM) = XF
  232.          MN(IM) = XMN
  233.          MW2(IM) = XMN * W2
  234.          QX(IM) = FMMODD(3)
  235.          QY(IM) = FMMODD(4)
  236.          QZ(IM) = FMMODD(5)
  237.          SEGDES MMODE
  238. 1950  CONTINUE
  239.       SEGDES MSOLEN
  240. *
  241.       MSOLEN = MSOLIS(5)
  242.       SEGACT MSOLEN
  243.       DO 1960 ID = 1,NBMODE
  244.          DEPL(ID) = ISOLEN(ID)
  245. 1960  CONTINUE
  246.       SEGDES MSOLEN
  247. *
  248.       SEGDES MSOLUT
  249. *
  250. *     CAS DES MODES DE CORPS SOLIDE
  251. *     RECHERCHE DE FREQUENCE(S) NULLE(S) DANS L'OBJET SOLUTION
  252. *
  253.       XF1 = 0.D0
  254.       DO 1972 I = 1,NBMODE
  255.          XFI = FREQ(I)
  256.          IF (XFI .LT. EPSI) THEN
  257.             CORSOL = .TRUE.
  258.          ELSE
  259.             IF (XF1 .EQ. 0.D0) XF1 =XFI
  260.          ENDIF
  261. 1972  CONTINUE
  262. *
  263.       IF ( CORSOL ) THEN
  264.          IF (XFREQ .EQ. 0.D0) THEN
  265. *           RECHERCHE DE LA 1-ERE FREQUENCE NON NULLE
  266.             DO 1974 I = 1,NBMODE
  267.                XFI = FREQ(I)
  268.                IF ((XFI .LT. XF1) .AND.(XFI .GE. EPSI))THEN
  269.                   XF1 = XFI
  270.                ENDIF
  271. 1974        CONTINUE
  272.             XFREQ = XF1 / 2.D0
  273.          ENDIF
  274. *
  275.          IF ( IIMPI .GT. 0 ) THEN
  276.          WRITE (IOIMP,998) ( FREQ(I),I=1,NBMODE)
  277. 998      FORMAT (/1X,'SBR PSMO LISTE DES FREQ ',/1X,10(E12.5,1X))
  278.          WRITE ( IOIMP, 1002 )  XFREQ
  279. 1002     FORMAT ( /1X, 'SBR PSMO CORPS SOLIDES 1ERE FREQ*0.5 N.NUL'
  280.      C   ,' OU FREQ IMPO  ',E12.5 )
  281.          ENDIF
  282.          W2 = (DEUXPI * XFREQ) ** 2
  283.          CALL DECALE(IRAI1,IMAS1,W2,IRAID)
  284.          IF (IERR.NE.0) RETURN
  285. *
  286.          DO 19100 IM = 1,NBMODE
  287.             W2I = ( DEUXPI * FREQ(IM) ) ** 2
  288.             MW2(IM) = MN(IM) * ( W2I - W2 )
  289. 19100    CONTINUE
  290. *
  291.       ELSE
  292.          IRAID = IRAI1
  293.       ENDIF
  294. *
  295.       SEGDES MTRAV
  296. *
  297.       NUME = NBMODE
  298.       NBMOD1 = NBMODE + 1
  299.       XFRST = 0.D0
  300.       XMNST = 0.D0
  301.       XQ1 = 0.D0
  302.       XQ2 = 0.D0
  303.       XQ3 = 0.D0
  304.       ICHE1 = 0
  305. *
  306. *     CAS DE L'ACCELERATION SISMIQUE D'ENSEMBLE
  307. *
  308.       IF ( SISMIQ ) THEN
  309.          CALL ECRCHA('MAIL')
  310.          CALL ECROBJ('RIGIDITE',IRAID)
  311.          CALL EXTRAI
  312.          IF (IERR.NE.0) RETURN
  313.          CALL LIROBJ('MAILLAGE',IMAIL,1,IRETOU)
  314.          IF (IERR.NE.0) RETURN
  315.          DO 1980 ID = 1,3
  316.             DIR = DIRECT(ID)
  317.             IF (DIR .NE. '  ') THEN
  318.                CALL PSACCE(IRAID,IMAS1,IMAIL,MTRAV,DIR,ICHP1)
  319.                N = 0
  320.                SEGINI MJONCT
  321.                IJONCT = MJONCT
  322.                MJODDL = DIR
  323.                MJOTYP = 'SEIS'
  324.                MJOPOI = 0
  325.                SEGDES MJONCT
  326.                MCHPOI = ICHP1
  327.                SEGACT MCHPOI
  328.                IF (DIR .EQ. 'UX') THEN
  329.                   MOCHDE = 'EMSISEISMEX'
  330.                ELSE IF (DIR .EQ. 'UY') THEN
  331.                   MOCHDE = 'EMSISEISMEY'
  332.                ELSE
  333.                   MOCHDE = 'EMSISEISMEZ'
  334.                ENDIF
  335.                SEGDES MCHPOI
  336.                NUME = NUME + 1
  337.                IF (NUME .EQ. NBMOD1) THEN
  338.                   CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
  339.      &                        ICHP1,ICHE1,IJONCT,ISOLS)
  340.                ELSE
  341.                   CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
  342.      &                        ICHP1,ICHE1,IJONCT,ISOL1)
  343.                   CALL FUSOLU(ISOLS,ISOL1,ISOL2)
  344.                   IF (IERR.NE.0) RETURN
  345.                   CALL DESOLU(ISOLS)
  346.                   IF (IERR.NE.0) RETURN
  347.                   CALL DESOLU(ISOL1)
  348.                   IF (IERR.NE.0) RETURN
  349.                   ISOLS = ISOL2
  350.                ENDIF
  351.             ENDIF
  352. 1980     CONTINUE
  353.       ENDIF
  354. *
  355. *     CAS DES FORCES CONCENTREES OU DE CHOCS
  356. *
  357.       IF ( FORCON ) THEN
  358.          DO 1920 IC = 1,NBCHP
  359.             CALL EXTRA4(LCHPT,IC,ICHPT)
  360.             IF (IERR.NE.0) RETURN
  361.             CALL PSCHPT(IRAID,IMAS1,MTRAV,ICHPT,'FORC',ICHP1)
  362.             N = 1
  363.             SEGINI MJONCT
  364.             IJONCT = MJONCT
  365.             MJODDL = '    '
  366.             MJOTYP = 'FORC'
  367.             MJOPOI = 0
  368.             IPCHJO(1) = ICHPT
  369.             ISTRJO(1) = 0
  370.             IPOSJO(1) = 0
  371.             SEGDES MJONCT
  372.             MCHPOI = ICHP1
  373.             SEGACT MCHPOI
  374.             MOCHDE = 'EMSIFORCECONCENTREE'
  375.             SEGDES MCHPOI
  376.             NUME = NUME + 1
  377.             IF (NUME .EQ. NBMOD1) THEN
  378.                CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
  379.      &                     ICHP1,ICHE1,IJONCT,ISOLS)
  380.             ELSE
  381.                CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
  382.      &                     ICHP1,ICHE1,IJONCT,ISOL1)
  383.                CALL FUSOLU(ISOLS,ISOL1,ISOL2)
  384.                IF (IERR.NE.0) RETURN
  385.                CALL DESOLU(ISOLS)
  386.                IF (IERR.NE.0) RETURN
  387.                CALL DESOLU(ISOL1)
  388.                IF (IERR.NE.0) RETURN
  389.                ISOLS = ISOL2
  390.             ENDIF
  391. 1920     CONTINUE
  392.       ENDIF
  393. *
  394. *     CAS DES FORCES DE CHOC
  395. *
  396.       IF (IAT1 .EQ. 1) THEN
  397.          MATTAC = IATT
  398.          SEGACT MATTAC
  399.          NSOUMA = LISATT(/1)
  400.          DO 1932 IS =1,NSOUMA
  401.             MSOUMA = LISATT(IS)
  402.             SEGACT MSOUMA
  403.             IF (ITYATT .NE. 'CHOC') THEN
  404.                SEGDES MSOUMA
  405.                GOTO 1932
  406.             ENDIF
  407.             MGEOCH = IGEOCH
  408.             SEGACT MGEOCH
  409.             MELEME = INORCH(1)
  410.             SEGDES MGEOCH
  411.             SEGACT MELEME
  412.             NORM = NUM(1,1)
  413.             SEGDES MELEME
  414.             NJONCT = IATREL(/1)
  415.             DO 1934 IJ =1,NJONCT
  416.                MJONCT = IATREL(IJ)
  417.                SEGACT MJONCT
  418.                DO 1936 IJ2 = 1,2
  419.                   ISTR = ISTRJO(IJ2)
  420.                   IF (ISTR.NE.0) THEN
  421.                      MCHPOI = IPCHJO(IJ2)
  422.                      SEGACT MCHPOI
  423.                      MSOUPO = IPCHP(1)
  424.                      SEGDES MCHPOI
  425.                      SEGACT MSOUPO
  426.                      MELEME = IGEOC
  427.                      SEGDES MSOUPO
  428.                      SEGACT MELEME
  429.                      IPT = NUM(1,IJ2)
  430.                      SEGDES MELEME
  431. *
  432.                      CALL PSCHOC(IRAID,MTRAV,IPT,NORM,IJ2, ICHP1)
  433.                      N = 1
  434.                      SEGINI MJONC1
  435.                      IJONCT = MJONC1
  436.                      MJONC1.MJODDL = '    '
  437.                      MJONC1.MJOTYP = 'CHOC'
  438.                      MJONC1.MJOPOI = IPT
  439.                      MJONC1.IPCHJO(1) = 0
  440.                      MJONC1.ISTRJO(1) = ISTR
  441.                      MJONC1.IPOSJO(1) = 0
  442.                      SEGDES MJONC1
  443. *
  444.                      MCHPOI = ICHP1
  445.                      SEGACT MCHPOI
  446.                      MOCHDE = 'EMSIFORCEDECHOC'
  447.                      SEGDES MCHPOI
  448. *
  449.                      NUME = NUME + 1
  450.                      IF (NUME .EQ. NBMOD1) THEN
  451.                         CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,
  452.      &                              XQ2,XQ3,ICHP1,ICHE1,IJONCT,ISOLS)
  453.                      ELSE
  454.                         CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,
  455.      &                              XQ2,XQ3,ICHP1,ICHE1,IJONCT,ISOL1)
  456.                         CALL FUSOLU(ISOLS,ISOL1,ISOL2)
  457.                         IF (IERR.NE.0) RETURN
  458.                         CALL DESOLU(ISOLS)
  459.                         IF (IERR.NE.0) RETURN
  460.                         CALL DESOLU(ISOL1)
  461.                         IF (IERR.NE.0) RETURN
  462.                         ISOLS = ISOL2
  463.                      ENDIF
  464.                   ENDIF
  465. 1936           CONTINUE
  466.                SEGDES MJONCT
  467. 1934        CONTINUE
  468.             SEGDES MSOUMA
  469. 1932     CONTINUE
  470.          SEGDES MATTAC
  471.       ENDIF
  472. *
  473. *     CAS DES STRUCTURES MULTISUPPORTEES
  474. *
  475.       IF ( STRUCM ) THEN
  476.          DO 1942 IC = 1,NBCHP
  477.             CALL EXTRA4(LCHPT,IC,ICHPT)
  478.             IF (IERR.NE.0) RETURN
  479.             CALL PSCHPT(IRAID,IMAS1,MTRAV,ICHPT,'DEPL',ICHP1)
  480.             N = 1
  481.             SEGINI MJONCT
  482.             IJONCT = MJONCT
  483.             MJODDL = '    '
  484.             MJOTYP = 'DEPL'
  485.             MJOPOI = 0
  486.             IPCHJO(1) = ICHPT
  487.             ISTRJO(1) = 0
  488.             IPOSJO(1) = 0
  489.             SEGDES MJONCT
  490.             MCHPOI = ICHP1
  491.             SEGACT MCHPOI
  492.             MOCHDE = 'EMSISTRUCTUREMULTISUPPORTEE'
  493.             SEGDES MCHPOI
  494.             NUME = NUME + 1
  495.             IF (NUME .EQ. NBMOD1) THEN
  496.                CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
  497.      &                     ICHP1,ICHE1,IJONCT,ISOLS)
  498.             ELSE
  499.                CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
  500.      &                     ICHP1,ICHE1,IJONCT,ISOL1)
  501.                CALL FUSOLU(ISOLS,ISOL1,ISOL2)
  502.                IF (IERR.NE.0) RETURN
  503.                CALL DESOLU(ISOLS)
  504.                IF (IERR.NE.0) RETURN
  505.                CALL DESOLU(ISOL1)
  506.                IF (IERR.NE.0) RETURN
  507.                ISOLS = ISOL2
  508.             ENDIF
  509. 1942     CONTINUE
  510.       ENDIF
  511. *
  512.       SEGSUP MTRAV
  513. *
  514.       CALL ECROBJ('SOLUTION',ISOLS)
  515. *
  516.       RETURN
  517. *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*++*+*+*
  518. *                        nouvelle version
  519. *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*++*+*+*
  520.  2000 CONTINUE
  521.       IRAI1 = 0
  522.       IMAS1 = 0
  523.  1    CALL LIROBJ('RIGIDITE',IRET,0,IRETOU)
  524.       IF (IRETOU.NE.0) THEN
  525.          MRIGID = IRET
  526.          SEGACT,MRIGID
  527.          IF (MTYMAT.EQ.'RIGIDITE') THEN
  528.             IF (IRAI1.NE.0) THEN
  529.                MOTERR(1:8)='RIGIDITE'
  530.                MOTERR(9:16)='RIGIDITE'
  531.                CALL ERREUR(130)
  532. *              la matrice de rigidite a d{ja {t{ donn{e
  533.                SEGDES,MRIGID
  534.                RETURN
  535.             ENDIF
  536.             IRAI1 = MRIGID
  537.             SEGDES,MRIGID
  538.             IF (IMAS1.EQ.0) GOTO 1
  539.          ELSE IF (MTYMAT.EQ.'MASSE') THEN
  540.             IF (IMAS1.NE.0) THEN
  541.                MOTERR(1:8)='RIGIDITE'
  542.                MOTERR(9:16)='MASSE'
  543.                CALL ERREUR(130)
  544. *              la matrice de masse a d{ja {t{ donn{e
  545.                SEGDES,MRIGID
  546.                RETURN
  547.             ENDIF
  548.             IMAS1 = MRIGID
  549.             SEGDES,MRIGID
  550.             IF (IRAI1.EQ.0) GOTO 1
  551.          ELSE
  552.             MOTERR(1:8) = 'RIGIDITE'
  553.             MOTERR(9:16) = MTYMAT
  554.             CALL ERREUR(131)
  555. *           on n'attend pas ce sous type de rigidit{
  556.             SEGDES,MRIGID
  557.             RETURN
  558.          ENDIF
  559.       ENDIF
  560. *
  561.       CALL LIRTAB('BASE_DE_MODES',ITMOD,1,IRET)
  562.       IF (IERR .NE. 0) RETURN
  563. *
  564.       CALL LIRTAB('POINT_DE_LIAISON',ITLIA,0,IRETOU)
  565.       IF (IRETOU .EQ. 1) THEN
  566.          IAT1 = 1
  567.       ENDIF
  568. *
  569.       CALL LIROBJ('CHPOINT ',ICHPT,0,IRETOU)
  570.       IF (IRETOU .EQ. 0) THEN
  571.          CALL LIROBJ('LISTCHPO',LCHPT,0,IRETOU)
  572.          IF (IRETOU .EQ. 1) THEN
  573.             CALL ACTOBJ('LISTCHPO',LCHPT,1)
  574.             LCH1 = 1
  575.          ENDIF
  576.       ELSE
  577.          CALL ACTOBJ('CHPOINT ',ICHPT,1)
  578.          ICH1 = 1
  579.       ENDIF
  580.       IF (ICH1 .EQ. 1) THEN
  581.          CALL ECROBJ('CHPOINT ',ICHPT)
  582.          CALL SUITE1
  583.          IF(IERR.NE.0) RETURN
  584.          CALL LIROBJ('LISTCHPO',LCHPT,1,IRETOU)
  585.          CALL ACTOBJ('LISTCHPO',LCHPT,1)
  586.          IF(IERR.NE.0) RETURN
  587.          LCH1 = 1
  588.       ENDIF
  589. *
  590.       IF (LCH1 .EQ. 1) THEN
  591.          IF ( SISMIQ ) THEN
  592.             STRUCM = .TRUE.
  593.             SISMIQ = .FALSE.
  594.          ELSE
  595.             FORCON = .TRUE.
  596.          ENDIF
  597.          CALL DIMEN2(LCHPT,NBCHP)
  598.          IF (IERR.NE.0) RETURN
  599.       ENDIF
  600. *
  601. *     remplissage de MTRAV
  602. *
  603.       CALL DIMEN7(ITMOD,NBMODE)
  604.       NBMODE = NBMODE - 2
  605. *
  606.       SEGINI MTRAV
  607.       DO 50 IM = 1,NBMODE
  608.          CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',L0,IP0,
  609.      &                      'TABLE',I1,X1,' ',L1,ITMK)
  610.          CALL ACCTAB(ITMK,'MOT',I0,X0,'FREQUENCE',L0,IP0,
  611.      &               'FLOTTANT',I1,XF,' ',L1,IP1)
  612.          CALL ACCTAB(ITMK,'MOT',I0,X0,'MASSE_GENERALISEE',L0,IP0,
  613.      &               'FLOTTANT',I1,XMN,' ',L1,IP1)
  614.          CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',L0,IP0,
  615.      &                  'TABLE',I1,X1,' ',L1,ITDG)
  616.          CALL ACCTAB(ITDG,'ENTIER',1,X0,' ',L0,IP0,
  617.      &                  'FLOTTANT',I1,XQX,' ',L1,IP1)
  618.          CALL ACCTAB(ITDG,'ENTIER',2,X0,' ',L0,IP0,
  619.      &                  'FLOTTANT',I1,XQY,' ',L1,IP1)
  620.          CALL ACCTAB(ITDG,'ENTIER',3,X0,' ',L0,IP0,
  621.      &                  'FLOTTANT',I1,XQZ,' ',L1,IP1)
  622.          CALL ACCTAB(ITMK,'MOT',I0,X0,'DEFORMEE_MODALE',L0,IP0,
  623.      &                'CHPOINT',I1,X1,' ',L1,ICHDM)
  624.          W2 = ( DEUXPI * XF ) ** 2
  625.          FREQ(IM) = XF
  626.          MN(IM) = XMN
  627.          MW2(IM) = XMN * W2
  628.          QX(IM) = XQX
  629.          QY(IM) = XQY
  630.          QZ(IM) = XQZ
  631.          DEPL(IM) = ICHDM
  632. 50    CONTINUE
  633. *
  634. *     cas des modes de corps solide
  635. *     recherche de fr{quence(s) nulle(s)
  636. *
  637.       XF1 = 0.D0
  638.       DO 72 I = 1,NBMODE
  639.          XFI = FREQ(I)
  640.          IF (XFI .LT. EPSI) THEN
  641.             CORSOL = .TRUE.
  642.          ELSE
  643.             IF (XF1 .EQ. 0.D0) XF1 =XFI
  644.          ENDIF
  645. 72    CONTINUE
  646. *
  647.       IF ( CORSOL ) THEN
  648.          IF (XFREQ .EQ. 0.D0) THEN
  649. *           recherche de la 1-}re fr{quence non nulle
  650.             DO 74 I = 1,NBMODE
  651.                XFI = FREQ(I)
  652.                IF ((XFI .LT. XF1) .AND.(XFI .GE. EPSI))THEN
  653.                   XF1 = XFI
  654.                ENDIF
  655. 74          CONTINUE
  656.             XFREQ = XF1 / 2.D0
  657.          ENDIF
  658. *
  659.          IF ( IIMPI .GT. 0 ) THEN
  660.          WRITE (IOIMP,999) ( FREQ(I),I=1,NBMODE)
  661. 999      FORMAT (/1X,'SBR PSMO liste des freq ',/1X,10(E12.5,1X))
  662.          WRITE ( IOIMP, 1000 )  XFREQ
  663. 1000     FORMAT ( /1X, 'SBR PSMO corps solides 1}re freq*0.5 n.nil'
  664.      &   ,' OU FREQ IMPO  ',E12.5 )
  665.          ENDIF
  666.          W2 = (DEUXPI * XFREQ) ** 2
  667.          IF (IMAS1.EQ.0) THEN
  668.             MOTERR(1:8) = 'RIGIDITE'
  669.             MOTERR(9:16) = 'MASSE   '
  670.             CALL ERREUR(131)
  671.             SEGSUP,MTRAV
  672.             RETURN
  673.          ENDIF
  674.          CALL DECALE(IRAI1,IMAS1,W2,IRAID)
  675.          IF (IERR.NE.0) RETURN
  676. *
  677.          DO 100 IM = 1,NBMODE
  678.             W2I = ( DEUXPI * FREQ(IM) ) ** 2
  679.             MW2(IM) = MN(IM) * ( W2I - W2 )
  680.  100     CONTINUE
  681. *
  682.       ELSE
  683.          IRAID = IRAI1
  684.       ENDIF
  685. *
  686.       SEGDES MTRAV
  687. *
  688. *     cr{ation de la table de sortie
  689. *
  690.       CALL CRTABL(ITPSMO)
  691.       CALL ECCTAB(ITPSMO,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  692.      &                   'MOT',I1,X1,'PSEUDO_MODE',L1,IP1)
  693.       IPSMO = 0
  694. *
  695. *     cas de l'acceleration sismique d'ensemble
  696. *
  697.       IF ( SISMIQ ) THEN
  698.          IF (IRAID.EQ.0) THEN
  699.             MOTERR(1:8)='RIGIDITE'
  700.             MOTERR(9:16)='RAIDEUR'
  701.             CALL ERREUR(79)
  702.             SEGSUP,MTRAV
  703.             RETURN
  704.          ENDIF
  705.          IF (IMAS1.EQ.0) THEN
  706.             MOTERR(1:8)='RIGIDITE'
  707.             MOTERR(9:16)='MASSE'
  708.             CALL ERREUR(79)
  709.             SEGSUP,MTRAV
  710.             RETURN
  711.          ENDIF
  712.          CALL ECRCHA('MAIL')
  713.          CALL ECROBJ('RIGIDITE',IRAID)
  714.          CALL EXTRAI
  715.          IF (IERR.NE.0) RETURN
  716.          CALL LIROBJ('MAILLAGE',IMAIL,1,IRETOU)
  717.          IF (IERR.NE.0) RETURN
  718.          DO 80 ID = 1,3
  719.             DIR = DIRECT(ID)
  720.             IF (DIR .NE. '  ') THEN
  721.                CALL PSACCE(IRAID,IMAS1,IMAIL,MTRAV,DIR,ICHP1)
  722.                MCHPOI = ICHP1
  723.                SEGACT MCHPOI*MOD
  724.                IF (DIR .EQ. 'UX') THEN
  725.                   MOCHDE = 'EMSISEISMEX'
  726.                   IENT = 1
  727.                ELSE IF (DIR .EQ. 'UY') THEN
  728.                   MOCHDE = 'EMSISEISMEY'
  729.                   IENT = 2
  730.                ELSE
  731.                   MOCHDE = 'EMSISEISMEZ'
  732.                   IENT = 3
  733.                ENDIF
  734.                SEGDES MCHPOI
  735.                CALL CRTABL(ITSEIS)
  736.                CALL ECCTAB(ITSEIS,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  737.      &                            'MOT',I1,X1,'PSMO_SEIS',L1,IP1)
  738.                CALL ECCTAB(ITSEIS,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  739.      &                        'CHPOINT',I1,X1,' ',L1,ICHP1)
  740.                CALL ECCTAB(ITSEIS,'MOT',I0,X0,'DIRECTION',L0,IP0,
  741.      &                         'ENTIER',IENT,X1,' ',L1,IP1)
  742.                IPSMO = IPSMO + 1
  743.                CALL ECCTAB(ITPSMO,'ENTIER',IPSMO,X0,' ',L0,IP0,
  744.      &                             'TABLE',I1,X1,' ',L1,ITSEIS)
  745.             ENDIF
  746. 80       CONTINUE
  747.       ENDIF
  748. *
  749. *     cas des forces concentr{es
  750. *
  751.       IF ( FORCON ) THEN
  752.          IF (IRAID.EQ.0) THEN
  753.             MOTERR(1:8)='RIGIDITE'
  754.             MOTERR(9:16)='RAIDEUR'
  755.             CALL ERREUR(79)
  756.             SEGSUP,MTRAV
  757.             RETURN
  758.          ENDIF
  759.          DO 20 IC = 1,NBCHP
  760.             CALL EXTRA4(LCHPT,IC,ICHPT)
  761.             IF (IERR.NE.0) RETURN
  762.             CALL PSCHPT(IRAID,IMAS1,MTRAV,ICHPT,'FORC',ICHP1)
  763.             MCHPOI = ICHP1
  764.             SEGACT MCHPOI*MOD
  765.             MOCHDE = 'EMSIFORCECONCENTREE'
  766.             SEGDES MCHPOI
  767.             CALL CRTABL(ITFORC)
  768.             CALL ECCTAB(ITFORC,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  769.      &                         'MOT',I1,X1,'PSMO_FORC',L1,IP1)
  770.             CALL ECCTAB(ITFORC,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  771.      &                         'CHPOINT',I1,X1,' ',L1,ICHP1)
  772.             CALL ECCTAB(ITFORC,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  773.      &                     'CHPOINT',I1,X1,' ',L1,ICHPT)
  774.             CALL PROJTA(ICHPT,ITMOD,0,ICHPR)
  775.             CALL ECCTAB(ITFORC,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
  776.      &                     'CHPOINT',I1,X1,' ',L1,ICHPR)
  777.             IPSMO = IPSMO + 1
  778.             CALL ECCTAB(ITPSMO,'ENTIER',IPSMO,X0,' ',L0,IP0,
  779.      &                          'TABLE',I1,X1,' ',L1,ITFORC)
  780. 20       CONTINUE
  781.       ENDIF
  782. *
  783. *     cas des forces de choc
  784. *
  785.       IF (IAT1 .EQ. 1) THEN
  786.          IF (IRAID.EQ.0) THEN
  787.             MOTERR(1:8)='RIGIDITE'
  788.             MOTERR(9:16)='RAIDEUR'
  789.             CALL ERREUR(79)
  790.             SEGSUP,MTRAV
  791.             RETURN
  792.          ENDIF
  793.          IL = 0
  794.  32      CONTINUE
  795.          IL = IL + 1
  796.          TYPRET = ' '
  797.          CALL ACCTAB(ITLIA,'ENTIER',IL,X0,' ',L0,IP0,
  798.      &                       TYPRET,I1,X1,CHARRE,L1,ITLLL)
  799.          IF (ITLLL.NE.0 .AND. TYPRET.EQ.'TABLE   ') THEN
  800.             CALL ACCTAB(ITLLL,'MOT',I1,X0,'POINT',L0,IP0,
  801.      &                      'POINT',I1,X1,' ',L1,IPS)
  802.             CALL ACCTAB(ITLLL,'MOT',I1,X0,'NORMALE',L0,IP0,
  803.      &                      'POINT',I1,X1,' ',L1,IPN)
  804.             CALL PSCHOC(IRAID,MTRAV,IPS,IPN,1,ICHP1)
  805.             MCHPOI = ICHP1
  806.             SEGACT MCHPOI*MOD
  807.             MOCHDE = 'EMSIFORCEDECHOC'
  808.             SEGDES MCHPOI
  809.             CALL CRTABL(ILIAI)
  810.             CALL ECCTAB(ILIAI,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  811.      &                        'MOT',I1,X1,'PSMO_LIAI',L1,IP1)
  812.             CALL ECCTAB(ILIAI,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  813.      &                    'CHPOINT',I1,X1,' ',L1,ICHP1)
  814.             CALL ECCTAB(ILIAI,'MOT',I0,X0,'POINT',L0,IP0,
  815.      &                      'POINT',I1,X1,' ',L1,IPS)
  816.             CALL ECCTAB(ILIAI,'MOT',I0,X0,'NORMALE',L0,IP0,
  817.      &                      'POINT',I1,X1,' ',L1,IPN)
  818.             IPSMO = IPSMO + 1
  819.             CALL ECCTAB(ITPSMO,'ENTIER',IPSMO,X0,' ',L0,IP0,
  820.      &                          'TABLE',I1,X1,' ',L1,ILIAI)
  821.             GOTO 32
  822.          ENDIF
  823.       ENDIF
  824. *
  825. *     cas des structures multisupport{es
  826. *
  827.       IF ( STRUCM ) THEN
  828.          IF (IRAID.EQ.0) THEN
  829.             MOTERR(1:8)='RIGIDITE'
  830.             MOTERR(9:16)='RAIDEUR'
  831.             CALL ERREUR(79)
  832.             SEGSUP,MTRAV
  833.             RETURN
  834.          ENDIF
  835.          IF (IMAS1.EQ.0) THEN
  836.             MOTERR(1:8)='RIGIDITE'
  837.             MOTERR(9:16)='RAIDEUR'
  838.             CALL ERREUR(79)
  839.             SEGSUP,MTRAV
  840.             RETURN
  841.          ENDIF
  842.          DO 42 IC = 1,NBCHP
  843.             CALL EXTRA4(LCHPT,IC,ICHPT)
  844.             IF (IERR.NE.0) RETURN
  845.             CALL PSCHPT(IRAID,IMAS1,MTRAV,ICHPT,'DEPL',ICHP1)
  846.             MCHPOI = ICHP1
  847.             SEGACT MCHPOI*MOD
  848.             MOCHDE = 'EMSISTRUCTUREMULTISUPPORTEE'
  849.             SEGDES MCHPOI
  850.             CALL CRTABL(ITMULT)
  851.             CALL ECCTAB(ITMULT,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  852.      &                         'MOT',I1,X1,'PSMO_DEPL',L1,IP1)
  853.             CALL ECCTAB(ITMULT,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  854.      &                     'CHPOINT',I1,X1,' ',L1,ICHP1)
  855.             CALL ECCTAB(ITMULT,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  856.      &                     'CHPOINT',I1,X1,' ',L1,ICHPT)
  857.             CALL PROJTA(ICHPT,ITMOD,0,ICHPR)
  858.             CALL ECCTAB(ITMULT,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
  859.      &                     'CHPOINT',I1,X1,' ',L1,ICHPR)
  860.             IPSMO = IPSMO + 1
  861.             CALL ECCTAB(ITPSMO,'ENTIER',IPSMO,X0,' ',L0,IP0,
  862.      &                          'TABLE',I1,X1,' ',L1,ITMULT)
  863. 42       CONTINUE
  864.       ENDIF
  865. *
  866.       SEGSUP MTRAV
  867. *
  868.       CALL ECROBJ('TABLE   ',ITPSMO)
  869. *
  870.       END
  871.  
  872.  
  873.  
  874.  
  875.  
  876.  
  877.  
  878.  
  879.  
  880.  
  881.  
  882.  
  883.  
  884.  
  885.  

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