Télécharger la plaquette Cast3M


fr en

Télécharger dyn202.eso

Retour à la liste

Numérotation des lignes : 

dyn202

  1. C DYN202    SOURCE    BP208322  19/02/25    21:15:51     10120          
  2.       SUBROUTINE DYN202(I,ITLB,ITYP,KTLIAB,NPLB)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. *--------------------------------------------------------------------*
  6. *                                                                    *
  7. *     Op{rateur DYNE : algorithme de Fu - de Vogelaere               *
  8. *     ________________________________________________               *
  9. *                                                                    *
  10. *     Remplissage des tableaux de description des liaisons sur       *
  11. *     la base des informations contenues dans la table ILIB          *
  12. *     Liaison POINT_POINT avec ou sans amortissement                 *
  13. *     Liaison POINT_POINT_FROTTEMENT avec ou sans amortissement      *
  14. *     Liaison POINT_POINT_DEPLACEMENT_PLASTIQUE avec ou sans amortissement      *
  15. *                                                                    *
  16. *     Param}tres:                                                    *
  17. *                                                                    *
  18. * e   I       Num{ro de la liaison.                                  *
  19. * e   ITLB    Table rassemblant la description d'une liaison.        *
  20. * e   ITYP    Type de la liaison.                                    *
  21. *  s  KTLIAB  Segment descriptif des liaisons sur base B.            *
  22. * e   NPLB    Nombre total de points.                                *
  23. *                                                                    *
  24. *                                                                    *
  25. *     Auteur, date de cr{ation:                                      *
  26. *                                                                    *
  27. *     Lionel VIVAN, le 5 D{cembre 1990.                              *
  28. *                                                                    *
  29. *--------------------------------------------------------------------*
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC SMCOORD
  34. -INC SMEVOLL
  35. -INC SMLREEL
  36. *
  37.       SEGMENT MTLIAB
  38.          INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  39.          REAL*8 XPALB(NLIAB,NXPALB)
  40.          REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  41.       ENDSEGMENT
  42. *
  43.       LOGICAL L1,L0,LPERM
  44.       CHARACTER*8 MONAMO,MONPER,MARAID,TYPRET
  45.       CHARACTER*16 CHARRE
  46.       CHARACTER*20 MONECR
  47. *
  48.       MTLIAB = KTLIAB
  49. *
  50. * --- choc {l{mentaire POINT_POINT avec ou sans amortissement
  51. *
  52.        IF (ITYP.EQ.11) THEN
  53.          CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
  54.      &                    'POINT',I1,X1,CHARRE,L1,INOA)
  55.          IF (IERR.NE.0) RETURN
  56.          CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
  57.      &                    'POINT',I1,X1,CHARRE,L1,INOB)
  58.          IF (IERR.NE.0) RETURN
  59.          CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
  60.      &                    'POINT',I1,X1,CHARRE,L1,IPOI)
  61.          IF (IERR.NE.0) RETURN
  62.          MARAID = ' '
  63.          CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0,
  64.      &                    MARAID,I0,XRAID,CHARRE,L1,IP1)
  65.          IF (IERR.NE.0) RETURN
  66.          IF (MARAID .EQ. 'ENTIER  ') THEN
  67.            XRAID = 1.D0*I0
  68.            MARAID = 'FLOTTANT'
  69.          ENDIF
  70.          CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
  71.      &                    'FLOTTANT',I0,XJEU,CHARRE,L1,IP1)
  72.          IF (IERR.NE.0) RETURN
  73.  
  74.          MONPER = ' '
  75.          LPERM = .FALSE.
  76.          CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0,
  77.      &                    IP0,MONPER,I0,X1,CHARRE,LPERM,IP1)
  78.          IF (IERR.NE.0) RETURN
  79. *
  80.          MONAMO = ' '
  81.          CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
  82.      &                    MONAMO,I0,XAMON,CHARRE,L1,IP1)
  83.          IF (IERR.NE.0) RETURN
  84.          IF (MONAMO .EQ. 'ENTIER  ') THEN
  85.            XAMON = 1.D0*I0
  86.            MONAMO = 'FLOTTANT'
  87.          ENDIF
  88.  
  89.          TYPRET = ' '
  90.          CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
  91.      &                    TYPRET,I1,X1,CHARRE,L1,IPEVO)
  92.          IF (IERR.NE.0) RETURN
  93.  
  94.          IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
  95.             CALL ERREUR(891)
  96.             RETURN
  97.          ENDIF
  98. *
  99.          IF (TYPRET.EQ.'EVOLUTIO') THEN
  100.             ITYP = 111
  101.             XRAID = 0.d0
  102.          ENDIF
  103.  
  104.          IPALB(I,1) = ITYP
  105.          IPALB(I,3) = IDIM
  106.          IF(LPERM) IPALB(I,4)=2
  107.          XPALB(I,1) = XRAID
  108.          XPALB(I,2) = XJEU
  109. *
  110. *        normalisation de la normale
  111. *
  112.          IPNV  = (IDIM + 1) * (IPOI - 1)
  113.          PS = 0.D0
  114.          DO 10 ID = 1,IDIM
  115.             XC = XCOOR(IPNV + ID)
  116.             PS = PS + XC * XC
  117.  10         CONTINUE
  118. *        end do
  119.          IF (PS.LE.0.D0) THEN
  120.             CALL ERREUR(162)
  121.             RETURN
  122.          ENDIF
  123.          IF (MONAMO.EQ.'FLOTTANT') THEN
  124.             XPALB(I,3) = XAMON
  125.          ELSE
  126.             XPALB(I,3) = 0.d0
  127.          ENDIF
  128.             DO 12 ID = 1,IDIM
  129.                ID2 = 3 + ID
  130.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  131.  12            CONTINUE
  132. *           end do
  133. *
  134.          IF (IPALB(I,1) .EQ. 111) THEN
  135.          MEVOLL = IPEVO
  136. *
  137. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  138. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
  139. * tableaux xabsci et xordon
  140. *
  141.          SEGACT MEVOLL
  142.          KEVOLL = IEVOLL(1)
  143.          SEGACT KEVOLL
  144.          MLREE1 = IPROGX
  145.          MLREE2 = IPROGY
  146.          SEGACT MLREE1
  147.          SEGACT MLREE2
  148.          NIP = XABSCI(/2)
  149. *
  150.           DO 16 MM=1,NIP
  151.             XABSCI (I,MM) = MLREE1.PROG(MM)
  152.             XORDON (I,MM) = MLREE2.PROG(MM)
  153.  16       CONTINUE
  154. *
  155.          SEGDES MLREE1
  156.          SEGDES MLREE2
  157.          SEGDES KEVOLL
  158.          SEGDES MEVOLL
  159.          ENDIF
  160. *
  161.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  162.          IPLIB(I,1) = IPLAC
  163.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  164.          IPLIB(I,2) = IPLAC
  165. *
  166. * --- choc {l{mentaire POINT_POINT_FROTTEMENT avec ou sans amortissement
  167. *
  168.       elseIF (ITYP.EQ.13) THEN
  169.          CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
  170.      &                    'POINT',I1,X1,CHARRE,L1,INOA)
  171.          IF (IERR.NE.0) RETURN
  172.          CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
  173.      &                    'POINT',I1,X1,CHARRE,L1,INOB)
  174.          IF (IERR.NE.0) RETURN
  175.          CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
  176.      &                    'POINT',I1,X1,CHARRE,L1,IPOI)
  177.          IF (IERR.NE.0) RETURN
  178.          MARAID = ' '
  179.          CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR',L0,IP0,
  180.      &                    MARAID,I0,XRAID,CHARRE,L1,IP1)
  181.          IF (IERR.NE.0) RETURN
  182.          IF (MARAID .EQ. 'ENTIER  ') THEN
  183.            XRAID = 1.D0*I0
  184.            MARAID = 'FLOTTANT'
  185.          ENDIF
  186.  
  187.          CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
  188.      &                    'FLOTTANT',I0,XJEU,CHARRE,L1,IP1)
  189.          IF (IERR.NE.0) RETURN
  190.          CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_GLISSEMENT',L0,IP0,
  191.      &                    'FLOTTANT',I0,XGLIS,CHARRE,L1,IP1)
  192.          IF (IERR.NE.0) RETURN
  193.          CALL ACCTAB(ITLB,'MOT',I1,X0,'COEFFICIENT_ADHERENCE',L0,IP0,
  194.      &                    'FLOTTANT',I0,XADHE,CHARRE,L1,IP1)
  195.          IF (IERR.NE.0) RETURN
  196.          CALL ACCTAB(ITLB,'MOT',I1,X0,'RAIDEUR_TANGENTIELLE',L0,IP0,
  197.      &                    'FLOTTANT',I0,XRAIT,CHARRE,L1,IP1)
  198.          IF (IERR.NE.0) RETURN
  199.          CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT_TANGENTIEL',L0,
  200.      &                    IP0,'FLOTTANT',I0,XAMOT,CHARRE,L1,IP1)
  201.          IF (IERR.NE.0) RETURN
  202.          TYPRET = ' '
  203.          CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
  204.      &                    TYPRET,I1,X1,CHARRE,L1,IPEVO)
  205.          IF (IERR.NE.0) RETURN
  206. *
  207.          MONAMO = ' '
  208.          CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
  209.      &                    MONAMO,I0,XAMON,CHARRE,L1,IP1)
  210.          IF (IERR.NE.0) RETURN
  211.          IF (MONAMO .EQ. 'ENTIER  ') THEN
  212.            XAMON = 1.D0*I0
  213.            MONAMO = 'FLOTTANT'
  214.          ENDIF
  215.          IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
  216.             CALL ERREUR(891)
  217.             RETURN
  218.          ENDIF
  219.          IF (TYPRET.EQ.'EVOLUTIO') THEN
  220.             ITYP = 113
  221.             XRAID = 0.d0
  222.          ENDIF
  223. *
  224. *bp,2016 petit message informatif pour ceux qui, comme moi, n'auraient 
  225. *        pas lu la notice jusqu'au bout :
  226.          IF(XRAIT.LT.0.D0) THEN
  227.            IF(XAMOT.LE.0D0.OR.IIMPI.GT.0) THEN
  228.            WRITE(IOIMP,*) 'Liaison elementaire ..._FROTTEMENT numero',I
  229.            WRITE(IOIMP,*) 
  230.      &      'utilisation du modele de frottement regularise d ODEN'
  231.            ENDIF
  232.            IF(XAMOT.LE.0D0) THEN
  233. c             ERREUR:  %m1:8 = %r1 inferieur a %r2
  234.               MOTERR(1:8)='AMOR*_T*'
  235.               REAERR(1)=XAMOT
  236.               REAERR(2)=0.D0
  237.               CALL ERREUR(41)
  238.               RETURN
  239.            ENDIF
  240.          ENDIF
  241.  
  242.          IPALB(I,1) = ITYP
  243.          IPALB(I,3) = IDIM
  244.          XPALB(I,1) = XRAID
  245.          XPALB(I,2) = XJEU
  246.          XPALB(I,3) = XGLIS
  247.          XPALB(I,4) = XADHE
  248.          XPALB(I,5) = XRAIT
  249.          XPALB(I,6) = XAMOT
  250.          IF (MONAMO.EQ.'FLOTTANT') THEN
  251.             XPALB(I,7) = XAMON
  252.          ELSE
  253.             XPALB(I,7) = 0.D0
  254.          ENDIF
  255.  
  256. * cas particulier pas tres orthodoxe pour Gibert
  257. * on passe a ityp = -13 et on modifie et ajoute
  258. * devlb2, devlb1-->devfb2--->dgcha4--->dgchfr--->dgchgl, devso4
  259.          TYPRET = '  '
  260.          CALL ACCTAB(ITLB,'MOT',I1,X0,'MODELE',L0,IP0,
  261.      &                    TYPRET,I1,X1,CHARRE,L1,IGIB)
  262.          IF (TYPRET.EQ.'MOT') THEN
  263.             IF (CHARRE.EQ.'NEDJAI-GIBERT') THEN
  264.               IPALB(I,1) = -13
  265.             ELSE
  266.              CALL ERREUR(891)
  267.              RETURN
  268.             ENDIF
  269.          ELSEIF (IGIB.NE.0) THEN
  270.              CALL ERREUR(891)
  271.              RETURN
  272.          ENDIF
  273.  
  274.  
  275.  
  276.  
  277. *
  278. *        normalisation de la normale
  279. *
  280.          IPNV  = (IDIM + 1) * (IPOI - 1)
  281.          PS = 0.D0
  282.          DO 20 ID = 1,IDIM
  283.             XC = XCOOR(IPNV + ID)
  284.             PS = PS + XC * XC
  285.  20         CONTINUE
  286. *        end do
  287.          IF (PS.LE.0.D0) THEN
  288.             CALL ERREUR(162)
  289.             RETURN
  290.          ENDIF
  291.          DO 22 ID = 1,IDIM
  292.                ID2 = 7 + ID
  293.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  294.  22            CONTINUE
  295. *        end do
  296. *
  297.          IF (IPALB(I,1) .EQ. 113) THEN
  298.          MEVOLL = IPEVO
  299. *
  300. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  301. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
  302. * tableaux xabsci et xordon
  303. *
  304.          SEGACT MEVOLL
  305.          KEVOLL = IEVOLL(1)
  306.          SEGACT KEVOLL
  307.          MLREE1 = IPROGX
  308.          MLREE2 = IPROGY
  309.          SEGACT MLREE1
  310.          SEGACT MLREE2
  311.          NIP = XABSCI(/2)
  312. *
  313.           DO 24 MM=1,NIP
  314.             XABSCI (I,MM) = MLREE1.PROG(MM)
  315.             XORDON (I,MM) = MLREE2.PROG(MM)
  316.  24       CONTINUE
  317. *
  318.          SEGDES MLREE1
  319.          SEGDES MLREE2
  320.          SEGDES KEVOLL
  321.          SEGDES MEVOLL
  322.          ENDIF
  323. *
  324.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  325.          IPLIB(I,1) = IPLAC
  326.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  327.          IPLIB(I,2) = IPLAC
  328.  
  329. *
  330. * --- choc elementaire POINT_POINT_DEPLACEMENT_PLASTIQUE avec ou sans
  331. *                                                        amortissement
  332. *
  333.       ELSE IF (ITYP.EQ.16) THEN
  334.          CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_A',L0,IP0,
  335.      &                    'POINT',I1,X1,CHARRE,L1,INOA)
  336.          IF (IERR.NE.0) RETURN
  337.          CALL ACCTAB(ITLB,'MOT',I0,X0,'POINT_B',L0,IP0,
  338.      &                    'POINT',I1,X1,CHARRE,L1,INOB)
  339.          IF (IERR.NE.0) RETURN
  340.          CALL ACCTAB(ITLB,'MOT',I0,X0,'NORMALE',L0,IP0,
  341.      &                    'POINT',I1,X1,CHARRE,L1,IPOI)
  342.          IF (IERR.NE.0) RETURN
  343.          CALL ACCTAB(ITLB,'MOT',I1,X0,'JEU',L0,IP0,
  344.      &                    'FLOTTANT',I0,XJEU,CHARRE,L1,IP1)
  345.          IF (IERR.NE.0) RETURN
  346.          CALL ACCTAB(ITLB,'MOT',I1,X0,'LOI_DE_COMPORTEMENT',L0,IP0,
  347.      &                    'EVOLUTIO',I1,X1,CHARRE,L1,IPEVO)
  348.          IF (IERR.NE.0) RETURN
  349. *
  350.          MONPER = ' '
  351.          LPERM = .FALSE.
  352.          IPERM = 1
  353.          CALL ACCTAB(ITLB,'MOT',I1,X0,'LIAISON_PERMANENTE',L0,
  354.      &                    IP0,MONPER,I0,X1,CHARRE,LPERM,IP1)
  355.          IF (IERR.NE.0) RETURN
  356.  
  357.          IF (LPERM) THEN
  358.            CALL ACCTAB(ITLB,'MOT',I1,X0,'ECROUISSAGE',L0,
  359.      &                      IP0,'MOT',I0,X1,MONECR,L1,IP1)
  360.            IF (IERR.NE.0) RETURN
  361.            IF (.NOT.(XJEU.EQ.0.D0)) THEN
  362. *             WRITE (*,*) 'Liaison permanente, mise a zero du jeu.'
  363.              XJEU = 0.D0
  364.            ENDIF
  365.            IF (MONECR.EQ.'ISOTROPE') THEN
  366.              IPERM = 2
  367.            ELSEIF (MONECR.EQ.'CINEMATIQUE') THEN
  368.              IPERM = 3
  369.            ELSE
  370.              call erreur(21)
  371.              RETURN
  372.            ENDIF
  373.          ENDIF
  374. *
  375.          MEVOLL = IPEVO
  376. *
  377. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  378. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans des
  379. * tableaux xabsci et xordon
  380. *
  381.          SEGACT MEVOLL
  382.          KEVOLL = IEVOLL(1)
  383.          SEGACT KEVOLL
  384.          MLREE1 = IPROGX
  385.          MLREE2 = IPROGY
  386.          SEGACT MLREE1
  387.          SEGACT MLREE2
  388.          NIP = XABSCI(/2)
  389. *
  390.           DO 26 MM=1,NIP
  391.             XABSCI (I,MM) = MLREE1.PROG(MM)
  392.             XORDON (I,MM) = MLREE2.PROG(MM)
  393.  26       CONTINUE
  394. *
  395.          SEGDES MLREE1
  396.          SEGDES MLREE2
  397.          SEGDES KEVOLL
  398.          SEGDES MEVOLL
  399. *
  400.          MONAMO = ' '
  401.          CALL ACCTAB(ITLB,'MOT',I1,X0,'AMORTISSEMENT',L0,IP0,
  402.      &                    MONAMO,I0,XAMON,CHARRE,L1,IP1)
  403.          IF (IERR.NE.0) RETURN
  404. *
  405.          IPALB(I,1) = ITYP
  406.          IPALB(I,3) = IDIM
  407.          XPALB(I,1) = XJEU
  408.          IF(LPERM) IPALB(I,4)=2
  409.          IPALB(I,5) = IPERM
  410. *
  411. *        normalisation de la normale
  412. *
  413.          IPNV  = (IDIM + 1) * (IPOI - 1)
  414.          PS = 0.D0
  415.          DO 30 ID = 1,IDIM
  416.             XC = XCOOR(IPNV + ID)
  417.             PS = PS + XC * XC
  418.  30         CONTINUE
  419. *        end do
  420.          IF (PS.LE.0.D0) THEN
  421.             CALL ERREUR(162)
  422.             RETURN
  423.          ENDIF
  424.          IF (MONAMO.EQ.'FLOTTANT') THEN
  425.             IPALB(I,1) = 17
  426.             XPALB(I,2) = XAMON
  427.             DO 32 ID = 1,IDIM
  428.                ID2 = 2 + ID
  429.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  430.  32            CONTINUE
  431. *           end do
  432.          ELSE
  433.             DO 34 ID = 1,IDIM
  434.                ID2 = 1 + ID
  435.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  436.  34            CONTINUE
  437. *           end do
  438.          ENDIF
  439. *
  440.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  441.          IPLIB(I,1) = IPLAC
  442.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  443.          IPLIB(I,2) = IPLAC
  444. *
  445. * --- choc {l{mentaire POINT_POINT...
  446. *
  447. *     ELSE IF (ITYP.EQ. ) THEN
  448. *        ...
  449. *        ...
  450.       ENDIF
  451. *
  452.       END
  453.  
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  
  460.  
  461.  
  462.  
  463.  
  464.  
  465.  
  466.  
  467.  

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