Télécharger la plaquette Cast3M


fr en

Télécharger devalo.eso

Retour à la liste

Numérotation des lignes : 

devalo

  1. C DEVALO    SOURCE    CB215821  24/04/12    21:15:35     11897          
  2.       SUBROUTINE DEVALO(ITBAS,ITKM,ITA,ITLIA,ITCHAR,ITINIT,NP,PDT,NINS,
  3.      &                  ITSORT,ITREDU,KPREF,KTQ,KTKAM,KTPHI,KTLIAA,
  4.      &                  KTLIAB,KTFEX,KTPAS,KTRES,KTNUM,IPMAIL,REPRIS,
  5.      &                  ICHAIN,KOCLFA,KOCLB1,ITCARA,LMODYN)
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8(A-H,O-Z)
  8. *--------------------------------------------------------------------*
  9. *                                                                    *
  10. *     Operateur DYNE : algorithme de Fu - de Vogelaere               *
  11. *     ________________________________________________               *
  12. *                                                                    *
  13. *     Dimensionnement des tableaux de travail ( allocation de la     *
  14. *     memoire ).                                                     *
  15. *                                                                    *
  16. *     Parametres:                                                    *
  17. *                                                                    *
  18. * e   ITBAS   Table representant une base modale                     *
  19. * e   ITKM    Table contenant les matrices XK et XM                  *
  20. * e   ITA     Table contenant la matrice XASM                        *
  21. * e   ITLIA   Table rassemblant la description des liaisons          *
  22. * e   ITCHAR  Table contenant les chargements                        *
  23. * e   ITINIT  Table donnant les conditions initiales                 *
  24. * e   NP      Nombre de pas de calcul                                *
  25. * e   PDT     Valeur du pas de temps                                 *
  26. * e   NINS    On veut une sortie tous les NINS pas de calcul         *
  27. * e   ITSORT  Table definissant les resultats attendus               *
  28. * e   ITREDU  Table contenant les noms d'inconnues de la base B      *
  29. *             auxquelles on se restreint                             *
  30. * e   KPREF   Segment des points de reference                        *
  31. * s   MTQ     Segment contenant les variables generalisees           *
  32. *             (et les travaux)
  33. * s   MTKAM   Segment contenant les vecteurs XK, XASM et XM          *
  34. * s   MTPHI   Segment contenant les deformees modales                *
  35. * s   MTLIAA  Segment descriptif des liaisons en base A              *
  36. * s   MTLIAB  Segment descriptif des liaisons en base B              *
  37. * s   MTFEX   Segment contenant les chargements libres               *
  38. * s   MTPAS   Segment des variables au cours d'un pas de temps       *
  39. * s   MTRES   Segment de sauvegarde des resultats                    *
  40. * s   MTNUM   Segment contenant les parametres temporels             *
  41. * s   IPMAIL  Maillage de reference pour les CHPOINTs resultats      *
  42. * s   REPRIS  Vrai si reprise de calcul, faux sinon                  *
  43. * s   ICHAIN  Segment MLENTI (ACTIF) contenant les adresses des      *
  44. *             chaines dans la pile des mots de CCNOYAU               *
  45. * s   KOCLFA  Segment contenant les tableaux locaux de la subroutine *
  46. *             DEVLFA                                                 *
  47. * s   KOCLB1  Segment contenant les tableaux locaux de la subroutine *
  48. *             DEVLB1                                                 *
  49. *                                                                    *
  50. *     Auteur, date de creation:                                      *
  51. *                                                                    *
  52. *     Denis ROBERT-MOUGIN, le 25 mai 1989.                           *
  53. *     NTRA passe a 10000 le 28/1/93 par D. R.                        *
  54. *--------------------------------------------------------------------*
  55.  
  56. -INC PPARAM
  57. -INC CCOPTIO
  58. -INC SMCOORD
  59. -INC SMMODEL
  60. -INC SMELEME
  61. -INC SMCHAML
  62. -INC SMLENTI
  63. *
  64. *     Segment des variables generalisees:
  65. *
  66.       SEGMENT,MTQ
  67.          REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4)
  68.          REAL*8 WEXT(NA1,2),WINT(NA1,2)
  69.       ENDSEGMENT
  70. *
  71. *     Segment contenant les matrices XK, XASM et XM:
  72. *
  73.       SEGMENT,MTKAM
  74.          REAL*8 XK(NA1,NB1K),XASM(NA1,NB1C),XM(NA1,NB1M)
  75.          REAL*8 XOPER(NB1,NB1,NOPER)
  76.       ENDSEGMENT
  77. *
  78. *     Segment des deformees modales:
  79. *
  80.       SEGMENT,MTPHI
  81.          INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB)
  82.          INTEGER IAROTA(NSB)
  83.          REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB)
  84.       ENDSEGMENT
  85. *
  86. *     Segment descriptif des liaisons en base A:
  87. *
  88.       SEGMENT,MTLIAA
  89.          INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA)
  90.          REAL*8  XPALA(NLIAA,NXPALA)
  91.       ENDSEGMENT
  92. *
  93. *     Segment descriptif des liaisons en base B:
  94. *
  95.       SEGMENT MTLIAB
  96.          INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  97.          REAL*8 XPALB(NLIAB,NXPALB)
  98.          REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  99.       ENDSEGMENT
  100. *
  101. *     Segment representant les chargements libres:
  102. *
  103.       SEGMENT,MTFEX
  104.          REAL*8  FEXA(NPFEXA,NPC1,2)
  105.          REAL*8  FEXPSM(NPLB,NPC1,2,IDIMB)
  106.          REAL*8  FTEXB(NPLB,NPC1,2,IDIM)
  107. *         INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB)
  108.       ENDSEGMENT
  109. *
  110. *     Segment contenant les variables au cours d'un pas de temps:
  111. *
  112.       SEGMENT,MTPAS
  113.          REAL*8 FTOTA(NA1,4),FTOTB(NPLB,IDIMB),FTOTBA(NA1)
  114.          REAL*8 XPTB(NPLB,2,IDIMB),FINERT(NA1,4)
  115.          REAL*8 XVALA(NLIAA,4,NTVAR),XVALB(NLIAB,4,NTVAR)
  116.          REAL*8 FEXB(NPLB,2,IDIM),XCHPFB(2,NLIAB,4,NPLB)
  117.       ENDSEGMENT
  118. *
  119. *     Segment de sauvegarde des resultats (active dans DYNE15) :
  120. *
  121.       SEGMENT,MTRES
  122.          REAL*8  XRES(NRES,NCRES,NPRES),XREP(NREP,NCRES)
  123.          REAL*8  XRESLA(NLSA,NPRES,NVALA),XRESLB(NLSB,NPRES,NVALB)
  124.          REAL*8  XMREP(NLIAB,4,IDIMB)
  125.          INTEGER ICHRES(NVES),IPORES(NRESPO,NPRES),IPOREP(NREP)
  126.          INTEGER ILIRES(NRESLI,NCRES)
  127.          INTEGER IPOLA(NLSA),INULA(NLSA),IPLRLA(NLSA,NVALA)
  128.          INTEGER IPOLB(NLSB),INULB(NLSB),IPLRLB(NLSB,NVALB)
  129.          INTEGER ILIREA(NLSA,NTVAR),ILIREB(NLSB,NTVAR)
  130.          INTEGER ILIRNA(NLSA,NTVAR),ILIRNB(NLSB,NTVAR)
  131.          INTEGER IPOLR(1),IMREP(NLIAB,2),IPPREP(NLIAB,4)
  132.          INTEGER ILPOLA(NLIAA,2)
  133.       ENDSEGMENT
  134. *
  135. *     Segment contenant les parametres temporels:
  136. *
  137.       SEGMENT,MTNUM
  138.          REAL*8 XDT(NPC1),XTEMPS(NPC1)
  139.       ENDSEGMENT
  140. *
  141. *     Segment des points de reference:
  142. *
  143.       SEGMENT,MPREF
  144.          INTEGER IPOREF(NPREF)
  145.       ENDSEGMENT
  146. *
  147. *     Segment de points
  148. *
  149.       SEGMENT,NCPR(nbpts)
  150. *
  151. *     Segment de travail pour reprise force POLYNOMIALE base A
  152. *
  153.       SEGMENT,MTRA
  154.          INTEGER IPLA(NTRA)
  155.       ENDSEGMENT
  156. *
  157. * Segment "local" pour DEVLFA ...
  158.       SEGMENT,LOCLFA
  159.          REAL*8 FTEST(NA1,4)
  160.       ENDSEGMENT
  161. * Segment "local" pour DEVLB1 ...
  162.       SEGMENT,LOCLB1
  163.          REAL*8 FTEST2(NPLB,6)
  164.       ENDSEGMENT
  165. * Segment pour Champoints
  166.       SEGMENT,MSAM
  167.          integer jplibb(NPLB)
  168.       ENDSEGMENT
  169. * segment chapeau modeles liaisons
  170.       SEGMENT MOLIAI
  171.          integer modtla,modtlb
  172.       ENDSEGMENT
  173. *
  174.       segment mwinit
  175.         integer jpdep,jpvit,jrepr
  176.       endsegment
  177.       segment mtbas
  178.         integer itbmod,lsstru(np1),nsstru
  179.       endsegment
  180.       segment icma(0)
  181.       segment icnna2(0)
  182.       LOGICAL L0,L1,REPRIS,LMODYN
  183.       CHARACTER*6  MO2
  184.       CHARACTER*8  TYPRET,CHARRE
  185.       CHARACTER*10 MO1
  186.       CHARACTER*40 MONMOT
  187. *
  188.       ITREP  = 0
  189.       MTQ    = 0
  190.       MTKAM  = 0
  191.       MTPHI  = 0
  192.       MTLIAA = 0
  193.       MTLIAB = 0
  194.       MTFEX  = 0
  195.       MTPAS  = 0
  196.       MTRES  = 0
  197.       MTNUM  = 0
  198.       MTRA   = 0
  199.       XTINI  = 0.D0
  200.       ITLA = 0
  201.       ITLB = 0
  202.       REPRIS = .FALSE.
  203. *
  204. ************************************************************************
  205. *     On recupere le cas echeant, le temps de reprise:
  206. ************************************************************************
  207. *
  208.       IF (ITINIT.NE.0) THEN
  209.        if (lmodyn) then
  210.          mwinit = itinit
  211.          segact mwinit
  212.          if (jrepr.gt.0) then
  213.                itrep = jrepr
  214.                REPRIS = .TRUE.
  215.            CALL ACCTAB(ITREP,'MOT',I0,X0,'TEMPS_DE_REPRISE',L0,IP0,
  216.      &                      'FLOTTANT',I1,XTINI,CHARRE,L1,IP1)
  217.                IF (IERR.NE.0) RETURN
  218.          endif
  219.        else
  220.          TYPRET = ' '
  221.          CALL ACCTAB(ITINIT,'MOT',I0,X0,'REPRISE',L0,IP0,
  222.      &                     TYPRET,I1,X1,CHARRE,L1,ITREP)
  223.          IF (IERR.NE.0) RETURN
  224.          IF (ITREP.NE.0) THEN
  225.             IF (TYPRET.EQ.'TABLE   ') THEN
  226.                REPRIS = .TRUE.
  227.                CALL ACCTAB(ITREP,'MOT',I0,X0,'TEMPS_DE_REPRISE',L0,IP0,
  228.      &                      'FLOTTANT',I1,XTINI,CHARRE,L1,IP1)
  229.                IF (IERR.NE.0) RETURN
  230.             ELSE
  231.                CALL ERREUR(487)
  232.                RETURN
  233.             ENDIF
  234.          ENDIF
  235.        endif
  236.       ENDIF
  237.       IF (IIMPI.EQ.333) write(ioimp,*)'devalo: TEMPS_DE_REPRISE=',XTINI
  238. *
  239. ************************************************************************
  240. *     Parametres temporels: pas de temps constant
  241. ************************************************************************
  242. *
  243.       NPC1 = NP + 1
  244.       SEGINI,MTNUM
  245.       KTNUM = MTNUM
  246.       XDT(1) = PDT
  247.       XTEMPS(1) = XTINI
  248. c  ancienne methode
  249. c       DO 10 I = 2,NPC1
  250. c          XDT(I) = PDT
  251. c          XTEMPS(I) = XTEMPS(I-1) + PDT
  252. c  10   CONTINUE
  253. c new methode (bp,2020) : on constate une derive (accumulation d'erreur) 
  254. *     --> on remplace par un produit (un peu + cher mais + precis)
  255.       DO 10 I = 2,NPC1
  256.          XDT(I) = PDT
  257.          XTEMPS(I) = XTINI + (DBLE(I-1)*PDT)
  258.  10   CONTINUE
  259.  
  260. *
  261. ************************************************************************
  262. *     Recherche du nombre de modes: autant que de points de reference
  263. ************************************************************************
  264. *
  265.       MPREF = KPREF
  266.       NA1 = IPOREF(/1)
  267. c     on intialise NB1 a 1; le segment sera eventuellement ajuste
  268. c     lors du remplissage par DEVTRA (OU D2VTRA)
  269.       NB1  = 1
  270.       NB1K = 1
  271.       NB1C = 1
  272.       NB1M = 1
  273.       NOPER=0
  274.       SEGINI,MTQ,MTKAM
  275.       SEGINI,LOCLFA
  276.       KOCLFA = LOCLFA
  277.       KTQ = MTQ
  278.       KTKAM = MTKAM
  279. *
  280. ************************************************************************
  281. *     Gestion des segments descriptifs des liaisons
  282. ************************************************************************
  283. *
  284.       NLIAA  = 0
  285.       NIPALA = 0
  286.       NXPALA = 0
  287.       NPLAA  = 0
  288.       NPLA   = 0
  289.       NLIAB  = 0
  290.       NIPALB = 0
  291.       NXPALB = 0
  292.       NIP    = 0
  293.       NPLBB  = 0
  294.       NPLB   = 0
  295.       NPLSB  = 0
  296.       IDIMB  = 0
  297.       NA2    = 0
  298.       NSB    = 0
  299.       KCPR   = 0
  300.       NTVAR  = 6 + 4 * IDIM
  301. *
  302. *     MTRA indiquera la presence de liaisons POLYNOMIALEs
  303. *     (on suppose un maximum de 100 liaisons en base A)
  304. *+*   passe a 10000 le 28/1/93
  305.       NTRA   = 10000
  306.       SEGINI,MTRA
  307. *
  308.       IF (ITLIA.NE.0) THEN
  309.        if (lmodyn) then
  310.          mtbas = itbas
  311.          ipbmod = itbmod
  312.          call ecrcha('MAIL')
  313.          call ecrobj('MMODEL',ipbmod)
  314.          call extrai
  315.          call lirobj('MAILLAGE',ipt1,0,iret)
  316.          if (ierr.ne.0) return
  317.          if (iret.ne.1) then
  318.           write(6,*) 'pb developpement devalo'
  319.           return
  320.          endif
  321.          itmail = ipt1
  322.          segact ipt1
  323.          segini ncpr
  324.          do ie = 1,ipt1.num(/2)
  325.           ncpr(ipt1.num(1,ie)) = 1
  326.          enddo
  327.  
  328.          mmodel = itlia
  329.          segact mmodel
  330.          n1 = kmodel(/1)
  331.          segini mmode1,mmode2
  332.          klia = 0
  333.          klib = 0
  334.          do ik = 1,kmodel(/1)
  335.            imodel = kmodel(ik)
  336.            segact imodel
  337.            meleme = imamod
  338.            segact meleme
  339.  
  340.            if (ncpr(num(1,1)).gt.0) then
  341.              klia = klia + 1
  342.              mmode1.kmodel(klia) = imodel
  343.            else
  344.              klib = klib + 1
  345.              mmode2.kmodel(klib) = imodel
  346.            endif
  347.  
  348.          enddo
  349.          segdes mmodel
  350.          n1 = klia
  351.          itla = mmode1
  352.          segadj mmode1
  353.          n1 = klib
  354.          segadj mmode2
  355.          itlb = mmode2
  356.          segsup ncpr
  357.          segini moliai
  358.          modtla = itla
  359.          if (klia.eq.0) modtla = 0
  360.          modtlb = itlb
  361.          if (klib.eq.0) modtlb = 0
  362. * distingue liasons A et B
  363.          ITLIA = MOLIAI
  364. *
  365.        else
  366. *
  367.          TYPRET = ' '
  368.          CALL ACCTAB(ITLIA,'MOT',I0,X0,'LIAISON_A',L0,IP0,
  369.      &                    TYPRET,I1,X1,CHARRE,L1,ITLA)
  370.          IF (IERR.NE.0) RETURN
  371. *
  372. *        Liaisons sur la base A : determination des parametres
  373. *
  374.          IF (ITLA.NE.0.and.(.not.lmodyn)) THEN
  375.             IF (TYPRET.EQ.'TABLE   ') THEN
  376.                CALL DYNE21(ITLA,PDT,MTRA,KLIAA,KXPALA,KPLAA,KIPALA)
  377.                IF (IERR.NE.0) RETURN
  378.                NLIAA  = KLIAA
  379.                NIPALA = KIPALA
  380.                NXPALA = KXPALA
  381.                NPLAA  = KPLAA
  382.                NPLA   = NA1
  383.             ELSE
  384.                CALL ERREUR(492)
  385.                RETURN
  386.             ENDIF
  387.          ENDIF
  388. *
  389. *        Liaisons sur la base B : determination des parametres
  390. *
  391.          TYPRET = ' '
  392.          CALL ACCTAB(ITLIA,'MOT',I0,X0,'LIAISON_B',L0,IP0,
  393.      &                    TYPRET,I1,X1,CHARRE,L1,ITLB)
  394.          IF (IERR.NE.0) RETURN
  395.          IF (ITLB.NE.0.and.(.not.lmodyn)) THEN
  396.             IF (TYPRET.EQ.'TABLE   ') THEN
  397.                CALL DYNE22(ITLB,KLIAB,KXPALB,KPLBB,KPLB,KDIMB,KCPR,
  398.      &                     KIPALB,KNIP)
  399.                IF (IERR.NE.0) RETURN
  400.                NLIAB  = KLIAB
  401.                NIPALB = KIPALB
  402.                NXPALB = KXPALB
  403.                NPLBB  = KPLBB
  404.                NPLB   = KPLB
  405.                IDIMB  = KDIMB
  406.                NIP = KNIP
  407.             ELSE
  408.                CALL ERREUR(493)
  409.                RETURN
  410.             ENDIF
  411.          ENDIF
  412. *
  413.        endif
  414. *
  415.          if (lmodyn.and.klia.gt.0) then
  416.                CALL DYNE71(ITLA,PDT,MTRA,KLIAA,KXPALA,KPLAA,KIPALA)
  417.                IF (IERR.NE.0) RETURN
  418.                NLIAA  = KLIAA
  419.                NIPALA = KIPALA
  420.                NXPALA = KXPALA
  421.                NPLAA  = KPLAA
  422.                NPLA   = NA1
  423.          endif
  424.          if (lmodyn.and.klib.gt.0) then
  425.                CALL DYNE72(ITLB,KLIAB,KXPALB,KPLBB,KPLB,KDIMB,KCPR,
  426.      &                     KIPALB,KNIP,ITCARA)
  427.                IF (IERR.NE.0) RETURN
  428.                NLIAB  = KLIAB
  429.                NIPALB = KIPALB
  430.                NXPALB = KXPALB
  431.                NPLBB  = KPLBB
  432.                NPLB   = KPLB
  433.                IDIMB  = KDIMB
  434.                NIP = KNIP
  435.          endif
  436.       ENDIF
  437.       SEGINI,LOCLB1
  438.       KOCLB1 = LOCLB1
  439. *
  440. *     Les segments seront remplis dans le s-p DEVLIA:
  441. *
  442.       SEGINI,MTLIAA
  443.       SEGINI,MTLIAB
  444.       KTLIAA = MTLIAA
  445.       KTLIAB = MTLIAB
  446.       IF (NLIAB.NE.0) THEN
  447.          NCPR = KCPR
  448.          LCPR = nbpts    
  449.          IN = 0
  450.          DO 20 I = 1,LCPR
  451.             IF (NCPR(I).NE.0) THEN
  452.                IN = IN + 1
  453.                JPLIB(IN) = I
  454.             ENDIF
  455.  20         CONTINUE
  456. *        en do
  457.          SEGSUP,NCPR
  458.       ENDIF
  459. *
  460. ************************************************************************
  461. *     Segment des deformees modales:
  462. ************************************************************************
  463.  
  464. ***** Cas table BASE_MODALE et RAIDEUR_ET_MASSE *****
  465.  
  466.       IF (ITKM.GT.0) THEN
  467.          TYPRET = ' '
  468.          CALL ACCTAB(ITKM,'MOT',I0,X0,'BASE_MODALE',L0,IP0,
  469.      &               TYPRET,I1,X1,CHARRE,L1,ITBAS2)
  470.       ELSE
  471.          ITBAS2=ITBAS
  472.       ENDIF
  473.  
  474. c       IF (ITBAS.NE.0.and.(.not.lmodyn)) THEN
  475.       IF (ITBAS2.NE.0.and.(.not.lmodyn)) THEN
  476.  
  477.         CALL ACCTAB(ITBAS2,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  478.      &                     'MOT',I1,X1,MONMOT,L1,IP1)
  479.         IF (IERR.NE.0) RETURN
  480.         IF (IIMPI.EQ.333) write(ioimp,*) ITBAS2,'de SOUSTYPE',MONMOT
  481. *
  482. *      -Cas ou la base est unique
  483.         IF (MONMOT(1:11).EQ.'BASE_MODALE') THEN
  484.           NSB = 1
  485.           NA2 = NA1
  486. *         changement de dimension en cas de corps rigide
  487.           CALL ACCTAB(ITBAS2,'MOT',I0,X0,'MODES',L0,IP0,
  488.      &                    'TABLE',I1,X1,' ',L1,IBAS)
  489.           IP = 0
  490.  22       CONTINUE
  491.             IP = IP + 1
  492.             TYPRET = ' '
  493.             CALL ACCTAB(IBAS,'ENTIER',IP,X0,' ',L0,IP0,
  494.      &                        TYPRET,I1,X1,CHARRE,L1,ITP1)
  495.             IF (IERR.NE.0) RETURN
  496.             IF (TYPRET.NE.'TABLE') GOTO 23
  497.             IF (ITP1.LE.0)         GOTO 23
  498.             TYPRET = ' '
  499.             CALL ACCTAB(ITP1,'MOT',I0,X0,'CORPS_RIGIDE',L0,IP0,
  500.      &                        TYPRET,I1,X1,MONMOT,L1,IP1)
  501.             IF (IERR.NE.0) RETURN
  502.             IF (TYPRET.EQ.'MOT') THEN
  503.               IF (MONMOT(1:4).EQ.'VRAI') THEN
  504.                 if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3
  505.                 if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6
  506.                 GOTO 23
  507.               ENDIF
  508.             ENDIF
  509.           GOTO 22
  510.  23       CONTINUE
  511.  
  512. *      -Cas ou la base est un ensemble de bases
  513.         ELSE
  514.           IB = 0
  515.           NA2 = 0
  516. *         changement de dimension en cas de corps rigide
  517.           IR = 0
  518.  30       CONTINUE
  519.             IB = IB + 1
  520. c             write(ioimp,*) IB,'ieme base de l ensemble'
  521.             TYPRET = ' '
  522.             CALL ACCTAB(ITBAS2,'ENTIER',IB,X0,' ',L0,IP0,
  523.      &                         TYPRET,I1,X1,CHARRE,L1,ITBB)
  524.             IF (IERR.NE.0) RETURN
  525. c         --cas lecture table de la IB ieme base modale ok
  526.             IF (ITBB.NE.0) THEN
  527.             IF (TYPRET.EQ.'TABLE   ') THEN
  528.                CALL ACCTAB(ITBB,'MOT',I0,X0,'MODES',L0,IP0,
  529.      &                        'TABLE',I1,X1,' ',L1,IBAS)
  530.                IF (IERR.NE.0) RETURN
  531.                NNA2 = 0
  532.                IP = 0
  533.  32            CONTINUE
  534.                  IP = IP + 1
  535. c             write(ioimp,*) '  +',IP,'ieme mode de la ',IB,'ieme base'
  536.                  TYPRET = ' '
  537.                  CALL ACCTAB(IBAS,'ENTIER',IP,X0,' ',L0,IP0,
  538.      &                            TYPRET,I1,X1,CHARRE,L1,ITPP)
  539.                  IF (IERR.NE.0) RETURN
  540. c              --cas lecture table du IP ieme mode ok
  541.                  IF (ITPP.NE.0) THEN
  542.                  IF (TYPRET.EQ.'TABLE   ') THEN
  543. *                 changement de dimension en cas de corps rigide
  544.                   IF (IR.GT.1) GOTO 24
  545.                   TYPRET = ' '
  546.                   CALL ACCTAB(ITPP,'MOT',I0,X0,'CORPS_RIGIDE',L0,IP0,
  547.      &                    TYPRET,I1,X1,MONMOT,L1,IP1)
  548.                   IF (IERR.NE.0) RETURN
  549.                   IF (TYPRET.EQ.'MOT') THEN
  550.                     IF (MONMOT(1:4).EQ.'VRAI') THEN
  551.                       if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3
  552.                       if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6
  553.                     ENDIF
  554.                   ENDIF
  555.  24               CONTINUE
  556.                   NNA2 = NNA2 + 1
  557.                   GOTO 32
  558. c              --fin du cas lecture table du IP ieme mode ok
  559.                  ELSE
  560.                     CALL ERREUR(491)
  561.                     RETURN
  562.                  ENDIF
  563.                  ENDIF
  564. c              --fin du cas lecture table du IP ieme mode non ok
  565.                NA2 = MAX(NNA2,NA2)
  566.                GOTO 30
  567. c         --fin du cas lecture table de la IB ieme base modale ok
  568.             ELSE
  569.                CALL ERREUR(491)
  570.                RETURN
  571.             ENDIF
  572.             ENDIF
  573. c         --fin du cas lecture table de la IB ieme base modale non ok
  574.           NSB = IB - 1
  575.         ENDIF
  576. *      -fin distinction base modale simple / ensemble de bases
  577.         NPLSB = NPLB
  578.  
  579.  
  580. ***** Cas table PASAPAS *****
  581.  
  582.       ELSEIF (LMODYN) THEN
  583.  
  584.        mchelm = itcara
  585.        segact mchelm
  586.        n1 = imache(/1)
  587.        segini icma,icnna2
  588.           mtbas = ITBAS
  589.           MMODEL = ITBMOD
  590.           segact MMODEL
  591.           kstru = 0
  592.           do  im = 1,kmodel(/1)
  593.             imodel = kmodel(im)
  594.             segact imodel
  595. * recherche sommaire nombre de sous-structures independantes
  596.         do 46 in = 1,n1
  597.           meleme = imache(in)
  598.           if (meleme.ne.imamod) goto 46
  599.           if (conche(in).ne.conmod) goto 46
  600.           segact meleme
  601.           mchaml = ichaml(in)
  602.           segact mchaml
  603.           n2 = ielval(/1)
  604.  
  605.           do io = 1,n2
  606.             if (nomche(io)(1:4).eq.'CGRA') then
  607. * recherche corps rigide
  608.               if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3
  609.               if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6
  610.             else if (nomche(io)(1:4).eq.'DEFO') then
  611.               melval = ielval(io)
  612.               segact melval
  613. * assume que le maillage modèle  se réduit au point support
  614.               icdef1 = ielche(1,1)
  615.               call ecrcha('NOMU')
  616.               call ecrcha('MAIL')
  617.               call ecrobj('CHPOINT ',icdef1)
  618.               call extrai
  619.               call lirobj('MAILLAGE', icmaio,1,iret)
  620.               if (ierr.ne.0) return
  621.               if (kstru.eq.0) then
  622.                  kstru = 1
  623.                  icma(**)=icmaio
  624.                  icnna2(**)=1
  625.                  lsstru(im) = kstru
  626.               endif
  627.               if (in.gt.1) then
  628.                 ipt5 = icmaio
  629.                 do ic = 1,kstru
  630.                   icmic = icma(ic)
  631.                   CALL INTERB(icmaio,icmic,IRETIB,icinte)
  632.                   if (iretib.eq.0) then
  633.                      ipt6 = icinte
  634.                      segact ipt6,ipt5
  635.                      if (ipt5.num(/2).eq.ipt6.num(/2)) then
  636.                        segsup ipt6
  637.                        icnna2(ic) = icnna2(ic) + 1
  638.                        lsstru(im) = ic
  639.                        goto 47
  640.                      endif
  641.                      segsup ipt6
  642.                   endif
  643.                 enddo
  644.                 kstru = kstru + 1
  645.                 icma(**) = icmaio
  646.                 icnna2(**) = 1
  647.                 lsstru(im) = kstru
  648.               endif
  649.               goto 47
  650.             endif
  651.           enddo
  652.  46     continue
  653.  47     continue
  654.             segdes imodel
  655.           enddo
  656.             NSB = icma(/1)
  657.             NA2 = icnna2(1)
  658.             do ic = 1,icnna2(/1)
  659.              na2 = MAX(icnna2(ic),NA2)
  660.             enddo
  661.             nsstru = kstru
  662.             segsup icma,icnna2
  663.           segdes mmodel
  664. *
  665.       ENDIF
  666. *
  667. *   on met NPLSB a 1 car le calcul actuel est debile
  668. *   on ajuste la dimension dans dyne26
  669. *
  670. *                    MP
  671. *
  672.       NPLSB=1
  673.       SEGINI,MTPHI
  674.       KTPHI = MTPHI
  675. *
  676. ************************************************************************
  677. *     Variables au cours d'un pas de temps:
  678. ************************************************************************
  679. *
  680.       SEGINI,MTPAS
  681.       KTPAS = MTPAS
  682. *
  683. ************************************************************************
  684. *     Initialisation du segment representant les chargements ( bases A
  685. *     et B ), il sera rempli dans le s-p DEVFX0:
  686. ************************************************************************
  687. *
  688.       NPFEXA = NA1
  689.       NPFEXB = 0
  690.       SEGINI,MTFEX
  691.       KTFEX = MTFEX
  692. *
  693. ************************************************************************
  694. *     Gestion de la table definissant les resultats attendus:
  695. *     ( par la suite, on s'occupera de TREDU )
  696. ************************************************************************
  697. *
  698.       CALL DYNE15(ITSORT,KPREF,NA1,NP,NINS,ITLIA,KTRES,IPMAIL,REPRIS,
  699.      &        ICHAIN,NTVAR,NLIAA,NLIAB,NPLB,IDIMB,MTRA,ITCARA,lmodyn,
  700.      & na1)
  701.       IF (IERR.NE.0) RETURN
  702.       MTRES = KTRES
  703. *
  704. ************************************************************************
  705. *     Creation des objets resultats :
  706. ************************************************************************
  707. *
  708.       SEGINI,MSAM
  709.       KSAM=MSAM
  710.       DO 100 IP=1,NPLB
  711.          JPLIBB(IP)=JPLIB(IP)
  712.  100  CONTINUE
  713.       CALL DYNE17(ITBAS,ITKM,IPMAIL,KTRES,KPREF,NPLAA,NXPALA,KSAM,
  714.      & lmodyn)
  715.       IF (IERR.NE.0) RETURN
  716.       MSAM=KSAM
  717.       SEGSUP,MSAM
  718. *
  719. ************************************************************************
  720. *    Impressions :
  721. ************************************************************************
  722.  
  723.       IF (IIMPI.EQ.333) THEN
  724.          WRITE(IOIMP,*)'DEVALO : nombre de pas de temps ',NP
  725.          WRITE(IOIMP,*)'DEVALO : temps de reprise ',XTINI
  726. *
  727.          WRITE(IOIMP,*)'   segment MTLIAB'
  728.          WRITE(IOIMP,*)'     NLIAB  =',IPALB(/1)
  729.          WRITE(IOIMP,*)'     NIPALB =',IPALB(/2)
  730.          WRITE(IOIMP,*)'     NXPALB =',XPALB(/2)
  731.          WRITE(IOIMP,*)'     NPLBB  =',IPLIB(/2)
  732.          WRITE(IOIMP,*)'     NPLB   =',JPLIB(/1)
  733.          WRITE(IOIMP,*)'     NIP    =',XABSCI(/2)
  734. *
  735.          WRITE(IOIMP,*)'   segment MTLIAA'
  736.          WRITE(IOIMP,*)'     NLIAA  =',IPALA(/1)
  737.          WRITE(IOIMP,*)'     NIPALA =',IPALA(/2)
  738.          WRITE(IOIMP,*)'     NXPALA =',XPALA(/2)
  739.          WRITE(IOIMP,*)'     NPLAA  =',IPLIA(/2)
  740.          WRITE(IOIMP,*)'     NPLA   =',JPLIA(/1)
  741. *
  742.          WRITE(IOIMP,*)'   segment MTRES'
  743.          WRITE(IOIMP,*)'     NLSA   =',XRESLA(/1)
  744.          WRITE(IOIMP,*)'     NVALA  =',XRESLA(/3)
  745.          WRITE(IOIMP,*)'     NLSB   =',XRESLB(/1)
  746.          WRITE(IOIMP,*)'     NVALB  =',XRESLB(/3)
  747.          WRITE(IOIMP,*)'     NRES   =',XRES(/1)
  748.          WRITE(IOIMP,*)'     NCRES  =',XRES(/2)
  749.          WRITE(IOIMP,*)'     NPRES  =',XRES(/3)
  750.          WRITE(IOIMP,*)'     NREP   =',XREP(/1)
  751.          WRITE(IOIMP,*)'     NTVAR  =',ILIREB(/2)
  752.          WRITE(IOIMP,*)'     NLIAB  =',XMREP(/1)
  753.          WRITE(IOIMP,*)'     IDIMB  =',XMREP(/3)
  754.          WRITE(IOIMP,*)'     NLIAA  =',ILPOLA(/1)
  755. *
  756.          WRITE(IOIMP,*)'   segment MTFEX'
  757.          WRITE(IOIMP,*)'     NPC1   =',FEXA(/2)
  758.          WRITE(IOIMP,*)'     NPLB   =',FEXPSM(/1)
  759.          WRITE(IOIMP,*)'     IDIMB  =',FEXPSM(/4)
  760.          WRITE(IOIMP,*)'     NPFEXA =',FEXA(/1)
  761. *
  762.          DO 1000 IP = 1,NPLB
  763.             WRITE(IOIMP,*)'DEVALO :   JPLIB(',IP,') =',JPLIB(IP)
  764.  1000    CONTINUE
  765.       ENDIF
  766. *
  767.       RETURN
  768.       END
  769.  
  770.  
  771.  
  772.  
  773.  
  774.  
  775.  
  776.  
  777.  
  778.  
  779.  
  780.  
  781.  
  782.  
  783.  

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