C REDUCP SOURCE CB215821 20/11/25 13:38:51 10792 SUBROUTINE REDUCP (MCHPOI,MCHPO1,IRET) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMCHPOI -INC SMELEME -INC TMTRAV REAL*8 EPS SEGMENT NOINCO CHARACTER*(LOCOMP) INC(NMA) INTEGER NHA(NMA) ENDSEGMENT * * VERIFICATION QUE LES DEUX CHPOINTS ONT EXACTEMENT LA MEME STRUCTURE * IF (IPCHP(/1).NE.MCHPO1.IPCHP(/1)) THEN CALL ERREUR(21) RETURN ENDIF EPS=1.D-5 NMA=0 NNNOE=0 DO 1 I = 1 , IPCHP(/1) MSOUPO=IPCHP(I) MSOUP1=MCHPO1.IPCHP(I) NMA=NMA+NOCOMP(/2) IF(NOCOMP(/2).NE.MSOUP1.NOCOMP(/2)) THEN CALL ERREUR(21) RETURN ENDIF DO 2 J=1,NOCOMP(/2) IF (NOCOMP(J).EQ.MSOUP1.NOCOMP(J)) THEN IF (NOHARM(J).NE.MSOUP1.NOHARM(J)) THEN CALL ERREUR (21) RETURN ENDIF ELSE CALL ERREUR (21) RETURN ENDIF 2 CONTINUE MELEME=IGEOC IPT1=MSOUP1.IGEOC NNNOE=NNNOE+NUM(/2) IF(NUM(/2).NE.IPT1.NUM(/2)) THEN CALL ERREUR(21) RETURN ENDIF 1 CONTINUE * * ON CHERCHE LA DIMENSION DE MTRAV * SEGINI NOINCO NNIN=0 DO 3 I=1,IPCHP(/1) MSOUPO=IPCHP(I) DO 4 J=1,NOCOMP(/2) DO 5 K=1,NNIN IF(INC(K).NE.NOCOMP(J)) GOTO 5 IF(NHA(K).EQ.NOHARM(J)) GOTO 4 5 CONTINUE NNIN=NNIN+1 INC(NNIN)=NOCOMP(J) NHA(NNIN)=NOHARM(J) 4 CONTINUE 3 CONTINUE * * CREATION DE MTRAV ET REMPLISSAGE * SEGINI MTRAV DO 6 I=1,NNIN INCO(I)=INC(I) NHAR(I)=NHA(I) 6 CONTINUE NDEJ=0 DO 7 I=1,IPCHP(/1) MSOUPO=IPCHP(I) MSOUP1=MCHPO1.IPCHP(I) MELEME=IGEOC DO 8 J=1,NUM(/2) IGEO(J+NDEJ)=NUM(1,J) 8 CONTINUE MPOVAL=IPOVAL MPOVA1=MSOUP1.IPOVAL DO 9 J=1,NOCOMP(/2) DO 10 K=1,NNIN IF(INCO(K).EQ.NOCOMP(J)) THEN IF(NHAR(K).EQ.NOHARM(J)) THEN NHA(J)=K GO TO 9 ENDIF ENDIF 10 CONTINUE CALL ERREUR(5) RETURN 9 CONTINUE DO 11 J=1,NUM(/2) DO 12 K=1,NOCOMP(/2) NN=NHA(K) IF(ABS(MPOVA1.VPOCHA(J,K)).GT.EPS) THEN BB(NN,NDEJ+J)=VPOCHA(J,K) IBIN(NN,NDEJ+J)=1 ENDIF 12 CONTINUE 11 CONTINUE NDEJ=NDEJ+NUM(/2) 7 CONTINUE CALL CRECHP(MTRAV,IRET) * * on attribut les memes natures MCHPO2 = IRET NAT = MAX(1,JATTRI(/1)) NSOUPO=MCHPO2.IPCHP(/1) SEGADJ MCHPO2 IF ( JATTRI(/1) .NE. 0) THEN DO 13 I=1,NAT MCHPO2.JATTRI(I)=JATTRI(I) 13 CONTINUE ENDIF * SEGSUP MTRAV,NOINCO END