Sources Esope | Cast3M

chv2
C CHV2      SOURCE    JK148537  25/04/01    21:15:02     12223          
      SUBROUTINE CHV2(MMATRX,ISECO,MVECTX,NOID)
C
C  **** SUBROUTINE QUI A PARTIR D UN OBJET DE TYPE MATRICE ET D UN
C  **** CHPOINT FABRIQUE UN VECTEUR SECOND MEMBRE
C  **** LE CHPOIN EST DE TYPE SECOND MEMBRE
C
      IMPLICIT INTEGER(I-N)
-INC SMMATRI
-INC SMCHPOI
-INC SMELEME
 
-INC PPARAM
-INC CCOPTIO
-INC SMVECTD
-INC SMCOORD
      SEGMENT,ICPR(nbpts)
      SEGMENT,ICOR(NC1)
C
      IF(IIMPI.EQ.3) WRITE(IOIMP,1000) MMATRX,ISECO
 1000 FORMAT('  SUBROUTINE CHV2 : POINTEUR DE LA MATRICE=',I5,
     1                        '   POINTEUR DE L''OBJET CHPOINT=',I5)
C
C  ****  ACTIVATION DES SEGMENTS
C
      MMATRI=MMATRX
      SEGACT,MMATRI
      MCHPOI=ISECO
      SEGACT MCHPOI
      NSOUPO=IPCHP(/1)
      MELEME=IGEOMA
      SEGACT,MELEME
      MILIGN=IILIGN
      SEGACT,MILIGN
      INC=IPNO(/1)
      SEGDES,MILIGN
      SEGINI,MVECTD
      MIDUA=IIDUA
      SEGACT,MIDUA
      MHARK=IHARK
      SEGACT,MHARK
      IDU=IDUA(/2)
      MINCPO=IINCPO
      SEGACT,MINCPO
      N2=NUM(/2)
C
C  **** DANS ICPR ON COMPTE LES POINTS DE MELEME
C
      SEGINI ICPR
      DO 25 I=1,N2
      ICPR(NUM(1,I))=I
 25   CONTINUE
C
C
C  ****  FABRICATION D'UN VECTEUR SECOND MEMBRE DANS MVECTD
C  ****  ON VERIFIE QUE TOUTES LES COMPOSANTES DU VECTEUR EXISTENT DANS
C  ****  LA MATRICE  SI NOID=0 .
C
      DO 1 I=1,NSOUPO
      MSOUPO=IPCHP(I)
      SEGACT,MSOUPO
      IPT1=IGEOC
      SEGACT,IPT1
      NC=NOCOMP(/2)
      NC1=NC
      SEGINI,ICOR
      DO     KKIL = 1,NC1
      ICOR(KKIL)=0
      ENDDO
      DO 11 KI=1,NC
      DO 10 J=1,IDU
      IF(NOCOMP(KI).NE.IDUA(J)) GO TO 10
       if (ifour.eq.1) then
      IF(NOHARM(KI).NE.IHAR(J)) GO TO 10
       endif
      ICOR(KI)=J
      GO TO 11
   10 CONTINUE
   11 CONTINUE
      MPOVAL=IPOVAL
      SEGACT,MPOVAL
      N=VPOCHA(/1)
      DO 20 J=1,N
      K=ICPR(IPT1.NUM(1,J))
      IF(K.NE.0) GO TO 4
      IF(NOID.EQ.1) GO TO 20
C
C  ****  LE NUMERO DU NOEUD DU VECTEUR N'EXISTAIT PAS DANS LA MATRICE
C
      ITYP=53
      INTERR(1) = IPT1.NUM(1,J)
      CALL ERREUR (ITYP)
      RETURN
    4 CONTINUE
  40  CONTINUE
      DO 2 LI=1,NC
      KKIL=ICOR(LI)
      IF (KKIL.EQ.0) GOTO 55
      KI=INCPO(KKIL,K)
      IF(KI.NE.0)  GO TO 6
  55  CONTINUE
      IF(NOID.EQ.1) GO TO 2
C
C  ****  LE TYPE D'INCONNUE N'EXISTAIT PAS DANS LA MATRICE
C
      ITYP      = 54
      MOTERR    = NOCOMP(LI)
      INTERR(1) = NOHARM (LI)
      INTERR(2) = IPT1.NUM(1,J)
      CALL ERREUR(ITYP)
      RETURN
    6 CONTINUE
      VECTBB(KI)=VPOCHA(J,LI)
    2 CONTINUE
   20 CONTINUE
      SEGDES,MPOVAL
      SEGDES,MSOUPO
      SEGSUP,ICOR
      SEGDES,IPT1
    1 CONTINUE
      SEGSUP ICPR
      SEGDES,MELEME
      SEGDES,MCHPOI
      SEGDES MMATRI
      SEGDES,MIDUA
      SEGDES,MHARK
      SEGDES,MINCPO
      MVECTX=MVECTD
C
      IF(IIMPI.EQ.3) WRITE(IOIMP,1002)MVECTD
 1002 FORMAT('  SUBROUTINE CHV2 : POINTEUR DU VECTEUR =',I5)
*      SEGDES MVECTD
      RETURN
      END