1 : C REDUIR SOURCE CHAT 05/01/13 02:47:35 5004 2 : SUBROUTINE REDUIR(ICHP,IMEL,IRET) 3 : C ====================================================================== 4 : C REDUIT LE CHPOINT ICHP AUX POINTS CONTENUS DANS LE MELEME IMEL.LE 5 : C RESULTAT IRET EST UN MELEME. 6 : C ATTENTION : ON A DUPLIQUE LA GEOMETRIE ET LE MPOVAL DANS TOUS LES CAS 7 : C======================================================================= 8 : IMPLICIT INTEGER(I-N) 9 : -INC CCOPTIO 10 : -INC SMCHPOI 11 : -INC SMELEME 12 : -INC SMCOORD 13 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 14 : SEGMENT/ITRAV/(ITRAV1(NNOE),ITRAV2(NSOUP)) 15 : SEGINI ICPR 16 : IRET=0 17 : MELEME=IMEL 18 : SEGACT MELEME 19 : IKI=0 20 : NBSOUS=LISOUS(/1) 21 : IPT1=MELEME 22 : DO 4 ISOU=1,MAX(1,NBSOUS) 23 : IF (NBSOUS.NE.0) THEN 24 : IPT1=LISOUS(ISOU) 25 : SEGACT IPT1 26 : ENDIF 27 : NBNN=IPT1.NUM(/1) 28 : NBELEM=IPT1.NUM(/2) 29 : DO 6 I1=1,NBELEM 30 : DO 7 I2=1,NBNN 31 : IP1=IPT1.NUM(I2,I1) 32 : IF(ICPR(IP1).NE.0) GO TO 7 33 : IKI=IKI+1 34 : ICPR(IP1)=IKI 35 : 7 CONTINUE 36 : 6 CONTINUE 37 : IF(NBSOUS.NE.0) SEGDES IPT1 38 : 4 CONTINUE 39 : SEGDES MELEME 40 : NNOE=IKI 41 : C 42 : MCHPOI=ICHP 43 : SEGACT MCHPOI 44 : NSOUP=IPCHP(/1) 45 : NSOUPO=0 46 : NBNN=1 47 : NBSOUS=0 48 : NBREF=0 49 : SEGINI ITRAV 50 : DO 1 ISOU=1,NSOUP 51 : NBELEM=0 52 : MSOUPO=IPCHP(ISOU) 53 : SEGACT MSOUPO 54 : MELEME=IGEOC 55 : SEGACT MELEME 56 : N2=NUM(/2) 57 : DO 2 I=1,N2 58 : IF(ICPR(NUM(1,I)).EQ.0) GO TO 2 59 : NBELEM=NBELEM+1 59 : IF (NBELEM.GT.NNOE) CALL ERREUR(476) 60 : IF (IERR.NE.0) RETURN 61 : ITRAV1(NBELEM)=I 62 : 2 CONTINUE 63 : IF(NBELEM.EQ.0) GOTO 3 64 : MPOVAL=IPOVAL 65 : SEGACT MPOVAL 66 : NC=VPOCHA(/2) 67 : N=NBELEM 68 : SEGINI MPOVA1 69 : SEGINI IPT1 70 : IPT1.ITYPEL=1 71 : DO 17 I=1,NBELEM 72 : IP1=ITRAV1(I) 73 : IPT1.NUM(1,I)=NUM(1,IP1) 74 : DO 8 IC=1,NC 75 : MPOVA1.VPOCHA(I,IC)=VPOCHA(IP1,IC) 76 : 8 CONTINUE 77 : 17 CONTINUE 78 : SEGDES MPOVAL 79 : SEGDES IPT1,MPOVA1 80 : SEGINI MSOUP1 81 : MSOUP1.IGEOC=IPT1 82 : MSOUP1.IPOVAL=MPOVA1 83 : DO 9 IC=1,NC 84 : MSOUP1.NOCOMP(IC)=NOCOMP(IC) 85 : MSOUP1.NOHARM(IC)=NOHARM(IC) 86 : 9 CONTINUE 87 : SEGDES MSOUP1 88 : NSOUPO=NSOUPO+1 89 : ITRAV2(NSOUPO)=MSOUP1 90 : 3 CONTINUE 91 : SEGDES MSOUPO,MELEME 92 : 1 CONTINUE 93 : SEGSUP ICPR 94 : NAT=JATTRI(/1) 95 : SEGINI MCHPO1 96 : DO 10 I=1,NAT 97 : MCHPO1.JATTRI(I)=JATTRI(I) 98 : 10 CONTINUE 99 : DO 11 I=1,NSOUPO 100 : MCHPO1.IPCHP(I)=ITRAV2(I) 101 : 11 CONTINUE 102 : MCHPO1.IFOPOI=IFOPOI 103 : MCHPO1.MTYPOI=MTYPOI 104 : MCHPO1.MOCHDE=MOCHDE 105 : SEGDES MCHPO1 106 : IRET=MCHPO1 107 : 5000 CONTINUE 108 : SEGDES MCHPOI 109 : SEGSUP ITRAV 110 : RETURN 111 : END 112 :
© Cast3M 2003 - All rights reserved.
Disclaimer