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 78 : CALL ACCTAB(MTABLE,'MOT ',0,0.D0,'F',.TRUE.,0, 79 : & 'TABLE ',IVALRE,XVALRE,BLANK,LOGRE,MTB) 80 : DO I=1,L 80 : CALL ACCTAB(MTB,'ENTIER ',I,0.D0,BLANK,.TRUE.,0, 81 : & 'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MFI) 82 : MF(I)=MFI 83 : ENDDO 84 : ENDIF 85 : 86 : MTYPR=BLANK 86 : CALL ACCTAB(MTABLE,'MOT ',0,0.D0,'G',.TRUE.,0, 87 : & MTYPR,IVALRE,XVALRE,BLANK,LOGRE,MG) 88 : IF (MG.NE.0) THEN 89 : IF (MTYPR.NE.'LISTREEL') THEN 90 : MOTERR(1:8) ='G ' 91 : MOTERR(9:16)='LISTREEL' 91 : CALL ERREUR(800) 92 : RETURN 93 : ENDIF 94 : ENDIF 95 : 96 : * Lecture table DERI 97 : IF (L.GT.0) THEN 97 : CALL ACCTAB(MTAB1,'MOT ',0,0.D0,'F',.TRUE.,0, 98 : & 'TABLE ',IVALRE,XVALRE,BLANK,LOGRE,ITD1) 99 : DO J=1,K 99 : CALL ACCTAB(ITD1,'ENTIER ',J,0.D0,BLANK,.TRUE.,0, 100 : & 'TABLE ',IVALRE,XVALRE,BLANK,LOGRE,ITD11J) 101 : DO I=1,L 101 : CALL ACCTAB(ITD11J,'ENTIER ',I,0.D0,BLANK,.TRUE.,0, 102 : & 'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MDFJI) 103 : MDF(J,I)=MDFJI 104 : ENDDO 105 : ENDDO 106 : ENDIF 107 : 108 : IF (MG.NE.0) THEN 108 : CALL ACCTAB(MTAB1,'MOT ',0,0.D0,'G',.TRUE.,0, 109 : & 'TABLE ',IVALRE,XVALRE,BLANK,LOGRE,ITD2) 110 : DO J=1,K 110 : CALL ACCTAB(ITD2,'ENTIER ',J,0.D0,BLANK,.TRUE.,0, 111 : & 'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MDGJ) 112 : MDG(J)=MDGJ 113 : ENDDO 114 : ENDIF 115 : 116 : * valeurs des fonctions f_i 117 : DO I=1,L 118 : MLREE3=MF(I) 119 : SEGACT MLREE3 120 : DO M=1,N 121 : F(I,M)=MLREE3.PROG(M) 122 : ENDDO 123 : SEGDES MLREE3 124 : ENDDO 125 : 126 : * valeurs de la fonction g 127 : IF (MG.NE.0) THEN 128 : MLREE3=MG 129 : SEGACT MLREE3 130 : DO M=1,N 131 : G(M)=MLREE3.PROG(M) 132 : ENDDO 133 : SEGDES MLREE3 134 : ELSE 135 : DO J=1,N 136 : G(J)=0 137 : ENDDO 138 : ENDIF 139 : 140 : * valeurs de la dérivée des fonctions f_i / paramètres p_k 141 : DO J=1,K 142 : DO I=1,L 143 : MLREE3=MDF(J,I) 144 : SEGACT MLREE3 145 : DO M=1,N 146 : DF(J,I,M)=MLREE3.PROG(M) 147 : ENDDO 148 : SEGDES MLREE3 149 : ENDDO 150 : ENDDO 151 : 152 : * valeurs de la dérivée de g / paramètres p_k 153 : DO J=1,K 154 : IF (MG.NE.0) THEN 155 : MLREE3=MDG(J) 156 : SEGACT MLREE3 157 : DO M=1,N 158 : DG(J,M)=MLREE3.PROG(M) 159 : ENDDO 160 : SEGDES MLREE3 161 : ELSE 162 : DO M=1,N 163 : DG(J,M)=0 164 : ENDDO 165 : ENDIF 166 : ENDDO 167 : 168 : * valeurs des paramètres non linéaires 169 : IF (K.LE.0) GOTO 9999 170 : DO I=1,L 171 : Q(I)=MLREE1.PROG(I) 172 : ENDDO 173 : 174 : 175 : * Pour chaque paramètres p_j, somme sur tous les points de mesure 176 : * de l'erreur d'estimation pondérée par les poids, et par la 177 : * dérivée par rapport à p_j 178 : DO J=1,K 179 : B(J)=0 180 : D(J)=0 181 : ENDDO 182 : DO IN=1,N 183 : * calcul écart pondéré entre les valeur visées et 184 : * l'estimation avec ce jeu de paramètres 184 : CALL SSCAL(F,Q,IN,SC,L) 185 : Z = (PROG(IN)-G(IN)-SC) * MLREE4.PROG(IN)*MLREE4.PROG(IN) 186 : * sensibilité aux variations de chaque paramètre p_j, fois Z 187 : IF (L.LE.0) THEN 188 : DO J=1,K 189 : D(J)=D(J)+Z*DG(J,IN) 190 : ENDDO 191 : ELSE 192 : * si présence paramètres linéaires, priorité aux f_i 193 : DO J=1,K 193 : CALL SSCAL2 (DF,Q,IN,SC2,J,K,L,N) 194 : B(J)=DG(J,IN)+SC2 195 : ENDDO 196 : DO J=1,K 197 : D(J)=D(J)+Z*B(J) 198 : ENDDO 199 : ENDIF 200 : ENDDO 201 : 202 : * Variation et erreur quadratique totales 203 : A=0.D0 204 : DO J=1,K 205 : MLREE2.PROG(J)=D(J) 206 : A=A+D(J)*D(J) 207 : ENDDO 208 : 209 : SEGDES MLREEL,MLREE1,FG,DFDG,MTABLE,MTAB1 210 : SEGDES MLREE4,MLREE2 211 : SEGSUP TRAV 212 : 213 : 9999 RETURN 214 : END 215 :
© Cast3M 2003 - All rights reserved.
Disclaimer