1 : C REDUCP SOURCE CHAT 05/01/13 02:47:17 5004 2 : SUBROUTINE REDUCP (MCHPOI,MCHPO1,IRET) 3 : IMPLICIT INTEGER(I-N) 4 : -INC CCOPTIO 5 : -INC SMCHPOI 6 : -INC SMELEME 7 : -INC TMTRAV 8 : REAL*8 EPS 9 : SEGMENT NOINCO 10 : CHARACTER*4 INC(NMA) 11 : INTEGER NHA(NMA) 12 : ENDSEGMENT 13 : * 14 : * VERIFICATION QUE LES DEUX CHPOINTS ONT EXACTEMENT LA MEME STRUCTURE 15 : * 16 : SEGACT MCHPOI,MCHPO1 17 : IF (IPCHP(/1).NE.MCHPO1.IPCHP(/1)) THEN 17 : CALL ERREUR(21) 18 : SEGDES MCHPOI,MCHPO1 19 : RETURN 20 : ENDIF 21 : EPS=1.D-5 22 : NMA=0 23 : NNNOE=0 24 : DO 1 I = 1 , IPCHP(/1) 25 : MSOUPO=IPCHP(I) 26 : MSOUP1=MCHPO1.IPCHP(I) 27 : SEGACT MSOUPO,MSOUP1 28 : NMA=NMA+NOCOMP(/2) 29 : IF(NOCOMP(/2).NE.MSOUP1.NOCOMP(/2)) THEN 30 : SEGDES MCHPOI,MCHPO1,MSOUPO,MSOUP1 30 : CALL ERREUR(21) 31 : RETURN 32 : ENDIF 33 : DO 2 J=1,NOCOMP(/2) 34 : IF (NOCOMP(J).EQ.MSOUP1.NOCOMP(J)) THEN 35 : IF (NOHARM(J).NE.MSOUP1.NOHARM(J)) THEN 36 : SEGDES MCHPOI,MCHPO1,MSOUPO,MSOUP1 36 : CALL ERREUR (21) 37 : RETURN 38 : ENDIF 39 : ELSE 40 : SEGDES MCHPOI,MCHPO1,MSOUPO,MSOUP1 40 : CALL ERREUR (21) 41 : RETURN 42 : ENDIF 43 : 2 CONTINUE 44 : MELEME=IGEOC 45 : IPT1=MSOUP1.IGEOC 46 : SEGACT MELEME,IPT1 47 : NNNOE=NNNOE+NUM(/2) 48 : IF(NUM(/2).NE.IPT1.NUM(/2)) THEN 48 : CALL ERREUR(21) 49 : SEGDES MCHPOI,MCHPO1,MSOUPO,MSOUP1,MELEME,IPT1 50 : RETURN 51 : ENDIF 52 : 1 CONTINUE 53 : * 54 : * ON CHERCHE LA DIMENSION DE MTRAV 55 : * 56 : SEGINI NOINCO 57 : NNIN=0 58 : DO 3 I=1,IPCHP(/1) 59 : MSOUPO=IPCHP(I) 60 : DO 4 J=1,NOCOMP(/2) 61 : DO 5 K=1,NNIN 62 : IF (INC(K).NE.NOCOMP(J)) GO TO 5 63 : IF(NHA(K).EQ.NOHARM(J)) GO TO 4 64 : 5 CONTINUE 65 : NNIN=NNIN+1 66 : INC(NNIN)=NOCOMP(J) 67 : NHA(NNIN)=NOHARM(J) 68 : 4 CONTINUE 69 : 3 CONTINUE 70 : * 71 : * CREATION DE MTRAV ET REMPLISSAGE 72 : * 73 : SEGINI MTRAV 74 : DO 6 I=1,NNIN 75 : INCO(I)=INC(I) 76 : NHAR(I)=NHA(I) 77 : 6 CONTINUE 78 : NDEJ=0 79 : DO 7 I=1,IPCHP(/1) 80 : MSOUPO=IPCHP(I) 81 : MSOUP1=MCHPO1.IPCHP(I) 82 : MELEME=IGEOC 83 : DO 8 J=1,NUM(/2) 84 : IGEO(J+NDEJ)=NUM(1,J) 85 : 8 CONTINUE 86 : MPOVAL=IPOVAL 87 : MPOVA1=MSOUP1.IPOVAL 88 : SEGACT MPOVAL,MPOVA1 89 : DO 9 J=1,NOCOMP(/2) 90 : DO 10 K=1,NNIN 91 : IF(INCO(K).EQ.NOCOMP(J)) THEN 92 : IF(NHAR(K).EQ.NOHARM(J)) THEN 93 : NHA(J)=K 94 : GO TO 9 95 : ENDIF 96 : ENDIF 97 : 10 CONTINUE 97 : CALL ERREUR(5) 98 : RETURN 99 : 9 CONTINUE 100 : DO 11 J=1,NUM(/2) 101 : DO 12 K=1,NOCOMP(/2) 102 : NN=NHA(K) 103 : IF(ABS(MPOVA1.VPOCHA(J,K)).GT.EPS) THEN 104 : BB(NN,NDEJ+J)=VPOCHA(J,K) 105 : IBIN(NN,NDEJ+J)=1 106 : ENDIF 107 : 12 CONTINUE 108 : 11 CONTINUE 109 : NDEJ=NDEJ+NUM(/2) 110 : SEGDES MELEME,IPT1,MPOVAL,MPOVA1,MSOUPO,MSOUP1 111 : 7 CONTINUE 112 : 113 : SEGDES MTRAV,MCHPOI,MCHPO1 113 : CALL CRECHP(MTRAV,IRET) 114 : * 115 : * on attribut les memes natures 116 : MCHPO2 = IRET 117 : SEGACT MCHPOI,MCHPO2 118 : NAT = MAX(1,JATTRI(/1)) 119 : NSOUPO=MCHPO2.IPCHP(/1) 120 : SEGADJ MCHPO2 121 : IF ( JATTRI(/1) .NE. 0) THEN 122 : DO 13 I=1,NAT 123 : MCHPO2.JATTRI(I)=JATTRI(I) 124 : 13 CONTINUE 125 : ENDIF 126 : * 127 : SEGDES MCHPOI,MCHPO2 128 : SEGSUP MTRAV,NOINCO 129 : RETURN 130 : END 131 :
© Cast3M 2003 - All rights reserved.
Disclaimer