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    CB215821  25/04/23    21:15:44     12247          
  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.                         segini descr,xmatri
  458.                         irigel(3,jr)=descr
  459.                         irigel(4,jr)=Xmatri
  460.                         xmatri.symre=irigel(7,jr)
  461.                         do il=1,nligrp
  462.                            lisinc(il)=lisprj(in)(1:4)
  463.                            noelep(il)=il
  464.                         enddo
  465.                         do il=1,nligrd
  466.                            lisdua(il)=lisdub(in)(1:4)
  467.                            noeled(il)=il+nofset.lect(is)
  468.                         enddo
  469.                         do ip=1,nbel
  470.                            do iu=1,nligrp
  471.                               do ju=1,nligrd
  472.                                  re(ju,iu,ip)=am(ip,iu,ju)
  473.                               enddo
  474.                            enddo
  475.                         enddo
  476.                         segdes xmatri,descr
  477.                      else
  478. * recopier les transposées des matrices élémentaires
  479.                         nligrd=am(/2)
  480.                         nligrp=am(/3)
  481.                         segini descr,xmatri
  482.                         irigel(3,jr)=descr
  483.                         irigel(4,jr)=Xmatri
  484.                         xmatri.symre=irigel(7,jr)
  485.                         do il=1,nligrp
  486.                            lisinc(il)=lisdub(in)(1:4)
  487.                            noelep(il)=il+nofset.lect(is)
  488.                         enddo
  489.                         do il=1,nligrd
  490.                            lisdua(il)=lisprj(in)(1:4)
  491.                            noeled(il)=il
  492.                         enddo
  493.                         do ip=1,nbel
  494.                            do iu=1,nligrp
  495.                               do ju=1,nligrd
  496.                                  re(ju,iu,ip)=am(ip,ju,iu)
  497.                               enddo
  498.                            enddo
  499.                         enddo
  500.                         segdes xmatri,descr
  501.                      endif
  502.                      segdes izafm
  503.                   enddo
  504.                enddo
  505.             enddo
  506.  
  507.             segdes meleme
  508.             segdes jmatri
  509.             segsup nofset
  510.          enddo
  511.          segdes mrigid
  512.          segdes matrik
  513.          CALL ECRobj('RIGIDITE',mrigid)
  514.          return
  515.       elseif(typp.eq.'RIGIDITE') then
  516.          type='RIGIDITE'
  517.          call lirobj(type,mrigid,1,iret)
  518. *     WRITE(IOIMP,*)' rigidite '
  519.  
  520. *     On regarde si il y a un autre argument.
  521. *     Si ce n'est pas le cas on appele RIMB
  522. *     qui termine le travail.
  523. *     Modif GBM
  524.  
  525.          call quetyp(typp,0,iret)
  526.          if(typp.ne.'MAILLAGE') then
  527.             call RIMB(mrigid)
  528.             return
  529.          endif
  530.  
  531. *     fin de modif GBM 18/12/02
  532.  
  533.          type='MAILLAGE'
  534.          call lirobj(type,mele  ,1,iret)
  535. *      WRITE(IOIMP,*)' mele ',mele,iret
  536. *
  537. * eventuellemnt liste nom composante
  538. *
  539.          ico = 0
  540.          jmo=0
  541.          lmo=0
  542.          call quetyp(typp,ico,iret)
  543.          if(typp.eq.'LISTMOTS') then
  544.             call lirobj(typp,mlmots,0,iret)
  545.             segact mlmots
  546.             jmo = mots(/1)
  547.             lmo = mots(/2)
  548.          endif
  549.          segact mrigid
  550.          nrigel=irigel(/2)
  551.          nrige =irigel(/1)
  552.  
  553.          if(impj.eq.0) then
  554.             WRITE(IOIMP,*)' nrigel',nrigel,' nrige ',nrige
  555.             WRITE(IOIMP,*)' mtymat ',mtymat
  556.             do ir =1,nrigel
  557.                WRITE(IOIMP,*)' ir ',ir
  558.                WRITE(IOIMP,*)(irigel(ik,ir),ik=1,nrige)
  559.                WRITE(IOIMP,*)' '
  560.                meleme=irigel(1,ir)
  561.                segact meleme
  562.                nbs=lisous(/1)
  563.                WRITE(IOIMP,*)' nbre ssobjt mail ',nbs
  564.                if(nbs.eq.0) then
  565.                   nbnn=num(/1)
  566.                   nbl=num(/2)
  567.                   do iel=1,nbl
  568.                      WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn)
  569.                   enddo
  570.                endif
  571.                if(nbs.ge.1)then
  572.                   WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs)
  573.                   do iss=1,nbs
  574.                      ipt1=lisous(iss)
  575.                      segact ipt1
  576.                      nbnn=ipt1.num(/1)
  577.                      nbl =ipt1.num(/2)
  578.                      WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn
  579.                      do il = 1,nbl
  580.                         WRITE(IOIMP,*)il,'  ',(ipt1.num(iop,il),iop=1
  581.      $                       ,nbnn)
  582.                      enddo
  583.                      segdes ipt1
  584.                   enddo
  585.                endif
  586.                segdes meleme
  587.             enddo
  588.             WRITE(IOIMP,*)' coerig '
  589.             WRITE(IOIMP,*)(coerig(ik),ik=1,nrigel)
  590.             WRITE(IOIMP,*)' ichole imgeo1 imgeo2 iforig '
  591.             WRITE(IOIMP,*)  ichole,imgeo1,imgeo2,iforig
  592.             WRITE(IOIMP,*)' isupeq jrcond jrdepp jrdepd '
  593.             WRITE(IOIMP,*)  isupeq,jrcond,jrdepp,jrdepd
  594.             WRITE(IOIMP,*)' jrelim jrgard jrtot '
  595.             WRITE(IOIMP,*)  jrelim,jrgard,jrtot
  596.             do ir=1,nrigel
  597.                xmatri = irigel(4,ir)
  598.                descr  = irigel(3,ir)
  599.                segact xmatri,descr
  600.                nelrig = re(/3)
  601.                nligrp = noelep(/1)
  602.                nligrd = noeled(/1)
  603.                WRITE(IOIMP,*)' nelrig nligrp nligrd '
  604.                WRITE(IOIMP,*)  nelrig,nligrp,nligrd
  605.                WRITE(IOIMP,*)' lisinc '
  606.                WRITE(IOIMP,*)(lisinc(io),io=1,nligrp)
  607.                WRITE(IOIMP,*)' lisdua '
  608.                WRITE(IOIMP,*)(lisdua(io),io=1,nligrd)
  609.                WRITE(IOIMP,*)' noelep '
  610.                WRITE(IOIMP,*)(noelep(io),io=1,nligrp)
  611.                WRITE(IOIMP,*)' noeled '
  612.                WRITE(IOIMP,*)(noeled(io),io=1,nligrd)
  613.                do ie=1, nelrig
  614. *            xmatri = imattt(ie)
  615. *            segact xmatri
  616.                   WRITE(IOIMP,*)' iel ',ie
  617.                   do ij =1,nligrd
  618.                      WRITE(IOIMP,*)ij,(re(ij,kj,ie),kj=1,nligrp)
  619.                   enddo
  620. *            segdes xmatri
  621.                enddo
  622.                segdes xmatri,descr
  623.             enddo
  624.          endif
  625.  
  626.          nmatri = nrigel
  627.          nrige = 7
  628.          nrig = irigel(/1)
  629.          nkid=9
  630.          nkmt=7
  631.          segini matrik
  632. *      WRITE(IOIMP,*)' creation matrik',matrik
  633.          do in=1,nrigel
  634.             jrigel(1,in)=irigel(1,in)
  635.             jrigel(2,in)=irigel(1,in)
  636.             meleme = irigel(1,in)
  637.             segact meleme
  638.             jrigel(7,in)=0
  639.             if(nrig.gt.6) then
  640.                jrigel(7,in)=irigel(7,in)
  641.             endif
  642. *        WRITE(IOIMP,*)' in ',in,irigel(7,in)
  643. *        WRITE(IOIMP,*)' in ',in,irigel(6,in)
  644.             if(irigel(6,in).ne.0)then
  645.                segsup matrik
  646.                WRITE(IOIMP,*)' matrice definie par une inegalite'
  647.                return
  648.             endif
  649.             if(irigel(5,in).ne.0) then
  650.                segsup matrik
  651.                WRITE(IOIMP,*)' harmonique de fourier non nulle'
  652.                return
  653.             endif
  654.             coef = coerig(in)
  655.             descr=irigel(3,in)
  656.             segact descr
  657.             xmatri = irigel(4,in)
  658.             segact xmatri
  659.             nbp = noelep(/1)
  660.             nbd = noeled(/1)
  661.             np  = num(/1)
  662.             nbme = nbp/np*nbd/np
  663.             nbel = num(/2)
  664.             mp =np
  665.             nbsous=1
  666.             segini jmatri
  667.             jrigel(4,in)=jmatri
  668. *        WRITE(IOIMP,*)' jmatri ',jmatri
  669.  
  670. *        WRITE(IOIMP,*)' jrigel ',(jrigel(iop,in),iop=1,7)
  671.  
  672.  
  673.  
  674.             l1=nbp/np
  675.             l2=np
  676.             segini iztra
  677. *        WRITE(IOIMP,*)' iztra ',iztra,l1,l2
  678.             k0 = 1
  679.             lisp(1)=lisinc(1)
  680.             do io=1,np
  681.                itab(1,io)=io
  682.             enddo
  683.             ltab(1)=1
  684.             do  j=2,nbp
  685.                nomi=lisinc(j)
  686.                do l=1,k0
  687.                   if(nomi.eq.lisp(l))then
  688.                      k=ltab(l)+1
  689.                      itab(l,k)=j
  690.                      ltab(l)=k
  691.                      go to 30
  692.                   endif
  693.                enddo
  694.                k0=k0+1
  695.                lisp(k0)=nomi
  696.                ltab(k0)=1
  697.                itab(k0,1)=j
  698.  30            continue
  699.             enddo
  700.             l3=nbd/np
  701.             l2=np
  702.             segini jztra
  703.             k0 = 1
  704.             lisd(1)=lisdua(1)
  705.             do io=1,np
  706.                jtab(1,io)=io
  707.             enddo
  708.             ktab(1)=1
  709.             do  j=2,nbd
  710.                nomi=lisdua(j)
  711.                do l=1,k0
  712.                   if(nomi.eq.lisd(l))then
  713.                      k=ktab(l)+1
  714.                      jtab(l,k)=j
  715.                      ktab(l)=k
  716.                      go to 31
  717.                   endif
  718.                enddo
  719.                k0=k0+1
  720.                lisd(k0)=nomi
  721.                ktab(k0)=1
  722.                jtab(k0,1)=j
  723.  31            continue
  724.             enddo
  725.             k=0
  726.             do lp=1,l1
  727.                do ld=1,l3
  728.                   k=k+1
  729.                   lisprj(k)=lisp(lp)
  730. *            lisdub(k)=lisd(ld)
  731.                   lisdub(k)=lisp(ld)
  732.                   if(lmo.ne.0.and.lmo.ge.lp)then
  733.                      lisprj(k)= mots(lp)
  734.                      lisdub(k)= mots(ld)
  735.                   endif
  736.                   segini izafm
  737.                   lizafm(1,k)=izafm
  738.                   kspgp = mele
  739.                   kspgd = mele
  740. *            WRITE(IOIMP,*)' kspgp ',kspgp
  741.                   do ip =1,nbel
  742. *               xmatri = imattt(ip)
  743. *               segact xmatri
  744.                      ll=0
  745.                      do ki=1,np
  746.                         do kj=1,np
  747.                            il= noelep(ki)
  748.                            jl= noeled(kj)
  749.                            ii=itab(lp,ki)
  750.                            jj=jtab(ld,kj)
  751. *                  am(ip,il,jl)=coef * re(jj,ii)
  752.                            ll=ll+1
  753.                            il=noelep(ii)
  754.                            jl=noelep(jj)
  755.                            if(ip.eq.1)then
  756. *      WRITE(IOIMP,*)' lp ',lp,' ki ',ki,' nop  ',il,' ii ',ii,' ip ',ip
  757. *      WRITE(IOIMP,*)' ld ',ld,' kj ',kj,' nod  ',jl,' jj ',jj
  758.                            endif
  759.                            am(ip,il,jl)=coef * re(jj,ii,ip)
  760. *****              am(ip,ki,kj)=coef * re(ii,jj)
  761.                         enddo
  762.                      enddo
  763. *               segdes xmatri
  764.                   enddo
  765. *            WRITE(IOIMP,*)' finfin '
  766.                   segdes izafm
  767.                enddo
  768.             enddo
  769. *        WRITE(IOIMP,*)' fin 1 '
  770.             segsup iztra,jztra
  771.             segdes descr,xmatri
  772.             segdes jmatri
  773. *        WRITE(IOIMP,*)' segdes 1 '
  774.          enddo
  775.          segdes mrigid
  776. *        WRITE(IOIMP,*)' jrigel ',(jrigel(iop,1 ),iop=1,7)
  777. *        WRITE(IOIMP,*)' jrigel ',(jrigel(iop,2 ),iop=1,7)
  778.          segdes matrik
  779. *     WRITE(IOIMP,*)' segdes 2 '
  780.          CALL ECRobj('MATRIK',matrik)
  781.          return
  782.       else
  783.          WRITE(IOIMP,*)' erreur'
  784.          return
  785.       endif
  786. *
  787. * Error handling
  788. *
  789.  9999 CONTINUE
  790.       WRITE(IOIMP,*) 'An error was detected in subroutine rima'
  791.       CALL ERREUR(5)
  792.       RETURN
  793.       end
  794.  
  795.  
  796.  
  797.  

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