Return to distributions.F90 CVS log

Up to [local] / rpl / src

Correction d'une réinitialisation sauvage de la pile des variables par niveau
dans la copie de la structure de description du processus. Cela corrige
la fonction SPAWN qui échouait sur un segmentation fault car la pile des
variables par niveau était vide alors même que l'arbre des variables contenait
bien les variables. Passage à la prerelease 2.

    1: !===============================================================================
    2: ! RPL/2 (R) version 4.1.0.prerelease.2
    3: ! Copyright (C) 1989-2011 Dr. BERTRAND Joël
    4: !
    5: ! This file is part of RPL/2.
    6: !
    7: ! RPL/2 is free software; you can redistribute it and/or modify it
    8: ! under the terms of the CeCILL V2 License as published by the french
    9: ! CEA, CNRS and INRIA.
   10: !
   11: ! RPL/2 is distributed in the hope that it will be useful, but WITHOUT
   12: ! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   13: ! FITNESS FOR A PARTICULAR PURPOSE.  See the CeCILL V2 License
   14: ! for more details.
   15: !
   16: ! You should have received a copy of the CeCILL License
   17: ! along with RPL/2. If not, write to info@cecill.info.
   18: !===============================================================================
   19: 
   20: 
   21: #include "rplftypes-conv.inc"
   22: 
   23: 
   24: !===============================================================================
   25: ! Fonction renvoyant la valeur de la distribution X² à v degrés de liberté
   26: ! cumulée à droite
   27: !===============================================================================
   28: ! Entrées :
   29: !   real*8 X2    : valeur de la variable X²
   30: !   integer*4 NU : nombre de degrés de liberté
   31: !-------------------------------------------------------------------------------
   32: ! Sortie :
   33: !   real*8 donnant la probabilité P(X < X2)
   34: !-------------------------------------------------------------------------------
   35: ! Effets de bord : néant
   36: !===============================================================================
   37: 
   38: subroutine F90X2CD(X2, NU, RESULTAT) bind(C, name='f90x2cd')
   39:     use iso_c_binding
   40:     implicit none
   41: 
   42:     integer(rpl_integer8), intent(in) ::    NU
   43:     
   44:     real(rpl_real8), intent(out) ::         RESULTAT
   45:     real(rpl_real8), intent(in) ::          X2
   46: 
   47:     interface
   48:         real(c_double) function gsl_cdf_chisq_Q(X2, NU) &
   49:                 bind(C, name='gsl_cdf_chisq_Q')
   50:             use iso_c_binding
   51:             implicit none
   52:             real(c_double), intent(in), value    :: NU
   53:             real(c_double), intent(in), value    :: X2
   54:         end function
   55:     end interface
   56: 
   57:     RESULTAT = gsl_cdf_chisq_Q(X2, dble(NU))
   58: 
   59:     return
   60: end subroutine
   61: 
   62: 
   63: !===============================================================================
   64: ! Fonction renvoyant la valeur de la distribution F à v1 et v2 degrés de liberté
   65: ! cumulée à droite
   66: !===============================================================================
   67: ! Entrées :
   68: !   real*8 F      : valeur de la variable
   69: !   integer*4 NU1 : nombre de degrés de liberté
   70: !   integer*4 NU2 : nombre de degrés de liberté
   71: !-------------------------------------------------------------------------------
   72: ! Sortie :
   73: !   real*8 donnant la probabilité P(X < F)
   74: !-------------------------------------------------------------------------------
   75: ! Effets de bord : néant
   76: !===============================================================================
   77: 
   78: subroutine F90FCD(F, NU1, NU2, RESULTAT) bind(C, name='f90fcd')
   79:     use iso_c_binding
   80:     implicit none
   81: 
   82:     integer(rpl_integer8), intent(in) ::    NU1
   83:     integer(rpl_integer8), intent(in) ::    NU2
   84: 
   85:     real(rpl_real8), intent(in) ::          F
   86:     real(rpl_real8), intent(out) ::         RESULTAT
   87: 
   88:     interface
   89:         real(c_double) function gsl_cdf_fdist_Q(F, NU1, NU2) &
   90:                 bind(C, name='gsl_cdf_fdist_Q')
   91:             use iso_c_binding
   92:             implicit none
   93:             real(c_double), intent(in), value    :: NU1
   94:             real(c_double), intent(in), value    :: NU2
   95:             real(c_double), intent(in), value    :: F
   96:         end function
   97:     end interface
   98: 
   99:     RESULTAT = gsl_cdf_fdist_Q(F, dble(NU1), dble(NU2))
  100: 
  101:     return
  102: end subroutine
  103: 
  104: 
  105: !===============================================================================
  106: ! Fonction renvoyant la valeur de la distribution du t de Student
  107: ! cumulée à droite
  108: !===============================================================================
  109: ! Entrées :
  110: !   real*8 T : point de calcul
  111: !   real*8 N : nombre de degrés de liberté
  112: !-------------------------------------------------------------------------------
  113: ! Sortie :
  114: !   real*8 donnant la probabilité P(X < T)
  115: !-------------------------------------------------------------------------------
  116: ! Effets de bord : néant
  117: !===============================================================================
  118: 
  119: subroutine F90TCD(T, NU, RESULTAT) bind(C, name='f90tcd')
  120:     use iso_c_binding
  121:     implicit none
  122: 
  123:     integer(rpl_integer8), intent(in) ::        NU
  124: 
  125:     real(rpl_real8), intent(out) ::             RESULTAT
  126:     real(rpl_real8), intent(in) ::              T
  127: 
  128:     interface
  129:         real(c_double) function gsl_cdf_tdist_Q(T, NU) &
  130:                 bind(C, name='gsl_cdf_tdist_Q')
  131:             use iso_c_binding
  132:             implicit none
  133:             real(rpl_real8), intent(in), value  ::  NU
  134:             real(rpl_real8), intent(in), value  ::  T
  135:         end function
  136:     end interface
  137: 
  138:     RESULTAT = gsl_cdf_tdist_Q(T, dble(NU))
  139: 
  140:     return
  141: end subroutine
  142: 
  143: 
  144: !===============================================================================
  145: ! Fonction renvoyant la valeur de la distribution normale cumulée à droite
  146: !===============================================================================
  147: ! Entrées :
  148: !   real*8 X : point de calcul
  149: !   real*8 MOYENNE et VARIANCE de la distribution
  150: !-------------------------------------------------------------------------------
  151: ! Sortie :
  152: !   real*8 donnant la probabilité P(R < X)
  153: !-------------------------------------------------------------------------------
  154: ! Effets de bord : néant
  155: !===============================================================================
  156: 
  157: subroutine F90GAUSSCD(X, MOYENNE, VARIANCE, RESULTAT) bind(C, name='f90gausscd')
  158:     use iso_c_binding
  159:     implicit none
  160: 
  161:     real(rpl_real8), intent(in) ::      MOYENNE
  162:     real(rpl_real8), intent(in) ::      VARIANCE
  163:     real(rpl_real8), intent(in) ::      X
  164: 
  165:     real(rpl_real8), intent(out) ::     RESULTAT
  166: 
  167:     real(rpl_real8)                     Z
  168: 
  169:     interface
  170:         real(c_double) function gsl_cdf_ugaussian_Q(Z) &
  171:                 bind(C, name='gsl_cdf_ugaussian_Q')
  172:             use iso_c_binding
  173:             implicit none
  174:             real(c_double), intent(in), value ::    Z
  175:         end function
  176:     end interface
  177: 
  178:     Z = (X - MOYENNE) / sqrt(VARIANCE)
  179:     RESULTAT = gsl_cdf_ugaussian_Q(Z)
  180: 
  181:     return
  182: end subroutine
  183: 
  184: ! vim: ts=4