Télécharger la plaquette Cast3M


fr en

Télécharger psevrc.eso

Retour à la liste

Numérotation des lignes : 

psevrc

  1. C PSEVRC    SOURCE    CB215821  23/11/02    21:15:09     11779          
  2.       SUBROUTINE PSEVRC(ICONT,ITPS,IBAS,IBOO,IPX,KCHAR)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5.  
  6. *--------------------------------------------------------------------*
  7. *                                                                    *
  8. *     Prise en compte des pseudo-modes pour une recombinaison.       *
  9. *                                                                    *
  10. *     Param}tres:                                                    *
  11. *                                                                    *
  12. * e   ICONT   recombinaison d'un d{placement ( ICONT = 0 )           *
  13. *             recombinaison d'une contrainte ( ICONT = 1 )           *
  14. *             recombinaison d'une r{action   ( ICONT = 2 )           *
  15. * e   ITPS    table repr{sentant les pseudo-modes                    *
  16. * e   IBAS    table repr{sentant la base modale                      *
  17. * es  IBOO    segment des points en recombinaison                    *
  18. * e   IPX     listreel des temps de recombinaison                    *
  19. * e   KCHAR   chargement de la structure                             *
  20. *                                                                    *
  21. *     Auteur, date de cr{ation:                                      *
  22. *                                                                    *
  23. *     Lionel VIVAN, le 2 mai 1990.                                   *
  24. *                                                                    *
  25. *--------------------------------------------------------------------*
  26. *                                                                    *
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC SMCHARG
  31. -INC SMCHPOI
  32. -INC SMLREEL
  33. *
  34.       SEGMENT NUMOO
  35.         INTEGER NUMO(N),KLIST(N)
  36.         CHARACTER*(LOCHPO) NUDDL(N)
  37.       ENDSEGMENT
  38.  
  39.       LOGICAL L0,L1
  40.       CHARACTER*4  COMP
  41.       CHARACTER*8  TYPRET,CHARRE
  42.       CHARACTER*40 CMOT
  43.       PARAMETER (TOLER = 1.D-6)
  44. *
  45.       NUMOO = IBOO
  46.       SEGACT NUMOO
  47.       NP = NUMO(/1)
  48.       DO 2 I = 1,NP
  49.          MLREE3 = KLIST(I)
  50.          SEGACT MLREE3*MOD
  51.  2    CONTINUE
  52. *
  53.       MLREEL= IPX
  54.       SEGACT MLREEL
  55.       LDIM = PROG(/1)
  56. *
  57.       MCHARG = KCHAR
  58.       SEGACT MCHARG
  59.       NCHAR = KCHARG(/1)
  60. *
  61. *     Boucle sur les pseudo-modes
  62. *
  63.       IPS = 0
  64.  10   CONTINUE
  65.       IPS = IPS + 1
  66.       TYPRET = ' '
  67.       CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
  68.      &                   TYPRET,I1,X1,CHARRE,L1,ITPM)
  69.       IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE   ') THEN
  70.          CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  71.      &                    'MOT',I1,X1,CMOT,L1,IP1)
  72.          IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
  73.             CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  74.      &                   'CHPOINT',I1,X1,' ',L1,ICHBB)
  75. *
  76. *           boucle sur les chargements {l{mentaires
  77. *
  78.             DO 20 ICHA =1,NCHAR
  79.                ICHARG = KCHARG(ICHA)
  80.                SEGACT ICHARG
  81.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  82.      & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  83.                   SEGDES ICHARG
  84.                   GOTO 20
  85.                ENDIF
  86.                IF (ICHBB.EQ.ICHPO1) GOTO 100
  87.  20         CONTINUE
  88. *           end do
  89. *           on n'a pas trouv{ le chargement
  90.             INTERR(1) = IPS
  91.             CALL ERREUR(428)
  92.             SEGDES ICHARG
  93.             GOTO 10
  94.          ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
  95.             CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
  96.      &                    'ENTIER',IENT,X1,' ',L1,IP1)
  97.             CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
  98.      &                        'TABLE',I1,X1,' ',L1,ITMK)
  99.             CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
  100.      &                  L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
  101.             CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
  102.      &                     'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
  103. *
  104. *           boucle sur les chargements {l{mentaires
  105. *
  106.             DO 30 ICHA =1,NCHAR
  107.                ICHARG = KCHARG(ICHA)
  108.                SEGACT ICHARG
  109.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  110.      & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  111.                   SEGDES ICHARG
  112.                   GOTO 30
  113.                ENDIF
  114.                MCHPOI = ICHPO1
  115.                SEGACT MCHPOI
  116.                MSOUPO = IPCHP(1)
  117.                SEGDES MCHPOI
  118.                SEGACT MSOUPO
  119.                MPOVAL = IPOVAL
  120.                SEGDES MSOUPO
  121.                SEGACT MPOVAL
  122.                QXYZ = VPOCHA(1,1)
  123.                SEGDES MPOVAL
  124.                EPS = ABS(QXYZ + XQXYZ)
  125.                IF (EPS.LT.TOLER) GOTO 100
  126.  30            CONTINUE
  127. *           end do
  128. *           on n'a pas trouv{ le chargement
  129.             INTERR(1) = IPS
  130.             CALL ERREUR(428)
  131.             SEGDES ICHARG
  132.             GOTO 10
  133.          ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
  134.             CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
  135.      &                   'CHPOINT',I1,X1,' ',L1,ICHBB)
  136. *
  137. *           boucle sur les chargements {l{mentaires
  138. *
  139.             DO 40 ICHA =1,NCHAR
  140.                ICHARG = KCHARG(ICHA)
  141.                SEGACT ICHARG
  142.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHA).NE.'STAT'
  143.      & .OR.CHALIE(ICHA).NE.'LIE ') THEN
  144.                   SEGDES ICHARG
  145.                   GOTO 40
  146.                ENDIF
  147.                IF (ICHBB.EQ.ICHPO1) GOTO 100
  148.  40            CONTINUE
  149. *           end do
  150. *           on n'a pas trouv{ le chargement
  151.             INTERR(1) = IPS
  152.             CALL ERREUR(428)
  153.             SEGDES ICHARG
  154.             GOTO 10
  155.          ENDIF
  156. *
  157.  100     CONTINUE
  158.          ICDEP = 0
  159.          IF (ICONT.EQ.0) THEN
  160.             CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  161.      &                   'CHPOINT',I1,X1,' ',L1,ICDEP)
  162.             CALL ACTOBJ('CHPOINT',ICDEP,1)
  163.  
  164.          ELSE IF (ICONT.EQ.1) THEN
  165.             CALL ACCTAB(ITPM,'MOT',I0,X0,'CONTRAINTE',L0,IP0,
  166.      &                  'MCHAML  ',I1,X1,' ',L1,ICHAM1)
  167.             CALL ACTOBJ('MCHAML  ',ICHAM1,1)
  168. C* Manque le passage en MCHAML aux noeuds avec le modele !!!
  169. C*            CALL CHASUP(IPMODL,ICHAM1,ICHAM2,IRETOU,1)
  170. C*            IF (IRETOU.EQ.0) THEN
  171. C*               INTERR(1) = IPS
  172. C*               CALL ERREUR(___)
  173. C*               SEGDES ICHARG
  174. C*               GOTO 10
  175. C*            ENDIF
  176. C*            IMOY=1
  177. C*            CALL CHAMPO(ICHAM2,IMOY,ICDEP,IRETOU)
  178.             IMOY=1
  179.             CALL CHAMPO(ICHAM1,IMOY,ICDEP,IRETOU)
  180.             IF (IRETOU.EQ.0) THEN
  181.                INTERR(1) = IPS
  182.                CALL ERREUR(428)
  183.                SEGDES ICHARG
  184.                GOTO 10
  185.             ENDIF
  186.  
  187.          ELSE IF (ICONT.EQ.2) THEN
  188.             CALL ACCTAB(ITPM,'MOT',I0,X0,'REACTION',L0,IP0,
  189.      &                  'CHPOINT',I1,X1,' ',L1,ICDEP)
  190.             CALL ACTOBJ('CHPOINT',ICDEP,1)
  191.          ENDIF
  192.  
  193.          MLREE1 = ICHPO2
  194.          SEGACT MLREE1
  195.          NF = MLREE1.PROG(/1)
  196.          MLREE2 = ICHPO3
  197.          SEGACT MLREE2
  198.          IF (IIMPI.EQ.1804) THEN
  199.             WRITE(IOIMP,*)'PSEVRC : pseudo-mode num{ro ',IPS
  200.             WRITE(IOIMP,*)'PSEVRC :         chargement ',KCHAR
  201.             WRITE(IOIMP,*)'PSEVRC :             num{ro ',ICHA
  202.          ENDIF
  203.          N1 = 1
  204.          N2 = 2
  205.          DO 110 IT = 1,LDIM
  206.             XTEMP = PROG(IT)
  207.             CALL INTLIN(XTEMP,ICHPO2,ICHPO3,NF,N1,N2,XFTEM,IRETOU)
  208.             IF (IRETOU.EQ.0) THEN
  209.                INTERR(1) = IPS
  210.                CALL ERREUR(428)
  211.                SEGDES MLREE1
  212.                SEGDES MLREE2
  213.                SEGDES ICHARG
  214.                GOTO 10
  215.             ENDIF
  216.             IF (IIMPI.EQ.1804) THEN
  217.                WRITE(IOIMP,*)'PSEVRC :              temps ',XTEMP
  218.                WRITE(IOIMP,*)'PSEVRC :               f(t) ',XFTEM
  219.             ENDIF
  220. *
  221.             DO 120 IP = 1,NP
  222.                IPOIN = NUMO(IP)
  223.                COMP = NUDDL(IP)
  224.                CALL EXTRA9(ICDEP,IPOIN,COMP,0,.FALSE.,XFLOT,IRET)
  225.                IF (IRET.EQ.0) THEN
  226.                   INTERR(1) = IPS
  227.                   CALL ERREUR(428)
  228.                   SEGDES MLREE1
  229.                   SEGDES MLREE2
  230.                   SEGDES ICHARG
  231.                   GOTO 10
  232.                ENDIF
  233.                XVAL = XFLOT * XFTEM
  234.                IF (IIMPI.EQ.1804) THEN
  235.                   WRITE(IOIMP,*)'PSEVRC :           au point ',IPOIN
  236.                   WRITE(IOIMP,*)'PSEVRC :      de composante ',COMP
  237.                   WRITE(IOIMP,*)'PSEVRC :    valeur calcul{e ',XVAL
  238.                ENDIF
  239.                MLREE3 = KLIST(IP)
  240.                MLREE3.PROG(IT) = MLREE3.PROG(IT) + XVAL
  241.  120        CONTINUE
  242.  110     CONTINUE
  243.          SEGDES MLREE1
  244.          SEGDES MLREE2
  245.          SEGDES ICHARG
  246.          GOTO 10
  247.       ENDIF
  248. *
  249.       SEGDES MCHARG
  250.       SEGDES MLREEL
  251.       DO 4 I = 1,NP
  252.          MLREE3 = KLIST(I)
  253.          SEGDES MLREE3
  254.  4    CONTINUE
  255.       IBOO = NUMOO
  256. *
  257.       IF (ICONT.EQ.1) THEN
  258.          MCHPO1 = ICDEP
  259.          SEGSUP MCHPO1
  260.       ENDIF
  261. *
  262.       RETURN
  263.       END
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  

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