Télécharger pdfi.eso

Retour à la liste

Numérotation des lignes :

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

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