Sources Esope | Cast3M

xtx4
C XTX4      SOURCE    OF166741  24/10/03    21:15:46     12022          
 
*_______________________________________________________________________
*
*          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
*_______________________________________________________________________
 
      SUBROUTINE XTX4(IPCHE1,IPCHE2,FLO1,FLO2,XDRET,IRET)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMELEME
-INC SMCHAML
-INC SMINTE
-INC SMLREEL
 
      CHARACTER*16 CONCH1,CONCH2
      PARAMETER(XZER=0.D0)
      DIMENSION ITR(40)
      PARAMETER(NINF=3)
      DIMENSION INFOS(NINF)
 
      IRET = 0
      XDRET = XZER
 
      CALL ACTOBJ('MCHAML  ',IPCHE1,1)
      IF (IERR.NE.0) RETURN
      CALL ACTOBJ('MCHAML  ',IPCHE2,1)
      IF (IERR.NE.0) RETURN
 
      MCHEL1 = IPCHE1
      MCHEL2 = IPCHE2
*
*     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
 
      N31=MCHEL1.INFCHE(/2)
      N32=MCHEL2.INFCHE(/2)
      N33=MAX(N31,N32)
c* On doit avoir N31 = N32 = N33 = 6 !
 
      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
                  INF1=MCHEL1.INFCHE(ISOUS,IN3)
                  INF2=MCHEL2.INFCHE(IBB  ,IN3)
                  IF (IN3.EQ.4) THEN
                     IF (INF1.EQ.INF2) GOTO 21
                     INF1 = MCHEL1.INFCHE(ISOUS,6)
                     INF2 = MCHEL2.INFCHE(IBB  ,6)
                  ELSE IF (IN3.EQ.6) THEN
                     IF (INF1.EQ.0) INF1=1
                     IF (INF2.EQ.0) INF2=1
                  ELSE
                  ENDIF
                  IF (INF1.NE.INF2) GOTO 166
 21            CONTINUE
               GOTO 120
            ENDIF
 110     CONTINUE
         GOTO 166
*
  120    CONTINUE
*
*        ACTIVATION DU MELEME
*
         MELEME=IPMAI1
         NBELEM=NUM(/2)
*
         MINTE=MCHEL1.INFCHE(ISOUS,4)
         IF (MINTE.EQ.0) MINTE=MCHEL2.INFCHE(ISOUS2,4)
         IF (MINTE.EQ.0) THEN
            NBPGAU=NUM(/1)
         ELSE
            NBPGAU=POIGAU(/1)
         ENDIF
*
         MCHAM1=MCHEL1.ICHAML(ISOUS )
         MCHAM2=MCHEL2.ICHAML(IBB   )
*
         NCOMP1=MCHAM1.IELVAL(/1)
         NCOMP2=MCHAM2.IELVAL(/1)
         IF (NCOMP1.NE.NCOMP2) THEN
            CALL ERREUR (103)
            GOTO 666
         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 666
            ENDIF
*
            MELVA1=MCHAM1.IELVAL(ICOMP)
            MELVA2=MCHAM2.IELVAL(IPLAC)
            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)
c*                     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 666
                     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 666
            ENDIF
  150    CONTINUE
  100 CONTINUE
 
      IRET=1
 
      RETURN
*
*
 166  CONTINUE
C      MOTERR(1:16)=MOT1//MOT3
      CALL ERREUR(329)
 666  CONTINUE
 
      RETURN
      END