1 : C ETALPR SOURCE CHAT 05/01/12 23:46:07 5004 2 : SUBROUTINE ETALPR(MCHPOI,IINC,ICPR,ICONTR) 3 : C======================================================================= 4 : C CE SUBROUTINE REMPLIT ICPR ,IINC ET ICONTR 5 : C ICPR(K)=IK : LE POINT K EST A LA POSITION IK DANS MCHPOI 6 : C IINC(I) EST LA IEME COMPOSANTE DE MCHPOI(TOUTES LES COMPOSANTES 7 : C DANS IINC SONT DIFFERENTES) 8 : C MCONTR(I,J)=1 VEUT DIRE QUE LA IEME COMPOSANTE DANS IINC EXISTE 9 : C POUR LE IK IEME POINT (TEL QUE ICPR(K)=IK) DANS MCHPOI 10 : C 11 : C ATTENTION SEGINI ICPR. SEGINI IINC. SEGINI ICONTR 12 : C======================================================================= 13 : IMPLICIT INTEGER(I-N) 14 : -INC SMCHPOI 15 : -INC CCOPTIO 16 : -INC SMELEME 17 : -INC SMCOORD 18 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 19 : SEGMENT IINC 20 : CHARACTER*4 CIINC(0) 21 : ENDSEGMENT 22 : SEGMENT /ICONTR/(MCONTR(NNI1,IPR1)) 23 : C 24 : SEGINI ICPR 25 : SEGACT MCHPOI 26 : NSOUPO=IPCHP(/1) 27 : IK=0 28 : MSOUPO=IPCHP(1) 29 : SEGACT MSOUPO 30 : SEGINI IINC 31 : CIINC(**)=NOCOMP(1) 32 : SEGDES MSOUPO 33 : ININC=1 34 : DO 101 ISOU=1,NSOUPO 35 : MSOUPO=IPCHP(ISOU) 36 : SEGACT MSOUPO 37 : MELEME=IGEOC 38 : SEGACT MELEME 39 : N2=NUM(/2) 40 : DO 102 I2=1,N2 41 : K=NUM(1,I2) 42 : IK=IK+1 43 : ICPR(K)=IK 44 : 102 CONTINUE 45 : SEGDES MELEME 46 : DO 106 I2=1,NOCOMP(/2) 47 : DO 107 IJ=1,ININC 48 : IF(CIINC(IJ).EQ.NOCOMP(I2)) GO TO 106 49 : 107 CONTINUE 50 : CIINC(**)=NOCOMP(I2) 51 : ININC=ININC+1 52 : 106 CONTINUE 53 : SEGDES MSOUPO 54 : 101 CONTINUE 55 : NNI1=CIINC(/2) 56 : IPR1=IK 57 : SEGINI ICONTR 58 : DO 201 ISOU=1,NSOUPO 59 : MSOUPO=IPCHP(ISOU) 60 : SEGACT MSOUPO 61 : MELEME=IGEOC 62 : SEGACT MELEME 63 : N2=NUM(/2) 64 : NC=NOCOMP(/2) 65 : DO 202 J=1,NC 66 : DO 203 K=1,NNI1 67 : IF(NOCOMP(J).EQ.CIINC(K)) GO TO 204 68 : 203 CONTINUE 69 : 204 CONTINUE 70 : DO 205 I2=1,N2 71 : KI=ICPR(NUM(1,I2)) 72 : MCONTR(K,KI)=1 73 : 205 CONTINUE 74 : 202 CONTINUE 75 : SEGDES MELEME,MSOUPO 76 : 201 CONTINUE 77 : SEGDES ICONTR 78 : SEGDES MCHPOI 79 : SEGDES ICPR 80 : SEGDES IINC 81 : RETURN 82 : END 83 :
© Cast3M 2003 - All rights reserved.
Disclaimer