Télécharger la plaquette Cast3M


fr en

Télécharger cyne20.eso

Retour à la liste

Numérotation des lignes : 

cyne20

  1. C CYNE20    SOURCE    CB215821  24/04/12    21:15:33     11897          
  2.       SUBROUTINE CYNE20(ILIB,IWRK52,itruli)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. *--------------------------------------------------------------------*
  6. *   voir dyne20.eso                                                  *
  7. *     Operateur DYNE : algorithme de Fu - de Vogelaere             *
  8. *     ________________________________________________               *
  9. *                                                                    *
  10. *     Remplissage des tableaux de description des liaisons sur       *
  11. *     la base @ partir des informations contenues dans la            *
  12. *     table ILIB.                                                    *
  13. *                                                                    *
  14. *     Parametres:                                                    *
  15. *                                                                    *
  16. * e   ILIB    Table rassemblant la description des liaisons          *
  17. * es  KTLIAB  Segment descriptif des liaisons sur la base B.         *
  18. *                                                                    *
  19. *                                                                    *
  20. *     Parametres de dimensionnement pour une liaison sur base:       *
  21. *                                                                    *
  22. *     NIPALB : nombre de parametres pour definir le type des         *
  23. *              liaisons (NIPALB est fixe e 3).                       *
  24. *     NXPALB : nombre maxi de parametres internes definissant les    *
  25. *              liaisons.                                             *
  26. *     NPLBB  : nombre maxi de points intervenant dans une liaison.   *
  27. *                                                                    *
  28. *     NPLB   : nombre total de points.                               *
  29. *     NLIAB  : nombre total de liaisons.                             *
  30. *                                                                    *
  31. *                                                                    *
  32. *     Tableaux fortran pour les liaisons sur base B :                *
  33. *                                                                    *
  34. *     XPALB(NLIAB,NXPALB) : parametres de la liaison.                *
  35. *     IPALB(NLIAB,NIPALB) : renseigne sur le type de liaison.        *
  36. *                          et les eventuelles conditions             *
  37. *     XABSCI  Tableau contenant les abscisses de la loi plastique    *
  38. *             pour les liaisons point-point- ... -plastique          *
  39. *     XORDON  Tableau contenant les ordonnees de la loi plastique    *
  40. *             pour les liaisons point-point- ... -plastique          *
  41. *                                                                    *
  42. *     JPLIB(NPLB)         : numero global des points.                *
  43. *     IPLIB(NLIAB,NPLBB)  : numeros locaux des points concernes par  *
  44. *                           la liaison.                              *
  45. *                                                                    *
  46. *     Icorres  Pour garder le numero du pointeur des tables de       *
  47. *            liaison                                                 *
  48. *                                                                    *
  49. *                                                                    *
  50. *     Auteur, date de creation:                                      *
  51. *                                                                    *
  52. *     Lionel VIVAN, le 21 Septembre 1989.                            *
  53. *     E de LANGRE   08/94 laisns conditionnelles                     *
  54. *     I. Pinto 05/97, liaisons ligne_cercle,appels a dyn207          *
  55. *                                                                    *
  56. *--------------------------------------------------------------------*
  57. * ** voir DYNE20.ESO remplissage segment MTPHI
  58. *--------------------------------------------------------------------*
  59.  
  60. -INC PPARAM
  61. -INC CCOPTIO
  62. -INC SMCOORD
  63. -INC SMEVOLL
  64. -INC SMLREEL
  65. -INC SMMODEL
  66. -INC SMCHAML
  67. -INC SMELEME
  68. -INC SMCHPOI
  69. -INC DECHE
  70. -INC SMTABLE
  71. ** segment sous-structures dynamiques
  72.       segment struli
  73.        integer itlia,itbmod,momoda, mostat,itmail,molia
  74.        integer ldefo(np1),lcgra(np1),lsstru(np1)
  75.        integer nsstru,nndefo,nliab,nsb,na2,idimb
  76.        integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas
  77.        INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib
  78. * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0)
  79.        INTEGER ICHAIN
  80.       endsegment
  81. *
  82.       SEGMENT,NCPR(nbpts)
  83. * segment dimensionnement pour LIAISONS
  84. *
  85.       SEGMENT MTLIAB
  86.          INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  87.          REAL*8 XPALB(NLIAB,NXPALB)
  88.          REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  89.       ENDSEGMENT
  90. *
  91.       SEGMENT MLIGNE
  92.          INTEGER KPLIB(NPLB)
  93.       ENDSEGMENT
  94. *
  95.       SEGMENT,MTPHI
  96.          INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB)
  97.          INTEGER IAROTA(NSB)
  98.          REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB)
  99.       ENDSEGMENT
  100. * Segment pour Champoints
  101.       SEGMENT,MSAM
  102.          integer jplibb(NPLB)
  103.       ENDSEGMENT
  104.  
  105.       SEGMENT,MTRA
  106.          INTEGER IPLA(NTRA)
  107.       ENDSEGMENT
  108.  
  109.       SEGMENT MOLIAI
  110.          integer modtla,modtlb
  111.       ENDSEGMENT
  112. *
  113. *
  114.       LOGICAL Lo1,L0,log1,lvar,lmodyn,lva1
  115.       LOGICAL LPERM,LINTER,LECRO,LELAS,REPRIS
  116.       CHARACTER*40 CMOT,MONMOT,CMOT1 ,MONECR,CMOT2
  117.       CHARACTER*8 MONAMO,MONSEUIL,TYPRET,MARAID,MONPER
  118.       CHARACTER*16 CHARRE
  119.       CHARACTER*8 TYPREG,MONREC,MONJEU,MONSYM,MONELA,MONINTER
  120.       CHARACTER*8 MONESC,MONRAY,MONCAL,MONINV
  121.       CHARACTER*4 NOMTRI(6),NOMAXI(6),NOMPLA(3)
  122.       REAL*8      XAXROT(3),XROTA(2,3)
  123.       DATA NOMAXI/'UR  ','UT  ','UZ  ','RR  ','RT  ','RZ  '/
  124.       DATA NOMPLA/'UX  ','UY  ','RZ  '/
  125.       DATA NOMTRI/'UX  ','UY  ','UZ  ','RX  ','RY  ','RZ  '/
  126.  
  127.       struli = itruli
  128.  
  129.       wrk52 = iwrk52
  130.  
  131.         imodel = ilib
  132.         segact imodel
  133. * fabrique la table de sortie
  134. *
  135.          call crtabl(its1)
  136.          itsort = its1
  137.  
  138.             L1 = 1
  139.             N1 = 1
  140.             n3 = 6
  141.             segini mchelm
  142.             itcara = mchelm
  143.  
  144. * kich : reconstruit un mchaml ad hoc : ne pas oublier qu il s agit
  145. * de reutilisation .
  146.             n2 = valmat(/1)
  147.             segini mchaml
  148.             ichaml(1) = mchaml
  149.             imache(1) = imamod
  150.             conche(1) = conmod
  151.           do jn2 = 1,n2
  152.             nomche(jn2) = commat(jn2)
  153.             typche(jn2) = tyval(jn2)
  154.             ielval(jn2) = ivalma(jn2)
  155.             if(nomche(jn2).eq.'SORT') then
  156.              if (ielval(jn2).eq.0) then
  157.               call crtabl(ipsort)
  158.              else
  159.               melval = ielval(jn2)
  160. *             segact melval
  161.               ipsort = ielche(1,1)
  162.               if (typche(jn2).ne.'POINTEURTABLE') then
  163.                MOTERR(1:16) = typche(jn2)
  164.                MOTERR(17:20) = nomche(jn2)
  165.                MOTERR(21:36) = ' utile '
  166.                CALL ERREUR(552)
  167.                return
  168.               endif
  169.              endif
  170. c*              mtab1 = ipsort
  171. c*              segact mtab1
  172.              call ecrobj('TABLE',ipsort)
  173.              call indeta
  174.              call lirobj('TABLE   ',ITAC,1,IRETOU)
  175.              CALL DIMEN7 (ITAC,IDIMEN)
  176.       INDICE = 0
  177.  5100 CONTINUE
  178.       INDICE = INDICE + 1
  179.       TYPRET = ' '
  180.       CALL ACCTAB(ITAC,'ENTIER',INDICE,X0,' ',L0,IP0,
  181.      &                  TYPRET,I1,X1,CHARRE,LVA1,ITTL)
  182.       IF (TYPRET.EQ.'MMODEL  ' .AND. ITTL.NE.0) THEN
  183.          mmode1 = ittl
  184.          ipttl = ittl
  185.          segact mmode1
  186. * on attend une liaison elementaire
  187.          imode1 = mmode1.kmodel(1)
  188.          segact imode1
  189.        if (imode1.conmod.eq.conmod.or.imode1.imamod.eq.imamod) then
  190.          TYPRET = ' '
  191.          CALL ACCTAB(IPSORT,'MMODEL  ',I0,X0,' ',L0,ITTL,
  192.      &                     TYPRET,I1,X1,CHARRE,LVAR,ITVAR)
  193.  
  194.              CALL ECCTAB(ITS1,'MMODEL',0,0.D0,' ',.TRUE.,ittl,
  195.      &                     TYPRET,I1,X1,CHARRE,LVAR,ITVAR)
  196.  
  197.             goto 5010
  198.        endif
  199.       ENDIF
  200.       IF(INDICE.LE.IDIMEN) GOTO 5100
  201.             endif
  202.  
  203.  
  204.  5010  continue
  205.  
  206.            enddo
  207.  
  208.       NTVAR  = 6 + 4 * IDIM
  209. *
  210. *     MTRA indiquera la presence de liaisons POLYNOMIALEs
  211. *     (on suppose un maximum de 100 liaisons en base A)
  212. *+*   passe a 10000 le 28/1/93
  213.       NTRA   = 10000
  214.       SEGINI,MTRA
  215.  
  216.       lmodyn = .true.
  217.       np = 1
  218.       nins = 1
  219.       repris = .false.
  220.       idimb1 = idimb
  221.       nplb1 = nplb
  222.       moliai = molia
  223.       imolia = moliai
  224.       segact moliai
  225.       klia = 0
  226.       klib = 0
  227.       if (modtla.ne.0) then
  228.        mmode1 = modtla
  229.        segact mmode1
  230.        klia = mmode1.kmodel(/1)
  231.       endif
  232.       if (modtlb.ne.0) then
  233.        mmode1 = modtlb
  234.        segact mmode1
  235.        klib = mmode1.kmodel(/1)
  236.       endif
  237.       na1 = 0
  238.       nmost0 = 0
  239.       if (momoda.gt.0) then
  240.        mmode2 = momoda
  241.        segact mmode2
  242.        nmost0 = mmode2.kmodel(/1)
  243.        na1 = nmost0
  244.       endif
  245.       if (mostat.gt.0) then
  246.        mmode2 = mostat
  247.        segact mmode2
  248.        na1 = na1 + mmode2.kmodel(/1)
  249.       endif
  250. *
  251.        nliab = klib
  252.        nliabl=nliab
  253.         SEGINI,MTLIAB
  254.       KTLIAB = MTLIAB
  255.       IF (NLIAB.NE.0) THEN
  256.          NCPR = kcpr
  257.          LCPR =nbpts
  258.          IN = 0
  259.          DO 18 I = 1,LCPR
  260.             IF (NCPR(I).NE.0) THEN
  261.                IN = IN + 1
  262.                JPLIB(IN) = I
  263.             ENDIF
  264.  18         CONTINUE
  265. * segement ncpr detruit dans devini
  266.       ENDIF
  267. *
  268. *     Gestion de la table definissant les resultats attendus:
  269. *     ( par la suite, on s'occupera de TREDU )
  270. *
  271.  
  272.       jchain = ichain
  273.       ikpref = kpref
  274. *      if (klia.le.0) klia = 1
  275.       CALL DYNE15(ITS1,iKPREF,NA1,NP,NINS,IMOLIA,iktres,jtmail,REPRIS,
  276.      &  JCHAIN,NTVAR,klia,nliabl,nplb1,idimb1,MTRA,ITCARA,
  277.      &lmodyn,nmost0)
  278.  
  279.       IF (IERR.NE.0) RETURN
  280.       KTRES = iktres
  281.       itmail = jtmail
  282.       ichain = jchain
  283.  
  284. *     Creation des objets resultats :
  285. *
  286.       SEGINI,MSAM
  287.       KSAM=MSAM
  288.       DO 100 IP=1,NPLB
  289.          JPLIBB(IP)=JPLIB(IP)
  290.  100  CONTINUE
  291.       itkm = 0
  292.       jtmail = itmail
  293.       JTRES = KTRES
  294.       JPREF = KPREF
  295.       lmodyn = .true.
  296.       NPLAA = 0
  297.       NXPALA= 0
  298.       CALL DYNE17(1,ITKM,jtmail,JTRES,JPREF,NPLAA,NXPALA,KSAM,lmodyn)
  299.       IF (IERR.NE.0) RETURN
  300.       MSAM=KSAM
  301.       SEGSUP,MSAM
  302.  
  303. *
  304.       mchelm = itcara
  305.       segact mchelm
  306.        do im3 = 1,ichaml(/1)
  307.          mchaml = ichaml(im3)
  308.          segsup mchaml
  309.        enddo
  310.       segsup mchelm
  311.  
  312. *
  313. * model élémentaire
  314. *
  315.       II = 0
  316. *
  317.         imodel = ilib
  318.         segact imodel
  319.         ipt8 = imamod
  320.         segact ipt8
  321.         imod = ipt8.num(1,1)
  322.         inoa = ipt8.num(1,1)
  323.         isup = ipt8.num(1,1)
  324.  
  325.         I = jliaib
  326.  
  327.  51      continue
  328.         TYPRET = ' '
  329.         MONSEUIL = ' '
  330. *--------------------------------------------------------------------*
  331. * --- choc elementaire POINT_PLAN_FLUIDE
  332. *--------------------------------------------------------------------*
  333.         if (cmatee.eq.'PO_PL_FL') then
  334.                ITYP = 7
  335.                IPOI = int(valmat(1))
  336.                XINER = valmat(2)
  337.                XCONV = valmat(3)
  338.                XVISC = valmat(4)
  339.                XPCEL = valmat(5)
  340.                XPCRA = valmat(6)
  341.                XJEU = valmat(7)
  342.  
  343.          IPALB(I,1) = ITYP
  344.          IPALB(I,3) = IDIM
  345.          XPALB(I,1) = XINER
  346.          XPALB(I,2) = XCONV
  347.          XPALB(I,3) = XVISC
  348.          XPALB(I,4) = XPCEL
  349.          XPALB(I,5) = XPCRA
  350.          XPALB(I,6) = XJEU
  351. *
  352.          IPNV  = (IDIM + 1) * (IPOI - 1)
  353.          PS = 0.D0
  354.          DO 70 ID = 1,IDIM
  355.             XC = XCOOR(IPNV + ID)
  356.             PS = PS + XC * XC
  357.  70         CONTINUE
  358. *        end do
  359.          IF (PS.LE.0.D0) THEN
  360.             CALL ERREUR(162)
  361.             RETURN
  362.          ENDIF
  363.          ID1 = 6
  364.          DO 72 ID = 1,IDIM
  365.             XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS)
  366.  72         CONTINUE
  367. *        end do
  368.          CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD)
  369.          IPLIB(I,1) = IPLAC
  370. *
  371. *
  372. *--------------------------------------------------------------------*
  373. * ------ choc elementaire POINT_PLAN_FROTTEMENT
  374. *--------------------------------------------------------------------*
  375. *
  376.         else if(cmatee.eq.'PO_PL_FR') then
  377.                ITYP = 3
  378.                MARAID = ' '
  379.                TYPRET = ' '
  380.                MONAMO = ' '
  381.  
  382.                IPOI = int(valmat(1))
  383.               if (valmat(2).gt.0.) then
  384.                xrain = valmat(2)
  385.                MARAID = 'FLOTTANT'
  386.               endif
  387.                XJEU  = valmat(3)
  388.                XGLIS = valmat(4)
  389.                XADHE = valmat(5)
  390.                XRAIT = valmat(6)
  391.                XAMOT = valmat(7)
  392.  
  393.              if (valmat(/1).gt.7) then
  394.               if (valmat(8).gt.0.) then
  395.                xamon = valmat(8)
  396.                MONAMO = 'FLOTTANT'
  397.               endif
  398.               if (tyval(9)(9:16).eq.'EVOLUTIO') then
  399.                ipevo = int(valmat(9))
  400.                TYPRET = 'EVOLUTIO'
  401.               endif
  402.              endif
  403.  
  404.          IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
  405.             CALL ERREUR(891)
  406.             RETURN
  407.          ENDIF
  408.          IF (TYPRET.EQ.'EVOLUTIO') THEN
  409.             ITYP = 103
  410.             XRAIN = 0.d0
  411.          ENDIF
  412.          IPALB(I,1) = ITYP
  413.          IPALB(I,3) = IDIM
  414.          XPALB(I,1) = XRAIN
  415.          XPALB(I,2) = XJEU
  416.          XPALB(I,3) = XGLIS
  417.          XPALB(I,4) = XADHE
  418.          XPALB(I,5) = XRAIT
  419.          XPALB(I,6) = XAMOT
  420.          IF (MONAMO.EQ.'FLOTTANT') THEN
  421.             XPALB(I,7) = XAMON
  422.          ELSE
  423.             XPALB(I,7) = 0.D0
  424.          ENDIF
  425. *        NORMALE
  426.          IPNV  = (IDIM + 1) * (IPOI - 1)
  427.          PS = 0.D0
  428.          DO 20 ID = 1,IDIM
  429.             XC = XCOOR(IPNV + ID)
  430.             PS = PS + XC * XC
  431.  20      CONTINUE
  432.          IF (PS.LE.0.D0) THEN
  433.             CALL ERREUR(162)
  434.             RETURN
  435.          ENDIF
  436. cbp,2020         ID1 = 7
  437.          ID1 = 9
  438.          DO 22 ID = 1,IDIM
  439.             XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS)
  440.  22      CONTINUE
  441.  
  442.          IF (IPALB(I,1) .EQ. 103) THEN
  443.          MEVOLL = IPEVO
  444. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  445. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans
  446. * des tableaux xabsci et xordon
  447.          SEGACT MEVOLL
  448.          KEVOLL = IEVOLL(1)
  449.          SEGACT KEVOLL
  450.          MLREE1 = IPROGX
  451.          MLREE2 = IPROGY
  452.          SEGACT MLREE1
  453.          SEGACT MLREE2
  454.          NIP = XABSCI(/2)
  455.           DO 26 MM=1,NIP
  456.             XABSCI (I,MM) = MLREE1.PROG(MM)
  457.             XORDON (I,MM) = MLREE2.PROG(MM)
  458.  26       CONTINUE
  459.          SEGDES MLREE1
  460.          SEGDES MLREE2
  461.          SEGDES KEVOLL
  462.          SEGDES MEVOLL
  463.          ENDIF
  464. *
  465.          CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD)
  466.          IPLIB(I,1) = IPLAC
  467. *
  468. *--------------------------------------------------------------------*
  469. * ------ choc elementaire POINT_PLAN
  470. *--------------------------------------------------------------------*
  471.         else if(cmatee.eq.'PO_PL') then
  472.                ITYP = 1
  473.                IPERM = 0
  474.                XPALB(I,3) = 0.D0
  475.                MONSEUIL =' '
  476.                TYPRET= ' '
  477.               IPOI = int(valmat(1))
  478.               xraid = valmat(2)
  479.               xjeu = valmat(3)
  480.            if (ivalma(6).gt.0) then
  481.             MONSEUIL ='FLOTTANT'
  482.             xseuil = valmat(6)
  483.            endif
  484.             xamon = valmat(7)
  485.             XPALB(I,3) = XAMON
  486.            if (ivalma(4).gt.0) then
  487.             ipevo = int(valmat(4))
  488.             TYPRET = 'EVOLUTIO'
  489.            endif
  490. *?
  491.             if (valmat(5).ne.0) IPERM = 1
  492.  
  493.  
  494.          IPALB(I,1) = ITYP
  495.          IPALB(I,3) = IDIM
  496.          IPALB(I,4) = IPERM
  497.          XPALB(I,1) = XRAID
  498.          XPALB(I,2) = XJEU
  499. *
  500.          IPNV  = (IDIM + 1) * (IPOI - 1)
  501.          PS = 0.D0
  502.          DO 17 ID = 1,IDIM
  503.             XC = XCOOR(IPNV + ID)
  504.             PS = PS + XC * XC
  505.  17      CONTINUE
  506. *
  507.          IF (PS.LE.0.D0) THEN
  508.             CALL ERREUR(162)
  509.             RETURN
  510.          ENDIF
  511.          ID1 = 3
  512.  
  513.          IF (MONSEUIL .EQ.'FLOTTANT') THEN
  514.              IF (TYPRET .EQ. 'EVOLUTIO') THEN
  515.                 IPALB(I,1) = 101
  516.              ELSE
  517.                 IPALB(I,1) = 100
  518.              ENDIF
  519.              ID1 = 4
  520.              XPALB(I,ID1) = XSEUIL
  521.          ELSE
  522.              IF (TYPRET .EQ. 'EVOLUTIO') THEN
  523.                 IPALB(I,1) = 102
  524.              ENDIF
  525.          ENDIF
  526.  
  527. *
  528.          DO 12 ID = 1,IDIM
  529.             XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS)
  530.  12         CONTINUE
  531. *
  532.          IF (IPALB(I,1) .EQ. 101 .OR. IPALB(I,1) .EQ. 102) THEN
  533.          MEVOLL = IPEVO
  534. *
  535. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  536. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans
  537. * des tableaux xabsci et xordon
  538. *
  539.          SEGACT MEVOLL
  540.          KEVOLL = IEVOLL(1)
  541.          SEGACT KEVOLL
  542.          MLREE1 = IPROGX
  543.          MLREE2 = IPROGY
  544.          SEGACT MLREE1
  545.          SEGACT MLREE2
  546.          NIP = XABSCI(/2)
  547. *
  548.           DO 16 MM=1,NIP
  549.             XABSCI (I,MM) = MLREE1.PROG(MM)
  550.             XORDON (I,MM) = MLREE2.PROG(MM)
  551.  16       CONTINUE
  552. *
  553.          SEGDES MLREE1
  554.          SEGDES MLREE2
  555.          SEGDES KEVOLL
  556.          SEGDES MEVOLL
  557.          ENDIF
  558. *
  559. c         IMOD = num(1,1)
  560.          CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD)
  561.          IPLIB(I,1) = IPLAC
  562. *
  563. *--------------------------------------------------------------------*
  564. * ------ choc elementaire POINT_POINT_FROTTEMENT
  565. *--------------------------------------------------------------------*
  566.        else if (cmatee.eq.'PO_PO_FR') then
  567.           ITYP = 13
  568.           MARAID = ' '
  569.           MONPER = ' '
  570.           MONAMO = ' '
  571.           TYPRET = ' '
  572.           TYPREG = ' '
  573.           CHARRE = ' '
  574.           igibe = 0
  575.             IPOI = int(valmat(1))
  576.             xraid = valmat(2)
  577.             xjeu = valmat(3)
  578.             INOB =  int(valmat(4))
  579.             xadhe = valmat(5)
  580.             xrait = valmat(6)
  581.             xamot = valmat(7)
  582.             xglis = valmat(8)
  583.          if (valmat(/1).gt.8) then
  584.            if (tyval(10)(9:16).eq.'EVOLUTIO') then
  585.             ipevo = int(valmat(10))
  586.             TYPRET = 'EVOLUTIO'
  587.            endif
  588.            if (tyval(11)(1:6).eq.'ENTIER') then
  589.               igibe = int(valmat(11))
  590.               TYPREG = 'MOT'
  591.               if (igibe.eq.1) CHARRE = 'NEDJAI-GIBERT'
  592.            endif
  593.            if (tyval(9)(1:6).eq.'REAL*8') then
  594.             xamon = valmat(9)
  595.               MONAMO='FLOTTANT'
  596.            endif
  597.          endif
  598.  
  599.  
  600.           IF (IERR.NE.0) RETURN
  601. ** dans quel cas monamo est il entier?   PV
  602. **       IF (MONAMO .EQ. 'ENTIER  ') THEN
  603. **         XAMON = 1.D0*I0
  604. **         MONAMO = 'FLOTTANT'
  605. **       ENDIF
  606.          IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
  607.             CALL ERREUR(891)
  608.             RETURN
  609.          ENDIF
  610.          IF (TYPRET.EQ.'EVOLUTIO') THEN
  611.             ITYP = 113
  612.             XRAID = 0.d0
  613.          ENDIF
  614. *
  615.          IPALB(I,1) = ITYP
  616.          IPALB(I,3) = IDIM
  617.          XPALB(I,1) = XRAID
  618.          XPALB(I,2) = XJEU
  619.          XPALB(I,3) = XGLIS
  620.          XPALB(I,4) = XADHE
  621.          XPALB(I,5) = XRAIT
  622.          XPALB(I,6) = XAMOT
  623.          IF (MONAMO.EQ.'FLOTTANT') THEN
  624.             XPALB(I,7) = XAMON
  625.          ELSE
  626.             XPALB(I,7) = 0.D0
  627.          ENDIF
  628.  
  629. * cas particulier pas tres orthodoxe pour Gibert
  630. * on passe a ityp = -13 et on modifie et ajoute
  631. * devlb2, devlb1-->devfb2--->dgcha4--->dgchfr--->dgchgl, devso4
  632.          IF (TYPREG.EQ.'MOT') THEN
  633.             IF (CHARRE.EQ.'NEDJAI-GIBERT') THEN
  634.               IPALB(I,1) = -13
  635.             ELSE
  636.              CALL ERREUR(891)
  637.              RETURN
  638.             ENDIF
  639.          ELSEIF (IGIBE.NE.0) THEN
  640.              CALL ERREUR(891)
  641.              RETURN
  642.          ENDIF
  643.  
  644. *
  645. *        normalisation de la normale
  646. *
  647.          IPNV  = (IDIM + 1) * (IPOI - 1)
  648.          PS = 0.D0
  649.          DO 420 ID = 1,IDIM
  650.             XC = XCOOR(IPNV + ID)
  651.             PS = PS + XC * XC
  652.  420        CONTINUE
  653. *        end do
  654.          IF (PS.LE.0.D0) THEN
  655.             CALL ERREUR(162)
  656.             RETURN
  657.          ENDIF
  658.          DO 422 ID = 1,IDIM
  659.                ID2 = 7 + ID
  660.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  661.  422           CONTINUE
  662. *        end do
  663. *
  664.          IF (IPALB(I,1) .EQ. 113) THEN
  665.          MEVOLL = IPEVO
  666. *
  667. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  668. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans
  669. * des tableaux xabsci et xordon
  670. *
  671.          SEGACT MEVOLL
  672.          KEVOLL = IEVOLL(1)
  673.          SEGACT KEVOLL
  674.          MLREE1 = IPROGX
  675.          MLREE2 = IPROGY
  676.          SEGACT MLREE1
  677.          SEGACT MLREE2
  678.          NIP = XABSCI(/2)
  679. *
  680.           DO 424 MM=1,NIP
  681.             XABSCI (I,MM) = MLREE1.PROG(MM)
  682.             XORDON (I,MM) = MLREE2.PROG(MM)
  683.  424      CONTINUE
  684. *
  685.          SEGDES MLREE1
  686.          SEGDES MLREE2
  687.          SEGDES KEVOLL
  688.          SEGDES MEVOLL
  689.          ENDIF
  690. *
  691.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  692.          IPLIB(I,1) = IPLAC
  693.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  694.          IPLIB(I,2) = IPLAC
  695.  
  696. *
  697. *--------------------------------------------------------------------*
  698. * ------ choc elementaire POINT_POINT_DEPLACEMENT_PLASTIQUE
  699. *--------------------------------------------------------------------*
  700.         else if(cmatee.eq.'PO_PO_DP') then
  701.           ITYP = 16
  702.           MARAID = ' '
  703.           MONPER = ' '
  704.           LPERM = .false.
  705.           IPERM = 0
  706.           MONAMO = ' '
  707.           TYPRET = ' '
  708.  
  709.           IPOI = int(valmat(1))
  710.           IECRO = int(valmat(2))
  711. * IECRO = 1 <= isotrope , IECRO = 2 <= cinematique
  712.               LECRO = .true.
  713.               if (iecro.eq.1) monecr = 'ISOTROPE'
  714.               if (iecro.eq.2) monecr = 'CINEMATIQUE'
  715.           xjeu = valmat(3)
  716.           inob = int(valmat(4))
  717. * IPERM = 2 <= isotrope , IPERM = 3 <= cinematique
  718.           if (valmat(5).gt.0)  LPERM = .true.
  719.           IPERM = int(valmat(5))
  720.           IPEVO = int(valmat(6))
  721.            if (tyval(10)(9:16).eq.'EVOLUTIO') then
  722.              TYPRET = 'EVOLUTIO'
  723.            endif
  724.          if (valmat(/1).gt.6) then
  725.            xamon = valmat(7)
  726.              MONAMO='FLOTTANT'
  727.          endif
  728.  
  729.          IF (IERR.NE.0) RETURN
  730.  
  731.          IF (LPERM) THEN
  732.            IF (.NOT.(XJEU.EQ.0.D0)) THEN
  733. *             WRITE (*,*) 'Liaison permanente, mise a zero du jeu.'
  734.              XJEU = 0.D0
  735.            ENDIF
  736.  
  737.            IF (IPERM.ne.3.and.IPERM.ne.2) THEN
  738.              call erreur(21)
  739.              RETURN
  740.            ENDIF
  741.          ENDIF
  742. *
  743.          MEVOLL = IPEVO
  744. *
  745. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  746. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans
  747. * des tableaux xabsci et xordon
  748. *
  749.          SEGACT MEVOLL
  750.          KEVOLL = IEVOLL(1)
  751.          SEGACT KEVOLL
  752.          MLREE1 = IPROGX
  753.          MLREE2 = IPROGY
  754.          SEGACT MLREE1
  755.          SEGACT MLREE2
  756.          NIP = XABSCI(/2)
  757. *
  758.           DO 426 MM=1,NIP
  759.             XABSCI (I,MM) = MLREE1.PROG(MM)
  760.             XORDON (I,MM) = MLREE2.PROG(MM)
  761.  426      CONTINUE
  762. *
  763.          SEGDES MLREE1
  764.          SEGDES MLREE2
  765.          SEGDES KEVOLL
  766.          SEGDES MEVOLL
  767. *
  768.          IPALB(I,1) = ITYP
  769.          IPALB(I,3) = IDIM
  770.          XPALB(I,1) = XJEU
  771.          IPALB(I,5) = IPERM
  772. *
  773. *        normalisation de la normale
  774. *
  775.          IPNV  = (IDIM + 1) * (IPOI - 1)
  776.          PS = 0.D0
  777.          DO 30 ID = 1,IDIM
  778.             XC = XCOOR(IPNV + ID)
  779.             PS = PS + XC * XC
  780.  30         CONTINUE
  781. *        end do
  782.          IF (PS.LE.0.D0) THEN
  783.             CALL ERREUR(162)
  784.             RETURN
  785.          ENDIF
  786.          IF (MONAMO.EQ.'FLOTTANT') THEN
  787.             IPALB(I,1) = 17
  788.             XPALB(I,2) = XAMON
  789.             DO 32 ID = 1,IDIM
  790.                ID2 = 2 + ID
  791.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  792.  32            CONTINUE
  793. *           end do
  794.          ELSE
  795.             DO 34 ID = 1,IDIM
  796.                ID2 = 1 + ID
  797.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  798.  34            CONTINUE
  799. *           end do
  800.          ENDIF
  801. *
  802.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  803.          IPLIB(I,1) = IPLAC
  804.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  805.          IPLIB(I,2) = IPLAC
  806. *
  807. *--------------------------------------------------------------------*
  808. * ------ choc elementaire POINT_POINT_ROTATION_PLASTIQUE
  809. *--------------------------------------------------------------------*
  810.         else if(cmatee.eq.'PO_PO_RP') then
  811.           ITYP = 50
  812.           MARAID = ' '
  813.           MONPER = ' '
  814.           MONELA = ' '
  815.           LPERM = .FALSE.
  816.           LELAS = .FALSE.
  817.           LECRO = .FALSE.
  818.           IPERM = 0
  819.           MONAMO = ' '
  820.           TYPRET = ' '
  821.  
  822.           IPOI = int(valmat(1))
  823.           IECRO = int(valmat(2))
  824. * IECRO = 1 <= isotrope , IECRO = 2 <= cinematique
  825.               LECRO = .true.
  826.               if (iecro.eq.1) monecr = 'ISOTROPE'
  827.               if (iecro.eq.2) monecr = 'CINEMATIQUE'
  828.            xjeu = valmat(3)
  829.           inob = int(valmat(4))
  830. * iperm = -2 : liaison elastique permanente
  831. * iperm = -1 : choc elastique
  832. * iperm =  0 : donnees incoherentes ou insuffisantes
  833. * iperm =  1 : choc plastique
  834. * iperm =  2 : liaison plastique isotrope
  835. * iperm =  3 : liaison plastique cinematique
  836.           if (valmat(5).gt.0)  LPERM = .true.
  837.           IPERM = int(valmat(5))
  838.           IPEVO = int(valmat(6))
  839.            if (tyval(10)(9:16).eq.'EVOLUTIO') then
  840.              TYPRET = 'EVOLUTIO'
  841.            endif
  842.          if (valmat(/1).gt.6) then
  843.              xamon = valmat(7)
  844.            if (valmat(7).gt.0)    MONAMO='FLOTTANT'
  845.             if (valmat(8).gt.0)  LELAS = .true.
  846.          endif
  847.  
  848.          IF (IERR.NE.0) RETURN
  849.  
  850.          IF (LPERM) THEN
  851.            IF (LELAS.AND.(.NOT.LECRO)) IPERM = -2
  852.            IF (MONECR.EQ.'ISOTROPE'.AND.(.NOT.LELAS)) IPERM = 2
  853.            IF (MONECR.EQ.'CINEMATIQUE'.AND.(.NOT.LELAS)) IPERM = 3
  854.            IF (.NOT.(XJEU.EQ.0.)) THEN
  855. *             WRITE(*,*) 'Liaison permanente, mise a zero du jeu.'
  856.               XJEU = 0.D0
  857.            ENDIF
  858.          ELSE
  859.            IF (.NOT.LECRO) THEN
  860.                IF (LELAS) THEN
  861.                      IPERM = -1
  862.                ELSE
  863.                      IPERM = 1
  864.                ENDIF
  865.            ENDIF
  866.          ENDIF
  867.          IF (IPERM.EQ.0) THEN
  868.              CALL ERREUR(905)
  869.              RETURN
  870.          ENDIF
  871. *
  872.          MEVOLL = IPEVO
  873. *
  874. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  875. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans
  876. * des tableaux xabsci et xordon
  877. *
  878.          SEGACT MEVOLL
  879.          KEVOLL = IEVOLL(1)
  880.          SEGACT KEVOLL
  881.          MLREE1 = IPROGX
  882.          MLREE2 = IPROGY
  883.          SEGACT MLREE1
  884.          SEGACT MLREE2
  885. *         NIP = MLREE1.PROG(/1)
  886.           NIP = XABSCI(/2)
  887. *
  888.           DO 110 MM=1,NIP
  889.             XABSCI (I,MM) = MLREE1.PROG(MM)
  890.             XORDON (I,MM) = MLREE2.PROG(MM)
  891.  110      CONTINUE
  892. *
  893.          SEGDES MLREE1
  894.          SEGDES MLREE2
  895.          SEGDES KEVOLL
  896.          SEGDES MEVOLL
  897. *
  898.          IPALB(I,1) = ITYP
  899.          IPALB(I,3) = IDIM
  900.          IPALB(I,5) = IPERM
  901.          XPALB(I,1) = XJEU
  902. *
  903. *        normalisation de l'axe de rotation
  904. *
  905.          IPNV  = (IDIM + 1) * (IPOI - 1)
  906.          PS = 0.D0
  907.          DO 120 ID = 1,IDIM
  908.             XC = XCOOR(IPNV + ID)
  909.             PS = PS + XC * XC
  910.  120        CONTINUE
  911. *        end do
  912.          IF (PS.LE.0.D0) THEN
  913.             CALL ERREUR(162)
  914.             RETURN
  915.          ENDIF
  916.          IF (MONAMO.EQ.'FLOTTANT') THEN
  917.             IPALB(I,1) = 51
  918.             XPALB(I,2) = XAMON
  919.             DO 122 ID = 1,IDIM
  920.                ID2 = 2 + ID
  921.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  922.  122           CONTINUE
  923. *           end do
  924.          ELSE
  925.             DO 124  ID = 1,IDIM
  926.                ID2 = 1 + ID
  927.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  928.  124            CONTINUE
  929. *           end do
  930.          ENDIF
  931. *
  932.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  933.          IPLIB(I,1) = IPLAC
  934.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  935.          IPLIB(I,2) = IPLAC
  936. *
  937. *
  938. *--------------------------------------------------------------------*
  939. * ------ choc elementaire POINT_POINT
  940. *--------------------------------------------------------------------*
  941.         else if(cmatee.eq.'PO_PO') then
  942.           ITYP = 11
  943.           MARAID = ' '
  944.           MONPER = ' '
  945.           LPERM = .FALSE.
  946.           IPERM = 0
  947.           MONAMO = ' '
  948.           TYPRET = ' '
  949.           IPOI = int(valmat(1))
  950.           XRAID = valmat(2)
  951.           if (valmat(2).gt.0) MARAID = 'FLOTTANT'
  952.           XJEU = valmat(3)
  953.           INOB = int(valmat(4))
  954.           IPERM = int(valmat(5))
  955.           if (IPERM.gt.0)  LPERM = .true.
  956.           if (valmat(/1).gt.5) then
  957.             xamon = valmat(6)
  958.             if (valmat(6).gt.0)  MONAMO='FLOTTANT'
  959.              IPEVO = int(valmat(7))
  960.            if (tyval(7)(9:16).eq.'EVOLUTIO') then
  961.              TYPRET = 'EVOLUTIO'
  962.            endif
  963.  
  964.           endif
  965.  
  966.          IF (IERR.NE.0) RETURN
  967.  
  968.          IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN
  969.             CALL ERREUR(891)
  970.             RETURN
  971.          ENDIF
  972. *
  973.          IF (TYPRET.EQ.'EVOLUTIO') THEN
  974.             ITYP = 111
  975.             XRAID = 0.d0
  976.          ENDIF
  977.  
  978.          IPALB(I,1) = ITYP
  979.          IPALB(I,3) = IDIM
  980.          IPALB(I,4) = IPERM
  981.          XPALB(I,1) = XRAID
  982.          XPALB(I,2) = XJEU
  983. *
  984. *        normalisation de la normale
  985. *
  986.          IPNV  = (IDIM + 1) * (IPOI - 1)
  987.          PS = 0.D0
  988.          DO 111 ID = 1,IDIM
  989.             XC = XCOOR(IPNV + ID)
  990.             PS = PS + XC * XC
  991.  111     CONTINUE
  992. *        end do
  993.          IF (PS.LE.0.D0) THEN
  994.             CALL ERREUR(162)
  995.             RETURN
  996.          ENDIF
  997.          IF (MONAMO.EQ.'FLOTTANT') THEN
  998.             XPALB(I,3) = XAMON
  999.          ELSE
  1000.             XPALB(I,3) = 0.d0
  1001.          ENDIF
  1002.             DO 112 ID = 1,IDIM
  1003.                ID2 = 3 + ID
  1004.                XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS)
  1005.  112           CONTINUE
  1006. *           end do
  1007. *
  1008.          IF (IPALB(I,1) .EQ. 111) THEN
  1009.          MEVOLL = IPEVO
  1010. *
  1011. *  si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe)
  1012. * Ici, on recupere les abscisses et les ordonnees de l'evolution dans
  1013. * des tableaux xabsci et xordon
  1014. *
  1015.          SEGACT MEVOLL
  1016.          KEVOLL = IEVOLL(1)
  1017.          SEGACT KEVOLL
  1018.          MLREE1 = IPROGX
  1019.          MLREE2 = IPROGY
  1020.          SEGACT MLREE1
  1021.          SEGACT MLREE2
  1022.          NIP = XABSCI(/2)
  1023. *
  1024.           DO 116 MM=1,NIP
  1025.             XABSCI (I,MM) = MLREE1.PROG(MM)
  1026.             XORDON (I,MM) = MLREE2.PROG(MM)
  1027.  116      CONTINUE
  1028. *
  1029.          SEGDES MLREE1
  1030.          SEGDES MLREE2
  1031.          SEGDES KEVOLL
  1032.          SEGDES MEVOLL
  1033.          ENDIF
  1034. *
  1035.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  1036.          IPLIB(I,1) = IPLAC
  1037.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  1038.          IPLIB(I,2) = IPLAC
  1039. *
  1040. *--------------------------------------------------------------------*
  1041. * ------ choc elementaire POINT_CERCLE_MOBILE
  1042. *--------------------------------------------------------------------*
  1043.         else if(cmatee.eq.'PO_CE_MO') then
  1044.           ITYP = 33
  1045.                MONAMO = ' '
  1046.                MARAID = ' '
  1047.                MONINTER = ' '
  1048.                LINTER = .true.
  1049.            IPOI = int(valmat(1))
  1050.            xraid = valmat(2)
  1051.             if (valmat(2).gt.0)    MARAID = 'FLOTTANT'
  1052.            INOB = int(valmat(3))
  1053.            XRAYO = valmat(4)
  1054.            XGLIS = valmat(5)
  1055.            XADHE = valmat(6)
  1056.            XRAIT = valmat(7)
  1057.            XAMOT = valmat(8)
  1058.            if (valmat(/1).gt.8) then
  1059.              xamon = valmat(10)
  1060.              if(valmat(10).gt.0) MONAMO = 'FLOTTANT'
  1061.              xinter = valmat(9)
  1062.             if(valmat(9).gt.0)  LINTER = .FALSE.
  1063.            endif
  1064.  
  1065.          IF (IERR.NE.0) RETURN
  1066.          IPALB(I,1) = ITYP
  1067.          IPALB(I,3) = IDIM
  1068. cbp         IPALB(I,4) = 1
  1069.          IF (.NOT.LINTER) THEN
  1070. cbp           IPALB(I,4) = 0
  1071. cbp : on laisse IPALB(I,4) pour les liaisons conditionnelles
  1072.             ITYP=ITYP+100
  1073.             IPALB(I,1) = ITYP           
  1074.          ENDIF
  1075.          XPALB(I,1) = XRAID
  1076.          XPALB(I,2) = XRAYO
  1077.          XPALB(I,3) = XGLIS
  1078.          XPALB(I,4) = XADHE
  1079.          XPALB(I,5) = XRAIT
  1080.          XPALB(I,6) = XAMOT
  1081. *
  1082. *        normalisation de la normale
  1083. *
  1084.          IPNV  = (IDIM + 1) * (IPOI - 1)
  1085.          IPNOA  = (IDIM + 1) * (INOA - 1)
  1086.          IPNOB  = (IDIM + 1) * (INOB - 1)
  1087.          PS = 0.D0
  1088.          DO 202 ID = 1,IDIM
  1089.             XC = XCOOR(IPNV + ID)
  1090.             PS = PS + XC * XC
  1091.  202         CONTINUE
  1092. ***
  1093.          IF (PS.LE.0.D0) THEN
  1094.             CALL ERREUR(162)
  1095.             RETURN
  1096.          ENDIF
  1097.          IF (MONAMO.EQ.'FLOTTANT') THEN
  1098.             IPALB(I,1) = 34
  1099.             XPALB(I,7) = XAMON
  1100.             ID1 = 7
  1101.          ELSE
  1102.             ID1 = 6
  1103.          ENDIF
  1104.          ID2 = ID1 + IDIM
  1105.          DO 222 ID = 1,IDIM
  1106.             XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS)
  1107.             XPALB(I,ID2+ID) = XCOOR(IPNOB+ID) - XCOOR(IPNOA+ID)
  1108.  222        CONTINUE
  1109.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOA)
  1110.          IPLIB(I,1) = IPLAC
  1111.          CALL PLACE2(JPLIB,NPLB,IPLAC,INOB)
  1112.          IPLIB(I,2) = IPLAC
  1113. *
  1114. *
  1115. *--------------------------------------------------------------------*
  1116. * ----- choc elementaire POINT_CERCLE_FROTTEMENT
  1117. *--------------------------------------------------------------------*
  1118. *
  1119.         else if(cmatee.eq.'PO_CE_FR') then
  1120.  
  1121.           ITYP = 23
  1122.                MONAMO = ' '
  1123.                MARAID = ' '
  1124.                MONINTER = ' '
  1125.                LINTER = .true.
  1126.           IPOI = int(valmat(1))
  1127.           XRAIN = valmat(2)
  1128.           if (valmat(2).gt.0)  MARAID = 'FLOTTANT'
  1129.           IEXC = int(valmat(3))
  1130.           XRAYO = valmat(4)
  1131.           XGLIS = valmat(5)
  1132.           XADHE = valmat(6)
  1133.           XRAIT = valmat(7)
  1134.           XAMOT = valmat(8)
  1135.           if (valmat(/1).gt.8) then
  1136.              xamon = valmat(10)
  1137.              if(valmat(10).gt.0) MONAMO = 'FLOTTANT'
  1138.              xinter = valmat(9)
  1139.             if(valmat(9).gt.0)  LINTER = .FALSE.
  1140.           else
  1141.              xamon=0.D0
  1142.           endif
  1143.  
  1144.          IF (IERR.NE.0) RETURN
  1145. *
  1146.          IPALB(I,1) = ITYP
  1147.          IPALB(I,3) = IDIM
  1148.          IF (.NOT.LINTER) THEN
  1149.             ITYP=ITYP+100
  1150.             IPALB(I,1) = ITYP           
  1151.          ENDIF
  1152.          XPALB(I,1) = XRAIN
  1153.          XPALB(I,2) = XRAYO
  1154.          XPALB(I,3) = XGLIS
  1155.          XPALB(I,4) = XADHE
  1156.          XPALB(I,5) = XRAIT
  1157.          XPALB(I,6) = XAMOT
  1158. cbp,2020         IF (MONAMO.EQ.'FLOTTANT') THEN
  1159. cbp,2020            IPALB(I,1) = 24
  1160.             XPALB(I,7) = XAMON
  1161. cbp,2020            ID1 = 7
  1162. cbp,2020 : ajout 3 reels pour la regularisation + Ventrainement
  1163.             ID1 = 10
  1164. cbp,2020         ELSE
  1165. cbp,2020            ID1 = 6
  1166. cbp,2020         ENDIF
  1167. *
  1168. *        normale au Cercle et excentrement
  1169.          IPNV  = (IDIM + 1) * (IPOI - 1)
  1170.          IPEX  = (IDIM + 1) * (IEXC - 1)
  1171.          PS = 0.D0
  1172.          DO 320 ID = 1,IDIM
  1173.             XC = XCOOR(IPNV + ID)
  1174.             PS = PS + XC * XC
  1175.  320     CONTINUE
  1176.          IF (PS.LE.0.D0) THEN
  1177.             CALL ERREUR(162)
  1178.             RETURN
  1179.          ENDIF
  1180.          ID2 = ID1 + IDIM
  1181.          DO 322 ID = 1,IDIM
  1182.             XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS)
  1183.             XPALB(I,ID2+ID) = XCOOR(IPEX + ID)
  1184.  322     CONTINUE
  1185.          CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD)
  1186.          IPLIB(I,1) = IPLAC
  1187. *
  1188.         else if(cmatee.eq.'PO_CE') then
  1189.           ITYP = 21
  1190.           MARAID = ' '
  1191.           MONPER = ' '
  1192.           MONAMO = ' '
  1193.           TYPRET = ' '
  1194.           IPOI = int(valmat(1))
  1195.           XRAID = valmat(2)
  1196.            if (valmat(2).gt.0)  MARAID = 'FLOTTANT'
  1197.           IEXC = int(valmat(3))
  1198.           XRAYO = valmat(4)
  1199.            if (valmat(/1).gt.4) then
  1200.              xamon = valmat(5)
  1201.              if(valmat(5).gt.0) MONAMO = 'FLOTTANT'
  1202.            endif
  1203.  
  1204.          IF (IERR.NE.0) RETURN
  1205.          IPALB(I,1) = ITYP
  1206.          IPALB(I,3) = IDIM
  1207.          XPALB(I,1) = XRAID
  1208.          XPALB(I,2) = XRAYO
  1209. *
  1210. *        normalisation de la normale
  1211. *
  1212.          IPNV  = (IDIM + 1) * (IPOI - 1)
  1213.          IPEX  = (IDIM + 1) * (IEXC - 1)
  1214.          PS = 0.D0
  1215.          DO 210 ID = 1,IDIM
  1216.             XC = XCOOR(IPNV + ID)
  1217.             PS = PS + XC * XC
  1218.  210        CONTINUE
  1219.          IF (PS.LE.0.D0) THEN
  1220.             CALL ERREUR(162)
  1221.             RETURN
  1222.          ENDIF
  1223.          IF (MONAMO.EQ.'FLOTTANT') THEN
  1224.             IPALB(I,1) = 22
  1225.             XPALB(I,3) = XAMON
  1226.             ID1 = 3
  1227.          ELSE
  1228.             ID1 = 2
  1229.          ENDIF
  1230.          ID2 = ID1 + IDIM
  1231.          DO 212 ID = 1,IDIM
  1232.             XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS)
  1233.             XPALB(I,ID2+ID) = XCOOR(IPEX + ID)
  1234.  212        CONTINUE
  1235. *        end do
  1236.          CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD)
  1237.          IPLIB(I,1) = IPLAC
  1238. *
  1239.         else if(cmatee.eq.'CE_PL_FR') then
  1240.           ITYP = 5
  1241.                MONAMO = ' '
  1242.                 IPOI = int(valmat(1))
  1243.               xrain = valmat(2)
  1244.               XJEU = valmat(3)
  1245.               MARAID = 'FLOTTANT'
  1246.               XRAYP = valmat(4)
  1247.              XGLIS = valmat(5)
  1248.               XADHE = valmat(6)
  1249.               XRAIT = valmat(7)
  1250.               XAMOT = valmat(8)
  1251.               xamon = valmat(9)
  1252.             if (xamon.ne.0.d0) MONAMO = 'FLOTTANT'
  1253.  
  1254.          IPALB(I,1) = ITYP
  1255.          IPALB(I,3) = IDIM
  1256.          XPALB(I,1) = XRAIN
  1257.          XPALB(I,2) = XJEU
  1258.          XPALB(I,3) = XGLIS
  1259.          XPALB(I,4) = XADHE
  1260.          XPALB(I,5) = XRAIT
  1261.          XPALB(I,6) = XAMOT
  1262. *
  1263.          IPNV  = (IDIM + 1) * (IPOI - 1)
  1264.          PS = 0.D0
  1265.          DO 230 ID = 1,IDIM
  1266.             XC = XCOOR(IPNV + ID)
  1267.             PS = PS + XC * XC
  1268.  230        CONTINUE
  1269. *        end do
  1270.          IF (PS.LE.0.D0) THEN
  1271.             CALL ERREUR(162)
  1272.             RETURN
  1273.          ENDIF
  1274.          IF (MONAMO.EQ.'FLOTTANT') THEN
  1275.             IPALB(I,1) = 6
  1276.             XPALB(I,7) = XAMON
  1277.             ID1 = 7
  1278.          ELSE
  1279.             ID1 = 6
  1280.          ENDIF
  1281.          ID8 = ID1 + 7*IDIM
  1282.          XPALB(I,ID8+1) = XRAYP
  1283.          DO 232 ID = 1,IDIM
  1284.             XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS)
  1285.  232     CONTINUE
  1286. *       end do
  1287.          CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD)
  1288.          IPLIB(I,1) = IPLAC
  1289. *
  1290.         else if(cmatee.eq.'CE_CE_FR') then
  1291.            ITYP = 25
  1292.            MONAMO = ' '
  1293.            MARAID = ' '
  1294.            MONINTER = ' '
  1295.            LINTER = .true.
  1296.            IPOI = int(valmat(1))
  1297.            xrain = valmat(2)
  1298.            if(valmat(2).gt.0)  MARAID = 'FLOTTANT'
  1299.            IEXC = int(valmat(3))
  1300.            XRAYP = valmat(4)
  1301.            XGLIS = valmat(5)
  1302.            XADHE = valmat(6)
  1303.            XRAIT = valmat(7)
  1304.            XAMOT = valmat(8)
  1305.            XRAYB = valmat(9)
  1306.            if(valmat(10).gt.0) then
  1307.             xamon = valmat(10)
  1308.             if (valmat(10).gt.0)  MONAMO = 'FLOTTANT'
  1309.             xinter = valmat(11)
  1310.             if (valmat(11).gt.0) LINTER = .false.
  1311.            endif
  1312.  
  1313.          IF (IERR.NE.0) RETURN
  1314. *
  1315.          IPALB(I,1) = ITYP
  1316.          IPALB(I,3) = IDIM
  1317. cbp         IPALB(I,4) = 1
  1318.          IF (.NOT.LINTER) THEN
  1319. cbp           IPALB(I,4) = 0
  1320. cbp : on laisse IPALB(I,4) pour les liaisons conditionnelles
  1321.             ITYP=ITYP+100
  1322.             IPALB(I,1) = ITYP           
  1323.          ENDIF
  1324.          XPALB(I,1) = XRAIN
  1325.          XPALB(I,2) = XRAYB
  1326.          XPALB(I,3) = XGLIS
  1327.          XPALB(I,4) = XADHE
  1328.          XPALB(I,5) = XRAIT
  1329.          XPALB(I,6) = XAMOT
  1330. *
  1331. *        normalisation de la normale
  1332. *
  1333.          IPNV  = (IDIM + 1) * (IPOI - 1)
  1334.          IPEX  = (IDIM + 1) * (IEXC - 1)
  1335.          PS = 0.D0
  1336.          DO 330 ID = 1,IDIM
  1337.             XC = XCOOR(IPNV + ID)
  1338.             PS = PS + XC * XC
  1339.  330     CONTINUE
  1340. *        end do
  1341. ***
  1342.          IF (PS.LE.0.D0) THEN
  1343.             CALL ERREUR(162)
  1344.             RETURN
  1345.          ENDIF
  1346.          IF (MONAMO.EQ.'FLOTTANT') THEN
  1347.             ID1 = 7
  1348.             IPALB(I,1) = 26
  1349.             XPALB(I,7) = XAMON
  1350.          ELSE
  1351.             ID1 = 6
  1352.          ENDIF
  1353.          ID10 = ID1 + 9*IDIM
  1354.          XPALB(I,ID10+1) = XRAYP
  1355.          ID2  = ID1 + IDIM
  1356.          ID3  = ID1 + 2*IDIM
  1357.          DO 332 ID = 1,IDIM
  1358.             XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS)
  1359.             XPALB(I,ID2+ID) = XCOOR(IPEX + ID)
  1360.  332     CONTINUE
  1361. *        end do
  1362.         CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD)
  1363.          IPLIB(I,1) = IPLAC
  1364. *
  1365. *--------------------------------------------------------------------*
  1366. * ----- choc elementaire ...
  1367. *--------------------------------------------------------------------*
  1368. *
  1369.         else if(cmatee.eq.'PR_PR_IN'.OR.cmatee.eq.'PR_PR_EX') then
  1370.            if(cmatee.eq.'PR_PR_IN') ityp = 31
  1371.            IF(cmatee.eq.'PR_PR_EX') ITYP = 32
  1372.  
  1373.           INOR = int(valmat(1))
  1374.               xraid = valmat(2)
  1375.               MARAID = 'FLOTTANT'
  1376.               IMA1 = int(valmat(3))
  1377.               IMA2 = int(valmat(4))
  1378.               xpuis = valmat(5)
  1379.  
  1380.          IF (IERR.NE.0) RETURN
  1381. *
  1382.          IPALB(I,1) = ITYP
  1383.          IPALB(I,3) = IDIM
  1384.          XPALB(I,1) = XRAID
  1385.          XPALB(I,3) = XPUIS
  1386.          ID1 = 3
  1387.          IP1 = 5
  1388. *
  1389. *        le maillage IMA1 est en {l{ment de type POI1
  1390.          MELEME = IMA1
  1391.          SEGACT MELEME
  1392.          NOMBN1 = NUM(/2)
  1393.          IPALB(I,4) = NOMBN1
  1394.          IDP = ID1 + 5*IDIM
  1395.          DO 512  IE = 1,NOMBN1
  1396.             IPT = NUM(1,IE)
  1397.             INPT = ( IDIM + 1 ) * ( IPT - 1 )
  1398.             DO 514 ID = 1,IDIM
  1399.                XPALB(I,IDP+ID) = XCOOR(INPT + ID)
  1400.  514        CONTINUE
  1401. *           end do
  1402.             IDP = IDP + IDIM
  1403.  512      CONTINUE
  1404. *        end do
  1405.          SEGDES MELEME
  1406. *
  1407. *        le maillage IMA2 est en {l{ment de type POI1
  1408.          MELEME = IMA2
  1409.          SEGACT MELEME
  1410.          NOMBN2 = NUM(/2)
  1411.          IPALB(I,5) = NOMBN2
  1412.          DO 516  IE = 1,NOMBN2
  1413.             IPT = NUM(1,IE)
  1414.             INPT = ( IDIM + 1 ) * ( IPT - 1 )
  1415.             DO 518 ID = 1,IDIM
  1416.                XPALB(I,IDP+ID) = XCOOR(INPT + ID)
  1417.  518        CONTINUE
  1418. *           end do
  1419.             IDP = IDP + IDIM
  1420.  516      CONTINUE
  1421. *        end do
  1422.          SEGDES MELEME
  1423.          CALL PLACE2(JPLIB,NPLB,IPLAC,ISUP)
  1424.          IPLIB(I,1) = IPLAC
  1425. *
  1426. *        cr{ation d'un rep}re orthonorm{ dans le plan des maillages
  1427. *        le point origine est le premier point de IMA1
  1428.          CALL DYNE28(INOR,ISUP,XPALB,NLIABl,I,ID1)
  1429.          IF (IERR.NE.0) RETURN
  1430. *
  1431. *        coefficient des droites form{es par les {l{ments de IMA1
  1432.          CALL DYNE29(IPALB,XPALB,NLIABl,NOMBN1,NOMBN2,I,ID1,IP1)
  1433. *
  1434. *        position initiale de IMA2 par rapport @ IMA1
  1435.          CALL DYNE30(IPALB,XPALB,NLIABl,NOMBN1,NOMBN2,I,ID1,IP1)
  1436. *
  1437. *        calcul de la section du profil mobile
  1438.          CALL DYNE33(XPALB,IPALB,NLIABl,I,ID1,XSECT)
  1439.          XPALB(I,2) = XSECT
  1440. *
  1441. *
  1442. *--------------------------------------------------------------------*
  1443. * ----- choc elementaire ...
  1444. *--------------------------------------------------------------------*
  1445.         else if(cmatee.eq.'LI_LI_FR') then
  1446.            ITYP = 35
  1447.            MONJEU = ' '
  1448.            MONAMO = ' '
  1449.            MARAID = ' '
  1450.            CMOT = ' '
  1451.            MONESC = ' '
  1452.            MONSYM = ' '
  1453.            MONREC = ' '
  1454.            INOR = 0
  1455.            SEGINI MLIGNE
  1456.  
  1457. *
  1458.          INOR = int(valmat(1))
  1459.          IMAI = int(valmat(2))
  1460.            MONESC = tyval(3)(9:16)
  1461.          IESC = int(valmat(3))
  1462.           MELEME = IESC
  1463.           SEGACT MELEME
  1464.           if (num(/2).eq.1) then
  1465.            MONESC = 'POINT'
  1466.            IESC = num(1,1)
  1467.            segdes meleme
  1468.           endif
  1469.          if (valmat(4).gt.0) then
  1470.                 if (tyval(4)(1:8).eq.'POINTEUR') then
  1471.                  IRAIES = int(valmat(4))
  1472.                  MARAID = 'CHPOINT'
  1473.                 else
  1474.                  xraide = valmat(4)
  1475.                  MARAID = 'FLOTTANT'
  1476.                 endif
  1477.          endif
  1478.          IPALB(I,1) = ITYP
  1479.          IPALB(I,3) = IDIM
  1480. c         XPALB(I,3) = XGLIS
  1481. c         XPALB(I,4) = XADHE
  1482. c         XPALB(I,5) = XRAIT
  1483. c         XPALB(I,6) = XAMOT
  1484.          XPALB(I,3) = valmat(5)
  1485.          XPALB(I,4) = valmat(6)
  1486.          XPALB(I,5) = valmat(7)
  1487.          XPALB(I,6) = valmat(8)
  1488.          xjeu = valmat(9)
  1489.          if (xjeu.gt.0.)   MONJEU = 'FLOTTANT'
  1490.          if (valmat(10).gt.0) then
  1491.            if (tyval(10)(1:8).eq.'POINTEUR') then
  1492.                  typret=tyval(10)(9:16)
  1493.                  iamoes = int(valmat(10))
  1494.                  MONAMO = 'CHPOINT'
  1495.            else
  1496.                  XAMO = valmat(10)
  1497.                  MONAMO = 'FLOTTANT'
  1498.            endif
  1499.          endif
  1500.          irchec = int(valmat(11))
  1501.            if (irchec.gt.0) MONREC = 'MOT'
  1502.               if (irchec.eq.1) CMOT(1:7)= 'GLOBALE'
  1503.          isyme = int(valmat(12))
  1504.             if (isyme.gt.0)  MONSYM = 'MOT'
  1505.               if (isyme.eq.1) CMOT1(1:7)='LOCALE'
  1506.               if (isyme.eq.2) CMOT1(1:4)='VRAI'
  1507.               if (isyme.eq.3) CMOT1(1:7)='GLOBALE'
  1508.  
  1509. *
  1510.          IF (MONAMO.EQ.'CHPOINT') THEN
  1511.             IPALB(I,1) = 36
  1512.             ID1 = 7
  1513.          ELSE
  1514.             ID1 = 6
  1515.          ENDIF
  1516. *   Normale au plan
  1517.          IF (IDIM.EQ.3) THEN
  1518.            if (inor.eq.0) call erreur(26)
  1519.             IPNO  = (IDIM + 1) * (INOR - 1)
  1520.             PS = 0.D0
  1521.             DO 80 ID = 1,IDIM
  1522.                XC = XCOOR(IPNO + ID)
  1523.                PS = PS + XC * XC
  1524.  80         CONTINUE
  1525. *        end do
  1526.             IF (PS.LE.0.D0) THEN
  1527.                CALL ERREUR(162)
  1528.                RETURN
  1529.             ENDIF
  1530.             DO 81 ID=1,IDIM
  1531.                XPALB(I,ID1+ID) = XCOOR(IPNO + ID) / SQRT(PS)
  1532.  81         CONTINUE
  1533.          ELSE
  1534.             DO 82 ID=1,IDIM
  1535.                XPALB(I,ID1+ID) = 0.D0
  1536.  82         CONTINUE
  1537.          ENDIF
  1538.          IF (MONJEU.EQ.'FLOTTANT') THEN
  1539.             XPALB(I,2) = XJEU
  1540.          ELSE
  1541.             XPALB(I,2) = 0.D0
  1542.          ENDIF
  1543. *   La recherche s'effectue par defaut localement
  1544.          IF (MONREC.EQ.'MOT') THEN
  1545.             IF (CMOT(1:7).EQ.'GLOBALE') THEN
  1546.                 IPALB(I,23) = 1
  1547.             ELSE
  1548.                 IPALB(I,23) = 0
  1549.             ENDIF
  1550.          ELSE
  1551.             IPALB(I,23) = 0
  1552.          ENDIF
  1553. *   Coordonnees du maillage_maitre
  1554.          MELEME = IMAI
  1555.          SEGACT MELEME
  1556. *   Pour savoir si le contour est ferme
  1557.          NELEMA = NUM(/2)
  1558.          IF (NUM(1,1).EQ.NUM(2,NELEMA)) THEN
  1559.             NNOEMA = NELEMA
  1560.             IFERMA = 1
  1561.          ELSE
  1562.             NNOEMA = NELEMA +1
  1563.             IFERMA = 0
  1564.          ENDIF
  1565.          IPALB(I,21) = NNOEMA
  1566.          IPALB(I,24) = IFERMA
  1567.          ID2 = ID1 + 4*IDIM
  1568.          IPT = NUM(1,1)
  1569.          INPT = (IDIM+1)*(IPT-1)
  1570.          CALL PLACE2(JPLIB,NPLB,IPLAC,IPT)
  1571.          IPLIB(I,1) = IPLAC
  1572.          KPLIB(1) = IPT
  1573.          DO 84 ID=1,IDIM
  1574.             XPALB(I,ID2+ID) = XCOOR(INPT+ID)
  1575.  84         CONTINUE
  1576.          DO 85 IE=1,(NNOEMA-1)
  1577.             IPT = NUM(2,IE)
  1578.             INPT = (IDIM+1)*(IPT-1)
  1579.             CALL PLACE2(JPLIB,NPLB,IPLAC,IPT)
  1580.             IPLIB(I,IE+1) = IPLAC
  1581.             KPLIB(IE+1) = IPT
  1582.             IDIE = ID2 + IE*IDIM
  1583.             DO 86 ID=1,IDIM
  1584.                 XPALB(I,IDIE+ID) = XCOOR(INPT+ID)
  1585.  86             CONTINUE
  1586.  85         CONTINUE
  1587.          SEGDES MELEME
  1588. *   Maillage_esclave
  1589.          ID3 = ID2 + NNOEMA*IDIM
  1590.          IF (MONESC.EQ.'POINT') THEN
  1591. * La ligne esclave est un point
  1592.             NNOEES=1
  1593.             IFERES=0
  1594.             ISYMET=-1
  1595. * Lecture des coordonnees
  1596.             IPESC = (IDIM+1)*(IESC-1)
  1597.             CALL PLACE2(JPLIB,NPLB,IPLAC,IESC)
  1598.             IPLIB(I,NNOEMA+1)  = IPLAC
  1599.             KPLIB(NNOEMA+1) = IESC
  1600.             DO 90 ID = 1,IDIM
  1601.                XPALB(I,ID3+ID) = XCOOR(IPESC+ID)
  1602.  90         CONTINUE
  1603. *
  1604.             IPALB(I,22) = NNOEES
  1605.             IPALB(I,25) = IFERES
  1606.             IPALB(I,26) = ISYMET
  1607.          ELSE
  1608.          IF (MONESC.EQ.'MAILLAGE') THEN
  1609. *    La ligne esclave est un maillage
  1610.             MELEME = IESC
  1611.             SEGACT MELEME
  1612. *   Pour savoir si le contour est ferme
  1613.             NELEES = NUM(/2)
  1614.             IF (NUM(1,1).EQ.NUM(2,NELEES)) THEN
  1615.                NNOEES = NELEES
  1616.                IFERES = 1
  1617.             ELSE
  1618.                NNOEES = NELEES +1
  1619.                IFERES = 0
  1620.             ENDIF
  1621.             IPALB(I,22) = NNOEES
  1622.             IPALB(I,25) = IFERES
  1623. *   Coordonnees du maillage_esclave
  1624.             IPT = NUM(1,1)
  1625.             INPT = (IDIM+1)*(IPT-1)
  1626.             CALL PLACE2(JPLIB,NPLB,IPLAC,IPT)
  1627.             IPLIB(I,NNOEMA+1) = IPLAC
  1628.             KPLIB(NNOEMA+1) = IPT
  1629.             DO 94 ID=1,IDIM
  1630.                XPALB(I,ID3+ID) = XCOOR(INPT+ID)
  1631.  94         CONTINUE
  1632.             DO 95 IE=1,(NNOEES-1)
  1633.                IPT = NUM(2,IE)
  1634.                INPT = (IDIM+1)*(IPT-1)
  1635.                CALL PLACE2(JPLIB,NPLB,IPLAC,IPT)
  1636.                IPLIB(I,NNOEMA+IE+1) = IPLAC
  1637.                KPLIB(NNOEMA+IE+1) = IPT
  1638.                IDIE = ID3 + IE*IDIM
  1639.                DO 96 ID=1,IDIM
  1640.                   XPALB(I,IDIE+ID) = XCOOR(INPT+ID)
  1641.  96            CONTINUE
  1642.  95         CONTINUE
  1643.             SEGDES MELEME
  1644. *   Le traitement symetrique par defaut ne s'effectue pas
  1645.             IF (MONSYM.EQ.'MOT') THEN
  1646.                IF (CMOT1(1:7).EQ.'LOCALE') THEN
  1647.                   IPALB(I,26) = 1
  1648.                ELSE
  1649.                   IF (CMOT1(1:4).EQ.'VRAI'.OR.
  1650.      & CMOT1(1:7).EQ.'GLOBALE') THEN
  1651.                      IPALB(I,26) = 0
  1652.                   ELSE
  1653.                      IPALB(I,26) = -1
  1654.                   ENDIF
  1655.                ENDIF
  1656.             ELSE
  1657.                IPALB(I,26) = -1
  1658.             ENDIF
  1659.          ELSE
  1660. * La ligne esclave n'est ni un point ni un maillage
  1661. *           CALL ERREUR(...)
  1662.             RETURN
  1663.          ENDIF
  1664.          ENDIF
  1665. * Lecture des chpoints de raideur et d amortissement
  1666. * Raideurs des noeuds esclaves  et maitres
  1667.          ID4=ID1+(2*(NNOEMA+NNOEES)+4)*IDIM
  1668.          MCHPOI=IRAIES
  1669.          SEGACT,MCHPOI
  1670.          NSOUP=IPCHP(/1)
  1671.          DO 700 IPC=1,NSOUP
  1672.              MSOUPO=IPCHP(IPC)
  1673.              SEGACT,MSOUPO
  1674.              MELEME = IGEOC
  1675.              SEGACT,MELEME
  1676.              MPOVAL = IPOVAL
  1677.              SEGACT,MPOVAL
  1678.              NNN = NUM(/2)
  1679.              DO 711 INN=1,NNN
  1680.                IPT = NUM(1,INN)
  1681.                CALL PLACE2(KPLIB,NPLB,IPLAC,IPT)
  1682.                IF (IPLAC.NE.0) THEN
  1683.                   XPALB(I,ID4+IPLAC)=VPOCHA(INN,1)
  1684.                ENDIF
  1685.  711         CONTINUE
  1686.              SEGDES,MPOVAL,MELEME
  1687.              SEGDES MSOUPO
  1688.  700     CONTINUE
  1689.          SEGDES,MCHPOI
  1690. *  Amortissement des noeuds esclaves et maitres
  1691.          ID5=ID4+NNOEMA+NNOEES
  1692.          IF (IPALB(I,1).EQ.36) THEN
  1693.               MCHPOI=IAMOES
  1694.               SEGACT,MCHPOI
  1695.               NSOUP = IPCHP(/1)
  1696.               DO 121 IPC=1,NSOUP
  1697.                  MSOUPO=IPCHP(IPC)
  1698.                  SEGACT,MSOUPO
  1699.                  MELEME = IGEOC
  1700.                  SEGACT,MELEME
  1701.                  MPOVAL = IPOVAL
  1702.                  SEGACT,MPOVAL
  1703.                  NNN=NUM(/2)
  1704.                  DO 130 INN=1,NNN
  1705.                     IPT = NUM(1,INN)
  1706.                     CALL PLACE2(KPLIB,NPLB,IPLAC,IPT)
  1707.                     IF (IPLAC.NE.0) THEN
  1708.                         XPALB(I,ID5+IPLAC)=VPOCHA(INN,1)
  1709.                     ENDIF
  1710.  130             CONTINUE
  1711.                  SEGDES MPOVAL,MELEME
  1712.                  SEGDES MSOUPO
  1713.  121          CONTINUE
  1714.                SEGDES MCHPOI
  1715.          ENDIF
  1716.          SEGSUP MLIGNE
  1717.  
  1718. *--------------------------------------------------------------------*
  1719. * ----- choc elementaire LIGNE_CERCLE_FROTTEMENT
  1720. *--------------------------------------------------------------------*
  1721.         else if(cmatee.eq.'LI_CE_FR') then
  1722. *
  1723. * --- choc élémentaire LIGNE_CERCLE_FROTTEMENT
  1724. *            avec ou sans amortissement
  1725. *
  1726.            ITYP = 37
  1727.            MONJEU = ' '
  1728.            MONAMO = ' '
  1729.            MARAID = ' '
  1730.            CMOT = ' '
  1731.            MONESC = ' '
  1732.            MONSYM = ' '
  1733.            MONREC = ' '
  1734.            INOR = 0
  1735.            SEGINI MLIGNE
  1736.  
  1737.          IMAI = int(valmat(2))
  1738.          MONESC = tyval(3)(9:16)
  1739.          IESC = int(valmat(3))
  1740.           MELEME = IESC
  1741.           SEGACT MELEME
  1742.           if (num(/2).eq.1) then
  1743.            MONESC = 'POINT'
  1744.            IESC = num(1,1)
  1745.            segdes meleme
  1746.           endif
  1747.          IRAIES = int(valmat(4))
  1748.          XGLIS = valmat(5)
  1749.          XADHE = valmat(6)
  1750.          XRAIT = valmat(7)
  1751.          XAMOT = valmat(8)
  1752. *
  1753.          if (valmat(/1).gt.8) MONAMO = tyval(9)(9:16)
  1754.          IAMOES = int(valmat(9))
  1755. *
  1756.          if (valmat(/1).gt.8) MONREC = tyval(10)
  1757.          iorec = int(valmat(10))
  1758.          if (iorec.eq.1) CMOT='VRAI'
  1759. *
  1760.          if (valmat(/1).gt.8) MONRAY = tyval(11)
  1761.          XRAY = valmat(11)
  1762.  
  1763.          if (valmat(/1).gt.8) MONCAL = tyval(12)
  1764.          iotnor = int(valmat(12))
  1765.          if (iotnor.eq.1) CMOT2='VRAI'
  1766. *
  1767.          IPALB(I,1) = ITYP
  1768.          IPALB(I,3) = IDIM
  1769.          XPALB(I,3) = XGLIS
  1770.          XPALB(I,4) = XADHE
  1771.          XPALB(I,5) = XRAIT
  1772.          XPALB(I,6) = XAMOT
  1773. *
  1774.          IF (MONCAL.EQ.'ENTIER') THEN
  1775.             IF (CMOT2(1:4).EQ.'VRAI') THEN
  1776.                IPALB(I,1)=39
  1777.             ENDIF
  1778.          ENDIF
  1779.  
  1780.  
  1781.          IF (MONAMO.EQ.'CHPOINT') THEN
  1782.             IPALB(I,1) = IPALB(I,1)+1
  1783.             ID1 = 7
  1784.          ELSE
  1785.             ID1 = 6
  1786.          ENDIF
  1787.  
  1788.  
  1789. *   Normale aux butees ou au cylindre enveloppant le segment
  1790.          IF (IDIM.EQ.3) THEN
  1791.             INOR = int(valmat(1))
  1792.             IF (IERR.NE.0) RETURN
  1793.             IPNO  = (IDIM + 1) * (INOR - 1)
  1794.             PS = 0.D0
  1795.             DO 3780 ID = 1,IDIM
  1796.                XC = XCOOR(IPNO + ID)
  1797.                PS = PS + XC * XC
  1798.  3780         CONTINUE
  1799. *        end do
  1800.             IF (PS.LE.0.D0) THEN
  1801.                CALL ERREUR(162)
  1802.                RETURN
  1803.             ENDIF
  1804.             DO 3781 ID=1,IDIM
  1805.                XPALB(I,ID1+ID) = XCOOR(IPNO + ID) / SQRT(PS)
  1806.  3781         CONTINUE
  1807.          ELSE
  1808.             DO 3782 ID=1,IDIM
  1809.                XPALB(I,ID1+ID) = 0.D0
  1810.  3782         CONTINUE
  1811.          ENDIF
  1812.          IF (MONRAY.EQ.'FLOTTANT') THEN
  1813.             XPALB(I,2) = XRAY
  1814.          ELSE
  1815.             XPALB(I,2) = 0.D0
  1816.          ENDIF
  1817. *   La recherche s'effectue par défaut localement
  1818.          IF (MONREC.EQ.'MOT') THEN
  1819.             IF (CMOT(1:7).EQ.'GLOBALE') THEN
  1820.                 IPALB(I,23) = 1
  1821.             ELSE
  1822.                 IPALB(I,23) = 0
  1823.             ENDIF
  1824.          ELSE
  1825.             IPALB(I,23) = 0
  1826.          ENDIF
  1827. *
  1828. *   Coordonnées du maillage_maitre
  1829.          MELEME = IMAI
  1830.  
  1831.          SEGACT MELEME
  1832.  
  1833.  
  1834. *   Pour savoir si le contour est fermé
  1835.          NELEMA = NUM(/2)
  1836.          IF (NUM(1,1).EQ.NUM(2,NELEMA)) THEN
  1837.             NNOEMA = NELEMA
  1838.             IFERMA = 1
  1839.          ELSE
  1840.             NNOEMA = NELEMA +1
  1841.             IFERMA = 0
  1842.          ENDIF
  1843.          IPALB(I,21) = NNOEMA
  1844.          IPALB(I,24) = IFERMA
  1845.          ID2 = ID1 + 4*IDIM
  1846.          IPT = NUM(1,1)
  1847.          INPT = (IDIM+1)*(IPT-1)
  1848.          CALL PLACE2(JPLIB,NPLB,IPLAC,IPT)
  1849.          IPLIB(I,1) = IPLAC
  1850.          KPLIB(1) = IPT
  1851.          DO 3784 ID=1,IDIM
  1852.             XPALB(I,ID2+ID) = XCOOR(INPT+ID)
  1853.  3784         CONTINUE
  1854.          DO 3785 IE=1,(NNOEMA-1)
  1855.             IPT = NUM(2,IE)
  1856.             INPT = (IDIM+1)*(IPT-1)
  1857.             CALL PLACE2(JPLIB,NPLB,IPLAC,IPT)
  1858.             IPLIB(I,IE+1) = IPLAC
  1859.             KPLIB(IE+1) = IPT
  1860.             IDIE = ID2 + IE*IDIM
  1861.             DO 3786 ID=1,IDIM
  1862.                 XPALB(I,IDIE+ID) = XCOOR(INPT+ID)
  1863.  3786             CONTINUE
  1864.  3785         CONTINUE
  1865.          SEGDES MELEME
  1866. *
  1867. *   Maillage_esclave
  1868.          ID3 = ID2 + NNOEMA*IDIM
  1869.          IF (MONESC.EQ.'POINT') THEN
  1870. * La ligne esclave est un point
  1871.             NNOEES=1
  1872.             IFERES=0
  1873.             ISYMET=-1
  1874. * Lecture des coordonnées
  1875.             IPESC = (IDIM+1)*(IESC-1)
  1876.             CALL PLACE2(JPLIB,NPLB,IPLAC,IESC)
  1877.             IPLIB(I,NNOEMA+1)  = IPLAC
  1878.             KPLIB(NNOEMA+1) = IESC
  1879.             DO 3790 ID = 1,IDIM
  1880.                XPALB(I,ID3+ID) = XCOOR(IPESC+ID)
  1881.  3790         CONTINUE
  1882. *
  1883.             IPALB(I,22) = NNOEES
  1884.             IPALB(I,25) = IFERES
  1885.             IPALB(I,26) = ISYMET
  1886.          ELSE
  1887.          IF (MONESC.EQ.'MAILLAGE') THEN
  1888. *    La ligne esclave est un maillage
  1889.             MELEME = IESC
  1890.             SEGACT MELEME
  1891. *   Pour savoir si le contour est fermé
  1892.             NELEES = NUM(/2)
  1893.             IF (NUM(1,1).EQ.NUM(2,NELEES)) THEN
  1894.                NNOEES = NELEES
  1895.                IFERES = 1
  1896.             ELSE
  1897.                NNOEES = NELEES +1
  1898.                IFERES = 0
  1899.             ENDIF
  1900.             IPALB(I,22) = NNOEES
  1901.             IPALB(I,25) = IFERES
  1902. *   Coordonnées du maillage_esclave
  1903.             IPT = NUM(1,1)
  1904.             INPT = (IDIM+1)*(IPT-1)
  1905.             CALL PLACE2(JPLIB,NPLB,IPLAC,IPT)
  1906.             IPLIB(I,NNOEMA+1) = IPLAC
  1907.             KPLIB(NNOEMA+1) = IPT
  1908.             DO 3794 ID=1,IDIM
  1909.                XPALB(I,ID3+ID) = XCOOR(INPT+ID)
  1910.  3794         CONTINUE
  1911.             DO 3795 IE=1,(NNOEES-1)
  1912.                IPT = NUM(2,IE)
  1913.                INPT = (IDIM+1)*(IPT-1)
  1914.                CALL PLACE2(JPLIB,NPLB,IPLAC,IPT)
  1915.                IPLIB(I,NNOEMA+IE+1) = IPLAC
  1916.                KPLIB(NNOEMA+IE+1) = IPT
  1917.                IDIE = ID3 + IE*IDIM
  1918.                DO 3796 ID=1,IDIM
  1919.                   XPALB(I,IDIE+ID) = XCOOR(INPT+ID)
  1920.  3796            CONTINUE
  1921.  3795         CONTINUE
  1922.             SEGDES MELEME
  1923.             MONINV=' '
  1924.             if (valmat(/1).gt.8) then
  1925.               if (valmat(13).gt.0) then
  1926.                 MONINV = 'LOGIQUE'
  1927.                 Lo1 = .true.
  1928.               endif
  1929.             else
  1930.             endif
  1931. *   Le traitement symétrique ne s'effectue pas PAR DÉFAUT
  1932.  
  1933.             IF (MONINV.EQ.'LOGIQUE') THEN
  1934.                IF (.NOT.Lo1) THEN
  1935.                   IPALB(I,26) = -1
  1936.                ELSE
  1937.                   IPALB(I,26) = 0
  1938.                ENDIF
  1939.             ELSE
  1940.                IPALB(I,26) = -1
  1941.             ENDIF
  1942.  
  1943.          ELSE
  1944. * La ligne esclave n'est ni un point ni un maillage
  1945. *           CALL ERREUR(...)
  1946.             RETURN
  1947.          ENDIF
  1948.          ENDIF
  1949. * Lecture des chpoints de raideur et d amortissement
  1950. * Raideurs des noeuds esclaves  et maitres
  1951.          ID4=ID1+(2*(NNOEMA+NNOEES)+4)*IDIM
  1952.          MCHPOI=IRAIES
  1953.          SEGACT,MCHPOI
  1954.          NSOUP=IPCHP(/1)
  1955.          DO 37100 IPC=1,NSOUP
  1956.              MSOUPO=IPCHP(IPC)
  1957.              SEGACT,MSOUPO
  1958.              MELEME = IGEOC
  1959.              SEGACT,MELEME
  1960.              MPOVAL = IPOVAL
  1961.              SEGACT,MPOVAL
  1962.              NNN = NUM(/2)
  1963.              DO 37110 INN=1,NNN
  1964.                IPT = NUM(1,INN)
  1965.                CALL PLACE2(KPLIB,NPLB,IPLAC,IPT)
  1966.                IF (IPLAC.NE.0) THEN
  1967.                   XPALB(I,ID4+IPLAC)=VPOCHA(INN,1)
  1968.                ENDIF
  1969. 37110         CONTINUE
  1970.              SEGDES,MPOVAL,MELEME
  1971.              SEGDES MSOUPO
  1972. 37100     CONTINUE
  1973.          SEGDES,MCHPOI
  1974. *  Amortissement des noeuds esclaves et maitres
  1975.          ID5=ID4+NNOEMA+NNOEES
  1976.         IF (IPALB(I,1).EQ.38 .OR. IPALB(I,1).EQ.40) THEN
  1977.               MCHPOI=IAMOES
  1978.               SEGACT,MCHPOI
  1979.               NSOUP = IPCHP(/1)
  1980.               DO 37120 IPC=1,NSOUP
  1981.                  MSOUPO=IPCHP(IPC)
  1982.                  SEGACT,MSOUPO
  1983.                  MELEME = IGEOC
  1984.                  SEGACT,MELEME
  1985.                  MPOVAL = IPOVAL
  1986.                  SEGACT,MPOVAL
  1987.                  NNN=NUM(/2)
  1988.                  DO 37130 INN=1,NNN
  1989.                     IPT = NUM(1,INN)
  1990.                     CALL PLACE2(KPLIB,NPLB,IPLAC,IPT)
  1991.                     IF (IPLAC.NE.0) THEN
  1992.                         XPALB(I,ID5+IPLAC)=VPOCHA(INN,1)
  1993.                     ENDIF
  1994. 37130           CONTINUE
  1995.                  SEGDES MPOVAL,MELEME
  1996.                  SEGDES MSOUPO
  1997. 37120         CONTINUE
  1998.                SEGDES MCHPOI
  1999.          ENDIF
  2000.          SEGSUP MLIGNE
  2001. *
  2002.  
  2003. *--------------------------------------------------------------------*
  2004. * ----- choc elementaire PALIER_FLUIDE (RODELI)
  2005. *--------------------------------------------------------------------*
  2006.         else if(cmatee.eq.'PA_FL_RO') then
  2007.          ITYP = 60
  2008.          MONMOT='RODELI'
  2009.       MTLIAB = KTLIAB
  2010. *
  2011.       NUML = I
  2012.       IP1 = imod
  2013.       IF (IERR.NE.0) RETURN
  2014.          CALL PLACE2(JPLIB,NPLB,IPLAC,IP1)
  2015.          IPLIB(NUML,1) = IPLAC
  2016. *
  2017. * Valeurs de IPALB et XPALB communes à tous les types de
  2018. *    paliers fluides :
  2019. *
  2020.       IPALB(NUML,1) = ITYP
  2021.       IPALB(NUML,2) = 0
  2022.       IPALB(NUML,3) = 3
  2023.       IPALB(NUML,4) = 0
  2024. *
  2025.               XPALB(NUML,4) = valmat(1)
  2026.               XPALB(NUML,6) = valmat(2)
  2027.               XPALB(NUML,1) = valmat(3)
  2028.               XPALB(NUML,2) = valmat(4)
  2029.               XPALB(NUML,3) = valmat(5)
  2030.               XPALB(NUML,7) = valmat(6)
  2031.               XPALB(NUML,8) = valmat(7)
  2032.               XPALB(NUML,9) = valmat(8)
  2033.               XPALB(NUML,5) = valmat(9)
  2034.               itgeom = int(valmat(10))
  2035.  
  2036. *
  2037.       IF (MONMOT.EQ.'RODELI'.and.itgeom.gt.0) THEN
  2038. * ----- Cas du palier cylindrique ou à lobes, avec modèle de Rhode et Li
  2039. *
  2040.        IPALB(NUML,5) = 1
  2041.        CALL ACCTAB(ITGEOM,'MOT',I0,X0,'NOMBRE_LOBES',L0,IP0,
  2042.      &                    'ENTIER',NLOB,X1,' ',Lo1,IP1)
  2043.  
  2044.        IF (IERR.NE.0) RETURN
  2045.        IPALB(NUML,6) = NLOB
  2046.  
  2047. C Nombre de parametres reels :
  2048.        NBPR = 6
  2049.        IPALB(NUML,7) = NBPR
  2050.  
  2051.        CALL ACCTAB(ITGEOM,'MOT',I0,X0,'CRITERE_ARRET',L0,IP0,
  2052.      &                    'FLOTTANT',I1,X1,MONMOT,Lo1,IP1)
  2053.        XPALB(NUML,10) = X1
  2054.  
  2055.        IF (IERR.NE.0) RETURN
  2056.        DO 610 ILOB = 1, NLOB
  2057. *
  2058.           CALL ACCTAB(ITGEOM,'ENTIER',ILOB,X0,MONMOT,L0,IP0,
  2059.      &                    'TABLE',I1,X1,' ',Lo1,ITLOB)
  2060.  
  2061.           IF (IERR.NE.0) RETURN
  2062.           CALL ACCTAB(ITLOB,'MOT',I0,X0,'JEU_USINAGE',L0,IP0,
  2063.      &              'FLOTTANT',I1,X1,MONMOT,Lo1,IP1)
  2064.           XPALB(NUML,11+NBPR*(ILOB-1)) = X1
  2065.  
  2066.           IF (IERR.NE.0) RETURN
  2067.           CALL ACCTAB(ITLOB,'MOT',I0,X0,'ASYMETRIE',L0,IP0,
  2068.      &              'FLOTTANT',I1,X1,MONMOT,Lo1,IP1)
  2069.           XPALB(NUML,12+NBPR*(ILOB-1)) = X1
  2070.  
  2071.           IF (IERR.NE.0) RETURN
  2072.           CALL ACCTAB(ITLOB,'MOT',I0,X0,'PRECHARGE',L0,IP0,
  2073.      &              'FLOTTANT',I1,X1,MONMOT,Lo1,IP1)
  2074.           XPALB(NUML,13+NBPR*(ILOB-1)) = X1
  2075.  
  2076.           IF (IERR.NE.0) RETURN
  2077.           CALL ACCTAB(ITLOB,'MOT',I0,X0,'ANGLE_DEBUT',L0,IP0,
  2078.      &              'FLOTTANT',I1,X1,MONMOT,Lo1,IP1)
  2079.           XPALB(NUML,14+NBPR*(ILOB-1)) = X1
  2080.           ANGDEB = X1
  2081.  
  2082.           IF (IERR.NE.0) RETURN
  2083.           CALL ACCTAB(ITLOB,'MOT',I0,X0,'AMPL_ANGLE',L0,IP0,
  2084.      &              'FLOTTANT',I1,X1,MONMOT,Lo1,IP1)
  2085.           XPALB(NUML,15+NBPR*(ILOB-1)) = X1
  2086.           AMPLIT=X1
  2087.  
  2088.           IF (IERR.NE.0) RETURN
  2089.           CALL ACCTAB(ITLOB,'MOT',I0,X0,'COEF_SUR',L0,IP0,
  2090.      &              'FLOTTANT',I1,X1,MONMOT,Lo1,IP1)
  2091.           XPALB(NUML,16+NBPR*(ILOB-1)) = X1
  2092.  
  2093.           IF (IERR.NE.0) RETURN
  2094.           CALL ACCTAB(ITLOB,'MOT',I0,X0,'NB_MAILLES',L0,IP0,
  2095.      &                    'ENTIER',I1,X1,' ',Lo1,IP1)
  2096. cbp2018          IPALB(NUML,7+ILOB) = I1
  2097.           NMAIL=I1
  2098.           CALL COS208(ANGDEB,AMPLIT,NMAIL,KLREEL)
  2099.           IPALB(NUML,7+ILOB) = KLREEL
  2100.  
  2101. c         on ecrit ce listreel dans la table afin qu'il ne soit pas
  2102. c         supprime si menage pendant l'execution (concerne pasapas)
  2103.           CALL ECCTAB(ITLOB,'MOT',0,0.d0,'COSSIN',.false.,0,
  2104.      &                      'LISTREEL',0,0.d0,' ',.false.,KLREEL)
  2105.  
  2106.           IF (IERR.NE.0) RETURN
  2107.  610     CONTINUE
  2108.         ENDIF
  2109. *
  2110.         else
  2111. c         write(6,*) 'verifier nom liaison', cmatee
  2112.          call erreur(5)
  2113.          return
  2114.         endif
  2115.  
  2116. *
  2117. * traiter liaisons conditionnelles
  2118. *
  2119.        if (.false.) then
  2120.        DO I = 1,kmodel(/1)
  2121.          ksi = 0
  2122.          imodel = kmodel(I)
  2123.          segact imodel
  2124.          if (tymode(/2).gt.0) then
  2125.            do 722 ilc = 1,tymode(/2)
  2126.              do j =1,kmodel(/1)
  2127.                 if (kmodel(j).eq.ivamod(ilc)) then
  2128.               ksi = ksi + 1
  2129.               ipalb(i,4) = 1
  2130.               IF (tymode(ilc).EQ.'CONDINFE' ) THEN
  2131.                 ipalb (i,4+ksi) = j
  2132.               ELSE IF (tymode(ilc).EQ.'CONDSUPE' ) THEN
  2133.                 ipalb (i,4+ksi) = -1 * j
  2134.               ENDIF
  2135.                 endif
  2136.                 goto 722
  2137.              enddo
  2138.  722       continue
  2139.          endif
  2140.  723     continue
  2141.        ENDDO
  2142.        endif
  2143.  
  2144. * ranger
  2145.        segdes ipt8
  2146. *
  2147.  10      CONTINUE
  2148. *
  2149. *
  2150. *   ----- liaisons conditionnelles ?
  2151. *
  2152.       IF (IIMPI.EQ.333) THEN
  2153. c         NLIAB  = IPALB(/1)
  2154. c         NIPALB = IPALB(/2)
  2155. c         NXPALB = XPALB(/2)
  2156. c         NPLBB  = IPLIB(/2)
  2157. c         NPLB   = JPLIB(/1)
  2158.        DO 1000 IN = 1,NLIAB
  2159.           DO 1002 II = 1,NIPALB
  2160.           WRITE(IOIMP,*)'cYNE20 : IPALB(',IN,',',II,') =',IPALB(IN,II)
  2161.  1002     CONTINUE
  2162.           DO 1004 IX = 1,NXPALB
  2163.           WRITE(IOIMP,*)'cYNE20 : XPALB(',IN,',',IX,') =',XPALB(IN,IX)
  2164.  1004     CONTINUE
  2165.           DO 1006 IP = 1,NPLBB
  2166.           WRITE(IOIMP,*)'cYNE20 : IPLIB(',IN,',',IP,') =',IPLIB(IN,IP)
  2167.  1006     CONTINUE
  2168.  1000  CONTINUE
  2169.        DO 1008 IP = 1,NPLB
  2170.           WRITE(IOIMP,*)'cYNE20 : JPLIB(',IP,') =',JPLIB(IP)
  2171.  1008  CONTINUE
  2172.       ENDIF
  2173. *
  2174. * remplissage MTPHI
  2175. *
  2176.       NPLSB=1
  2177.       SEGINI,MTPHI
  2178.       KTPHI = MTPHI
  2179.       MTLIAB = KTLIAB
  2180. *
  2181. c      NLIAB  = IPALB(/1)
  2182. c      NPLB   = JPLIB(/1)
  2183. c      NSB    = XPHILB(/1)
  2184. c      NPLSB  = XPHILB(/2)
  2185. c      NA2  = XPHILB(/3)
  2186. c      IDIMB  = XPHILB(/4)
  2187.       IA1 = 0
  2188.  
  2189.          do IB = 1,nsstru
  2190. *
  2191. * de DYNE26.ESO
  2192. *
  2193.       IORSB(IB) = IA1 + 1
  2194.       IAROTA(IB) = 0
  2195.       IROT = 0
  2196.       IN = 0
  2197.  
  2198.        do 41 ik =1,ldefo(/1)
  2199.  
  2200.         if (lsstru(ik).ne.ib) goto 41
  2201.          IN =  IN + 1
  2202.  
  2203.                   IA1 = IA1 + 1
  2204.  
  2205.            icdm = ldefo(ik)
  2206.  
  2207. **
  2208. *   Prise en compte d'un mode de rotation de corps rigide
  2209.            if (lcgra(ik).gt.0) then
  2210.              ICDG = lcgra(ik)
  2211.                 IAROTA(IB)=IA1
  2212.                 IROT = IN
  2213.            endif
  2214. *
  2215. *
  2216.           IF (NLIAB.NE.0) THEN
  2217.             DO 42 ID = 1,IDIMB
  2218. c              cas AXI ou FOURIER
  2219.                IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
  2220.                   CMOT = NOMAXI(ID)
  2221.                ELSE
  2222. c                 cas PLAN
  2223.                   IF (IFOMOD.EQ.-1) THEN
  2224.                       CMOT = NOMPLA(ID)
  2225.                   ELSE
  2226.                       CMOT = NOMTRI(ID)
  2227.                   ENDIF
  2228.                ENDIF
  2229.                IF (IIMPI.EQ.333) THEN
  2230.                   WRITE(IOIMP,*)'DYNE26 :  composante @ extraire :',CMOT
  2231.                ENDIF
  2232.                ICOMP  = 0
  2233.                DO 44 IP = 1,NPLB
  2234.                   IPOINT = JPLIB(IP)
  2235. *
  2236. *     On extrait du chpoint ICDM au point IPOINT de composante CMOT
  2237. *
  2238.                   CALL EXTRA9(ICDM,IPOINT,CMOT,0,.FALSE.,XVAL,IRET)
  2239.                      ICOMP = ICOMP + 1
  2240. *
  2241. *          on ajuste la taille si necessaire
  2242. *                      MP
  2243.                          IF(ICOMP.GT.NPLSB) THEN
  2244.                              NPLSB=ICOMP
  2245.                              SEGADJ MTPHI
  2246.                          ENDIF
  2247.                      IPLSB(IP) = ICOMP
  2248. * suite a la modif dans extra9, car on attribue une valeur meme
  2249. * si le point n'existe pas dans le chpoint
  2250.                      IF (XVAL.NE.0.) THEN
  2251.                       IF ((IBASB(IP).NE.0).AND.(IBASB(IP).NE.IB)) THEN
  2252.                        call erreur (783)
  2253.                         RETURN
  2254.                       ENDIF
  2255.                         IBASB(IP) = IB
  2256.                      ELSE
  2257.             IF ((IB.EQ.NSB).AND.(IBASB(IP).EQ.0)) IBASB(IP) = IB
  2258.                      ENDIF
  2259. *
  2260.                      XPHILB(IB,ICOMP,IN,ID) = XVAL
  2261.       IF (IIMPI.EQ.333) THEN
  2262.         WRITE(IOIMP,*)'cyne20 :   IPLSB(',IP,') =',IPLSB(IP)
  2263.         WRITE(IOIMP,*)'cyne20 :   IBASB(',IP,') =',IBASB(IP)
  2264.         XVA2 = XPHILB(IB,ICOMP,IN,ID)
  2265.         WRITE(IOIMP,*)'cyne20 :   XPHILB(',IB,ICOMP,IN,ID,') =',XVA2
  2266.       ENDIF
  2267.  
  2268.  44               CONTINUE
  2269. *              end do
  2270.  42            CONTINUE
  2271. *           end do
  2272.           ENDIF
  2273. *
  2274.  
  2275.  41    continue
  2276.        INMSB(IB) = IN
  2277.        IN = IN + 1
  2278.  
  2279. **
  2280. *   Remplissage des fausses d?form?es modales de rotations
  2281. **
  2282.  50   continue
  2283.       IF (IAROTA(IB).NE.0) THEN
  2284. **         RIGIDE = .TRUE.
  2285.          MERR = 0
  2286.          NPLUS = IN + 1
  2287.          IF (NPLUS.GT.NA2) THEN
  2288. * On r?ajuste le dimension NA2 de XPHILB
  2289.                  NA2 = NPLUS
  2290.                  SEGADJ MTPHI
  2291.          ENDIF
  2292.          DO 118 IP=1,NPLB
  2293.              IPOINT=JPLIB(IP)
  2294.              IPOS=IPLSB(IP)
  2295.              IBBAS= IBASB(IP)
  2296.              IF (IBBAS.EQ.IB) THEN
  2297.                 DO 220 ID=(IDIM+1),IDIMB
  2298.                   XAXROT(ID-IDIM) = XPHILB(IB,IPOS,IROT,ID)
  2299.  220            CONTINUE
  2300. * En tridimensionnel l'axe de rotation est le vecteur propre de rotation
  2301. * On norme l axe du plan de rotation
  2302.                 CALL DYNE41(XAXROT,MERR,IDIM)
  2303. * En bidimensionnel l'axe de rotation est fixe
  2304. * Calcul des fausses d?form?es modales de rotation
  2305.                 CALL DYNE42(XROTA,XAXROT,IPOINT,ICDG,IDIMB,MERR)
  2306.              DO 622 ID =1,IDIMB
  2307.                  XPHILB(IB,IPOS,IN,ID)  = XROTA(1,ID)
  2308.                  XPHILB(IB,IPOS,IN+1,ID)= XROTA(2,ID)
  2309.  622         CONTINUE
  2310.              ENDIF
  2311.  118       CONTINUE
  2312.       ENDIF
  2313.       IF (IIMPI.EQ.333) THEN
  2314.         WRITE(IOIMP,*)'DYNE26 :   INMSB(',IB,') =',INMSB(IB)
  2315.         WRITE(IOIMP,*)'DYNE26 :   IORSB(',IB,') =',IORSB(IB)
  2316.         WRITE(IOIMP,*)'DYNE26 :   IAROTA(',IB,') =',IAROTA(IB)
  2317.       ENDIF
  2318. *
  2319.                   IF (IERR.NE.0) RETURN
  2320. * fin boucle sousstructure
  2321.          enddo
  2322.  
  2323.       RETURN
  2324.       END
  2325.  
  2326.  
  2327.  
  2328.  
  2329.  
  2330.  
  2331.  
  2332.  
  2333.  
  2334.  
  2335.  
  2336.  
  2337.  
  2338.  
  2339.  
  2340.  
  2341.  

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