Télécharger la plaquette Cast3M


fr en

Télécharger pdfi.eso

Retour à la liste

Numérotation des lignes : 

pdfi

  1. C PDFI      SOURCE    FANDEUR   22/05/02    21:15:28     11359          
  2.       SUBROUTINE PDFI(K,LQ,ITF,ITD,LY,LD,A,LPOI)
  3. *-----------------------------------------------------------------------
  4. *
  5. *     Calcule l'erreur quadratique totale pondérée
  6. *     et la sensibilité aux variations de chaque paramètre
  7. *
  8. *-----------------------------------------------------------------------
  9. *
  10. *     Appellée par AJU2
  11. *
  12. *-----------------------------------------------------------------------
  13. *
  14. *     Modifications :
  15. *     21/04/2006 : p. Maugis
  16. *       filtre si pas de paramètre linéaire + initialisation B et D
  17. *
  18. *-----------------------------------------------------------------------
  19.       IMPLICIT INTEGER(I-N)
  20.       IMPLICIT REAL*8 (A-H,O-Z)
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMLREEL
  25. -INC SMTABLE
  26.       POINTEUR MLREE4.MLREEL
  27. *TABLEAUX DE TRAVAIL
  28.       SEGMENT TRAV
  29.           REAL*8  Q(I)
  30.           INTEGER MF(I)
  31.           INTEGER MDG(J)
  32.           INTEGER MDF(J,I)
  33.           REAL*8  D(J)
  34.           REAL*8  B(J)
  35.       ENDSEGMENT
  36. *TABLEAUX DES VALEURS DE F,G
  37.       SEGMENT FG
  38.           REAL*8 F(I,M)
  39.           REAL*8 G(M)
  40.       ENDSEGMENT
  41. *TABLEAUX DES VALEURS DE DF/DPj,DG/Pj
  42.       SEGMENT DFDG
  43.           REAL*8 DF(J,I,M)
  44.           REAL*8 DG(J,M)
  45.       ENDSEGMENT
  46.       CHARACTER*8 BLANK
  47.       REAL*8 XVALRE
  48.       LOGICAL LOGRE
  49.       DATA BLANK/'        '/
  50.       CHARACTER*8 MTYPR
  51. C---------------------------------------------------
  52. *LISTE DES VALEURS DE Y
  53.       MLREEL=LY
  54.       SEGACT MLREEL
  55. *LISTE DES POIDS
  56.       MLREE4=LPOI
  57.       SEGACT MLREE4
  58.       N=PROG(/1)
  59. *LISTE DES PARAMETRES LINEAIRES
  60.       MLREE1=LQ
  61.       SEGACT MLREE1
  62.       L=MLREE1.PROG(/1)
  63. *LISTE DES VALEURS DE DPHI/DPj
  64.       JG=K
  65.       SEGINI MLREE2
  66.       LD=MLREE2
  67. *TABLE DES VALEURS DES Fi ET G
  68.       MTABLE=ITF
  69.       SEGACT MTABLE
  70. *TABLE DES VALEURS DE DFi/DPj ET DG/DPj
  71.       MTAB1=ITD
  72.       SEGACT MTAB1
  73.       I=L
  74.       J=K
  75.       M=N
  76.       SEGINI DFDG,FG,TRAV
  77.  
  78.  
  79. *     Lecture table FCT
  80.       IF (L.GT.0) THEN
  81.         CALL ACCTAB(MTABLE,'MOT     ',0,0.D0,'F',.TRUE.,0,
  82.      &                    'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,MTB)
  83.         DO I=1,L
  84.           CALL ACCTAB(MTB,'ENTIER  ',I,0.D0,BLANK,.TRUE.,0,
  85.      &                    'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MFI)
  86.           MF(I)=MFI
  87.         ENDDO
  88.       ENDIF
  89.  
  90.       MTYPR=BLANK
  91.       CALL ACCTAB(MTABLE,'MOT     ',0,0.D0,'G',.TRUE.,0,
  92.      &                   MTYPR,IVALRE,XVALRE,BLANK,LOGRE,MG)
  93.       IF (MG.NE.0) THEN
  94.          IF (MTYPR.NE.'LISTREEL') THEN
  95.             MOTERR(1:8) ='G       '
  96.             MOTERR(9:16)='LISTREEL'
  97.             CALL ERREUR(800)
  98.             RETURN
  99.          ENDIF
  100.       ENDIF
  101.  
  102. *     Lecture table DERI
  103.       IF (L.GT.0) THEN
  104.          CALL ACCTAB(MTAB1,'MOT     ',0,0.D0,'F',.TRUE.,0,
  105.      &                     'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,ITD1)
  106.          DO J=1,K
  107.            CALL ACCTAB(ITD1,'ENTIER  ',J,0.D0,BLANK,.TRUE.,0,
  108.      &                      'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,ITD11J)
  109.            DO I=1,L
  110.              CALL ACCTAB(ITD11J,'ENTIER  ',I,0.D0,BLANK,.TRUE.,0,
  111.      &                       'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MDFJI)
  112.              MDF(J,I)=MDFJI
  113.            ENDDO
  114.          ENDDO
  115.       ENDIF
  116.  
  117.       IF (MG.NE.0) THEN
  118.          CALL ACCTAB(MTAB1,'MOT     ',0,0.D0,'G',.TRUE.,0,
  119.      &                    'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,ITD2)
  120.          DO J=1,K
  121.             CALL ACCTAB(ITD2,'ENTIER  ',J,0.D0,BLANK,.TRUE.,0,
  122.      &                       'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MDGJ)
  123.             MDG(J)=MDGJ
  124.          ENDDO
  125.       ENDIF
  126.  
  127. *     valeurs des fonctions f_i
  128.       DO I=1,L
  129.             MLREE3=MF(I)
  130.             SEGACT MLREE3
  131.             DO M=1,N
  132.                  F(I,M)=MLREE3.PROG(M)
  133.             ENDDO
  134.             SEGDES MLREE3
  135.       ENDDO
  136.  
  137. *     valeurs de la fonction g
  138.       IF (MG.NE.0) THEN
  139.          MLREE3=MG
  140.          SEGACT MLREE3
  141.          DO M=1,N
  142.                G(M)=MLREE3.PROG(M)
  143.          ENDDO
  144.          SEGDES MLREE3
  145.       ELSE
  146.          DO J=1,N
  147.               G(J)=0
  148.          ENDDO
  149.       ENDIF
  150.  
  151. *     valeurs de la dérivée des fonctions f_i / paramètres p_k
  152.       DO J=1,K
  153.             DO I=1,L
  154.                  MLREE3=MDF(J,I)
  155.                  SEGACT MLREE3
  156.                  DO M=1,N
  157.                        DF(J,I,M)=MLREE3.PROG(M)
  158.                  ENDDO
  159.                  SEGDES MLREE3
  160.             ENDDO
  161.       ENDDO
  162.  
  163. *     valeurs de la dérivée de g / paramètres p_k
  164.       DO J=1,K
  165.          IF (MG.NE.0) THEN
  166.             MLREE3=MDG(J)
  167.             SEGACT MLREE3
  168.             DO M=1,N
  169.                   DG(J,M)=MLREE3.PROG(M)
  170.             ENDDO
  171.             SEGDES MLREE3
  172.          ELSE
  173.             DO M=1,N
  174.                   DG(J,M)=0
  175.             ENDDO
  176.          ENDIF
  177.       ENDDO
  178.  
  179. *      valeurs des paramètres non linéaires
  180.       IF (K.LE.0) GOTO 9999
  181.       DO I=1,L
  182.             Q(I)=MLREE1.PROG(I)
  183.       ENDDO
  184.  
  185.  
  186. *     Pour chaque paramètres p_j, somme sur tous les points de mesure
  187. *     de l'erreur d'estimation pondérée par les poids, et par la
  188. *     dérivée par rapport à p_j
  189.       DO J=1,K
  190.             B(J)=0
  191.             D(J)=0
  192.       ENDDO
  193.       DO IN=1,N
  194. *           calcul écart pondéré entre les valeur visées et
  195. *           l'estimation avec ce jeu de paramètres
  196.             CALL SSCAL1(F,Q,IN,SC,L)
  197.             Z = (PROG(IN)-G(IN)-SC) * MLREE4.PROG(IN)*MLREE4.PROG(IN)
  198. *           sensibilité aux variations de chaque paramètre p_j, fois Z
  199.             IF (L.LE.0) THEN
  200.                   DO J=1,K
  201.                         D(J)=D(J)+Z*DG(J,IN)
  202.                   ENDDO
  203.             ELSE
  204. *                 si présence paramètres linéaires, priorité aux f_i
  205.                   DO J=1,K
  206.                         CALL SSCAL2 (DF,Q,IN,SC2,J,K,L,N)
  207.                         B(J)=DG(J,IN)+SC2
  208.                   ENDDO
  209.                   DO J=1,K
  210.                         D(J)=D(J)+Z*B(J)
  211.                   ENDDO
  212.             ENDIF
  213.       ENDDO
  214.  
  215. *     Variation et erreur quadratique totales
  216.       A=0.D0
  217.       DO J=1,K
  218.             MLREE2.PROG(J)=D(J)
  219.             A=A+D(J)*D(J)
  220.       ENDDO
  221.  
  222.       SEGDES MLREEL,MLREE1,FG,DFDG,MTABLE,MTAB1
  223.       SEGDES MLREE4,MLREE2
  224.       SEGSUP TRAV
  225.  
  226.  9999 CONTINUE
  227. C      RETURN
  228.       END
  229.  
  230.  
  231.  

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