Télécharger dual01.eso

Retour à la liste

dual01
C DUAL01    SOURCE    CB215821  25/04/23    21:15:17     12247          
      SUBROUTINE dual01(mrigid,ri1)
C a appeler dual  ulterieurement
c====================================================================
c
c     entrees
c           mrigid  rigidité   [C]  de dependance  rela depend
c     sorties
C           ri1   [C] Transpose non symétrique
C     La différence par rapport à dual00, c'est que la matrice à
C     transposer n'est pas nécessairement symétrique.
c
c====================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC PPARAM
-INC CCHAMP
 
-INC SMRIGID
-INC SMCOORD
-INC SMELEME
 
      CHARACTER*4 CMOT
      character*(LOCHPO) NOMM,NODUA
 
      segment snomip
        character*(LOCHPO) nomip(0)
      endsegment
      segment snomda
        character*(LOCHPO) nomda(0)
      endsegment
 
      segment snomm
        character*(LOCHPO) nompi(nomip(/2)),nompa(nomda(/2))
      endsegment
 
      segact mrigid
 
C on en profite  pour recenser les inconnues en question (primales)
C  a voir
      segini snomip,snomda
 
      DO 1501 I=1,IRIGEL(/2)
*         MELEME=IRIGEL(1,I)
*         SEGACT MELEME
         DESCR=IRIGEL(3,I)
         SEGACT DESCR
C   attention ces matrices ne sont pas carrees  il faut 2 boucles
C          pour identifier les inconnues
 
         DO 1402 J=1,LISINC(/2)
            IF(nomip(/2).EQ.0) THEN
               nomip(**)=LISINC(J)
            ELSE
               DO 1406 K=1,nomip(/2)
                  IF(LISINC(J).EQ.nomip(K)) GO TO 1405
 1406          CONTINUE
               nomip(**)=LISINC(J)
 1405          CONTINUE
            ENDIF
 1402    CONTINUE
C
         DO 1502 J=1,LISDUA(/2)
            IF(nomda(/2).EQ.0) THEN
               nomda(**)=LISDUA(J)
            ELSE
               DO 1506 K=1,nomda(/2)
                  IF(LISDUA(J).EQ.nomda(K)) GO TO 1505
 1506          CONTINUE
               nomda(**)=LISDUA(J)
 1505          CONTINUE
            ENDIF
 1502    CONTINUE
 
 1501 CONTINUE
 
C      tableau des correspondances
 
      segini snomm
 
      do 325 il=1,nomip(/2)
         NOMM =nomip(IL)
         do 326 in = 1,lnomdd
            if (NOMM.EQ.NOMDD(in)) then
               NOMPI(il) =NOMDU(in)
               goto 327
            endif
 326     continue
         NOMPI(il)=NOMM
 327     continue
 325  continue
 
      do 425 il=1,nomda(/2)
         NOMM =nomda(IL)
         do 426 in = 1,lnomdd
            if (NOMM.EQ.NOMDU(in)) then
               NOMPA(il) =NOMDD(in)
               goto 427
            endif
 426     continue
         NOMPA(il)=NOMM
 427     continue
 425  continue
 
 
*      write(6,*) 'primales',(nomip(j),j=1,nomip(/2)),'sortie ' ,
*     &     ( nompi(j),j=1,nompi(/2))
*
*
*      write(6,*) 'duales  ',(nomda(j),j=1,nomda(/2)),'sortie ' ,
*     &     ( nompa(j),j=1,nompa(/2))
 
C on stoke le ddel en question en position ad-hoc
 
      nrigel=coerig(/1)
      segini , ri1
      ri1.mtymat=mtymat
      ri1.iforig=iforig
 
      do 1700 ima=1,IRIGEL(/2)
         ri1.coerig(ima)=coerig(ima)
         do 1750 iri =1,irigel(/1)
            if(iri.eq.3.or.iri.eq.4) goto 1750
            ri1.irigel(iri,ima)= IRIGEL(iri,ima)
 1750    continue
 
         descr = irigel(3,ima)
 
         nligrp = lisdua(/2)
         nligrd = lisinc(/2)
         segini des1
         ri1.irigel(3,ima) = des1
C
         do 1634 ik=1,lisinc(/2)
            nomm = lisinc(ik)
            do 1635 ij=1,nomip(/2)
               if(NOMM.eq.NOMIP(ij)) des1.lisdua(ik) = nompi(ij)
 1635       continue
            des1.noeled(ik)=noelep(ik)
 1634    continue
 
         do 1644 ik=1,lisdua(/2)
            nomm = lisdua(ik)
            do 1645 ij=1,nomda(/2)
               if(NOMM.eq.NOMDA(ij)) des1.lisinc(ik) = nompa(ij)
 1645       continue
            des1.noelep(ik)=noeled(ik)
 1644    continue
         segdes des1,descr
 
         if (irigel(7,ima).ne.0.or.nligrp.ne.nligrd) then
            XMATRI = IRIGEL(4,ima)
            segact XMATRI
            NELRIG=XMATRI.RE(/3)
            SEGINI xmatr1
            xmatr1.symre=symre
            do i=1,nelrig
               do j=1,nligrp
                  do k=1,nligrd
                     xmatr1.re(k,j,i)=re(j,k,i)
                  enddo
               enddo
            enddo
            segdes xmatr1,xmatri
            ri1.irigel(4,ima)=xmatr1
         else
            ri1.irigel(4,ima)=irigel(4,ima)
         endif
 1700 continue
 
      segdes ri1,mrigid
 
      segsup ,snomm,snomip,snomda
 
c      RETURN
      END
 
 
 
 

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