Télécharger la plaquette Cast3M


fr en

Télécharger rima.eso

Retour à la liste

Numérotation des lignes : 

rima

  1. C RIMA      SOURCE    FANDEUR   22/03/01    21:15:08     11301          
  2.       subroutine rima
  3.  
  4. ********************************************
  5. *   traduction objet rigi en matrik
  6. *              ou    matrik en rigi
  7. *
  8. *******************************************
  9.  
  10.       IMPLICIT INTEGER(I-N)
  11.       IMPLICIT REAL*8 (A-H,O-Z)
  12.  
  13.  
  14. -INC PPARAM
  15. -INC CCOPTIO
  16. -INC SMLENTI
  17.       POINTEUR NOFSET.MLENTI
  18. -INC SMELEME
  19.       POINTEUR MELPRI.MELEME,MELDUA.MELEME
  20.       POINTEUR SMLPRI.MELEME,SMLDUA.MELEME
  21. -INC SMRIGID
  22. -INC SMLMOTS
  23. *INC SMMATRIK
  24.  
  25.       CHARACTER*8 MOTCLE(1)
  26.       DATA MOTCLE /'NSYM'/
  27.  
  28.       SEGMENT MATRIK
  29.       REAL*8  COEMTK(NMATRI)
  30.       INTEGER jRIGEL(NRIGE,NMATRI)
  31.       INTEGER KSYM,KMINC,KMINCP,KMINCD,KIZM
  32.       INTEGER KISPGT,KISPGP,KISPGD
  33.       INTEGER KNTTT,KNTTP,KNTTD
  34.       INTEGER KIDMAT(NKID)
  35.       INTEGER KKMMT(NKMT)
  36.       ENDSEGMENT
  37.  
  38.       SEGMENT jMATRI
  39.       CHARACTER*8 LISPRj(NBME),LISDUb(NBME)
  40.       INTEGER LIZAFM(NBSOUS,NBME)
  41.       INTEGER KSPGP,KSPGD
  42.       ENDSEGMENT
  43.  
  44. C Stokage matrices elementaires non assemblees (valeurs)
  45.       SEGMENT IZAFM
  46.       REAL*8  AM(NBEL,NP,MP)
  47.       ENDSEGMENT
  48.       POINTEUR IPM1.IZAFM,IPM2.IZAFM,IPM3.IZAFM,IPM4.IZAFM
  49.       POINTEUR IPM5.IZAFM,IPM6.IZAFM,IPM7.IZAFM,IPM8.IZAFM
  50.       POINTEUR IPM9.IZAFM
  51.  
  52. C Reperage des inconnues
  53.       SEGMENT MINC
  54.       CHARACTER*8 LISjNC(NBI)
  55.       INTEGER     NPOS(NPT+1)
  56.       INTEGER     MPOS(NPT,NBI+1)
  57.       ENDSEGMENT
  58.       POINTEUR MINCP.MINC,MINCD.MINC
  59.  
  60.       SEGMENT PMORS
  61.       INTEGER IA (NTT+1)
  62.       INTEGER JA (NJA)
  63.       ENDSEGMENT
  64.       POINTEUR PMS1.PMORS,PMS2.PMORS
  65.  
  66. C Segment de stokage
  67.       SEGMENT IZA
  68.       REAL*8  A(NBVA)
  69.       ENDSEGMENT
  70.       POINTEUR IZA1.IZA,IZA2.IZA,IZAU.IZA,IZAL.IZA,ISA.IZA
  71.  
  72.       SEGMENT IDMAT
  73.       INTEGER KZA(NTT),NUIA(NTT,2)
  74.       INTEGER NUAN(NPT),NUNA(NPT)
  75.       INTEGER IDIAG
  76.       INTEGER IDESCL(NBLK)
  77.       INTEGER IDESCU(NBLK)
  78.       INTEGER NLDBLK(NBLK+1)
  79.       ENDSEGMENT
  80.  
  81. C*******************************************************************
  82. C
  83. C    REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES  puis assemblees
  84. C    (description par sous-zone associees a un operateur)
  85. C
  86. C   IRIGEL(1,I)   : POINTEUR SUR L'OBJET GEOMETRIE (Inconnues primales)
  87. C   IRIGEL(2,I)   : POINTEUR SUR L'OBJET GEOMETRIE (Inconnues duales)
  88. C   IRIGEL(3,I)   : Non utilise (POINTEUR SUR LE SEGMENT DESCRIPTIF D'UNE
  89. C                                MATRICE ELEMENTAIRE.(SEGMENT DESCR)
  90. C   IRIGEL(4,I)   : POINTEUR SUR LE SEGMENT CONTENANT LES POINTEURS
  91. C                        DES MATRICES DE MRIGIDITE DE CHAQUE ELEMENTS.
  92. C                        (SEGMENT IMATRI)
  93. C   IRIGEL(5,I)   : Non utilise
  94. C   IRIGEL(6,I)   : Non utilise
  95. C   IRIGEL(7,1)   : 0   LA MATRICE EST SYMETRIQUE
  96. C                 : 1   LA MATRICE EST ANTISYMETRIQUE
  97. C                 : 2   LA MATRICE EST NON SYMETRIQUE
  98. C                 : 3   LA MATRICE EST RECTANGULAIRE avec SPGP # SPGD
  99. C                 : 4   LA MATRICE EST type 3 et CCt (on ne stoke que C)
  100. C                 : 5   LA MATRICE EST diagonale
  101. C                 : 6   LA MATRICE EST deja assemblee en morse
  102.  
  103. C KSIM  =0 matrice symetrique  =2 matrice non symetrique
  104. C KMINC , KMINCP , KMINCD : pointeur sur MINC repartition des inconnues
  105. C totales primales et duales                            PROFKS PKINC
  106. C KIZM  : pointeur sur les connectivites globales
  107. C KISPGT KISPGP KISPGD ; SPG assemble pour inc totales,prim et dua
  108. C KNTTT  KNTTP  KNTTD  ; nb d'inconnues total
  109.  
  110.  
  111. C KIDMAT: pointeur sur stokage bloc IDMAT (Cholevski)    TRIAKS
  112. C KS2B  : pointeur sur second membre(IZA)cree ds PROFKS calcule ds KASMBR
  113. C KMORS : pointeur sur profil Morse(PMORS)               ASSMT (KALMOR)
  114. C KISA  : pointeur sur stokage Morse(IZA)                ASSMT (KALMOR)
  115. C KMRST : pointeur sur profil Morse(PMORS)de AAt         PROFKS(KALMOR)
  116. C KIST  : pointeur sur stokage Morse(IZA) de AAt         PROFKS(KALMOR)
  117. C KCLIM : pointeur sur stokage C lim (CHPT)
  118. C KTRING: 0 pas triangulée 1 triangulée
  119.  
  120. C  nkid=9 :  IDMATP,IDMATD,KS2B,KMORS,KISA,KMRST,KIST,KCLIM,KTRING
  121.  
  122. C LIZAFM(NBSOUS,.) description par sous-objet geometrique -> IZAFM
  123. C KSPGP , KSPGD : SPG pour les inconnues primales et duales
  124. C  nkmt=7 :  KMMT,MATRIU,MATRIP,IZDU,IZDP,IZFU,IZFP
  125. C                               (IZA)(IZA)(IZA)(IZA)
  126. *  NPT nb de noeud  NBI nb de composantes total  NTT nb total de DDL
  127. *  MPOS(NPT,NBI+1) = 0 si l'inconnue j n est pas defini au noeud i
  128. *            sinon = k rang de cette inconnue pour le noeud i
  129. *  MPOS(i,NBI+1) nb d'inconnues au noeud i
  130. *  NPOS(NPT)     Position de la 1ere inconnue du noeud i
  131. *  NPOS et MPOS  sont donnes ds la numerotation optimisee
  132. *  KZA(NTT)    Longueur de chaque ligne de la matrice (diag comprise)
  133. *  NUIA(NTT,2) 1/ numero du bloc dans lequel se trouve la ligne i de la
  134. *                 matrice
  135. *              2/ position du debut de la ligne dans le segment IZA - 1
  136.  
  137. C*******************************************************************
  138.  
  139.       segment iztra
  140.       character*4 lisp(l1)
  141.       integer     itab(l1,l2),ltab(l1)
  142.       endsegment
  143.       segment jztra
  144.       character*4 lisd(l3)
  145.       integer     jtab(l3,l2),ktab(l3)
  146.       endsegment
  147.  
  148.  
  149.       character*8 type,typp
  150.       character*4 nomi
  151. *      WRITE(IOIMP,*) ' entree dans rima'
  152.       impj = 1
  153. *     impj = 0
  154.       impr=0
  155.  
  156.       call quetyp(typp,0,iret)
  157. *     WRITE(IOIMP,*)' typp ',typp
  158.  
  159.       if(typp.eq.'MATRIK')then
  160.          type = typp
  161.          CALL LIROBJ(TYPE,MATRIK,1,IRET)
  162. *     WRITE(IOIMP,*)' iret ',iret,' ierr ',ierr
  163.          CALL LIRMOT(MOTCLE,1,IVAL,0)
  164. *     WRITE(IOIMP,*)' IVAL ',IVAL
  165.          type ='MATRIK'
  166.          segact matrik
  167.          nmatri = jrigel(/2)
  168.          if(impj.eq.0)then
  169.             WRITE(IOIMP,*)'  MATRIK '
  170.             WRITE(IOIMP,*)' nmatri ',nmatri
  171.             nrigel = jrigel(/1)
  172.             do ik=1,nmatri
  173.                WRITE(IOIMP,*) ik
  174.                WRITE(IOIMP,*)(jrigel(il,ik),il=1,nrigel)
  175.                WRITE(IOIMP,*)' '
  176.                meleme= jrigel(1,ik)
  177.                segact meleme
  178.                nbs=lisous(/1)
  179.                WRITE(IOIMP,*)' nbre ssobjt mail p',nbs
  180.                if(nbs.eq.0) then
  181.                   nbnn=num(/1)
  182.                   nbl= num(/2)
  183.                   do iel=1,nbl
  184.                      WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn)
  185.                   enddo
  186.                endif
  187.                if(nbs.ge.1)then
  188.                   WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs)
  189.                   do iss=1,nbs
  190.                      ipt1=lisous(iss)
  191.                      segact ipt1
  192.                      nbnn=ipt1.num(/1)
  193.                      nbl =ipt1.num(/2)
  194.                      WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn
  195.                      do il = 1,nbl
  196.                         WRITE(IOIMP,*)il,'  ',(ipt1.num(iop,il),iop=1
  197.      $                       ,nbnn)
  198.                      enddo
  199.                      segdes ipt1
  200.                   enddo
  201.                endif
  202.                segdes meleme
  203.                meleme= jrigel(2,ik)
  204.                segact meleme
  205.                nbs=lisous(/1)
  206.                WRITE(IOIMP,*)' nbre ssobjt mail d',nbs
  207.                if(nbs.eq.0) then
  208.                   nbnn=num(/1)
  209.                   nbl= num(/2)
  210.                   do iel=1,nbl
  211.                      WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn)
  212.                   enddo
  213.                endif
  214.                if(nbs.ge.1)then
  215.                   WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs)
  216.                   do iss=1,nbs
  217.                      ipt1=lisous(iss)
  218.                      segact ipt1
  219.                      nbnn=ipt1.num(/1)
  220.                      nbl =ipt1.num(/2)
  221.                      WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn
  222.                      do il = 1,nbl
  223.                         WRITE(IOIMP,*)il,'  ',(ipt1.num(iop,il),iop=1
  224.      $                       ,nbnn)
  225.                      enddo
  226.                      segdes ipt1
  227.                   enddo
  228.                endif
  229.                segdes meleme
  230.             enddo
  231.             WRITE(IOIMP,*)'ksym kminc kmincd kizm'
  232.             WRITE(IOIMP,*) ksym,kminc,kmincd,kizm
  233.             WRITE(IOIMP,*)'kispgt kispgp kispgd knttt knttp knttd'
  234.             WRITE(IOIMP,*) kispgt,kispgp,kispgd,knttt,knttp,knttd
  235.             nkid=kidmat(/1)
  236.             WRITE(IOIMP,*)' kidmat '
  237.             WRITE(IOIMP,*)(kidmat(il),il=1,nkid)
  238.             nkmt=kkmmt(/1)
  239.             WRITE(IOIMP,*)' kkmmt  '
  240.             WRITE(IOIMP,*)(kkmmt(il),il=1,nkmt)
  241.             do ik=1,nmatri
  242.                WRITE(IOIMP,*)' ik ',ik
  243.                jmatri = jrigel(4,ik)
  244.                segact jmatri
  245.                nbme = lisprj(/2)
  246.                nbsous = lizafm(/1)
  247.                WRITE(IOIMP,*)' nbme nbsous kspgp kspgd '
  248.                WRITE(IOIMP,*)  nbme,nbsous,kspgp,kspgd
  249.                WRITE(IOIMP,*)' lisprj '
  250.                WRITE(IOIMP,*)(lisprj(il),il=1,nbme)
  251.                WRITE(IOIMP,*)' lisdub '
  252.                WRITE(IOIMP,*)(lisdub(il),il=1,nbme)
  253.                do im=1,nbme
  254.                   WRITE(IOIMP,*)' im ',im
  255.                   do is=1,nbsous
  256.                      WRITE(IOIMP,*)' is ',is
  257.                      izafm = lizafm(is,im)
  258.                      segact izafm
  259.                      nbel=am(/1)
  260.                      np=am(/2)
  261.                      mp=am(/3)
  262.                      WRITE(IOIMP,*)' nbel np mp'
  263.                      WRITE(IOIMP,*)  nbel,np,mp
  264.                      do ie=1,nbel
  265.                         WRITE(IOIMP,*)' iel ',ie
  266.                         do ip =1,np
  267.                            WRITE(IOIMP,*)ip,(am(ie,ip,kp),kp=1,mp)
  268.                         enddo
  269.                      enddo
  270.                      segdes izafm
  271.                   enddo
  272.                enddo
  273.                segdes jmatri
  274.             enddo
  275.          endif
  276.  
  277. * Ligne suivante inutile cf include SMRIGID
  278. *         nrige = 8
  279.          nrigel = 0
  280.          do ir=1,nmatri
  281.             ir7=jrigel(7,ir)
  282.             ncmul=1
  283.             if (ir7.EQ.4) ncmul=2
  284.             jmatri=jrigel(4,ir)
  285.             segact jmatri
  286.             nbs=lizafm(/1)
  287.             nbe=lizafm(/2)
  288.             nrigel=nrigel+nbs*nbe*ncmul
  289.          enddo
  290.  
  291.          segini mrigid
  292.          mtymat='MATRIK  '
  293.          iforig=ifour
  294.          jr=0
  295.          do ir=1,nmatri
  296.             ir7=jrigel(7,ir)
  297.             ncmul=1
  298.             if (ir7.EQ.4) ncmul=2
  299.             jmatri=jrigel(4,ir)
  300.             nbs=lizafm(/1)
  301.             nbe=lizafm(/2)
  302.             melpri =jrigel(1,ir)
  303.             meldua =jrigel(2,ir)
  304.             jg=nbs
  305.             segini nofset
  306.             if (melpri.eq.meldua) then
  307. *               Write(ioimp,*) 'Cas melpri=meldua'
  308.                meleme=melpri
  309.             else
  310. *               Write(ioimp,*) 'Cas melpri.ne.meldua'
  311. * On s'arrange pour que les deux maillages aient le même nombre de
  312. * sous-maillages
  313.                call fixmel(melpri,meldua,melpr2,meldu2,impr,iret)
  314.                if (iret.ne.0) goto 9999
  315.                melpri=melpr2
  316.                meldua=meldu2
  317.                segact melpri,meldua
  318.                nbsou1=melpri.lisous(/1)
  319.                nbsou2=meldua.lisous(/1)
  320. *               write(ioimp,*) 'nbsou1=',nbsou1
  321. *               write(ioimp,*) 'nbsou2=',nbsou2
  322. *               write(ioimp,*) 'nbs=',nbs
  323.                if (nbsou1.ne.nbsou2) goto 9999
  324.                if (max(1,nbsou1).ne.nbs) goto 9999
  325.                if (nbsou1.eq.0) then
  326.                   nbnn1=melpri.num(/1)
  327.                   nbnn2=meldua.num(/1)
  328.                   nbel1=melpri.num(/2)
  329.                   nbel2=meldua.num(/2)
  330.                   if (nbel1.ne.nbel2) goto 9999
  331.                   nofset.lect(1)=nbnn1
  332.                   nbnn=nbnn1+nbnn2
  333.                   nbelem=nbel1
  334.                   nbref=0
  335.                   nbsous=0
  336.                   segini meleme
  337.                   do ibelem=1,nbelem
  338.                      do ibnn1=1,nbnn1
  339.                         num(ibnn1,ibelem)=melpri.num(ibnn1,ibelem)
  340.                      enddo
  341.                      do ibnn2=1,nbnn2
  342.                         num(ibnn2+nbnn1,ibelem)=meldua.num(ibnn2,ibelem)
  343.                      enddo
  344.                   enddo
  345.                   segdes meleme
  346.                   segdes melpri,meldua
  347.                else
  348.                   nbsous=nbs
  349.                   nbref=0
  350.                   nbnn=0
  351.                   nbelem=0
  352.                   segini meleme
  353.                   do isous=1,nbs
  354.                      smlpri=melpri.lisous(isous)
  355.                      smldua=meldua.lisous(isous)
  356.                      segact smlpri,smldua
  357.                      nbnn1=smlpri.num(/1)
  358.                      nbnn2=smldua.num(/1)
  359.                      nbel1=smlpri.num(/2)
  360.                      nbel2=smldua.num(/2)
  361.                      if (nbel1.ne.nbel2) goto 9999
  362.                      nofset.lect(isous)=nbnn1
  363.                      nbnn=nbnn1+nbnn2
  364.                      nbelem=nbel1
  365.                      nbref=0
  366.                      nbsous=0
  367.                      segini ipt1
  368.                      do ibelem=1,nbelem
  369.                         do ibnn1=1,nbnn1
  370.                            ipt1.num(ibnn1,ibelem)=smlpri.num(ibnn1
  371.      $                          ,ibelem)
  372.                         enddo
  373.                         do ibnn2=1,nbnn2
  374.                            ipt1.num(ibnn2+nbnn1,ibelem)=smldua.num(ibnn2
  375.      $                          ,ibelem)
  376.                         enddo
  377.                      enddo
  378.                      segdes ipt1
  379.                      segdes smlpri,smldua
  380.                      lisous(isous)=ipt1
  381.                   enddo
  382.                   segdes meleme
  383.                endif
  384.             endif
  385. *       WRITE(IOIMP,*)' meleme ',meleme
  386. *       call ecmail(meleme,1)
  387.             segact meleme
  388.             nbs2 = lisous(/1)
  389.             if(nbs2 .eq.0) then
  390.                nbs2 = 1
  391.             endif
  392.             if (nbs.ne.nbs2) then
  393.                write(ioimp,*) 'lizafm non compatible avec meleme'
  394.                goto 9999
  395.             endif
  396. *       WRITE(IOIMP,*)' aa '
  397.             do icmul=1,ncmul
  398.                do is=1,nbs
  399.                   do in=1,nbe
  400.                      jr =jr+1
  401. *           WRITE(IOIMP,*)' jr ',jr,ir,is,in
  402.                      coerig(jr)=1.d0
  403.                      if(nbs.eq.1) then
  404.                         irigel(1,jr)=meleme
  405.                      else
  406.                         irigel(1,jr)=lisous(is)
  407.                      endif
  408. *           WRITE(IOIMP,*)' bb '
  409.                      irigel(2,jr)=0
  410.                      irigel(5,jr)=0
  411.                      irigel(6,jr)=0
  412.                      ii = jrigel(7,ir)
  413.                      if(ii.le.2) then
  414.                         irigel(7,jr)=ii
  415.  
  416.             if(IVAL.EQ.1.AND.ii.EQ.0)then
  417.             irigel(7,jr)=2
  418.             endif
  419.  
  420.                      elseif(ii.eq.3)then
  421. *                     WRITE(IOIMP,*)' support primal dual differents '
  422. *                     WRITE(IOIMP,*)'  on ne fait rien'
  423. *                     segsup mrigid
  424. *                     return
  425.                         irigel(7,jr)=2
  426.                      elseif(ii.eq.4)then
  427.                         irigel(7,jr)=2
  428.                         icc = 1
  429.                      elseif(ii.eq.5)then
  430.                         irigel(7,jr)=2
  431.                      elseif(ii.eq.6)then
  432.                         WRITE(IOIMP,*
  433.      $                       )' matrice de type morse on ne fait rien'
  434.                         goto 9999
  435. *                     segsup mrigid
  436. *                     return
  437.                      endif
  438.                      irigel(7,jr)=jrigel(7,ir)
  439.  
  440.             if(IVAL.EQ.1.AND.jrigel(7,ir).EQ.0)then
  441.             irigel(7,jr)=2
  442.             endif
  443.  
  444.                      irigel(8,jr)=0
  445. c*                     iforig=-1
  446.                      iforig=ifour
  447.                      jmatri = jrigel(4,ir)
  448.                      izafm=lizafm(is,in)
  449.                      segact izafm
  450.                      nbel=am(/1)
  451.                      nelrig=nbel
  452.                      if (icmul.eq.1) then
  453. * recopier les matrices élémentaires
  454.                         nligrp=am(/2)
  455.                         nligrd=am(/3)
  456.                         segini descr,xmatri
  457.                         irigel(3,jr)=descr
  458.                         irigel(4,jr)=Xmatri
  459.                         xmatri.symre=irigel(7,jr)
  460.                         do il=1,nligrp
  461.                            lisinc(il)=lisprj(in)(1:4)
  462.                            noelep(il)=il
  463.                         enddo
  464.                         do il=1,nligrd
  465.                            lisdua(il)=lisdub(in)(1:4)
  466.                            noeled(il)=il+nofset.lect(is)
  467.                         enddo
  468.                         do ip=1,nbel
  469.                            do iu=1,nligrp
  470.                               do ju=1,nligrd
  471.                                  re(ju,iu,ip)=am(ip,iu,ju)
  472.                               enddo
  473.                            enddo
  474.                         enddo
  475.                         segdes xmatri,descr
  476.                      else
  477. * recopier les transposées des matrices élémentaires
  478.                         nligrd=am(/2)
  479.                         nligrp=am(/3)
  480.                         segini descr,xmatri
  481.                         irigel(3,jr)=descr
  482.                         irigel(4,jr)=Xmatri
  483.                         xmatri.symre=irigel(7,jr)
  484.                         do il=1,nligrp
  485.                            lisinc(il)=lisdub(in)(1:4)
  486.                            noelep(il)=il+nofset.lect(is)
  487.                         enddo
  488.                         do il=1,nligrd
  489.                            lisdua(il)=lisprj(in)(1:4)
  490.                            noeled(il)=il
  491.                         enddo
  492.                         do ip=1,nbel
  493.                            do iu=1,nligrp
  494.                               do ju=1,nligrd
  495.                                  re(ju,iu,ip)=am(ip,ju,iu)
  496.                               enddo
  497.                            enddo
  498.                         enddo
  499.                         segdes xmatri,descr
  500.                      endif
  501.                      segdes izafm
  502.                   enddo
  503.                enddo
  504.             enddo
  505.  
  506.             segdes meleme
  507.             segdes jmatri
  508.             segsup nofset
  509.          enddo
  510.          segdes mrigid
  511.          segdes matrik
  512.          CALL ECRobj('RIGIDITE',mrigid)
  513.          return
  514.       elseif(typp.eq.'RIGIDITE') then
  515.          type='RIGIDITE'
  516.          call lirobj(type,mrigid,1,iret)
  517. *     WRITE(IOIMP,*)' rigidite '
  518.  
  519. *     On regarde si il y a un autre argument.
  520. *     Si ce n'est pas le cas on appele RIMB
  521. *     qui termine le travail.
  522. *     Modif GBM
  523.  
  524.          call quetyp(typp,0,iret)
  525.          if(typp.ne.'MAILLAGE') then
  526.             call RIMB(mrigid)
  527.             return
  528.          endif
  529.  
  530. *     fin de modif GBM 18/12/02
  531.  
  532.          type='MAILLAGE'
  533.          call lirobj(type,mele  ,1,iret)
  534. *      WRITE(IOIMP,*)' mele ',mele,iret
  535. *
  536. * eventuellemnt liste nom composante
  537. *
  538.          ico = 0
  539.          jmo=0
  540.          lmo=0
  541.          call quetyp(typp,ico,iret)
  542.          if(typp.eq.'LISTMOTS') then
  543.             call lirobj(typp,mlmots,0,iret)
  544.             segact mlmots
  545.             jmo = mots(/1)
  546.             lmo = mots(/2)
  547.          endif
  548.          segact mrigid
  549.          nrigel=irigel(/2)
  550.          nrige =irigel(/1)
  551.  
  552.          if(impj.eq.0) then
  553.             WRITE(IOIMP,*)' nrigel',nrigel,' nrige ',nrige
  554.             WRITE(IOIMP,*)' mtymat ',mtymat
  555.             do ir =1,nrigel
  556.                WRITE(IOIMP,*)' ir ',ir
  557.                WRITE(IOIMP,*)(irigel(ik,ir),ik=1,nrige)
  558.                WRITE(IOIMP,*)' '
  559.                meleme=irigel(1,ir)
  560.                segact meleme
  561.                nbs=lisous(/1)
  562.                WRITE(IOIMP,*)' nbre ssobjt mail ',nbs
  563.                if(nbs.eq.0) then
  564.                   nbnn=num(/1)
  565.                   nbl=num(/2)
  566.                   do iel=1,nbl
  567.                      WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn)
  568.                   enddo
  569.                endif
  570.                if(nbs.ge.1)then
  571.                   WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs)
  572.                   do iss=1,nbs
  573.                      ipt1=lisous(iss)
  574.                      segact ipt1
  575.                      nbnn=ipt1.num(/1)
  576.                      nbl =ipt1.num(/2)
  577.                      WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn
  578.                      do il = 1,nbl
  579.                         WRITE(IOIMP,*)il,'  ',(ipt1.num(iop,il),iop=1
  580.      $                       ,nbnn)
  581.                      enddo
  582.                      segdes ipt1
  583.                   enddo
  584.                endif
  585.                segdes meleme
  586.             enddo
  587.             WRITE(IOIMP,*)' coerig '
  588.             WRITE(IOIMP,*)(coerig(ik),ik=1,nrigel)
  589.             WRITE(IOIMP,*)' ichole imgeo1 imgeo2 iforig '
  590.             WRITE(IOIMP,*)  ichole,imgeo1,imgeo2,iforig
  591.             WRITE(IOIMP,*)' isupeq jrcond jrdepp jrdepd '
  592.             WRITE(IOIMP,*)  isupeq,jrcond,jrdepp,jrdepd
  593.             WRITE(IOIMP,*)' jrelim jrgard jrtot '
  594.             WRITE(IOIMP,*)  jrelim,jrgard,jrtot
  595.             do ir=1,nrigel
  596.                xmatri = irigel(4,ir)
  597.                descr  = irigel(3,ir)
  598.                segact xmatri,descr
  599.                nelrig = re(/3)
  600.                nligrp = noelep(/1)
  601.                nligrd = noeled(/1)
  602.                WRITE(IOIMP,*)' nelrig nligrp nligrd '
  603.                WRITE(IOIMP,*)  nelrig,nligrp,nligrd
  604.                WRITE(IOIMP,*)' lisinc '
  605.                WRITE(IOIMP,*)(lisinc(io),io=1,nligrp)
  606.                WRITE(IOIMP,*)' lisdua '
  607.                WRITE(IOIMP,*)(lisdua(io),io=1,nligrd)
  608.                WRITE(IOIMP,*)' noelep '
  609.                WRITE(IOIMP,*)(noelep(io),io=1,nligrp)
  610.                WRITE(IOIMP,*)' noeled '
  611.                WRITE(IOIMP,*)(noeled(io),io=1,nligrd)
  612.                do ie=1, nelrig
  613. *            xmatri = imattt(ie)
  614. *            segact xmatri
  615.                   WRITE(IOIMP,*)' iel ',ie
  616.                   do ij =1,nligrd
  617.                      WRITE(IOIMP,*)ij,(re(ij,kj,ie),kj=1,nligrp)
  618.                   enddo
  619. *            segdes xmatri
  620.                enddo
  621.                segdes xmatri,descr
  622.             enddo
  623.          endif
  624.  
  625.          nmatri = nrigel
  626.          nrige = 7
  627.          nrig = irigel(/1)
  628.          nkid=9
  629.          nkmt=7
  630.          segini matrik
  631. *      WRITE(IOIMP,*)' creation matrik',matrik
  632.          do in=1,nrigel
  633.             jrigel(1,in)=irigel(1,in)
  634.             jrigel(2,in)=irigel(1,in)
  635.             meleme = irigel(1,in)
  636.             segact meleme
  637.             jrigel(7,in)=0
  638.             if(nrig.gt.6) then
  639.                jrigel(7,in)=irigel(7,in)
  640.             endif
  641. *        WRITE(IOIMP,*)' in ',in,irigel(7,in)
  642. *        WRITE(IOIMP,*)' in ',in,irigel(6,in)
  643.             if(irigel(6,in).ne.0)then
  644.                segsup matrik
  645.                WRITE(IOIMP,*)' matrice definie par une inegalite'
  646.                return
  647.             endif
  648.             if(irigel(5,in).ne.0) then
  649.                segsup matrik
  650.                WRITE(IOIMP,*)' harmonique de fourier non nulle'
  651.                return
  652.             endif
  653.             coef = coerig(in)
  654.             descr=irigel(3,in)
  655.             segact descr
  656.             xmatri = irigel(4,in)
  657.             segact xmatri
  658.             nbp = noelep(/1)
  659.             nbd = noeled(/1)
  660.             np  = num(/1)
  661.             nbme = nbp/np*nbd/np
  662.             nbel = num(/2)
  663.             mp =np
  664.             nbsous=1
  665.             segini jmatri
  666.             jrigel(4,in)=jmatri
  667. *        WRITE(IOIMP,*)' jmatri ',jmatri
  668.  
  669. *        WRITE(IOIMP,*)' jrigel ',(jrigel(iop,in),iop=1,7)
  670.  
  671.  
  672.  
  673.             l1=nbp/np
  674.             l2=np
  675.             segini iztra
  676. *        WRITE(IOIMP,*)' iztra ',iztra,l1,l2
  677.             k0 = 1
  678.             lisp(1)=lisinc(1)
  679.             do io=1,np
  680.                itab(1,io)=io
  681.             enddo
  682.             ltab(1)=1
  683.             do  j=2,nbp
  684.                nomi=lisinc(j)
  685.                do l=1,k0
  686.                   if(nomi.eq.lisp(l))then
  687.                      k=ltab(l)+1
  688.                      itab(l,k)=j
  689.                      ltab(l)=k
  690.                      go to 30
  691.                   endif
  692.                enddo
  693.                k0=k0+1
  694.                lisp(k0)=nomi
  695.                ltab(k0)=1
  696.                itab(k0,1)=j
  697.  30            continue
  698.             enddo
  699.             l3=nbd/np
  700.             l2=np
  701.             segini jztra
  702.             k0 = 1
  703.             lisd(1)=lisdua(1)
  704.             do io=1,np
  705.                jtab(1,io)=io
  706.             enddo
  707.             ktab(1)=1
  708.             do  j=2,nbd
  709.                nomi=lisdua(j)
  710.                do l=1,k0
  711.                   if(nomi.eq.lisd(l))then
  712.                      k=ktab(l)+1
  713.                      jtab(l,k)=j
  714.                      ktab(l)=k
  715.                      go to 31
  716.                   endif
  717.                enddo
  718.                k0=k0+1
  719.                lisd(k0)=nomi
  720.                ktab(k0)=1
  721.                jtab(k0,1)=j
  722.  31            continue
  723.             enddo
  724.             k=0
  725.             do lp=1,l1
  726.                do ld=1,l3
  727.                   k=k+1
  728.                   lisprj(k)=lisp(lp)
  729. *            lisdub(k)=lisd(ld)
  730.                   lisdub(k)=lisp(ld)
  731.                   if(lmo.ne.0.and.lmo.ge.lp)then
  732.                      lisprj(k)= mots(lp)
  733.                      lisdub(k)= mots(ld)
  734.                   endif
  735.                   segini izafm
  736.                   lizafm(1,k)=izafm
  737.                   kspgp = mele
  738.                   kspgd = mele
  739. *            WRITE(IOIMP,*)' kspgp ',kspgp
  740.                   do ip =1,nbel
  741. *               xmatri = imattt(ip)
  742. *               segact xmatri
  743.                      ll=0
  744.                      do ki=1,np
  745.                         do kj=1,np
  746.                            il= noelep(ki)
  747.                            jl= noeled(kj)
  748.                            ii=itab(lp,ki)
  749.                            jj=jtab(ld,kj)
  750. *                  am(ip,il,jl)=coef * re(jj,ii)
  751.                            ll=ll+1
  752.                            il=noelep(ii)
  753.                            jl=noelep(jj)
  754.                            if(ip.eq.1)then
  755. *      WRITE(IOIMP,*)' lp ',lp,' ki ',ki,' nop  ',il,' ii ',ii,' ip ',ip
  756. *      WRITE(IOIMP,*)' ld ',ld,' kj ',kj,' nod  ',jl,' jj ',jj
  757.                            endif
  758.                            am(ip,il,jl)=coef * re(jj,ii,ip)
  759. *****              am(ip,ki,kj)=coef * re(ii,jj)
  760.                         enddo
  761.                      enddo
  762. *               segdes xmatri
  763.                   enddo
  764. *            WRITE(IOIMP,*)' finfin '
  765.                   segdes izafm
  766.                enddo
  767.             enddo
  768. *        WRITE(IOIMP,*)' fin 1 '
  769.             segsup iztra,jztra
  770.             segdes descr,xmatri
  771.             segdes jmatri
  772. *        WRITE(IOIMP,*)' segdes 1 '
  773.          enddo
  774.          segdes mrigid
  775. *        WRITE(IOIMP,*)' jrigel ',(jrigel(iop,1 ),iop=1,7)
  776. *        WRITE(IOIMP,*)' jrigel ',(jrigel(iop,2 ),iop=1,7)
  777.          segdes matrik
  778. *     WRITE(IOIMP,*)' segdes 2 '
  779.          CALL ECRobj('MATRIK',matrik)
  780.          return
  781.       else
  782.          WRITE(IOIMP,*)' erreur'
  783.          return
  784.       endif
  785. *
  786. * Error handling
  787. *
  788.  9999 CONTINUE
  789.       WRITE(IOIMP,*) 'An error was detected in subroutine rima'
  790.       CALL ERREUR(5)
  791.       RETURN
  792.       end
  793.  
  794.  
  795.  

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