Télécharger la plaquette Cast3M


fr en

Télécharger psrcd2.eso

Retour à la liste

Numérotation des lignes : 

psrcd2

  1. C PSRCD2    SOURCE    CB215821  20/11/25    13:38:01     10792          
  2.       SUBROUTINE PSRCD2(TYPE,ITPS,IBAS,ICHCR,KCHAR,XTEMP,ITRES,IPOS,
  3.      &                  ITLIA)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8(A-H,O-Z)
  6. *--------------------------------------------------------------------*
  7. *                                                                    *
  8. *     Prise en compte des pseudo-modes pour une recombinaison.       *
  9. *                                                                    *
  10. *     Param}tres:                                                    *
  11. *                                                                    *
  12. * e   TYPE    recombinaison d'une contrainte ou d'un d{placement     *
  13. *                        ou d'une r{action                           *
  14. * e   ITPS    table repr{sentant les pseudo-modes                    *
  15. * e   IBAS    table repr{sentant la base modale                      *
  16. * es  ICHCR   nouveau chamelem ou chpoint                            *
  17. * e   KCHAR   chargement de la structure                             *
  18. * e   XTEMP   temps de recombinaison                                 *
  19. * e   ITRES   table issue de l'op{rateur DYNE                        *
  20. * e   IPOS    position de XTEMP dans le listreel des temps           *
  21. * e   ITLIA   table des liaisons                                     *
  22. *                                                                    *
  23. *     Auteur, date de cr{ation:                                      *
  24. *                                                                    *
  25. *     Lionel VIVAN, le 18 avril 1990.                                *
  26. *                                                                    *
  27. *     Passage aux nouveaux mchamls par jm CAMPENON le 01/91          *
  28. *                                                                    *
  29. *--------------------------------------------------------------------*
  30. *                                                                    *
  31.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34. -INC CCREEL
  35. *-
  36. -INC SMCHARG
  37. -INC SMCHPOI
  38. -INC SMCOORD
  39. -INC SMELEME
  40. -INC SMLREEL
  41. *
  42.       LOGICAL L0,L1
  43.       CHARACTER*4 TYPE
  44.       CHARACTER*8 TYPRET,CHARRE
  45.       CHARACTER*40 CMOT,CTYP
  46.       PARAMETER (TOLER = 1.D-6 , IUN = 1 , NBPP = 1)
  47.       CHARACTER*13 MADIR1,MOTPPL(NBPP)
  48.       CHARACTER*21 MADIR2,MOTPPA(NBPP),MOTPPB(NBPP)
  49.       DATA MOTPPL/'FORCE_DE_CHOC'/
  50.       DATA MOTPPA/'FORCE_DE_CHOC_POINT_A'/
  51.       DATA MOTPPB/'FORCE_DE_CHOC_POINT_B'/
  52. *
  53.       IF (KCHAR.NE.0) THEN
  54.          MCHARG = KCHAR
  55.          SEGACT MCHARG
  56.          NCHAR = KCHARG(/1)
  57.       ENDIF
  58.       ITLIAB = 0
  59.       IF (ITLIA.NE.0) THEN
  60.          TYPRET = ' '
  61.          CALL ACCTAB(ITLIA,'MOT',I0,X0,'LIAISON_B',L0,IP0,
  62.      &                    TYPRET,I1,X1,CHARRE,L1,ITAB)
  63.          IF (ITAB.NE.0 .AND. TYPRET.EQ.'TABLE   ') ITLIAB = ITAB
  64.       ENDIF
  65.       CALL ACCTAB(IBAS,'MOT',I0,X0,'MAILLAGE',L1,IP0,
  66.      &            'MAILLAGE',I1,X1,' ',L1,IMAIL)
  67. *
  68. *     Boucle sur les pseudo-modes
  69. *
  70.       IPS = 0
  71.  10   CONTINUE
  72.       IPS = IPS + 1
  73.       TYPRET = ' '
  74.       CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
  75.      &                   TYPRET,I1,X1,CHARRE,L1,ITPM)
  76.       IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE   ') THEN
  77.          CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  78.      &                    'MOT',I1,X1,CMOT,L1,IP1)
  79.          IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
  80.             IF (KCHAR.EQ.0) GOTO 10
  81.             CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  82.      &                   'CHPOINT',I1,X1,' ',L1,ICHBB)
  83. *
  84. *           boucle sur les chargements {l{mentaires
  85. *
  86.             DO 20 ICHA =1,NCHAR
  87.                ICHARG = KCHARG(ICHA)
  88.                SEGACT ICHARG
  89.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  90.      & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  91.                   SEGDES ICHARG
  92.                   GOTO 20
  93.                ENDIF
  94.                IF (ICHBB.EQ.ICHPO1) GOTO 100
  95.  20            CONTINUE
  96. *           end do
  97. *           on n'a pas trouv{ le chargement
  98.             INTERR(1) = IPS
  99.             CALL ERREUR(428)
  100.             SEGDES ICHARG
  101.             GOTO 10
  102.          ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
  103.             IF (KCHAR.EQ.0) GOTO 10
  104.             CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
  105.      &                    'ENTIER',IENT,X1,' ',L1,IP1)
  106.             CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
  107.      &                        'TABLE',I1,X1,' ',L1,ITMK)
  108.             CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
  109.      &                  L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
  110.             CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
  111.      &                     'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
  112. *
  113. *           boucle sur les chargements {l{mentaires
  114. *
  115.             DO 30 ICHA =1,NCHAR
  116.                ICHARG = KCHARG(ICHA)
  117.                SEGACT ICHARG
  118.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  119.      & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  120.  
  121.                   SEGDES ICHARG
  122.                   GOTO 30
  123.                ENDIF
  124.                MCHPOI = ICHPO1
  125.                SEGACT MCHPOI
  126.                MSOUPO = IPCHP(1)
  127.                SEGDES MCHPOI
  128.                SEGACT MSOUPO
  129.                MPOVAL = IPOVAL
  130.                SEGDES MSOUPO
  131.                SEGACT MPOVAL
  132.                QXYZ = VPOCHA(1,1)
  133.                SEGDES MPOVAL
  134.                EPS = ABS(QXYZ + XQXYZ)
  135.                IF (EPS.LT.TOLER) GOTO 100
  136.  30         CONTINUE
  137. *           end do
  138. *           on n'a pas trouv{ le chargement
  139.             INTERR(1) = IPS
  140.             CALL ERREUR(428)
  141.             SEGDES ICHARG
  142.             GOTO 10
  143.          ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
  144.             IF (KCHAR.EQ.0) GOTO 10
  145.             CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  146.      &                   'CHPOINT',I1,X1,' ',L1,ICHBB)
  147. *
  148. *           boucle sur les chargements {l{mentaires
  149. *
  150.             DO 40 ICHA =1,NCHAR
  151.                ICHARG = KCHARG(ICHA)
  152.                SEGACT ICHARG
  153.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  154.      & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  155.                   SEGDES ICHARG
  156.                   GOTO 40
  157.                ENDIF
  158.                IF (ICHBB.EQ.ICHPO1) GOTO 100
  159.  40         CONTINUE
  160. *           end do
  161. *           on n'a pas trouv{ le chargement
  162.             INTERR(1) = IPS
  163.             CALL ERREUR(428)
  164.             SEGDES ICHARG
  165.             GOTO 10
  166.          ELSE IF (CMOT(1:9).EQ.'PSMO_LIAI') THEN
  167.             IF (ITLIAB.EQ.0) GOTO 10
  168.             CALL ACCTAB(ITPM,'MOT',I0,X0,'POINT',L0,IP0,
  169.      &                     'POINT',I1,X1,' ',L1,IPTS)
  170. *
  171. *           Le point appartient-il au maillage ?
  172. *
  173.             MELEME = IMAIL
  174.             SEGACT MELEME
  175.             NBEL = NUM(/2)
  176.             DO 50 IE = 1,NBEL
  177.                IPTR = NUM(1,IE)
  178.                IF (IPTR.EQ.IPTS) GOTO 52
  179.  50            CONTINUE
  180. *           END DO
  181.             SEGDES MELEME
  182.             GOTO 10
  183.  52         CONTINUE
  184.             SEGDES MELEME
  185.             CALL ACCTAB(ITPM,'MOT',I0,X0,'NORMALE',L0,IP0,
  186.      &                     'POINT',I1,X1,' ',L1,NORM)
  187. *
  188. *           A quelle table de liaison appartient le point ?
  189. *
  190.             ITL = 0
  191.  54         CONTINUE
  192.             ITL = ITL + 1
  193.             TYPRET = ' '
  194.             CALL ACCTAB(ITLIAB,'ENTIER',ITL,X0,' ',L0,IP0,
  195.      &                           TYPRET,I1,X1,CHARRE,L1,ITTL)
  196.             IF (ITTL.NE.0 .AND. TYPRET.EQ.'TABLE   ') THEN
  197.                CALL ACCTAB(ITTL,'MOT',I0,X0,'TYPE_LIAISON',L0,IP0,
  198.      &                          'MOT',I1,X1,CTYP,L1,IP1)
  199.                CALL ACCTAB(ITTL,'MOT',I0,X0,'NORMALE',L0,IP0,
  200.      &                        'POINT',I1,X1,' ',L1,INOR)
  201.                IF (CTYP(1:10).EQ.'POINT_PLAN') THEN
  202.                   CALL ACCTAB(ITTL,'MOT',I0,X0,'SUPPORT',L0,IP0,
  203.      &                           'POINT',I1,X1,' ',L1,IPTR)
  204.                   IF (IPTR.EQ.IPTS .AND. INOR.EQ.NORM) GOTO 56
  205.                   GOTO 54
  206.                ELSE IF (CTYP(1:11).EQ.'POINT_POINT') THEN
  207.                   NPTA = 0
  208.                   NPTB = 0
  209.                   CALL ACCTAB(ITTL,'MOT',I0,X0,'POINT_A',L0,IP0,
  210.      &                           'POINT',I1,X1,' ',L1,IPTA)
  211.                   IF (IPTA.EQ.IPTS .AND. INOR.EQ.NORM) THEN
  212.                      NPTA = 1
  213.                      GOTO 56
  214.                   ENDIF
  215.                   CALL ACCTAB(ITTL,'MOT',I0,X0,'POINT_B',L0,IP0,
  216.      &                           'POINT',I1,X1,' ',L1,IPTB)
  217.                   IF (IPTB.EQ.IPTS .AND. INOR.EQ.NORM) THEN
  218.                      NPTB = 1
  219.                      GOTO 56
  220.                   ENDIF
  221.                   GOTO 54
  222.                ELSE
  223.                   GOTO 54
  224.                ENDIF
  225.             ENDIF
  226.             GOTO 10
  227.  56         CONTINUE
  228.             IF (TYPE.EQ.'DEPL') THEN
  229.                CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  230.      &                      'CHPOINT',I1,X1,' ',L1,ICDEP)
  231.             ELSE IF (TYPE.EQ.'REAC') THEN
  232.                CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
  233.      &                      'CHPOINT',I1,X1,' ',L1,ICDEP)
  234.             ELSE IF (TYPE.EQ.'CONT') THEN
  235.                TYPRET = ' '
  236.                CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
  237.      &                     TYPRET,I1,X1,CHARRE,L1,ICDEP)
  238.             ENDIF
  239.             TYPRET = ' '
  240.             CALL ACCTAB(ITRES,'TABLE',I0,X0,' ',L0,ITTL,
  241.      &                         TYPRET,I1,X1,CHARRE,L1,ITRL1)
  242.             IF (ITRL1.NE.0 .AND. TYPRET.EQ.'TABLE   ') THEN
  243.                IF (CTYP(1:10).EQ.'POINT_PLAN') THEN
  244.                   MADIR1 = MOTPPL(NBPP)
  245.                   TYPRET = ' '
  246.                   CALL ACCTAB(ITRL1,'MOT',I0,X0,MADIR1,L0,IP0,
  247.      &                             TYPRET,I1,X1,CHARRE,L1,ILRX)
  248.                ELSE IF (CTYP(1:11).EQ.'POINT_POINT') THEN
  249.                   MADIR2 = ' '
  250.                   IF (NPTA.EQ.1) MADIR2 = MOTPPA(NBPP)
  251.                   IF (NPTB.EQ.1) MADIR2 = MOTPPB(NBPP)
  252.                   TYPRET = ' '
  253.                   CALL ACCTAB(ITRL1,'MOT',I0,X0,MADIR2,L0,IP0,
  254.      &                             TYPRET,I1,X1,CHARRE,L1,ILRX)
  255.                ENDIF
  256.                IF (ILRX.NE.0 .AND. TYPRET.EQ.'LISTREEL') THEN
  257.                   MLREEL = ILRX
  258.                   SEGACT MLREEL
  259.                   XFC = PROG(IPOS)
  260.                   SEGDES MLREEL
  261.                   IPNV  = (IDIM + 1) * (INOR - 1)
  262.                   PS = 0.D0
  263.                   DO 300 ID = 1,IDIM
  264.                      XC = XCOOR(IPNV + ID)
  265.                      PS = PS + XC * XC
  266.  300                 CONTINUE
  267. *                 END DO
  268.                   IF (PS.LE.XPETIT) THEN
  269.                      INTERR(1) = IPS
  270.                      CALL ERREUR(428)
  271.                      GOTO 10
  272.                   ENDIF
  273.                   DO 200 ID = 1,IDIM
  274.                      XNORM = XCOOR(IPNV + ID) / SQRT(PS)
  275.                      XFTEM = XFC * XNORM
  276.          IF (IIMPI.EQ.1804) THEN
  277.             WRITE(IOIMP,*)'PSRCD2 : pseudo-mode num{ro ',IPS
  278.             WRITE(IOIMP,*)'PSRCD2 :     point concern{ ',IPTS
  279.             WRITE(IOIMP,*)'PSRCD2 :              temps ',XTEMP
  280.             WRITE(IOIMP,*)'PSRCD2 :               f(t) ',XFTEM
  281.          ENDIF
  282.                      IF (TYPE.EQ.'CONT') THEN
  283.                         CALL MUCHEL(ICDEP,XFTEM,ICHR1,IUN)
  284.                         CALL ADCHEL(ICHCR,ICHR1,ICHCR,IUN)
  285.                      ELSE
  286.                         CALL ADCHPO(ICHCR,ICDEP,ICHCR,1D0,XFTEM)
  287.                      ENDIF
  288.  200              CONTINUE
  289. *                 END DO
  290.                ENDIF
  291.             ENDIF
  292.             GOTO 54
  293.          ELSE
  294.             GOTO 10
  295.          ENDIF
  296. *
  297.  100     CONTINUE
  298.          IF (TYPE.EQ.'DEPL') THEN
  299.             CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  300.      &                   'CHPOINT',I1,X1,' ',L1,ICDEP)
  301.          ELSE IF (TYPE.EQ.'REAC') THEN
  302.             CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
  303.      &                   'CHPOINT',I1,X1,' ',L1,ICDEP)
  304.          ELSE IF (TYPE.EQ.'CONT') THEN
  305.             TYPRET = ' '
  306.             CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
  307.      &                  TYPRET,I1,X1,CHARRE,L1,ICDEP)
  308.          ENDIF
  309.          MLREE1 = ICHPO2
  310.          SEGACT MLREE1
  311.          NF = MLREE1.PROG(/1)
  312.          MLREE2 = ICHPO3
  313.          SEGACT MLREE2
  314.          N1 = 1
  315.          N2 = 2
  316.          CALL INTLIN(XTEMP,ICHPO2,ICHPO3,NF,N1,N2,XFTEM,IRETOU)
  317.          IF (IRETOU.EQ.0) THEN
  318.             INTERR(1) = IPS
  319.             CALL ERREUR(428)
  320.             SEGDES MLREE1
  321.             SEGDES MLREE2
  322.             SEGDES ICHARG
  323.             GOTO 10
  324.          ENDIF
  325.          SEGDES MLREE1
  326.          SEGDES MLREE2
  327.          SEGDES ICHARG
  328.          IF (IIMPI.EQ.1804) THEN
  329.             WRITE(IOIMP,*)'PSRCD2 : pseudo-mode num{ro ',IPS
  330.             WRITE(IOIMP,*)'PSRCD2 :         chargement ',KCHAR
  331.             WRITE(IOIMP,*)'PSRCD2 :             num{ro ',ICHA
  332.             WRITE(IOIMP,*)'PSRCD2 :              temps ',XTEMP
  333.             WRITE(IOIMP,*)'PSRCD2 :               f(t) ',XFTEM
  334.          ENDIF
  335.          IF (TYPE.EQ.'CONT') THEN
  336.             CALL MUCHEL(ICDEP,XFTEM,ICHR1,IUN)
  337.             CALL ADCHEL(ICHCR,ICHR1,ICHCR,IUN)
  338.          ELSE
  339.             CALL ADCHPO(ICHCR,ICDEP,ICHCR,1D0,XFTEM)
  340.          ENDIF
  341.          GOTO 10
  342.       ENDIF
  343. *
  344.       IF (KCHAR.NE.0 ) SEGDES MCHARG
  345. *
  346.       RETURN
  347.       END
  348.  
  349.  
  350.  
  351.  

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