1 : C CHV2 SOURCE CHAT 09/11/25 21:15:00 6548 2 : SUBROUTINE CHV2(MMATRX,ISECO,MVECTX,NOID) 3 : C 4 : C **** SUBROUTINE QUI A PARTIR D UN OBJET DE TYPE MATRICE ET D UN 5 : C **** CHPOINT FABRIQUE UN VECTEUR SECOND MEMBRE 6 : C **** LE CHPOIN EST DE TYPE SECOND MEMBRE 7 : C 8 : IMPLICIT INTEGER(I-N) 9 : -INC SMMATRI 10 : -INC SMCHPOI 11 : -INC SMELEME 12 : -INC CCOPTIO 13 : -INC SMVECTD 14 : -INC SMCOORD 15 : SEGMENT,ICPR(XCOOR(/1)/(IDIM+1)) 16 : SEGMENT,ICOR(NC1) 17 : C 18 : IF(IIMPI.EQ.3) WRITE(IOIMP,1000) MMATRX,ISECO 19 : 1000 FORMAT(' SUBROUTINE CHV2 : POINTEUR DE LA MATRICE=',I5, 20 : 1 ' POINTEUR DE L''OBJET CHPOINT=',I5) 21 : C 22 : C **** ACTIVATION DES SEGMENTS 23 : C 24 : MMATRI=MMATRX 25 : SEGACT,MMATRI 26 : MCHPOI=ISECO 27 : SEGACT MCHPOI 28 : NSOUPO=IPCHP(/1) 29 : MELEME=IGEOMA 30 : SEGACT,MELEME 31 : MILIGN=IILIGN 32 : SEGACT,MILIGN 33 : INC=IPNO(/1) 34 : SEGDES,MILIGN 35 : SEGINI,MVECTD 36 : MIDUA=IIDUA 37 : SEGACT,MIDUA 38 : MHARK=IHARK 39 : SEGACT,MHARK 40 : IDU=IDUA(/2) 41 : MINCPO=IINCPO 42 : SEGACT,MINCPO 43 : N2=NUM(/2) 44 : C 45 : C **** DANS ICPR ON COMPTE LES POINTS DE MELEME 46 : C 47 : SEGINI ICPR 48 : DO 25 I=1,N2 49 : ICPR(NUM(1,I))=I 50 : 25 CONTINUE 51 : C 52 : C 53 : C **** FABRICATION D'UN VECTEUR SECOND MEMBRE DANS MVECTD 54 : C **** ON VERIFIE QUE TOUTES LES COMPOSANTES DU VECTEUR EXISTENT DANS 55 : C **** LA MATRICE SI NOID=0 . 56 : C 57 : DO 1 I=1,NSOUPO 58 : MSOUPO=IPCHP(I) 59 : SEGACT,MSOUPO 60 : IPT1=IGEOC 61 : SEGACT,IPT1 62 : NC=NOCOMP(/2) 63 : NC1=NC 64 : SEGINI,ICOR 65 : DO 110 KKIL = 1,NC1 66 : 110 ICOR(KKIL)=0 67 : DO 11 KI=1,NC 68 : DO 10 J=1,IDU 69 : IF(NOCOMP(KI).NE.IDUA(J)) GO TO 10 70 : IF(NOHARM(KI).NE.IHAR(J)) GO TO 10 71 : ICOR(KI)=J 72 : GO TO 11 73 : 10 CONTINUE 74 : 11 CONTINUE 75 : MPOVAL=IPOVAL 76 : SEGACT,MPOVAL 77 : N=VPOCHA(/1) 78 : DO 20 J=1,N 79 : K=ICPR(IPT1.NUM(1,J)) 80 : IF(K.NE.0) GO TO 4 81 : IF(NOID.EQ.1) GO TO 20 82 : C 83 : C **** LE NUMERO DU NOEUD DU VECTEUR N'EXISTAIT PAS DANS LA MATRICE 84 : C 85 : ITYP=53 86 : INTERR(1) = IPT1.NUM(1,J) 86 : CALL ERREUR (ITYP) 87 : RETURN 88 : 4 CONTINUE 89 : 40 CONTINUE 90 : DO 2 LI=1,NC 91 : KKIL=ICOR(LI) 92 : IF (KKIL.EQ.0) GOTO 55 93 : KI=INCPO(KKIL,K) 94 : IF(KI.NE.0) GO TO 6 95 : 55 CONTINUE 96 : IF(NOID.EQ.1) GO TO 2 97 : C 98 : C **** LE TYPE D'INCONNUE N'EXISTAIT PAS DANS LA MATRICE 99 : C 100 : ITYP=54 101 : MOTERR(1:4) = NOCOMP(LI) 102 : INTERR(1) = NOHARM (LI) 103 : INTERR(2) = IPT1.NUM(1,J) 103 : CALL ERREUR(ITYP) 104 : RETURN 105 : 6 CONTINUE 106 : VECTBB(KI)=VPOCHA(J,LI) 107 : 2 CONTINUE 108 : 20 CONTINUE 109 : SEGDES,MPOVAL 110 : SEGDES,MSOUPO 111 : SEGSUP,ICOR 112 : SEGDES,IPT1 113 : 1 CONTINUE 114 : SEGSUP ICPR 115 : SEGDES,MELEME 116 : SEGDES,MCHPOI 117 : SEGDES MMATRI 118 : SEGDES,MIDUA 119 : SEGDES,MHARK 120 : SEGDES,MINCPO 121 : MVECTX=MVECTD 122 : C 123 : IF(IIMPI.EQ.3) WRITE(IOIMP,1002)MVECTD 124 : 1002 FORMAT(' SUBROUTINE CHV2 : POINTEUR DU VECTEUR =',I5) 125 : * SEGDES MVECTD 126 : RETURN 127 : END 128 : 129 : 130 : 131 : 132 : 133 :
© Cast3M 2003 - All rights reserved.
Disclaimer