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

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