C CHV1 SOURCE CB215821 20/11/25 13:19:39 10792 SUBROUTINE CHV1(MMATRX,ISECO,MVECTX,NOID) C C **** SUBROUTINE QUI A PARTIR D UN OBJET DE TYPE MATRICE ET D UN C **** CHPOINT FABRIQUE UN VECTEUR PREMIER MEMBRE C **** LE CHPOIN EST DE TYPE PREMIER 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 MIMIK=IIMIK SEGACT,MIMIK MHARK=IHARK SEGACT,MHARK IDU=IMIK(/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.IMIK(J)) GO TO 10 IF(NOHARM(KI).NE.IHAR(J)) GO TO 10 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,MIMIK 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