Télécharger kmors.eso

Retour à la liste

kmors
C KMORS     SOURCE    PV        20/09/26    21:17:34     10724          
      SUBROUTINE KMORS(ASSTAB,MATRIK,LL)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C     ***********************************************
C     * Routine de remplissage du tableau de ASSTAB *
C     * avec le profil de MATRIK.                   *
C     * Entree/sortie : MATRIK                      *
C     * Sortie : ASSTAB                             *
C     ***********************************************
 
-INC SMMATRIK
 
-INC SMELEME
      POINTEUR MELEMP.MELEME,MELEMD.MELEME
      POINTEUR SPGD.MELEME
-INC SMLENTI
      POINTEUR IPADP.MLENTI,IPADD.MLENTI
 
      SEGMENT ASSTAB
      INTEGER ITAB(NBCOMP,NTA)
      ENDSEGMENT
 
      INTEGER PRI,DUA
 
C     *********************************
C     On active le segment MATRIK et on
C     pointe sur tous les elements dont
C     on a besoin
C     *********************************
 
      SEGACT MATRIK
      MELEMP=IRIGEL(1,LL)
      MELEMD=IRIGEL(2,LL)
 
C     On prend le segment IMATRI
      IMATRI=IRIGEL(4,LL)
      SEGACT IMATRI
      NBSOUS=LIZAFM(/1)
      IF (NBSOUS.EQ.0) NBSOUS=1
 
C     Le support dual contient le nombre de ligne de la matrice
C     pour une variable scalaire uniquement
      SPGD=KSPGD
      SEGACT SPGD
      NBCOMP=10
      NTA=SPGD.NUM(/2)
      SEGDES SPGD
 
C     On initialise ASSTAB
      SEGINI ASSTAB
      IPT1=MELEMP
      IPT2=MELEMD
 
C     On active les connectivites primales et duales pour
C     prendre les NBSOUS1 et NBSOUS2
      SEGACT MELEMP,MELEMD
      NBSOUS1=MELEMP.LISOUS(/1)
      NBSOUS2=MELEMD.LISOUS(/1)
      IF (NBSOUS1.EQ.0) NBSOUS1=1
      IF (NBSOUS2.EQ.0) NBSOUS2=1
 
      NBEL1=0
      NBEL2=0
      NTTD=0
 
      DO L=1,NBSOUS
C     Si NBSOUS n est pas egal a 1 c est que l on est en
C     multi-elements cependant, il se peut que les connectivites
C     (aucune, une seule ou les deux) soit un support (par
C     exemple l inconue primale est sur les CENTRE). Dans ce cas
C     le MELEME n'a pas de LISOUS.
         IF (NBSOUS.NE.1) THEN
            IF (NBSOUS1.NE.1) THEN
               IPT1=MELEMP.LISOUS(L)
            END IF
            IF (NBSOUS2.NE.1) THEN
               IPT2=MELEMD.LISOUS(L)
            END IF
         END IF
 
         CALL KRIPAD(IPT1,IPADP)
         CALL KRIPAD(IPT2,IPADD)
 
         SEGACT IPT1,IPT2
         SEGACT IPADP,IPADD
 
         NP=IPT1.NUM(/1)
         MP=IPT2.NUM(/1)
 
C     Il faut faire attention pour le nombre d elements
         IF (NBSOUS.EQ.1) THEN
            NBEL=IPT1.NUM(/2)
         ELSE
            IF (NBSOUS1.NE.1) THEN
               NBEL=IPT1.NUM(/2)
            ELSEIF (NBSOUS2.NE.1) THEN
               NBEL=IPT2.NUM(/2)
            END IF
         END IF
 
         DO K=1,NBEL
            DO I=1,NP
               DO J=1,MP
                  IF (NBSOUS.EQ.1) THEN
                     PRI=IPADP.LECT(IPT1.NUM(I,K))
                     DUA=IPADD.LECT(IPT2.NUM(J,K))
                  ELSE
                     IF (NBSOUS1.NE.1) THEN
                        PRI=IPADP.LECT(IPT1.NUM(I,K))
                     ELSE
                        PRI=IPADP.LECT(IPT1.NUM(I,NBEL1+K))
                     END IF
                     IF (NBSOUS2.NE.1) THEN
                        DUA=IPADD.LECT(IPT2.NUM(J,K))
                     ELSE
                        DUA=IPADD.LECT(IPT2.NUM(J,NBEL2+K))
                     END IF
                  END IF
                  NTTD=MAX(NTTD,DUA)
 
                  NB=ITAB(1,DUA)
 100              CONTINUE
                  IF (NB+2.GT.NBCOMP) THEN
                     NBCOMP=NBCOMP+10
                     SEGADJ ASSTAB
                     GOTO 100
                  END IF
 
                  IFLAG=0
                  DO II=1,NB
                     IF (ITAB(II+1,DUA).EQ.PRI) THEN
                        IFLAG=1
                     END IF
                  END DO
 
                  IF (IFLAG.EQ.0) THEN
                     ITAB(1,DUA)=NB+1
                     ITAB(NB+2,DUA)=PRI
                  END IF
 
               END DO
            END DO
         END DO
 
         NBEL1=NBEL1+NBEL
         NBEL2=NBEL2+NBEL
         SEGDES IPADP,IPADD
         SEGDES IPT1,IPT2
      END DO
 
      DO I=1,NTTD
         CALL ORDOTA(ITAB(2,I),ITAB(1,I))
      END DO
 
      SEGDES ASSTAB
      SEGDES MELEMP,MELEMD
      SEGDES IMATRI
      SEGDES MATRIK
      END
 
 
 
 
 
 
 

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