Télécharger la plaquette Cast3M


fr en

Télécharger xtx2.eso

Retour à la liste

Numérotation des lignes : 

xtx2

  1. C XTX2      SOURCE    CB215821  26/08/24    21:18:58     12622          
  2. *_______________________________________________________________________
  3. *
  4. *              OPERATEUR XTX
  5. *
  6. *    ENTREE :
  7. *    --------
  8. *        IPCHE1   POINTEUR SUR UN MCHAM
  9. *
  10. *
  11. *    SORTIE :
  12. *    --------
  13. *        XFLOT    NORME DU CHAMELEM
  14. *        IRET     =1 OU 0 SUIVANT SUCCES OU PAS
  15. *_______________________________________________________________________
  16.  
  17.       SUBROUTINE XTX2(IPCHE1,XFLOT,IRET)
  18.  
  19.       IMPLICIT INTEGER(I-N)
  20.       IMPLICIT REAL*8(A-H,O-Z)
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24.  
  25. -INC SMELEME
  26. -INC SMINTE
  27. -INC SMLREEL
  28. -INC SMCHAML
  29.  
  30.       IRET = 0
  31.       CALL ACTOBJ('MCHAML  ',IPCHE1,1)
  32.       IF (IERR.NE.0) RETURN
  33.  
  34.       MCHELM = IPCHE1
  35.       NSOUS=ICHAML(/1)
  36.  
  37.       XFLOT=0.D0
  38. *
  39. *     BOUCLE SUR LES SOUS REFERENCES
  40. *
  41.       DO 100 ISOUS=1,NSOUS
  42. *
  43. *        RECUPERATION DES CARACTERISTIQUES DU CHAMELEM
  44. *
  45.          MELEME=IMACHE(ISOUS)
  46.          NBELEM=NUM(/2)
  47.  
  48.          MINTE=INFCHE(ISOUS,4)
  49.          IF (MINTE.EQ.0) THEN
  50.             NBPGAU=NUM(/1)
  51.          ELSE
  52.             NBPGAU=POIGAU(/1)
  53.          ENDIF
  54. *
  55.          MCHAML=ICHAML(ISOUS)
  56.          NCOMP=IELVAL(/1)
  57. *
  58.          DO 110 ICOMP=1,NCOMP
  59.             MELVAL=IELVAL(ICOMP)
  60.             IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN
  61.                DO 667 IGAU=1,NBPGAU
  62.                   IGMN=MIN(IGAU,VELCHE(/1))
  63.                   DO 200 IB=1,NBELEM
  64.                      IBMN=MIN(IB,VELCHE(/2))
  65.                      XX=VELCHE(IGMN,IBMN)
  66.                      XFLOT=XFLOT+XX*XX
  67.  200           CONTINUE
  68.   667          CONTINUE
  69.             ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  70.                DO 668 IGAU=1,NBPGAU
  71.                   IGMN=MIN(IGAU,IELCHE(/1))
  72.                   DO 201 IB=1,NBELEM
  73.                      IBMN=MIN(IB,IELCHE(/2))
  74.                      MLREEL=IELCHE(IGMN,IBMN)
  75. c*                     SEGACT MLREEL
  76.                      DO 120 IPROG=1,PROG(/1)
  77.                         XX=PROG(IPROG)
  78.                         XFLOT=XFLOT+XX*XX
  79.  120                 CONTINUE
  80.  201           CONTINUE
  81.   668          CONTINUE
  82.             ELSE
  83.                MOTERR(1:4)=NOMCHE(ICOMP)
  84.                CALL ERREUR (197)
  85.                GOTO 666
  86.             ENDIF
  87.  110     CONTINUE
  88.  100  CONTINUE
  89.       IRET = 1
  90.       RETURN
  91.  
  92.  666  CONTINUE
  93.       IRET=0
  94.       RETURN
  95.       END
  96.  
  97.  
  98.  
  99.  

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