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