Télécharger la plaquette Cast3M


fr en

Télécharger agreg1.eso

Retour à la liste

Numérotation des lignes : 

agreg1

  1. C AGREG1    SOURCE    FD218221  25/03/11    21:15:02     12187          
  2.       SUBROUTINE AGREG1(MLREEL,ICAS,XP,IROBU,AGR)
  3.  
  4. C     Application d'une fonction d'agregation sur un
  5. C     objet LISTREEL
  6.  
  7. C     Entrees :
  8. C     ---------
  9. C       MLREEL : Pointeur vers le LISTREEL (suppose actif)
  10. C       ICAS   : Entier, code de la fonction
  11. C                = 1  'SOMM'  Somme
  12. C                = 2  'PROD'  Produit
  13. C                = 3  'MOYE'  Moyenne arithmetique (moment d'ordre 1)
  14. C                = 4  'MOHA'  Moyenne harmonique
  15. C                = 5  'MOGE'  Moyenne geometrique
  16. C                = 6  'VARI'  Variance (moment centre d'ordre 2)
  17. C                = 7  'ECTY'  Ecart type
  18. C                = 8  'ASYM'  Coefficient d'asymetrie (moment centre reduit d'ordre 3)
  19. C                = 9  'KURT'  Kurtosis (moment centre reduit d'ordre 4)
  20. C                = 10 'MEDI'  Mediane
  21. C                = 11 'PMOM'  Moment d'ordre P
  22. C                = 12 'PMOY'  Moyenne generalise d'ordre P
  23. C                = 13 'PNOR'  Norme generalisee d'ordre P
  24. C                = 14 'LEHM'  Fonction de Lehmer d'ordre P
  25. C                = 15 'KSL'   Fonction de Kreisselmeir Steinhauser inferieure d'ordre P (MellowMax)
  26. C                = 16 'KSU'   Fonction de Kreisselmeir Steinhauser superieure d'ordre P (LogSumExp)
  27. C                = 17 'BOLT'  Fonction de Boltzmann d'ordre P
  28. C       XP    : Flottant, parametre pour les fonctions 'PMOY' 'PMOM' 'PNOR' 'LEHM'
  29. C                                                      'KSL'  'KSL'  'BOLT'
  30. C       IROB  : Entier, pour calcul robuste au overflow
  31. C               = 0 pour un calcul "naif"
  32. C               = autre chose pour un calcul "robuste" en normalisant les valeurs avec
  33. C                 la norme infinie ou bien le maximum, selon la fonction choisie
  34.  
  35. C     Sorties :
  36. C     ---------
  37. C       AGR    : Flottant, valeur de la fonction d'agregation
  38.  
  39.  
  40. C     Typages implicites habituels
  41.       IMPLICIT INTEGER(I-N)
  42.       IMPLICIT REAL*8(A-H,O-Z)
  43.  
  44. C     Les includes necessaires
  45. -INC CCREEL
  46. -INC SMLREEL
  47.  
  48. C     Quelques objets
  49.       LOGICAL ROBU
  50.  
  51. C     Taille du LISTREEL
  52.       NX=MLREEL.PROG(/1)
  53.  
  54. C     Initialisation du resultat
  55.       AGR=0.D0
  56.  
  57. C     Cas trivial non traite
  58.       IF (NX.LT.1) THEN
  59.         CALL ERREUR(21)
  60.         RETURN
  61.       ENDIF
  62.  
  63. C     Calcul robuste ?
  64.       ROBU=.FALSE.
  65.       IF (IROBU.NE.0) THEN
  66.         ROBU=.TRUE.
  67.         IF (ICAS.GE.12) THEN
  68.           CALL MAXIN3(MLREEL,IMAX,VMAX,1,0)
  69.           VINF=ABS(VMAX)
  70.           VPMAX=XP*VMAX
  71.         ENDIF
  72.       ENDIF
  73.  
  74. C     Cas de la P moyenne avec P=0 --> on utilise MOGE (moyenne geometrique)
  75.       IF ((ICAS.EQ.12).AND.(ABS(XP).LT.XPETIT)) THEN
  76.         ICAS=5
  77.       ENDIF
  78.  
  79. C     Somme (aussi utilise pour la moyenne, la variance, l'ecart type,
  80. C            l'asymetrie, le kurtosis)
  81.       IF ((ICAS.EQ.1).OR.(ICAS.EQ.3).OR.(ICAS.EQ.6).OR.(ICAS.EQ.7).OR.
  82.      &    (ICAS.EQ.8).OR.(ICAS.EQ.9)) THEN
  83.         SUM=0.D0
  84.         DO I=1,NX
  85.           XI=MLREEL.PROG(I)
  86.           SUM=SUM+XI
  87.         ENDDO
  88.         IF (ICAS.EQ.1) AGR=SUM
  89.       ENDIF
  90.  
  91. C     Produit (aussi utilise pour la moyenne geometrique)
  92.       IF ((ICAS.EQ.2).OR.(ICAS.EQ.5)) THEN
  93.         XPRO=1.D0
  94.         DO I=1,NX
  95.           XI=MLREEL.PROG(I)
  96.           XPRO=XPRO*XI
  97.         ENDDO
  98.         IF (ICAS.EQ.2) AGR=XPRO
  99.       ENDIF
  100.  
  101. C     Moyenne (aussi utilise pour la variance, l'ecart type, l'asymetrie, le kurtosis)
  102.       IF ((ICAS.EQ.3).OR.(ICAS.EQ.6).OR.(ICAS.EQ.7).OR.(ICAS.EQ.8).OR.
  103.      &    (ICAS.EQ.9)) THEN
  104.         XMOY=SUM/NX
  105.         IF (ICAS.EQ.3) AGR=XMOY
  106.       ENDIF
  107.  
  108. C     Moyenne harmonique
  109.       IF (ICAS.EQ.4) THEN
  110.         DO I=1,NX
  111.           XI=MLREEL.PROG(I)
  112.           AGR=AGR+(1.D0/XI)
  113.         ENDDO
  114.         AGR=NX/AGR
  115.       ENDIF
  116.  
  117. C     Moyenne geometrique
  118.       IF (ICAS.EQ.5) THEN
  119.         AGR=XPRO**(1.D0/NX)
  120.       ENDIF
  121.  
  122. C     Variance (aussi utilise pour l'ecart type, l'asymetrie, le kurtosis)
  123.       IF ((ICAS.EQ.6).OR.(ICAS.EQ.7).OR.(ICAS.EQ.8).OR.
  124.      &    (ICAS.EQ.9)) THEN
  125.         VAR=0.D0
  126.         DO I=1,NX
  127.           XI=MLREEL.PROG(I)
  128.           XM=XI-XMOY
  129.           VAR=VAR+(XM*XM)
  130.         ENDDO
  131.         VAR=VAR/NX
  132.         IF (ICAS.EQ.6) AGR=VAR
  133.       ENDIF
  134.  
  135. C     Ecart type (aussi utilise pour l'asymetrie, le kurtosis)
  136.       IF ((ICAS.EQ.7).OR.(ICAS.EQ.8).OR.(ICAS.EQ.9)) THEN
  137.         SIG=SQRT(VAR)
  138.         IF (ICAS.EQ.7) AGR=SIG
  139.       ENDIF
  140.  
  141. C     Coefficient d'asymetrie
  142.       IF (ICAS.EQ.8) THEN
  143.         AGR=0.D0
  144.         DO I=1,NX
  145.           XI=MLREEL.PROG(I)
  146.           AGR=AGR+(((XI-XMOY)/SIG)**3)
  147.         ENDDO
  148.         AGR=AGR/NX
  149.       ENDIF
  150.  
  151. C     Kurtosis
  152.       IF (ICAS.EQ.9) THEN
  153.         AGR=0.D0
  154.         DO I=1,NX
  155.           XI=MLREEL.PROG(I)
  156.           AGR=AGR+(((XI-XMOY)/SIG)**4)
  157.         ENDDO
  158.         AGR=AGR/NX
  159.       ENDIF
  160.  
  161. C     Mediane
  162.       IF (ICAS.EQ.10) THEN
  163. C       Tri des valeurs en ordre croissant (par insertion)
  164.         CALL ORDON1(MLREEL,.TRUE.,.FALSE.,0)
  165. C       Obtention de la valeur mediane
  166.         IF (MOD(NX,2).EQ.0) THEN
  167.           AGR=0.5D0*(MLREEL.PROG(NX/2)+MLREEL.PROG(NX/2+1))
  168.         ELSE
  169.           AGR=MLREEL.PROG(NX/2+1)
  170.         ENDIF
  171.       ENDIF
  172.  
  173. C     Moment d'ordre P
  174.       IF (ICAS.EQ.11) THEN
  175.         AGR=0.D0
  176.         DO I=1,NX
  177.           XI=MLREEL.PROG(I)
  178.           AGR=AGR+(XI**XP)
  179.         ENDDO
  180.       ENDIF
  181.  
  182. C     P moyenne (aussi utlise pour LEHM)
  183.       IF ((ICAS.EQ.12).OR.(ICAS.EQ.14)) THEN
  184.         SUMP=0.D0
  185.         DO I=1,NX
  186.           XI=MLREEL.PROG(I)
  187.           IF (ROBU) XI=XI/VINF
  188.           SUMP=SUMP+(XI**XP)
  189.         ENDDO
  190.         IF (ICAS.EQ.12) THEN
  191.           AGR=(SUMP/NX)**(1.D0/XP)
  192.           IF (ROBU) AGR=VINF*AGR
  193.         ENDIF
  194.       ENDIF
  195.  
  196. C     P norme
  197.       IF (ICAS.EQ.13) THEN
  198.         AGR=0.D0
  199.         DO I=1,NX
  200.           XI=MLREEL.PROG(I)
  201.           IF (ROBU) XI=XI/VINF
  202.           AGR=AGR+((ABS(XI))**XP)
  203.         ENDDO
  204.         AGR=AGR**(1.D0/XP)
  205.         IF (ROBU) AGR=VINF*AGR
  206.       ENDIF
  207.  
  208. C     Fonction de Lehmer
  209.       IF (ICAS.EQ.14) THEN
  210.         XPM1=XP-1.D0
  211.         SUMPM1=0.D0
  212.         DO I=1,NX
  213.           XI=MLREEL.PROG(I)
  214.           IF (ROBU) XI=XI/VINF
  215.           SUMPM1=SUMPM1+(XI**XPM1)
  216.         ENDDO
  217.         AGR=SUMP/SUMPM1
  218.         IF (ROBU) AGR=VINF*AGR
  219.       ENDIF
  220.  
  221. C     Fonctions de Kreisselmeir Steinhauser (aussi utilise pour Boltzmann)
  222.       IF ((ICAS.EQ.15).OR.(ICAS.EQ.16).OR.(ICAS.EQ.17)) THEN
  223.         SUMEP=0.D0
  224.         DO I=1,NX
  225.           XI=MLREEL.PROG(I)
  226.           IF (ROBU) XI=XI-VMAX
  227.           SUMEP=SUMEP+(EXP(XP*XI))
  228.         ENDDO
  229.       ENDIF
  230.       IF ((ICAS.EQ.15).OR.(ICAS.EQ.16)) THEN
  231.         IF (ICAS.EQ.15) AGR=(LOG(SUMEP/NX))/XP
  232.         IF (ICAS.EQ.16) AGR=(LOG(SUMEP))/XP
  233.         IF (ROBU) AGR=VMAX+AGR
  234.       ENDIF
  235.  
  236. C     Moyenne de Boltzmann
  237.       IF (ICAS.EQ.17) THEN
  238.         SUMXEP=0.D0
  239.         DO I=1,NX
  240.           XI=MLREEL.PROG(I)
  241.           IF (ROBU) XI=XI-VMAX
  242.           SUMXEP=SUMXEP+(XI*EXP(XP*XI))
  243.         ENDDO
  244.         AGR=SUMXEP/SUMEP
  245.         IF (ROBU) AGR=VMAX+AGR
  246.       ENDIF
  247.  
  248.       RETURN
  249.       END
  250.  
  251.  

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