Télécharger la plaquette Cast3M


fr en

Télécharger xtx4.eso

Retour à la liste

Numérotation des lignes : 

xtx4

  1. C XTX4      SOURCE    CB215821  20/11/04    21:22:22     10766          
  2.       SUBROUTINE XTX4(IPCHE1,IPCHE2,FLO1,FLO2,XDRET,IRET)
  3. *_______________________________________________________________________
  4. *
  5. *          OPERATEUR XTX
  6. *
  7. *    ENTREES :
  8. *    ---------
  9. *        IPCHE1   POINTEUR SUR UN CHAMELEM
  10. *        IPCHE2   POINTEUR SUR UN CHAMELEM
  11. *        FLO1     FLOTTANT
  12. *        FLO2     FLOTTANT
  13. *
  14. *
  15. *    SORTIES :
  16. *    ---------
  17. *        XDRET    XTX = FLO1 * ICH1 + FLO2 * FLO2
  18. *        IRET     1 SI SUCCES 0 SINON
  19. *
  20. *    PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 02/91
  21. *
  22. *_______________________________________________________________________
  23. *
  24.       IMPLICIT INTEGER(I-N)
  25.       IMPLICIT REAL*8(A-H,O-Z)
  26. *
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC SMELEME
  31. -INC SMCHAML
  32. -INC SMINTE
  33. -INC SMLREEL
  34. *
  35. C      CHARACTER*8 MOT1,MOT3
  36.       CHARACTER*16 CONCH1,CONCH2
  37.       PARAMETER(XZER=0.D0)
  38.       DIMENSION ITR(40)
  39.       PARAMETER(NINF=3)
  40.       DIMENSION INFOS(NINF)
  41. *
  42.       XDRET=XZER
  43.       IRET=1
  44. *
  45.       MCHEL1=IPCHE1
  46.       MCHEL2=IPCHE2
  47. *
  48.       SEGACT MCHEL1,MCHEL2
  49. *
  50. *     LES CHAMELEMS SONT ILS COMPATIBLES    ??
  51. *
  52.       NSOUS1=MCHEL1.ICHAML(/1)
  53.       NSOUS2=MCHEL2.ICHAML(/1)
  54.       IF (NSOUS1.NE.NSOUS2) GOTO 166
  55. *
  56.       IFO1=MCHEL1.IFOCHE
  57.       IFO2=MCHEL2.IFOCHE
  58.       IF (IFO1.NE.IFO2) GOTO 166
  59. *
  60.       GOTO 20
  61. *
  62. *     GESTION DE  L ERREUR
  63. *
  64.   166 CONTINUE
  65. C      MOTERR(1:16)=MOT1//MOT3
  66.       CALL ERREUR(329)
  67.       GOTO 666
  68. *
  69.   20  CONTINUE
  70.       N31=MCHEL1.INFCHE(/2)
  71.       N32=MCHEL2.INFCHE(/2)
  72.       N33=MAX(N31,N32)
  73. *
  74.       DO 100 ISOUS=1,NSOUS1
  75.          IPMAI1=MCHEL1.IMACHE(ISOUS)
  76.          CONCH1=MCHEL1.CONCHE(ISOUS)
  77.          DO 110 ISOUS2=1,NSOUS2
  78.             IBB=ISOUS2
  79.             IPMAI2=MCHEL2.IMACHE(ISOUS2)
  80.             CONCH2=MCHEL2.CONCHE(ISOUS2)
  81.             IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  82. *
  83. *              Verification pour les INFCHEs
  84. *
  85.                CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  86.                IF (IRTD.EQ.0) GOTO 166
  87.                DO 21 IN3=1,N33
  88.                   IF (IN3.GT.N31) THEN
  89.                      INF1=0
  90.                   ELSE
  91.                      INF1=MCHEL1.INFCHE(ISOUS,IN3)
  92.                   ENDIF
  93.                   IF (IN3.GT.N32) THEN
  94.                      INF2=0
  95.                   ELSE
  96.                      INF2=MCHEL2.INFCHE(IBB  ,IN3)
  97.                   ENDIF
  98.                   IF (IN3.EQ.4) THEN
  99.                      IF (INF1.EQ.INF2) GOTO 21
  100.                      IF (N31.GE.6) INF1=MCHEL1.INFCHE(ISOUS,6)
  101.                      IF (N32.GE.6) INF2=MCHEL2.INFCHE(IBB  ,6)
  102.                      IF (INF1.EQ.0) INF1=1
  103.                      IF (INF2.EQ.0) INF1=1
  104.                      IF (INF1.EQ.INF2) GOTO 21
  105.                      GOTO 166
  106.                   ELSE IF (IN3.EQ.6) THEN
  107.                      IF (INF1.EQ.0) INF1=1
  108.                      IF (INF2.EQ.0) INF1=1
  109.                      IF (INF1.EQ.INF2) GOTO 21
  110.                      GOTO 166
  111.                   ELSE
  112.                      IF (INF1.EQ.INF2) GOTO 21
  113.                      GOTO 166
  114.                   ENDIF
  115.  21            CONTINUE
  116.                GOTO 120
  117.             ENDIF
  118.  110     CONTINUE
  119.          GOTO 166
  120. *
  121.   120    CONTINUE
  122. *
  123. *        ACTIVATION DU MELEME
  124. *
  125.          MELEME=IPMAI1
  126.          SEGACT MELEME
  127.          NBELEM=NUM(/2)
  128. *
  129.          MINTE=0
  130.          IF (N31.GE.4) MINTE=MCHEL1.INFCHE(ISOUS,4)
  131.          IF (MINTE.EQ.0.AND.N32.GE.4) MINTE=MCHEL2.INFCHE(ISOUS2,4)
  132.          IF (MINTE.EQ.0) THEN
  133.             NBPGAU=NUM(/1)
  134.          ELSE
  135.             SEGACT MINTE
  136.             NBPGAU=POIGAU(/1)
  137.             SEGDES MINTE
  138.          ENDIF
  139.          SEGDES MELEME
  140. *
  141.          MCHAM1=MCHEL1.ICHAML(ISOUS )
  142.          MCHAM2=MCHEL2.ICHAML(IBB   )
  143.          SEGACT MCHAM1,MCHAM2
  144. *
  145.          NCOMP1=MCHAM1.IELVAL(/1)
  146.          NCOMP2=MCHAM2.IELVAL(/1)
  147.          IF (NCOMP1.NE.NCOMP2) THEN
  148.             CALL ERREUR (103)
  149.             GOTO 667
  150.          ENDIF
  151. *
  152.          DO 150 ICOMP=1,NCOMP1
  153.             CALL PLACE(MCHAM2.NOMCHE,NCOMP2,IPLAC,MCHAM1.NOMCHE(ICOMP))
  154.             IF (IPLAC.EQ.0) THEN
  155.                MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  156.                MOTERR(5:8)=MCHEL1.TITCHE
  157.                CALL ERREUR (77)
  158.                GOTO 667
  159.             ENDIF
  160. *
  161.             MELVA1=MCHAM1.IELVAL(ICOMP)
  162.             MELVA2=MCHAM2.IELVAL(IPLAC)
  163.             SEGACT MELVA1,MELVA2
  164.             IF ( MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8'.AND.
  165.      &           MCHAM2.TYPCHE(IPLAC).EQ.'REAL*8'     ) THEN
  166.                DO 300 IB=1,NBELEM
  167.                   IBMN1=MIN(IB,MELVA1.VELCHE(/2))
  168.                   IBMN2=MIN(IB,MELVA2.VELCHE(/2))
  169.                   DO 400 IGAU=1,NBPGAU
  170.                      IGMN1=MIN(IGAU,MELVA1.VELCHE(/1))
  171.                      IGMN2=MIN(IGAU,MELVA2.VELCHE(/1))
  172.                      XXT1=MELVA1.VELCHE(IGMN1,IBMN1)
  173.                      XXT2=MELVA2.VELCHE(IGMN2,IBMN2)
  174.                      XX    = FLO1*XXT1 + FLO2*XXT2
  175.                      XDRET = XDRET + XX*XX
  176.   400             CONTINUE
  177.   300          CONTINUE
  178.             ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL'.AND.
  179.      &               MCHAM2.TYPCHE(IPLAC).EQ.'POINTEURLISTREEL' ) THEN
  180.                DO 301 IB=1,NBELEM
  181.                   IBMN1=MIN(IB,MELVA1.IELCHE(/2))
  182.                   IBMN2=MIN(IB,MELVA2.IELCHE(/2))
  183.                   DO 401 IGAU=1,NBPGAU
  184.                      IGMN1=MIN(IGAU,MELVA1.IELCHE(/1))
  185.                      IGMN2=MIN(IGAU,MELVA2.IELCHE(/1))
  186.                      MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  187.                      MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  188.                      SEGACT MLREE1,MLREE2
  189.                      JG1=MLREE1.PROG(/1)
  190.                      JG2=MLREE2.PROG(/1)
  191.                      IF (JG1.NE.JG2) THEN
  192.                         MOTERR(1:4)='XTX '
  193.                         MOTERR(5:12)='MLREEL'
  194.                         CALL ERREUR (125)
  195.                         GOTO 668
  196.                      ENDIF
  197.                      DO 200 IPROG=1,JG1
  198.                         XXT1=MLREE1.PROG(IPROG)
  199.                         XXT2=MLREE2.PROG(IPROG)
  200.                         XX    = FLO1*XXT1 + FLO2*FLO2
  201.                         XDRET = XDRET + XX*XX
  202.   200                CONTINUE
  203.   401             CONTINUE
  204.   301         CONTINUE
  205.             ELSE
  206.                MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  207.                CALL ERREUR (197)
  208.                GOTO 668
  209.             ENDIF
  210.   150    CONTINUE
  211.   100 CONTINUE
  212.       RETURN
  213. *
  214.  668  CONTINUE
  215. *
  216.  667  CONTINUE
  217. *
  218.   666 CONTINUE
  219.       IRET=0
  220.       RETURN
  221.       END
  222.  
  223.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales