Télécharger la plaquette Cast3M


fr en

Télécharger xtx3.eso

Retour à la liste

Numérotation des lignes : 

xtx3

  1. C XTX3      SOURCE    CB215821  20/11/25    13:43:34     10792          
  2.       SUBROUTINE XTX3(ICH1,ICH2,FLO1,FLO2,XDRET,IRET)
  3. C=======================================================================
  4. C  ENTREES
  5. C     ICH1 POINTEUR SUR UN CHPOINT
  6. C     ICH2 POINTEUR SUR UN CHPOINT
  7. C     FLO1 FLOTTANT
  8. C     FLO2 FLOTTANT
  9. C  SORTIES
  10. C     XDRET   = XTX  FLO1 * ICH1 + FLO2 * FLO2
  11. C     IRET   = 1 SI SUCCES 0 SINON
  12. C=======================================================================
  13.       IMPLICIT INTEGER(I-N)
  14.       IMPLICIT REAL*8(A-H,O-Z)
  15.       PARAMETER(XZER=0.D0)
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC SMCHPOI
  20.       DIMENSION ITR(40)
  21. C
  22.       XDRET=XZER
  23.       IRET=1
  24. C
  25.       MCHPO1=ICH1
  26.       MCHPO2=ICH2
  27. C
  28.       SEGACT MCHPO1,MCHPO2
  29.       NS1=MCHPO1.IPCHP(/1)
  30.       NS2=MCHPO2.IPCHP(/1)
  31.       MOTERR(1:8)=MCHPO1.MTYPOI
  32.       MOTERR(9:16)=MCHPO2.MTYPOI
  33. C
  34. C     LES CHPOINTS SONT ILS COMPATIBLES    ??
  35. C
  36.       IF(MCHPO1.IFOPOI.NE.MCHPO2.IFOPOI) GOTO 166
  37.       IF(NS1.NE.NS2) GOTO  166
  38. C
  39.       GOTO 20
  40. C
  41. C       GESTION DE  L ERREUR
  42. C
  43.   166 CONTINUE
  44.       IRET=0
  45.       CALL ERREUR(347)
  46.       GOTO 666
  47.   20  CONTINUE
  48. C
  49. C      QUELLES CORESPONDANCE ENTRE LES SOUS PAQUETS DES CHPOINTS
  50. C
  51.       DO 100 IA=1,NS1
  52.       MSOUP1=MCHPO1.IPCHP(IA)
  53.       SEGACT MSOUP1
  54.       IGEO1=MSOUP1.IGEOC
  55.       SEGDES MSOUP1
  56.       DO 110 IB=1,NS2
  57.       MSOUP2=MCHPO2.IPCHP(IB)
  58.       SEGACT MSOUP2
  59.       IGEO2=MSOUP2.IGEOC
  60.       IBB  =MSOUP2.IPOVAL
  61.       SEGDES MSOUP2
  62.       IF(IGEO1.EQ.IGEO2) GOTO 120
  63.   110 CONTINUE
  64. C
  65. C     MESSAGE D ERREUR
  66. C
  67.       IRET=0
  68.       CALL ERREUR(348)
  69.       GOTO 666
  70.   120 CONTINUE
  71.       ITR(IA)=IBB
  72.   100 CONTINUE
  73. C
  74. C     BOUCLE SUR LES SOUS PAQUETS  EN COMMUN
  75. C
  76.       DO 200 IA=1,NS1
  77.       MSOUP1=MCHPO1.IPCHP(IA)
  78.       SEGACT MSOUP1
  79.       MPOVA1=MSOUP1.IPOVAL
  80.       SEGDES MSOUP1
  81.       IBB=ITR(IA)
  82.       MPOVA2= IBB
  83. C
  84.       SEGACT MPOVA1,MPOVA2
  85.       N1  =MPOVA1.VPOCHA(/1)
  86.       NC1 =MPOVA1.VPOCHA(/2)
  87.       N2  =MPOVA2.VPOCHA(/1)
  88.       NC2 =MPOVA2.VPOCHA(/2)
  89. C
  90. C       VERIFICATION TAILLE DES CHPOINTS
  91. C
  92.       IF(N1.NE.N2) GOTO 444
  93.       IF(NC1.NE.NC2) GOTO 444
  94.       GOTO 330
  95. C
  96. C       ERREUR TAILLE CHPOINTS
  97. C
  98.   444 CONTINUE
  99.       MOTERR(1:8)='XTX3'
  100.       IRET=0
  101.       CALL ERREUR(178)
  102.       SEGDES MPOVA1,MPOVA2
  103.       GOTO 666
  104. C
  105.   330 CONTINUE
  106.       DO 300 IB=1,N1
  107.       DO 400 IC=1,NC1
  108.       XXT1=MPOVA1.VPOCHA(IB,IC)
  109.       XXT2=MPOVA2.VPOCHA(IB,IC)
  110.       XX  =      FLO1*XXT1+FLO2*FLO2
  111.       XDRET  = XDRET + XX*XX
  112.   400 CONTINUE
  113.   300 CONTINUE
  114.       SEGDES MPOVA1,MPOVA2
  115.   200 CONTINUE
  116. C
  117.   666 CONTINUE
  118.       SEGDES MCHPO1,MCHPO2
  119.       RETURN
  120.       END
  121.  
  122.  
  123.  

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