Télécharger la plaquette Cast3M


fr en

Télécharger devps2.eso

Retour à la liste

Numérotation des lignes : 

devps2

  1. C DEVPS2    SOURCE    CB215821  20/11/25    13:25:03     10792          
  2.       SUBROUTINE DEVPS2(ICHAR1,KTLIAB,KTNUM,KTPHI,KTFEX,REPRIS,ITPS,
  3.      &                  IBAS,NUMBAS)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8(A-H,O-Z)
  6. *--------------------------------------------------------------------*
  7. *                                                                    *
  8. *     Opérateur DYNE : algorithme de Fu - de Vogelaere               *
  9. *     ________________________________________________               *
  10. *                                                                    *
  11. *     Remplissage du tableau FEXPSM, representant les pseudo-modes   *
  12. *     aux points de liaison.                                         *
  13. *                                                                    *
  14. *     Paramètres:                                                    *
  15. *                                                                    *
  16. * e   ITCHAR  Table représentant les chargements                     *
  17. * e   ITBAS   Table représentant la base modale                      *
  18. * e   KTLIAB  Segment contenant les liaisons sur base B              *
  19. * e   KTNUM   Segment contenant les paramètres numériques            *
  20. * e   KTPHI   Segment des déformées modales                          *
  21. * es  KTFEX   Segment contenant les chargements libres               *
  22. * e   REPRIS  Logique indiquant si le calcul est en reprise          *
  23. * e   ITPS    Table contenant les pseudo-modes                       *
  24. * e   IBAS    Table contenant les modes                              *
  25. * e   NUMBAS  numéro de la sous base                                 *
  26. *                                                                    *
  27. *     Auteur, date de création:                                      *
  28. *                                                                    *
  29. *     Lionel VIVAN, le 10 avril 1990                                 *
  30. *                                                                    *
  31. *--------------------------------------------------------------------*
  32. *
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC SMCHARG
  37. -INC SMLREEL
  38. -INC SMCHPOI
  39. *
  40. *     FEXPSM(.,.,1,.)  valeur au pas  m
  41. *     FEXPSM(.,.,2,.)  valeur au pas  m - 1/2
  42. *
  43.       SEGMENT,MTNUM
  44.          REAL*8 XDT(NPC1),XTEMPS(NPC1)
  45.       ENDSEGMENT
  46.       SEGMENT,MTFEX
  47.          REAL*8  FEXA(NPFEXA,NPC1,2)
  48.          REAL*8  FEXPSM(NPLB,NPC1,2,IDIMB)
  49.          REAL*8  FTEXB(NPLB,NPC1,2,IDIM)
  50. *         INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB)
  51.       ENDSEGMENT
  52.       SEGMENT,MTPHI
  53.          INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB)
  54.          INTEGER IAROTA(NSB)
  55.          REAL*8  XPHILB(NSB,NPLSB,NA2,IDIMB)
  56.       ENDSEGMENT
  57.       SEGMENT,MTLIAB
  58.          INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  59.          REAL*8  XPALB(NLIAB,NXPALB)
  60.          REAL*8  XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  61.       ENDSEGMENT
  62.       SEGMENT,MTRAV
  63.          REAL*8 FTCHG(NPC2)
  64.       ENDSEGMENT
  65. *
  66.       LOGICAL L0,L1,REPRIS
  67.       CHARACTER*4  NOMAXI(6),NOMTRI(6),COMP
  68.       CHARACTER*8  TYPRET,CHARRE
  69.       CHARACTER*40 CMOT
  70.       PARAMETER ( TOLER = 1.E-6 )
  71. *
  72.       DATA NOMAXI/'UR  ','UZ  ','UT  ','RR  ','RZ  ','RT  '/
  73.       DATA NOMTRI/'UX  ','UY  ','UZ  ','RX  ','RY  ','RZ  '/
  74. *
  75.       MTNUM  = KTNUM
  76.       MTFEX  = KTFEX
  77.       MTPHI  = KTPHI
  78.       MTLIAB = KTLIAB
  79.       NPC1   = XDT(/1)
  80.       NPLB   = IBASB(/1)
  81.       NSB    = XPHILB(/1)
  82.       IDIMB  = XPHILB(/4)
  83.       MCHARG = ICHAR1
  84.       SEGACT,MCHARG
  85.       NCHAR = KCHARG(/1)
  86. *
  87. ************************************************************************
  88. *     BOUCLE SUR LES PSEUDO-MODES
  89. ************************************************************************
  90. *
  91.       IPS = 0
  92.  10   CONTINUE
  93.       IPS = IPS + 1
  94.       TYPRET = ' '
  95.       CALL ACCTAB(ITPS,'ENTIER',IPS,X0,' ',L0,IP0,
  96.      &                   TYPRET,I1,X1,CHARRE,L1,ITPM)
  97.       IF (ITPM.NE.0 .AND. TYPRET.EQ.'TABLE   ') THEN
  98.          CALL ACCTAB(ITPM,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  99.      &                    'MOT',I1,X1,CMOT,L1,IP1)
  100.  
  101. ******** CAS D'UN PSEUDO MODE DE SOUSTYPE : 'PSMO_FORC' ****************
  102.          IF (CMOT(1:9).EQ.'PSMO_FORC') THEN
  103.  
  104.             CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
  105.      &                   'CHPOINT',I1,X1,CHARRE,L1,ICHBA)
  106. *
  107. *---------- boucle sur les chargements elementaires ------------------ *
  108. *           jusqu'a trouver celui qui correspond au pseudo mode 
  109.             DO 20 ICHAR=1,NCHAR
  110.                ICHARG = KCHARG(ICHAR)
  111.                SEGACT,ICHARG
  112.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  113.      &            .OR.CHALIE(ICHAR).NE.'LIE ') THEN
  114.                   SEGDES ICHARG
  115.                   GOTO 20
  116.                ENDIF
  117. c              test sur le pointeur du CHPOINT definissant le pseudo-mode
  118.                IF (ICHBA.EQ.ICHPO1) GOTO 120
  119.  20         CONTINUE
  120. *       --- on n'a pas trouve le chargement : erreur ! ---
  121.             INTERR(1) = IPS
  122.             CALL ERREUR(428)
  123.             GOTO 10            
  124. *       --- on a trouve le chargement : on continue ---
  125.  120        CONTINUE
  126.             IF (IIMPI.EQ.333) THEN
  127.                WRITE(IOIMP,*)'DEVPSM : pseudo-mode numero ',IPS
  128.                WRITE(IOIMP,*)'DEVPSM :         chargement ',ICHAR1
  129.                WRITE(IOIMP,*)'DEVPSM :             numero ',ICHAR
  130.             ENDIF
  131.  
  132. *---------- interpolation de f(t) ------------------ *
  133.             MLR1 = ICHPO2
  134.             MLR2 = ICHPO3
  135.             CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  136.             IF (IERR.NE.0) RETURN
  137.             MTRAV = KTRAV
  138.             SEGDES ICHARG
  139. *
  140. *---------- boucle sur les points de liaison ------------------ *
  141.             DO 30 IPL = 1,NPLB
  142.                IB   = IBASB(IPL)
  143.                IF (IB.EQ.NUMBAS) THEN
  144.                   IPTL = JPLIB(IPL)
  145.                   CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  146.      &                         'CHPOINT',I1,X1,' ',L1,ICHPS)
  147.                   DO 40 ID = 1,IDIMB
  148.                      IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  149.                         COMP = NOMAXI(ID)
  150.                      ELSE
  151.                         COMP = NOMTRI(ID)
  152.                      ENDIF
  153.                      CALL EXTRA9(ICHPS,IPTL,COMP,0,.false.,XVAL,IRET)
  154.                      IF (IRET.EQ.1) THEN
  155.                         DO 50 IT=1,NPC1
  156.                            NP = 2 * IT
  157.                            FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  158.      &                                           ( XVAL * FTCHG(NP) )
  159.                            NI = NP - 1
  160.                            FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  161.      &                                           ( XVAL * FTCHG(NI) )
  162.  50                        CONTINUE
  163.                      ENDIF
  164.  40                  CONTINUE
  165.                ENDIF
  166.  30            CONTINUE
  167. *---------- fin de boucle sur les points de liaison ------------------ *
  168.  
  169.             SEGSUP MTRAV
  170. c           ON PASSE AU PSEUDO-MODE SUIVANT
  171.             GOTO 10
  172.  
  173.  
  174. ******** CAS D'UN PSEUDO MODE DE SOUSTYPE : 'PSMO_SEIS' ****************            
  175.          ELSE IF (CMOT(1:9).EQ.'PSMO_SEIS') THEN
  176.  
  177.             CALL ACCTAB(ITPM,'MOT',I0,X0,'DIRECTION',L0,IP0,
  178.      &                    'ENTIER',IENT,X1,' ',L1,IP1)
  179.             CALL ACCTAB(IBAS,'ENTIER',1,X0,' ',L0,IP0,
  180.      &                        'TABLE',I1,X1,' ',L1,ITMK)
  181.             CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',
  182.      &                  L0,IP0,'TABLE',I1,X1,' ',L1,ITMD)
  183.             CALL ACCTAB(ITMD,'ENTIER',IENT,X0,' ',L0,IP0,
  184.      &                     'FLOTTANT',I1,XQXYZ,' ',L1,IP1)
  185. *
  186. *---------- boucle sur les chargements elementaires ------------------ *
  187. *           jusqu'a trouver celui qui correspond au pseudo mode 
  188.             DO 24 ICHAR=1,NCHAR
  189.                ICHARG = KCHARG(ICHAR)
  190.                SEGACT,ICHARG
  191.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  192.      &            .OR.CHALIE(ICHAR).NE.'LIE ') THEN
  193.                   SEGDES ICHARG
  194.                   GOTO 24
  195.                ENDIF
  196.                MCHPOI = ICHPO1
  197.                SEGACT MCHPOI
  198.                MSOUPO = IPCHP(1)
  199.                SEGDES MCHPOI
  200.                SEGACT MSOUPO
  201.                MPOVAL = IPOVAL
  202.                SEGDES MSOUPO
  203.                SEGACT MPOVAL
  204.                QXYZ = VPOCHA(1,1)
  205.                SEGDES MPOVAL
  206.                EPS = ABS(QXYZ + XQXYZ)
  207. c              test sur l'unique valeur du CHPOINT definissant le pseudo-mode
  208.                IF (EPS.LT.TOLER) GOTO 124
  209.  24            CONTINUE
  210. *       --- on n'a pas trouve le chargement : erreur ! ---
  211.             INTERR(1) = IPS
  212.             CALL ERREUR(428)
  213.             GOTO 10
  214. *       --- on a trouve le chargement : on continue ---
  215.  124        CONTINUE
  216.             IF (IIMPI.EQ.333) THEN
  217.                WRITE(IOIMP,*)'DEVPSM : pseudo-mode numero ',IPS
  218.                WRITE(IOIMP,*)'DEVPSM :         chargement ',ICHAR1
  219.                WRITE(IOIMP,*)'DEVPSM :             numero ',ICHAR
  220.             ENDIF
  221.  
  222. *---------- interpolation de f(t) ------------------ *
  223.             MLR1 = ICHPO2
  224.             MLR2 = ICHPO3
  225.             CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  226.             IF (IERR.NE.0) RETURN
  227.             MTRAV = KTRAV
  228.             SEGDES ICHARG
  229. *
  230. *---------- boucle sur les points de liaison ------------------ *
  231.             DO 32 IPL = 1,NPLB
  232.                IB   = IBASB(IPL)
  233.                IF (IB.EQ.NUMBAS) THEN
  234.                   IPTL = JPLIB(IPL)
  235.                   CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  236.      &                         'CHPOINT',I1,X1,' ',L1,ICHPS)
  237.                   DO 42 ID = 1,IDIMB
  238.                      IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  239.                         COMP = NOMAXI(ID)
  240.                      ELSE
  241.                         COMP = NOMTRI(ID)
  242.                      ENDIF
  243.                      IRET=0
  244.                      CALL EXTRA9(ICHPS,IPTL,COMP,0,.false.,XVAL,IRET)
  245.                      IF (IRET.EQ.1) THEN
  246.                         DO 52 IT=1,NPC1
  247.                            NP = 2 * IT
  248.                            FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  249.      &                                           ( XVAL * FTCHG(NP) )
  250.                            NI = NP - 1
  251.                            FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  252.      &                                           ( XVAL * FTCHG(NI) )
  253.  52                        CONTINUE
  254.                      ENDIF
  255.  42                  CONTINUE
  256.                   ENDIF
  257.  32            CONTINUE
  258. *---------- fin de boucle sur les points de liaison ------------------ *
  259.  
  260.             SEGSUP MTRAV
  261. c           ON PASSE AU PSEUDO-MODE SUIVANT
  262.             GOTO 10
  263.  
  264. ******** CAS D'UN PSEUDO MODE DE SOUSTYPE : 'PSMO_DEPL' ****************            
  265.          ELSE IF (CMOT(1:9).EQ.'PSMO_DEPL') THEN
  266.  
  267.             CALL ACCTAB(ITPM,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
  268.      &                   'CHPOINT',I1,X1,' ',L1,ICHBA)
  269. *
  270. *---------- boucle sur les chargements elementaires ------------------ *
  271. *           jusqu'a trouver celui qui correspond au pseudo mode 
  272.             DO 28 ICHAR=1,NCHAR
  273.                ICHARG = KCHARG(ICHAR)
  274.                SEGACT,ICHARG
  275.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
  276.      &            .OR.CHALIE(ICHAR).NE.'LIE ') THEN
  277.                   SEGDES ICHARG
  278.                   GOTO 28
  279.                ENDIF
  280. c              test sur le pointeur du CHPOINT definissant le pseudo-mode
  281.                IF (ICHBA.EQ.ICHPO1) GOTO 128
  282.  28            CONTINUE
  283. *       --- on n'a pas trouve le chargement : erreur ! ---
  284.             INTERR(1) = IPS
  285.             CALL ERREUR(428)
  286.             GOTO 10
  287. *       --- on a trouve le chargement : on continue ---
  288.  128        CONTINUE
  289.             IF (IIMPI.EQ.333) THEN
  290.                WRITE(IOIMP,*)'DEVPSM : pseudo-mode numero ',IPS
  291.                WRITE(IOIMP,*)'DEVPSM :         chargement ',ICHAR1
  292.                WRITE(IOIMP,*)'DEVPSM :             numero ',ICHAR
  293.             ENDIF
  294.  
  295. *---------- interpolation de f(t) ------------------ *
  296.             MLR1 = ICHPO2
  297.             MLR2 = ICHPO3
  298.             CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
  299.             IF (IERR.NE.0) RETURN
  300.             MTRAV = KTRAV
  301.             SEGDES ICHARG
  302. *
  303. *---------- boucle sur les points de liaison ------------------ *
  304.             DO 34 IPL = 1,NPLB
  305.                IB   = IBASB(IPL)
  306.                IF (IB.EQ.NUMBAS) THEN
  307.                   IPTL = JPLIB(IPL)
  308.                   CALL ACCTAB(ITPM,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
  309.      &                         'CHPOINT',I1,X1,' ',L1,ICHPS)
  310.                   DO 44 ID = 1,IDIMB
  311.                      IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  312.                         COMP = NOMAXI(ID)
  313.                      ELSE
  314.                         COMP = NOMTRI(ID)
  315.                      ENDIF
  316.                      CALL EXTRA9(ICHPS,IPTL,COMP,0,.false.,XVAL,IRET)
  317.                      IF (IRET.EQ.1) THEN
  318.                         DO 54 IT=1,NPC1
  319.                            NP = 2 * IT
  320.                            FEXPSM(IPL,IT,1,ID) = FEXPSM(IPL,IT,1,ID) +
  321.      &                                           ( XVAL * FTCHG(NP) )
  322.                            NI = NP - 1
  323.                            FEXPSM(IPL,IT,2,ID) = FEXPSM(IPL,IT,1,ID) +
  324.      &                                           ( XVAL * FTCHG(NI) )
  325.  54                        CONTINUE
  326.                      ENDIF
  327.  44                  CONTINUE
  328.                ENDIF
  329.  34            CONTINUE
  330. *---------- fin de boucle sur les points de liaison ------------------ *
  331.  
  332.             SEGSUP MTRAV
  333. c           ON PASSE AU PSEUDO-MODE SUIVANT
  334.             GOTO 10
  335.  
  336.          ENDIF
  337. ******** FIN DISTINCTION ENTRE LES SOUSTYPE DES PSEUDO MODE ************
  338.  
  339.       ENDIF
  340.       SEGDES MCHARG
  341. *
  342.       END
  343.  
  344.  
  345.  
  346.  
  347.  
  348.  
  349.  
  350.  
  351.  

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