C XTX4 SOURCE CB215821 20/11/04 21:22:22 10766 SUBROUTINE XTX4(IPCHE1,IPCHE2,FLO1,FLO2,XDRET,IRET) *_______________________________________________________________________ * * OPERATEUR XTX * * ENTREES : * --------- * IPCHE1 POINTEUR SUR UN CHAMELEM * IPCHE2 POINTEUR SUR UN CHAMELEM * FLO1 FLOTTANT * FLO2 FLOTTANT * * * SORTIES : * --------- * XDRET XTX = FLO1 * ICH1 + FLO2 * FLO2 * IRET 1 SI SUCCES 0 SINON * * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 02/91 * *_______________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCHAML -INC SMINTE -INC SMLREEL * C CHARACTER*8 MOT1,MOT3 CHARACTER*16 CONCH1,CONCH2 PARAMETER(XZER=0.D0) DIMENSION ITR(40) PARAMETER(NINF=3) DIMENSION INFOS(NINF) * XDRET=XZER IRET=1 * MCHEL1=IPCHE1 MCHEL2=IPCHE2 * SEGACT MCHEL1,MCHEL2 * * LES CHAMELEMS SONT ILS COMPATIBLES ?? * NSOUS1=MCHEL1.ICHAML(/1) NSOUS2=MCHEL2.ICHAML(/1) IF (NSOUS1.NE.NSOUS2) GOTO 166 * IFO1=MCHEL1.IFOCHE IFO2=MCHEL2.IFOCHE IF (IFO1.NE.IFO2) GOTO 166 * GOTO 20 * * GESTION DE L ERREUR * 166 CONTINUE C MOTERR(1:16)=MOT1//MOT3 CALL ERREUR(329) GOTO 666 * 20 CONTINUE N31=MCHEL1.INFCHE(/2) N32=MCHEL2.INFCHE(/2) N33=MAX(N31,N32) * DO 100 ISOUS=1,NSOUS1 IPMAI1=MCHEL1.IMACHE(ISOUS) CONCH1=MCHEL1.CONCHE(ISOUS) DO 110 ISOUS2=1,NSOUS2 IBB=ISOUS2 IPMAI2=MCHEL2.IMACHE(ISOUS2) CONCH2=MCHEL2.CONCHE(ISOUS2) IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN * * Verification pour les INFCHEs * CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 166 DO 21 IN3=1,N33 IF (IN3.GT.N31) THEN INF1=0 ELSE INF1=MCHEL1.INFCHE(ISOUS,IN3) ENDIF IF (IN3.GT.N32) THEN INF2=0 ELSE INF2=MCHEL2.INFCHE(IBB ,IN3) ENDIF IF (IN3.EQ.4) THEN IF (INF1.EQ.INF2) GOTO 21 IF (N31.GE.6) INF1=MCHEL1.INFCHE(ISOUS,6) IF (N32.GE.6) INF2=MCHEL2.INFCHE(IBB ,6) IF (INF1.EQ.0) INF1=1 IF (INF2.EQ.0) INF1=1 IF (INF1.EQ.INF2) GOTO 21 GOTO 166 ELSE IF (IN3.EQ.6) THEN IF (INF1.EQ.0) INF1=1 IF (INF2.EQ.0) INF1=1 IF (INF1.EQ.INF2) GOTO 21 GOTO 166 ELSE IF (INF1.EQ.INF2) GOTO 21 GOTO 166 ENDIF 21 CONTINUE GOTO 120 ENDIF 110 CONTINUE GOTO 166 * 120 CONTINUE * * ACTIVATION DU MELEME * MELEME=IPMAI1 SEGACT MELEME NBELEM=NUM(/2) * MINTE=0 IF (N31.GE.4) MINTE=MCHEL1.INFCHE(ISOUS,4) IF (MINTE.EQ.0.AND.N32.GE.4) MINTE=MCHEL2.INFCHE(ISOUS2,4) IF (MINTE.EQ.0) THEN NBPGAU=NUM(/1) ELSE SEGACT MINTE NBPGAU=POIGAU(/1) SEGDES MINTE ENDIF SEGDES MELEME * MCHAM1=MCHEL1.ICHAML(ISOUS ) MCHAM2=MCHEL2.ICHAML(IBB ) SEGACT MCHAM1,MCHAM2 * NCOMP1=MCHAM1.IELVAL(/1) NCOMP2=MCHAM2.IELVAL(/1) IF (NCOMP1.NE.NCOMP2) THEN CALL ERREUR (103) GOTO 667 ENDIF * DO 150 ICOMP=1,NCOMP1 CALL PLACE(MCHAM2.NOMCHE,NCOMP2,IPLAC,MCHAM1.NOMCHE(ICOMP)) IF (IPLAC.EQ.0) THEN MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) MOTERR(5:8)=MCHEL1.TITCHE CALL ERREUR (77) GOTO 667 ENDIF * MELVA1=MCHAM1.IELVAL(ICOMP) MELVA2=MCHAM2.IELVAL(IPLAC) SEGACT MELVA1,MELVA2 IF ( MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8'.AND. & MCHAM2.TYPCHE(IPLAC).EQ.'REAL*8' ) THEN DO 300 IB=1,NBELEM IBMN1=MIN(IB,MELVA1.VELCHE(/2)) IBMN2=MIN(IB,MELVA2.VELCHE(/2)) DO 400 IGAU=1,NBPGAU IGMN1=MIN(IGAU,MELVA1.VELCHE(/1)) IGMN2=MIN(IGAU,MELVA2.VELCHE(/1)) XXT1=MELVA1.VELCHE(IGMN1,IBMN1) XXT2=MELVA2.VELCHE(IGMN2,IBMN2) XX = FLO1*XXT1 + FLO2*XXT2 XDRET = XDRET + XX*XX 400 CONTINUE 300 CONTINUE ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL'.AND. & MCHAM2.TYPCHE(IPLAC).EQ.'POINTEURLISTREEL' ) THEN DO 301 IB=1,NBELEM IBMN1=MIN(IB,MELVA1.IELCHE(/2)) IBMN2=MIN(IB,MELVA2.IELCHE(/2)) DO 401 IGAU=1,NBPGAU IGMN1=MIN(IGAU,MELVA1.IELCHE(/1)) IGMN2=MIN(IGAU,MELVA2.IELCHE(/1)) MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) SEGACT MLREE1,MLREE2 JG1=MLREE1.PROG(/1) JG2=MLREE2.PROG(/1) IF (JG1.NE.JG2) THEN MOTERR(1:4)='XTX ' MOTERR(5:12)='MLREEL' CALL ERREUR (125) GOTO 668 ENDIF DO 200 IPROG=1,JG1 XXT1=MLREE1.PROG(IPROG) XXT2=MLREE2.PROG(IPROG) XX = FLO1*XXT1 + FLO2*FLO2 XDRET = XDRET + XX*XX 200 CONTINUE 401 CONTINUE 301 CONTINUE ELSE MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) CALL ERREUR (197) GOTO 668 ENDIF 150 CONTINUE 100 CONTINUE RETURN * 668 CONTINUE * 667 CONTINUE * 666 CONTINUE IRET=0 RETURN END