Télécharger la plaquette Cast3M


fr en

Télécharger coml10.eso

Retour à la liste

Numérotation des lignes : 

coml10

  1. C COML10    SOURCE    CB215821  25/04/23    21:15:06     12247          
  2.  
  3.       SUBROUTINE COML10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC CCGEOME
  12. -INC CCHAMP
  13. * segment deroulant le mcheml
  14. -INC DECHE
  15. -INC SMCHPOI
  16. -INC SMCOORD
  17. -INC SMELEME
  18. -INC SMLENTI
  19. -INC SMLREEL
  20. *-------------------------------------------------------------
  21. * CF DEVPAS et autres s-p de DYNE
  22. ** calcul des vitesses correct pour dernière liaison (JLIAIB.eq.NLIADY)
  23. *-------------------------------------------------------------
  24.  
  25. ** segment sous-structures dynamiques
  26.       segment struli
  27.        integer itlia,itbmod,momoda, mostat,itmail,molia
  28.        integer ldefo(np1),lcgra(np1),lsstru(np1)
  29.        integer nsstru,nndefo,nliab,nsb,na2,idimb
  30.        integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas
  31.        INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib
  32. * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0)
  33.        INTEGER ICHAIN
  34.       endsegment
  35. *
  36. *     Segment contenant les variables au cours d'un pas de temps:
  37. *
  38.       SEGMENT,MTPAS
  39.          REAL*8 FTOTA(NA1,4),FTOTB(NPLB,IDIMB),FTOTBA(NA1)
  40.          REAL*8 XPTB(NPLB,2,IDIMB),FINERT(NA1,4)
  41.          REAL*8 XVALA(NLIAA,4,NTVAR),XVALB(NLIAB,4,NTVAR)
  42.          REAL*8 FEXB(NPLB,2,IDIM),XCHPFB(2,NLIAB,4,NPLB)
  43.       ENDSEGMENT
  44. *
  45.       SEGMENT,MTKAM
  46.          REAL*8 XK(NA1,NB1K),XASM(NA1,NB1C),XM(NA1,NB1M)
  47.          REAL*8 XOPER(NB1,NB1,NOPER)
  48.       ENDSEGMENT
  49. *
  50.       SEGMENT,MTQ
  51.          REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4)
  52.          REAL*8 WEXT(NA1,2),WINT(NA1,2)
  53.       ENDSEGMENT
  54. *
  55.       SEGMENT MTLIAB
  56.          INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  57.          REAL*8 XPALB(NLIAB,NXPALB)
  58.          REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  59.       ENDSEGMENT
  60. *
  61.       SEGMENT,MTLIAA
  62.          INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA)
  63.          REAL*8  XPALA(NLIAA,NXPALA)
  64.       ENDSEGMENT
  65. *
  66.       SEGMENT,MTPHI
  67.          INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB)
  68.          INTEGER IAROTA(NSB)
  69.          REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB)
  70.       ENDSEGMENT
  71.  
  72.       SEGMENT,MTRES
  73.          REAL*8 XRES(NRES,NCRES,NPRES),XREP(NREP,NCRES)
  74.          REAL*8 XRESLA(NLSA,NPRES,NVALA),XRESLB(NLSB,NPRES,NVALB)
  75.          REAL*8 XMREP(NLIAB,4,IDIMB)
  76.          INTEGER ICHRES(NVES),IPORES(NRESPO,NPRES),IPOREP(NREP)
  77.          INTEGER ILIRES(NRESLI,NCRES)
  78.          INTEGER IPOLA(NLSA),INULA(NLSA),IPLRLA(NLSA,NVALA)
  79.          INTEGER IPOLB(NLSB),INULB(NLSB),IPLRLB(NLSB,NVALB)
  80.          INTEGER ILIREA(NLSA,NTVAR),ILIREB(NLSB,NTVAR)
  81.          INTEGER ILIRNA(NLSA,NTVAR),ILIRNB(NLSB,NTVAR)
  82.          INTEGER IPOLR(1),IMREP(NLIAB,2),IPPREP(NLIAB,4)
  83.          INTEGER ILPOLA(NLIAA,2)
  84.       ENDSEGMENT
  85.  
  86.       SEGMENT,MPREF
  87.          INTEGER IPOREF(NPREF)
  88.       ENDSEGMENT
  89. *
  90.       SEGMENT,MTFEX
  91.          REAL*8  FEXA(NPFEXA,NPC1,2)
  92.          REAL*8  FEXPSM(NPLB,NPC1,2,IDIMB)
  93.          REAL*8  FTEXB(NPLB,NPC1,2,IDIM)
  94. *         INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB)
  95.       ENDSEGMENT
  96.       SEGMENT,MTNUM
  97.          REAL*8 XDT(NPC1),XTEMPS(NPC1)
  98.       ENDSEGMENT
  99. c Segment "local" pour DEVLFA ...
  100.       SEGMENT,LOCLFA
  101.          REAL*8 FTEST(NA1,4)
  102.       ENDSEGMENT
  103. * Segment "local" pour DEVLB1 ...
  104.       SEGMENT,LOCLB1
  105.          REAL*8 FTEST2(NPLB,6)
  106.       ENDSEGMENT
  107.  
  108. * Segment pour Champoints
  109.       SEGMENT,MSAM
  110.          integer jplibb(NPLB)
  111.       ENDSEGMENT
  112. *
  113.       SEGMENT,ICPR(nbpts)
  114. *
  115.       PARAMETER ( ZERO=0.D0 )
  116.       LOGICAL RIGIDE,REPRIS,LMODYN
  117. *
  118.       IERRD = 0
  119.  
  120.       struli = itruli
  121.       lmodyn = .true.
  122.       MTKAM = ktkam
  123.       MPREF = KPREF
  124.       NPREF = iporef(/1)
  125.       rigide = .false.
  126.  
  127. *     npc1 = 1   plante dans devso4 : pv
  128.       npc1 = 2
  129.       SEGINI,MTNUM
  130.       KTNUM = MTNUM
  131.       xdt(1) = tempf - temp0
  132.       xtemps(1) = temp0
  133.  
  134.       IF (var0(3).gt.0.and.var0(4).gt.0) THEN
  135. *--------------------------------------------------------------------*
  136. * suite d un calcul avec variables internes de preconditionnement
  137. * VAEN , VARE, pour  modeles liaisons herites de DYNE de_vogelaere
  138. *--------------------------------------------------------------------*
  139. *      its2 = int(var0(2))
  140.       mlreel = int(var0(4))
  141.       segact mlreel
  142.       mlenti = int(var0(3))
  143.       segact mlenti
  144.       itmail = int(var0(5))
  145.       jjr = 0
  146.       jje = 0
  147.  
  148.       jje = jje + 1
  149.        JLIAIB  = lect(jje)
  150.  
  151.       jje = jje + 1
  152.        nchain = lect(jje)
  153.        if (ichain.eq.0) then
  154.          jg = nchain
  155.          segini,mlent3
  156.          ichain = mlent3
  157.        else
  158.          mlent3 = ichain
  159.          jg = mlent3.lect(/1)
  160.          if (nchain.ne.jg) then
  161.            write(6,*) 'pb developpement coml10'
  162.            ierr = 2
  163.            return
  164.          endif
  165.        endif
  166.       do lg = 1,nchain
  167.        jje = jje + 1
  168.        if (JLIAIB.eq.1) mlent3.lect(lg)= lect(jje)
  169.       enddo
  170.        jje = jje + 1
  171.        NPAS = lect(jje)
  172.       jje = jje + 1
  173.        NIPALB = lect(jje)
  174.       jje = jje + 1
  175.        NXPALB = lect(jje)
  176.       jje = jje + 1
  177.        NPLBB  = lect(jje)
  178.       jje = jje + 1
  179.        NPLB = lect(jje)
  180.       jje = jje + 1
  181.        NPLSB = lect(jje)
  182.       jje = jje + 1
  183.        NIP = lect(jje)
  184.       jje = jje + 1
  185.       nsstru = lect(jje)
  186.       jje = jje + 1
  187.       nndefo = lect(jje)
  188.       MTQ = KTQ
  189.            NA1 = q1(/1)
  190.       jje = jje + 1
  191.       nliab = lect(jje)
  192.       jje = jje + 1
  193.       nsb  = lect(jje)
  194.       jje = jje + 1
  195.       na2 = lect(jje)
  196.       jje = jje + 1
  197.       idimb = lect(jje)
  198.       jje = jje + 1
  199.       NTVAR = lect(jje)
  200.       jje = jje + 1
  201.        NLIAA = lect(jje)
  202.       jje = jje + 1
  203.        NRES = lect(jje)
  204.       jje = jje + 1
  205.        NCRES = lect(jje)
  206.       jje = jje + 1
  207.        NPRES  = lect(jje)
  208.       jje = jje + 1
  209.        NREP = lect(jje)
  210.       jje = jje + 1
  211.        NLSA  = lect(jje)
  212.       jje = jje + 1
  213.        NVALA  = lect(jje)
  214.       jje = jje + 1
  215.        NLSB  = lect(jje)
  216.       jje = jje + 1
  217.        NVALB = lect(jje)
  218.       jje = jje + 1
  219.        NVES  = lect(jje)
  220.       jje = jje + 1
  221.        i2MAX  = lect(jje)
  222.  
  223. *     seulement sortie chpoint pour pasapas 
  224. *     (et pas de listreel comme dans dyne)
  225.       NRESPO=NRES
  226.       NRESLI=0
  227.  
  228.       NPRES = 1
  229.       segini MTRES
  230.  
  231. * MTRES
  232.       do lg1 = 1,NVES
  233.         jje = jje + 1
  234.         ichres(lg1) = lect(jje)
  235.       enddo
  236.       do lg1 = 1,NLSA
  237.         jje = jje + 1
  238.          ipola(lg1) = lect(jje)
  239.       enddo
  240.       do lg1 = 1,NLSA
  241.         jje = jje + 1
  242.         inula(lg1) = lect(jje)
  243.       enddo
  244.       do lg1 = 1,NLSB
  245.         jje = jje + 1
  246.         ipolb(lg1) = lect(jje)
  247.       enddo
  248.       do lg1 = 1,NLSB
  249.         jje = jje + 1
  250.         inulb(lg1) = lect(jje)
  251.       enddo
  252.       do lg1 = 1,nlsa
  253.         do lg2 = 1,ntvar
  254.          jje = jje + 1
  255.          ilirea(lg1,lg2) = lect(jje)
  256.         enddo
  257.       enddo
  258.       do lg1 = 1,nlsa
  259.         do lg2 = 1,ntvar
  260.          jje = jje + 1
  261.          ilirna(lg1,lg2) = lect(jje)
  262.         enddo
  263.       enddo
  264.       do lg1 = 1,nlsb
  265.         do lg2 = 1,ntvar
  266.          jje = jje + 1
  267.          ilireb(lg1,lg2) = lect(jje)
  268.         enddo
  269.       enddo
  270.       do lg1 = 1,nlsb
  271.         do lg2 = 1,ntvar
  272.          jje = jje + 1
  273.          ilirnb(lg1,lg2) = lect(jje)
  274.         enddo
  275.       enddo
  276.       do lg1 = 1,nliaa
  277.         do lg2 = 1,2
  278.          jje = jje + 1
  279.          ilpola(lg1,lg2) = lect(jje)
  280.         enddo
  281.       enddo
  282.  
  283. * MTPAS
  284.       if (JLIAIB.eq.1) then
  285.        segini MTPAS
  286.        ktpas = mtpas
  287.       else
  288.        mtpas = ktpas
  289.       endif
  290.       do lu1 = 1,nplb
  291. cbp,2020-09       do lu2 = 1, 4
  292.        do lu2 = 1, 2
  293.         do lu3 = 1,idimb
  294.          jjr = jjr + 1
  295.           xptb(lu1,lu2,lu3) = prog(jjr)
  296.         enddo
  297.        enddo
  298.       enddo
  299.       do lu1 = 1,na1
  300.         do lu2 = 1,4
  301.          jjr = jjr + 1
  302.           finert(lu1,lu2) = prog(jjr)
  303.         enddo
  304.       enddo
  305.       do lu1 = 1,nliaa
  306.        do lu2 = 1, 4
  307.         do lu3 = 1,ntvar
  308.          jjr = jjr + 1
  309.          xvala(lu1,lu2,lu3) = prog(jjr)
  310.         enddo
  311.        enddo
  312.       enddo
  313.       do lu1 = 1,nliab
  314.        do lu2 = 1, 4
  315.         do lu3 = 1,ntvar
  316.          jjr = jjr + 1
  317.          xvalb(lu1,lu2,lu3) = prog(jjr)
  318.         enddo
  319.        enddo
  320.       enddo
  321.       do lu1 = 1,nplb
  322.        do lu2 = 1, 2
  323.         do lu3 = 1,idim
  324.          jjr = jjr + 1
  325.          fexb(lu1,lu2,lu3) = prog(jjr)
  326.         enddo
  327.        enddo
  328.       enddo
  329.       do lu1 = 1,2
  330.        do lu2 = 1, nliab
  331.         do lu3 = 1,4
  332.          do lu4 = 1,nplb
  333.          jjr = jjr + 1
  334.           XCHPFB(lu1,lu2,lu3,lu4) = prog(jjr)
  335.          enddo
  336.         enddo
  337.        enddo
  338.       enddo
  339.       do lu1 = 1,na1
  340.          jjr = jjr + 1
  341.           ftota(lu1,3) = prog(jjr)
  342.          jjr = jjr + 1
  343.           ftota(lu1,4) = prog(jjr)
  344.       enddo
  345. * MTQ
  346.       MTQ = KTQ
  347.       do lu1 = 1,na1
  348.         do lu2 = 1,2
  349.          jjr = jjr + 1
  350.          wext(lu1,lu2) = prog(jjr)
  351.         enddo
  352.       enddo
  353.       do lu1 = 1,na1
  354.         do lu2 = 1,2
  355.          jjr = jjr + 1
  356.           wint(lu1,lu2) = prog(jjr)
  357.         enddo
  358.       enddo
  359. * MTLIAB
  360.       segini MTLIAB
  361.       do lu1 = 1,nliab
  362.         do lu2 = 1,nxpalb
  363.          jjr = jjr + 1
  364.          xpalb(lu1,lu2) = prog(jjr)
  365.         enddo
  366.       enddo
  367.       do lu1 = 1,nliab
  368.         do lu2 = 1,nip
  369.          jjr = jjr + 1
  370.          xabsci(lu1,lu2) = prog(jjr)
  371.         enddo
  372.       enddo
  373.       do lu1 = 1,nliab
  374.         do lu2 = 1,nip
  375.          jjr = jjr + 1
  376.           xordon(lu1,lu2) = prog(jjr)
  377.         enddo
  378.       enddo
  379.       do lg1 = 1,nliab
  380.         do lg2 = 1,nipalb
  381.          jje = jje + 1
  382.          ipalb(lg1,lg2) = lect(jje)
  383.         enddo
  384.       enddo
  385.       do lg1 = 1,nliab
  386.         do lg2 = 1,nplbb
  387.          jje = jje + 1
  388.          iplib(lg1,lg2) = lect(jje)
  389.         enddo
  390.       enddo
  391.       do lg1=1,nplb
  392.          jje = jje + 1
  393.           jplib(lg1) = lect(jje)
  394.       enddo
  395. cbp   cas particulier ou IPALB contient un listreel a activer (palier)
  396.       do lg1 = 1,nliab
  397.         if(ipalb(lg1,1).eq.60) then
  398.           if(ipalb(lg1,5).eq.1) then
  399.             nlob=ipalb(lg1,6)
  400.             do ilob=1,nlob
  401.               mlree1=ipalb(lg1,7+ilob)
  402.               segact,mlree1
  403.             enddo
  404.           else
  405.               mlree1=ipalb(lg1,7)
  406.               segact,mlree1
  407.           endif
  408.         endif      
  409.       enddo
  410. cbp   fin du cas particulier ou IPALB contient un listreel a activer
  411.  
  412. * MTPHI
  413.       segini MTPHI
  414.       do lu1 = 1,nsb
  415.        do lu2 = 1,nplsb
  416.         do lu3 = 1,na2
  417.          do lu4 = 1,idimb
  418.          jjr = jjr + 1
  419.           xphilb(lu1,lu2,lu3,lu4) = prog(jjr)
  420.          enddo
  421.         enddo
  422.        enddo
  423.       enddo
  424.       do lg1=1,nplb
  425.          jje = jje + 1
  426.          ibasb(lg1) = lect(jje)
  427.       enddo
  428.       do lg1=1,nplb
  429.          jje = jje + 1
  430.          iplsb(lg1) = lect(jje)
  431.       enddo
  432.       do lg1=1,nsb
  433.          jje = jje + 1
  434.          inmsb(lg1) = lect(jje)
  435.       enddo
  436.       do lg1=1,nsb
  437.          jje = jje + 1
  438.          iorsb(lg1) = lect(jje)
  439.       enddo
  440.       do lg1=1,nsb
  441.          jje = jje + 1
  442.          iarota(lg1) = lect(jje)
  443.       enddo
  444. * MTFEX
  445.       NPFEXA = q1(/1)
  446.       NPFEXB = 0
  447.       segini MTFEX
  448.       do lu1 = 1,nplb
  449.        do lu2 = 1,npc1
  450.         do lu3 = 1,2
  451.          do lu4 = 1,idimb
  452.          jjr = jjr + 1
  453.          fexpsm(lu1,lu2,lu3,lu4) = prog(jjr)
  454.          enddo
  455.         enddo
  456.        enddo
  457.       enddo
  458.       do lu1 = 1,npfexa
  459.          jjr = jjr + 1
  460.          fexa(lu1,1,1) = prog(jjr)
  461.       enddo
  462. * LOCLFA
  463.        segini loclfa
  464. c      do lu1 = 1,na1
  465. c        do lu2 = 1,4
  466. c         jjr = jjr + 1
  467. c         prog(jjr) = ftest(lu1,lu2)
  468. c        enddo
  469. c      enddo
  470. c      do lu1 = 1,na1
  471. c        do lu2 = 1,4
  472. c         jjr = jjr + 1
  473. c         prog(jjr) = ftota0(lu1,lu2)
  474. c        enddo
  475. c      enddo
  476. *LOCLB1
  477.       segini loclb1
  478.       do lu1 = 1,nplb
  479.         do lu2 = 1,6
  480.          jjr = jjr + 1
  481.           ftest2(lu1,lu2) = prog(jjr)
  482.         enddo
  483.       enddo
  484.  
  485.       KTRES = MTRES
  486.       KPREF = MPREF
  487.       SEGINI,MSAM
  488.       KSAM=MSAM
  489.       DO 100 IP=1,NPLB
  490.          JPLIBB(IP)=JPLIB(IP)
  491.  100  CONTINUE
  492.       itkm = 0
  493.       jtmail = itmail
  494.       JTRES = KTRES
  495.       JPREF = KPREF
  496.       NLIAA = ilpola(/1)
  497.       NXPALA = 1
  498.       NIPALA=3
  499.       NPLAA = 0
  500.       NPLA = 0
  501.       segini MTLIAA
  502.       ktliaa = mtliaa
  503.       CALL DYNE17(1,ITKM,jtmail,JTRES,JPREF,NPLAA,NXPALA,KSAM,lmodyn)
  504.       IF (IERR.NE.0) RETURN
  505.       MSAM=KSAM
  506.       SEGSUP,MSAM
  507.  
  508.       ELSE
  509. * 1er pas
  510.  
  511.       i2MAX = 0
  512.       MTQ = ktq
  513.       MTPHI  = ktphi
  514.       do istru=1,nsstru
  515.        if(iarota(istru).ne.0) rigide = .true.
  516.       enddo
  517.       MTLIAB = ktliab
  518. c      NSB = XPHILB(/1)
  519.       NPLSB = XPHILB(/2)
  520. c      NA2 =  XPHILB(/3)
  521. c      IDIMB = XPHILB(/4)
  522. c      NPLB = JPLIB(/1)
  523.       NA1 = nndefo
  524.       segini loclfa
  525.       KOCLFA = loclfa
  526.       segini loclb1
  527.       KOCLB1 = loclb1
  528.       NPAS = 0
  529.  
  530.        MTRES  = KTRES
  531.        ITINIT = 0
  532.        REPRIS = .false.
  533.       JKCPR = kcpr
  534.       NLIAA = ilpola(/1)
  535.       NXPALA = 1
  536.       NIPALA=3
  537.       NPLAA = 0
  538.       NPLA = 0
  539.       segini MTLIAA
  540.       ktliaa = mtliaa
  541. * voir comalo
  542.       NTVAR  = 6 + 4 * IDIM
  543. *      segini mtpas
  544.       if (JLIAIB.eq.1) then
  545.        segini MTPAS
  546.        ktpas = mtpas
  547.       else
  548.        mtpas = ktpas
  549.       endif
  550.       JKTPAS = ktpas
  551.       NPFEXA = q1(/1)
  552.       NPFEXB = 0
  553.       SEGINI MTFEX
  554.       KTFEX = MTFEX
  555.       JKTLIAB = ktliab
  556.       JKTQ = ktq
  557.       JKTPHI = ktphi
  558.       JKTKAM = KTKAM
  559. * kich : permet d'initialiser mais inexact
  560.       CALL DEVINI(ITINIT,JKTKAM,JKTQ,KTFEX,JKTPAS,KTNUM,KTLIAA,JKTLIAB,
  561.      &            JKTPHI,JKCPR,KOCLFA,KOCLB1,REPRIS,RIGIDE,lmodyn)
  562.  
  563. *       segsup mtfex
  564.       ENDIF
  565.  
  566.       IVINIT = 0
  567. *      SEGINI MTFEX
  568.       KTFEX = MTFEX
  569.  
  570.       nliady = nliab + nliaa
  571.  
  572. c      NLIAB = IPALB(/1)
  573.  
  574.       NPAS = NPAS + 1
  575.       NPASF = 1
  576.  
  577.       do istru=1,nsstru
  578.        if(iarota(istru).ne.0) rigide = .true.
  579.       enddo
  580.  
  581. c calculs en 2 demi-pas Runge-Kutta/ initialisation pour 1ere liaison
  582.       do kna =1,na1
  583.         IF(JLIAIB.eq.1) THEN
  584. *voir devfxa
  585. *       fexa(kna,1,1) = q3(kna,2)
  586.  
  587. *       q1(kna,3) = q1(kna,2)
  588.        q1(kna,2) = (q1(kna,1) + q1(kna,2))* 0.5d0
  589. *       q2(kna,3) = q2(kna,2)
  590.        ftota(kna,2) = q3(kna,2)
  591.        ftota(kna,1) = q3(kna,2)
  592.         ENDIF
  593.  
  594.        q2(kna,1) = 0.d0
  595.        q2(kna,2) = 0.d0
  596.       enddo
  597.  
  598. ** voir devpas.eso
  599.       DO III = 2,1,-1
  600.  
  601.        PDT=XDT(npasf)
  602.        T=XTEMPS(npasf)
  603.  
  604. **     Ajout des forces de raideur avant demi-pas
  605.         IF(JLIAIB.eq.1) THEN
  606.       CALL DEVLK0(Q1,XK,FTOTA,NA1,1,III)
  607.         ENDIF
  608. *
  609. *     estimation de la vitesse (ici plutot que dans DEVLF*, bp,2020-09):
  610. *     on espere que cela est coherent ici ...?
  611. *     \dot{q}_1/2 ~ ({q}_1/2 - {q}_0  ) / dt/2
  612. *     \dot{q}_1   ~ ({q}_1   - {q}_1/2) / dt/2
  613.       DO I=1,NA1
  614.         Q2(I,III)=(Q1(I,III)-Q1(I,III+1))*2./PDT
  615.       ENDDO
  616.  
  617. * forces liaisons base A (modes)
  618.  
  619.       IF (NLIAA.NE.0) THEN
  620.          CALL DEVLFA(Q1,Q2,FTOTA,NA1,IPALA,IPLIA,XPALA,XVALA,
  621.      &               NLIAA,PDT,T,npasf,III,FINERT,IVINIT,FTEST)
  622.       ENDIF
  623. *
  624. *
  625. *     Ajout des forces de liaison base B matérielle
  626. *
  627.       IF (NLIAB.NE.0) THEN
  628.          CALL DEVLFB(Q1,Q2,FTOTA,NA1,IPALB,IPLIB,XPALB,XVALB,NLIAB,
  629.      &               XPHILB,JPLIB,NPLB,IDIMB,FTOTB,FTOTBA,XPTB,PDT,T,
  630.      &               npasf,IBASB,IPLSB,INMSB,IORSB,NSB,NPLSB,NA2,III,
  631.      &               FEXPSM,NPC1,IERRD,FTEST2,
  632.      &               XABSCI,XORDON,NIP,FEXB,RIGIDE,IAROTA,XCHPFB)
  633.          IF (IERRD.NE.0) RETURN
  634.       ENDIF
  635.           IF(JLIAIB.eq.nliady) THEN
  636.       if (III.eq.2) then
  637.         if (npas.eq.1) then
  638.          do jj = 1,na1
  639.           ftota(jj,3) = ftota(jj,2)
  640.          enddo
  641.         endif
  642.         CALL DEVEQ2(Q2,NA1,XASM,XM,PDT,npasf,FTOTA,FINERT)
  643.        else
  644.         CALL DEVEQ4(Q2,NA1,XASM,XM,PDT,npasf,FTOTA,FINERT)
  645.        endif
  646.          ENDIF
  647.  
  648.       ENDDO
  649.  
  650. *         CALL DYNE16(Q1,Q2,Q3,NA1,FTOTA,XPTB,NPLB,IDIMB,FINERT)
  651.        DO 10 I=1,NA1
  652.          FINERT(I,3) = FINERT(I,1)
  653.          FINERT(I,4) = FINERT(I,2)
  654.          FTOTA(I,3) = FTOTA(I,1)
  655.          FTOTA(I,4) = FTOTA(I,2)
  656.  10     CONTINUE
  657. cbp,2020-09       DO 20 IP = 1,NPLB
  658. cbp,2020-09         DO 22 ID = 1,IDIMB
  659. cbp,2020-09            XPTB(IP,3,ID) = XPTB(IP,1,ID)
  660. cbp,2020-09            XPTB(IP,4,ID) = XPTB(IP,2,ID)
  661. cbp,2020-09 22         CONTINUE
  662. cbp,2020-09 20     CONTINUE
  663. *
  664. * calcul des travaux
  665. * fin devpas.eso
  666.  
  667. *
  668. * production chpoint forces base A (devso2)
  669. *
  670.          meleme = itmail
  671.          segact meleme
  672.          if (lisous(/1).eq.0) then
  673.           ipmmod = itmail
  674.           ipmsta = 0
  675.          else
  676.           ipmmod = lisous(1)
  677.           ipmsta = lisous(2)
  678.          endif
  679.  
  680.          NSOUPO = 1
  681.          if(ipmmod.gt.0.and.ipmsta.gt.0) nsoupo = 2
  682.          NAT=1
  683.          SEGINI,MCHPOI
  684.          IPCHPO = MCHPOI
  685.          MTYPOI = 'FLIAISONS'
  686.          IFOPOI = IFOUR
  687. *          nature  diffuse
  688.          JATTRI(1) = 1
  689.        nmost0 = 0
  690.        KIPCHP = 0
  691.  
  692.        icoe1 = 1
  693.        ymaxf = 0.d0
  694.        if (CMATE.eq.'PO_CE_MO') then
  695.         if (i2max.ne.0) then
  696.          if (FTOTBA(abs(i2max))*i2max.lt.0.d0) icoe1 = -1
  697.         endif
  698.        endif
  699.  
  700.        if (ipmmod.gt.0) then
  701.         NC = 1
  702.         IF(JLIAIB.eq.nliady)   NC = 2
  703.          SEGINI,MSOUPO
  704.          KIPCHP = KIPCHP + 1
  705.          IPCHP(KIPCHP)  = MSOUPO
  706.          NOCOMP(1) = 'FALF'
  707.          NOHARM(1) = NIFOUR
  708.         if (NC.eq.2) then
  709.          NOCOMP(2) = NOCOMP(1)
  710.          NOCOMP(2)(1:1) = 'V'
  711.          NOHARM(2) = NIFOUR
  712.         endif
  713.          IGEOC = ipmmod
  714.          ipt1 = ipmmod
  715.          segact ipt1
  716.          N = ipt1.num(/2)
  717.          nmost0 = N
  718.          SEGINI,MPOVAL
  719.          IPOVAL = MPOVAL
  720. *
  721.          do ii = 1,N
  722.           if (i2max.eq.0) then
  723.            if (abs(FTOTBA(ii)).gt.ymaxf) then
  724.             ymaxf = abs(FTOTBA(ii))
  725.             i2max = ii
  726.             if (FTOTBA(ii).lt.0.d0) i2max = -i2max
  727.            endif
  728.           endif
  729.           vpocha(ii,1) = -icoe1*FTOTBA(ii)
  730.           if (NC.eq.2) vpocha(ii,2) = q2(ii,1)
  731.          enddo
  732.  
  733.          SEGDES,MPOVAL,MSOUPO
  734.        endif
  735.  
  736. *kich : extension a tout hasard
  737.        if (ipmsta.gt.0) then
  738.         NC = 1
  739.         IF(JLIAIB.eq.nliady)   NC = 2
  740.          SEGINI,MSOUPO
  741.          KIPCHP = KIPCHP + 1
  742.          IPCHP(KIPCHP)  = MSOUPO
  743.          NOCOMP(1) = 'FBET'
  744.          NOHARM(1) = NIFOUR
  745.         if (NC.eq.2) then
  746.          NOCOMP(2) = NOCOMP(1)
  747.          NOCOMP(2)(1:1) = 'V'
  748.          NOHARM(2) = NIFOUR
  749.         endif
  750.          IGEOC = ipmsta
  751.          ipt1 = ipmsta
  752.          segact ipt1
  753.          N = ipt1.num(/2)
  754.          SEGINI,MPOVAL
  755.          IPOVAL = MPOVAL
  756. *
  757.          do ii = 1,N
  758.           vpocha(ii,1) = -icoe1*FTOTBA(ii + nmost0)
  759.           if (NC.eq.2) vpocha(ii,2) = q2(ii,1)
  760.          enddo
  761.  
  762.          SEGDES,MPOVAL,MSOUPO
  763.        endif
  764.  
  765.       segdes MCHPOI
  766.       varf(1) = IPCHPO
  767.        MTRES  = KTRES
  768. *
  769.        NINS = 1
  770.       NRES   = XRES(/1)
  771.       NCRES  = XRES(/2)
  772.       NPRES  = XRES(/3)
  773.       NREP   = XREP(/1)
  774.       NLSA   = XRESLA(/1)
  775.       NLSB   = XRESLB(/1)
  776.       NVES = ICHRES(/1)
  777.       NVALA =  IPLRLA(/2)
  778.       NVALB =  IPLRLB(/2)
  779. *
  780.          if (npas.eq.1) then
  781.           iins2 = 2
  782.          else
  783.           iins2 = 1
  784.          endif
  785. * range les resultats de la bonne liaison
  786.         if (jliaib.gt.1) then
  787.           do lu3 = 1,ntvar
  788.             xvalb(1,1,lu3)=xvalb(jliaib,1,lu3)
  789.           enddo
  790. *                  DO IP=1,NPLB
  791. *                    DO ID=1,2
  792. *                      II = II + 1
  793. *                      XCHPFB(ID,IIL,1,IP)  = XCHPFB(ID,jliaib,1,IP)
  794. *                    ENDDO
  795. *                   ENDDO
  796.         endif
  797.  
  798. * transit resultat
  799.          CALL DEVTR1(Q1,Q2,Q3,NA1,IINS2,NINS,FTOTA,XRES,ICHRES,NRES,
  800.      &               NCRES,NPRES,XREP,NREP,XVALA,INULA,NLIAA,NLSA,
  801.      &              XRESLA,XVALB,INULB,NLIAB,NLSB,XRESLB,ILIREA,ILIREB,
  802.      &               NTVAR,XPALB,IPALB,XMREP,IMREP,IDIMB,WEXT,WINT,
  803.      &               XCHPFB,NPLB)
  804.  
  805. * sauvegarde pour aller plus vite pas suivant
  806. *
  807.       JG = 1000
  808.       jje = 0
  809.       segini MLENTI
  810.       jje = jje + 1
  811.       lect(jje) = JLIAIB
  812.       nchain = 0
  813.         mlent3 = ichain
  814.         segact mlent3
  815.         nchain = mlent3.lect(/1)
  816.       jje = jje + 1
  817.       lect(jje) = nchain
  818.         do lg = 1,nchain
  819.          jje = jje + 1
  820.          lect(jje)=mlent3.lect(lg)
  821.         enddo
  822.       jje = jje + 1
  823.       lect(jje) = NPAS
  824.       jje = jje + 1
  825.       lect(jje) = NIPALB
  826.       jje = jje + 1
  827.       lect(jje) = NXPALB
  828.       jje = jje + 1
  829.       lect(jje) = NPLBB
  830.       jje = jje + 1
  831.       lect(jje) =  NPLB
  832.       jje = jje + 1
  833.       lect(jje) =  NPLSB
  834.       jje = jje + 1
  835.       lect(jje) = NIP
  836.       jje = jje + 1
  837.       lect(jje) = nsstru
  838.       jje = jje + 1
  839.       lect(jje) = nndefo
  840.       jje = jje + 1
  841.       lect(jje) = nliab
  842.       jje = jje + 1
  843.       lect(jje) = nsb
  844.       jje = jje + 1
  845.       lect(jje) = na2
  846.       jje = jje + 1
  847.       lect(jje) = idimb
  848.       jje = jje + 1
  849.       lect(jje) = NTVAR
  850.       jje = jje + 1
  851.       lect(jje) = NLIAA
  852.       jje = jje + 1
  853.       lect(jje) = NRES
  854.       jje = jje + 1
  855.       lect(jje) = NCRES
  856.       jje = jje + 1
  857.       lect(jje) = NPRES
  858.       jje = jje + 1
  859.       lect(jje) = NREP
  860.       jje = jje + 1
  861.       lect(jje) = NLSA
  862.       jje = jje + 1
  863.       lect(jje) = NVALA
  864.       jje = jje + 1
  865.       lect(jje) = NLSB
  866.       jje = jje + 1
  867.       lect(jje) = NVALB
  868.       jje = jje + 1
  869.       lect(jje) = NVES
  870.       jje = jje + 1
  871.       lect(jje) = i2MAX
  872.  
  873. * MTRES
  874.       do lg1 = 1,NVES
  875.         jje = jje + 1
  876.         lect(jje) = ichres(lg1)
  877.       enddo
  878.       do lg1 = 1,NLSA
  879.         jje = jje + 1
  880.         lect(jje) = ipola(lg1)
  881.       enddo
  882.       do lg1 = 1,NLSA
  883.         jje = jje + 1
  884.         lect(jje) = inula(lg1)
  885.       enddo
  886.       do lg1 = 1,NLSB
  887.         jje = jje + 1
  888.         lect(jje) = ipolb(lg1)
  889.       enddo
  890.       do lg1 = 1,NLSB
  891.         jje = jje + 1
  892.         lect(jje) = inulb(lg1)
  893.       enddo
  894.       do lg1 = 1,nlsa
  895.         do lg2 = 1,ntvar
  896.          jje = jje + 1
  897.          lect(jje)= ilirea(lg1,lg2)
  898.         enddo
  899.       enddo
  900.       do lg1 = 1,nlsa
  901.         do lg2 = 1,ntvar
  902.          jje = jje + 1
  903.          lect(jje)= ilirna(lg1,lg2)
  904.         enddo
  905.       enddo
  906.       do lg1 = 1,nlsb
  907.         do lg2 = 1,ntvar
  908.          jje = jje + 1
  909.          lect(jje)= ilireb(lg1,lg2)
  910.         enddo
  911.       enddo
  912.       do lg1 = 1,nlsb
  913.         do lg2 = 1,ntvar
  914.          jje = jje + 1
  915.          lect(jje)= ilirnb(lg1,lg2)
  916.         enddo
  917.       enddo
  918.       do lg1 = 1,nliaa
  919.         do lg2 = 1,2
  920.          jje = jje + 1
  921.          lect(jje)= ilpola(lg1,lg2)
  922.         enddo
  923.       enddo
  924.  
  925.       JG = (nplb*4*idimb)+(na1*4)+(nliaa*4*ntvar)+(nliab*4*ntvar)+
  926.      &(nplb*2*idim)+(2*nliab*4*nplb)+(2*na1)+(na1*2*2)+
  927.      &(nliab*(nxpalb+nip+nip))+(nsb*na2*nplsb*idimb)+
  928.      &(nplb*npc1*2*idimb)+ npfexa +(nplb*6*2)
  929.       SEGINI MLREEL
  930.       jjr = 0
  931. * MTPAS
  932.       do lu1 = 1,nplb
  933. cbp,2020-09       do lu2 = 1, 4
  934.        do lu2 = 1, 2
  935.         do lu3 = 1,idimb
  936.          jjr = jjr + 1
  937.          prog(jjr) = xptb(lu1,lu2,lu3)
  938.         enddo
  939.        enddo
  940.       enddo
  941.       do lu1 = 1,na1
  942.         do lu2 = 1,4
  943.          jjr = jjr + 1
  944.          prog(jjr) = finert(lu1,lu2)
  945.         enddo
  946.       enddo
  947.       do lu1 = 1,nliaa
  948.        do lu2 = 1, 4
  949.         do lu3 = 1,ntvar
  950.          jjr = jjr + 1
  951.          prog(jjr) = xvala(lu1,lu2,lu3)
  952.         enddo
  953.        enddo
  954.       enddo
  955.       do lu1 = 1,nliab
  956.        do lu2 = 1, 4
  957.         do lu3 = 1,ntvar
  958.          jjr = jjr + 1
  959.          prog(jjr) = xvalb(lu1,lu2,lu3)
  960.         enddo
  961.        enddo
  962.       enddo
  963.       do lu1 = 1,nplb
  964.        do lu2 = 1, 2
  965.         do lu3 = 1,idim
  966.          jjr = jjr + 1
  967.          prog(jjr) = fexb(lu1,lu2,lu3)
  968.         enddo
  969.        enddo
  970.       enddo
  971.       do lu1 = 1,2
  972.        do lu2 = 1, nliab
  973.         do lu3 = 1,4
  974.          do lu4 = 1,nplb
  975.          jjr = jjr + 1
  976.          prog(jjr) = XCHPFB(lu1,lu2,lu3,lu4)
  977.          enddo
  978.         enddo
  979.        enddo
  980.       enddo
  981.       do lu1 = 1,na1
  982.          jjr = jjr + 1
  983.           prog(jjr) = ftota(lu1,3)
  984.          jjr = jjr + 1
  985.           prog(jjr) = ftota(lu1,4)
  986.       enddo
  987. * MTQ
  988.       do lu1 = 1,na1
  989.         do lu2 = 1,2
  990.          jjr = jjr + 1
  991.          prog(jjr) = wext(lu1,lu2)
  992.         enddo
  993.       enddo
  994.       do lu1 = 1,na1
  995.         do lu2 = 1,2
  996.          jjr = jjr + 1
  997.          prog(jjr) = wint(lu1,lu2)
  998.         enddo
  999.       enddo
  1000. * MTLIAB
  1001.       do lu1 = 1,nliab
  1002.         do lu2 = 1,nxpalb
  1003.          jjr = jjr + 1
  1004.          prog(jjr) = xpalb(lu1,lu2)
  1005.         enddo
  1006.       enddo
  1007.       do lu1 = 1,nliab
  1008.         do lu2 = 1,nip
  1009.          jjr = jjr + 1
  1010.          prog(jjr) = xabsci(lu1,lu2)
  1011.         enddo
  1012.       enddo
  1013.       do lu1 = 1,nliab
  1014.         do lu2 = 1,nip
  1015.          jjr = jjr + 1
  1016.          prog(jjr) = xordon(lu1,lu2)
  1017.         enddo
  1018.       enddo
  1019.       do lg1 = 1,nliab
  1020.         do lg2 = 1,nipalb
  1021.          jje = jje + 1
  1022.          lect(jje)= ipalb(lg1,lg2)
  1023.         enddo
  1024.       enddo
  1025.       do lg1 = 1,nliab
  1026.         do lg2 = 1,nplbb
  1027.          jje = jje + 1
  1028.          lect(jje)= iplib(lg1,lg2)
  1029.         enddo
  1030.       enddo
  1031.       do lg1=1,nplb
  1032.          jje = jje + 1
  1033.          lect(jje)= jplib(lg1)
  1034.       enddo
  1035. * MTPHI
  1036.       do lu1 = 1,nsb
  1037.        do lu2 = 1,nplsb
  1038.         do lu3 = 1,na2
  1039.          do lu4 = 1,idimb
  1040.          jjr = jjr + 1
  1041.          prog(jjr) = xphilb(lu1,lu2,lu3,lu4)
  1042.          enddo
  1043.         enddo
  1044.        enddo
  1045.       enddo
  1046.       do lg1=1,nplb
  1047.          jje = jje + 1
  1048.          lect(jje)= ibasb(lg1)
  1049.       enddo
  1050.       do lg1=1,nplb
  1051.          jje = jje + 1
  1052.          lect(jje)= iplsb(lg1)
  1053.       enddo
  1054.       do lg1=1,nsb
  1055.          jje = jje + 1
  1056.          lect(jje)= inmsb(lg1)
  1057.       enddo
  1058.       do lg1=1,nsb
  1059.          jje = jje + 1
  1060.          lect(jje)= iorsb(lg1)
  1061.       enddo
  1062.       do lg1=1,nsb
  1063.          jje = jje + 1
  1064.          lect(jje)= iarota(lg1)
  1065.       enddo
  1066. * MTFEX
  1067.       do lu1 = 1,nplb
  1068.        do lu2 = 1,npc1
  1069.         do lu3 = 1,2
  1070.          do lu4 = 1,idimb
  1071.          jjr = jjr + 1
  1072.          prog(jjr) = fexpsm(lu1,lu2,lu3,lu4)
  1073.          enddo
  1074.         enddo
  1075.        enddo
  1076.       enddo
  1077.       do lu1 = 1,npfexa
  1078.          jjr = jjr + 1
  1079.          prog(jjr) = fexa(lu1,1,1)
  1080.       enddo
  1081. * LOCLFA
  1082. c      do lu1 = 1,na1
  1083. c        do lu2 = 1,4
  1084. c         jjr = jjr + 1
  1085. c         prog(jjr) = ftest(lu1,lu2)
  1086. c        enddo
  1087. c      enddo
  1088. c      do lu1 = 1,na1
  1089. c        do lu2 = 1,4
  1090. c         jjr = jjr + 1
  1091. c         prog(jjr) = ftota0(lu1,lu2)
  1092. c        enddo
  1093. c      enddo
  1094. *LOCLB1
  1095.       do lu1 = 1,nplb
  1096.         do lu2 = 1,6
  1097.          jjr = jjr + 1
  1098.          prog(jjr) = ftest2(lu1,lu2)
  1099.         enddo
  1100.       enddo
  1101.  
  1102.       JG = jjr
  1103.       segadj mlreel
  1104.       varf(4) = mlreel
  1105.       JG = JJE
  1106.       segadj mlenti
  1107.       varf(3) = mlenti
  1108.       varf(5) = itmail
  1109.       segdes mlreel,mlenti
  1110. *
  1111.        JKTLIAB= mtliab
  1112.        JKTPHI = mtphi
  1113.        JKTQ = mtq
  1114.        JKTRES = ktres
  1115.        JKTNUM = mtnum
  1116.        JKTFEX = mtfex
  1117.        JKPREF = mpref
  1118.        JKTLIAA = 0
  1119.        JKTKAM = 0
  1120.        JKTPAS = mtpas
  1121.        IPMAIL = itmail
  1122.        JMAILz = itmail
  1123.        REPRIS = .false.
  1124.        lmodyn = .true.
  1125.        jchain = ichain
  1126.  
  1127.         call crtabl(its2)
  1128.        ITDYN = its2
  1129.        CALL DEVSO5(JKPREF,JKTQ,JKTKAM,JKTPHI,JKTLIAA,JKTLIAB,JKTFEX,
  1130.      &       JKTPAS,JKTRES,JKTNUM,NINS,JMAILz,REPRIS,JCHAIN,
  1131.      &       LMODYN,ITDYN)
  1132.        if (ierr.ne.0) return
  1133.  
  1134.        if (itdyn.gt.0) varf(2) = itdyn
  1135.  
  1136.        IF(JLIAIB.eq.nliady) then
  1137.          SEGSUP,MPREF
  1138.          segsup,MTQ
  1139.          SEGSUP,MTKAM
  1140.          SEGSUP,MTPAS
  1141.        ENDIF
  1142.  
  1143.          SEGSUP MTFEX
  1144.          segsup mtnum
  1145. *
  1146.       SEGSUP,MTPHI
  1147.       SEGSUP,MTLIAB
  1148.       SEGSUP,MTLIAA
  1149.       SEGSUP,MTRES
  1150.       SEGSUP,LOCLFA
  1151.       SEGSUP,LOCLB1
  1152.       if (npas.eq.1.and.jliaib.lt.nliady) then
  1153.         mlent3 = ichain
  1154.         segsup mlent3
  1155.       endif
  1156.  
  1157.       ichain = jchain
  1158.  
  1159.       RETURN
  1160.       END
  1161.  
  1162.  
  1163.  
  1164.  
  1165.  
  1166.  
  1167.  
  1168.  
  1169.  
  1170.  
  1171.  
  1172.  
  1173.  
  1174.  
  1175.  
  1176.  
  1177.  
  1178.  
  1179.  
  1180.  
  1181.  
  1182.  

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