1 : C CHV1 SOURCE CHAT 05/01/12 22:02:16 5004 2 : C CHV1 SOURCE PV 96/12/17 21:21:08 2440 3 : SUBROUTINE CHV1(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 PREMIER MEMBRE 7 : C **** LE CHPOIN EST DE TYPE PREMIER 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 : MHARK=IHARK 40 : SEGACT,MHARK 41 : IDU=IMIK(/2) 42 : MINCPO=IINCPO 43 : SEGACT,MINCPO 44 : N2=NUM(/2) 45 : C 46 : C **** DANS ICPR ON COMPTE LES POINTS DE MELEME 47 : C 48 : SEGINI ICPR 49 : DO 25 I=1,N2 50 : ICPR(NUM(1,I))=I 51 : 25 CONTINUE 52 : C 53 : C 54 : C **** FABRICATION D'UN VECTEUR SECOND MEMBRE DANS MVECTD 55 : C **** ON VERIFIE QUE TOUTES LES COMPOSANTES DU VECTEUR EXISTENT DANS 56 : C **** LA MATRICE SI NOID=0 . 57 : C 58 : DO 1 I=1,NSOUPO 59 : MSOUPO=IPCHP(I) 60 : SEGACT,MSOUPO 61 : IPT1=IGEOC 62 : SEGACT,IPT1 63 : NC=NOCOMP(/2) 64 : NC1=NC 65 : SEGINI,ICOR 66 : DO 110 KKIL = 1,NC1 67 : 110 ICOR(KKIL)=0 68 : DO 11 KI=1,NC 69 : DO 10 J=1,IDU 70 : IF(NOCOMP(KI).NE.IMIK(J)) GO TO 10 71 : IF(NOHARM(KI).NE.IHAR(J)) GO TO 10 72 : ICOR(KI)=J 73 : GO TO 11 74 : 10 CONTINUE 75 : 11 CONTINUE 76 : MPOVAL=IPOVAL 77 : SEGACT,MPOVAL 78 : N=VPOCHA(/1) 79 : DO 20 J=1,N 80 : K=ICPR(IPT1.NUM(1,J)) 81 : IF(K.NE.0) GO TO 4 82 : IF(NOID.EQ.1) GO TO 20 83 : C 84 : C **** LE NUMERO DU NOEUD DU VECTEUR N'EXISTAIT PAS DANS LA MATRICE 85 : C 86 : ITYP=53 87 : INTERR(1) = IPT1.NUM(1,J) 87 : CALL ERREUR (ITYP) 88 : RETURN 89 : 4 CONTINUE 90 : 40 CONTINUE 91 : DO 2 LI=1,NC 92 : KKIL=ICOR(LI) 93 : IF (KKIL.EQ.0) GOTO 55 94 : KI=INCPO(KKIL,K) 95 : IF(KI.NE.0) GO TO 6 96 : 55 CONTINUE 97 : IF(NOID.EQ.1) GO TO 2 98 : C 99 : C **** LE TYPE D'INCONNUE N'EXISTAIT PAS DANS LA MATRICE 100 : C 101 : ITYP=54 102 : MOTERR(1:4) = NOCOMP(LI) 103 : INTERR(1) = NOHARM (LI) 104 : INTERR(2) = IPT1.NUM(1,J) 104 : CALL ERREUR(ITYP) 105 : RETURN 106 : 6 CONTINUE 107 : VECTBB(KI)=VPOCHA(J,LI) 108 : 2 CONTINUE 109 : 20 CONTINUE 110 : SEGDES,MPOVAL 111 : SEGDES,MSOUPO 112 : SEGSUP,ICOR 113 : SEGDES,IPT1 114 : 1 CONTINUE 115 : SEGSUP ICPR 116 : SEGDES,MELEME 117 : SEGDES,MCHPOI 118 : SEGDES MMATRI 119 : SEGDES,MIMIK 120 : SEGDES,MHARK 121 : SEGDES,MINCPO 122 : MVECTX=MVECTD 123 : C 124 : IF(IIMPI.EQ.3) WRITE(IOIMP,1002)MVECTD 125 : 1002 FORMAT(' SUBROUTINE CHV2 : POINTEUR DU VECTEUR =',I5) 126 : SEGDES MVECTD 127 : RETURN 128 : END 129 : 130 : 131 : 132 : 133 : 134 :
© Cast3M 2003 - All rights reserved.
Disclaimer