C PDFI      SOURCE    FANDEUR   22/05/02    21:15:28     11359          
      SUBROUTINE PDFI(K,LQ,ITF,ITD,LY,LD,A,LPOI)
*-----------------------------------------------------------------------
*
*     Calcule l'erreur quadratique totale pondérée
*     et la sensibilité aux variations de chaque paramètre
*
*-----------------------------------------------------------------------
*
*     Appellée par AJU2
*
*-----------------------------------------------------------------------
*
*     Modifications :
*     21/04/2006 : p. Maugis
*       filtre si pas de paramètre linéaire + initialisation B et D
*
*-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-INC SMLREEL
-INC SMTABLE
      POINTEUR MLREE4.MLREEL
*TABLEAUX DE TRAVAIL
      SEGMENT TRAV
          REAL*8  Q(I)
          INTEGER MF(I)
          INTEGER MDG(J)
          INTEGER MDF(J,I)
          REAL*8  D(J)
          REAL*8  B(J)
      ENDSEGMENT
*TABLEAUX DES VALEURS DE F,G
      SEGMENT FG
          REAL*8 F(I,M)
          REAL*8 G(M)
      ENDSEGMENT
*TABLEAUX DES VALEURS DE DF/DPj,DG/Pj
      SEGMENT DFDG
          REAL*8 DF(J,I,M)
          REAL*8 DG(J,M)
      ENDSEGMENT
      CHARACTER*8 BLANK
      REAL*8 XVALRE
      LOGICAL LOGRE
      DATA BLANK/'        '/
      CHARACTER*8 MTYPR
C---------------------------------------------------
*LISTE DES VALEURS DE Y
      MLREEL=LY
      SEGACT MLREEL
*LISTE DES POIDS
      MLREE4=LPOI
      SEGACT MLREE4
      N=PROG(/1)
*LISTE DES PARAMETRES LINEAIRES
      MLREE1=LQ
      SEGACT MLREE1
      L=MLREE1.PROG(/1)
*LISTE DES VALEURS DE DPHI/DPj
      JG=K
      SEGINI MLREE2
      LD=MLREE2
*TABLE DES VALEURS DES Fi ET G
      MTABLE=ITF
      SEGACT MTABLE
*TABLE DES VALEURS DE DFi/DPj ET DG/DPj
      MTAB1=ITD
      SEGACT MTAB1
      I=L
      J=K
      M=N
      SEGINI DFDG,FG,TRAV


*     Lecture table FCT
      IF (L.GT.0) THEN
        CALL ACCTAB(MTABLE,'MOT     ',0,0.D0,'F',.TRUE.,0,
     &                    'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,MTB)
        DO I=1,L
          CALL ACCTAB(MTB,'ENTIER  ',I,0.D0,BLANK,.TRUE.,0,
     &                    'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MFI)
          MF(I)=MFI
        ENDDO
      ENDIF

      MTYPR=BLANK
      CALL ACCTAB(MTABLE,'MOT     ',0,0.D0,'G',.TRUE.,0,
     &                   MTYPR,IVALRE,XVALRE,BLANK,LOGRE,MG)
      IF (MG.NE.0) THEN
         IF (MTYPR.NE.'LISTREEL') THEN
            MOTERR(1:8) ='G       '
            MOTERR(9:16)='LISTREEL'
            CALL ERREUR(800)
            RETURN
         ENDIF
      ENDIF

*     Lecture table DERI
      IF (L.GT.0) THEN
         CALL ACCTAB(MTAB1,'MOT     ',0,0.D0,'F',.TRUE.,0,
     &                     'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,ITD1)
         DO J=1,K
           CALL ACCTAB(ITD1,'ENTIER  ',J,0.D0,BLANK,.TRUE.,0,
     &                      'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,ITD11J)
           DO I=1,L
             CALL ACCTAB(ITD11J,'ENTIER  ',I,0.D0,BLANK,.TRUE.,0,
     &                       'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MDFJI)
             MDF(J,I)=MDFJI
           ENDDO
         ENDDO
      ENDIF

      IF (MG.NE.0) THEN
         CALL ACCTAB(MTAB1,'MOT     ',0,0.D0,'G',.TRUE.,0,
     &                    'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,ITD2)
         DO J=1,K
            CALL ACCTAB(ITD2,'ENTIER  ',J,0.D0,BLANK,.TRUE.,0,
     &                       'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MDGJ)
            MDG(J)=MDGJ
         ENDDO
      ENDIF

*     valeurs des fonctions f_i
      DO I=1,L
            MLREE3=MF(I)
            SEGACT MLREE3
            DO M=1,N
                 F(I,M)=MLREE3.PROG(M)
            ENDDO
            SEGDES MLREE3
      ENDDO

*     valeurs de la fonction g
      IF (MG.NE.0) THEN
         MLREE3=MG
         SEGACT MLREE3
         DO M=1,N
               G(M)=MLREE3.PROG(M)
         ENDDO
         SEGDES MLREE3
      ELSE
         DO J=1,N
              G(J)=0
         ENDDO
      ENDIF

*     valeurs de la dérivée des fonctions f_i / paramètres p_k
      DO J=1,K
            DO I=1,L
                 MLREE3=MDF(J,I)
                 SEGACT MLREE3
                 DO M=1,N
                       DF(J,I,M)=MLREE3.PROG(M)
                 ENDDO
                 SEGDES MLREE3
            ENDDO
      ENDDO

*     valeurs de la dérivée de g / paramètres p_k
      DO J=1,K
         IF (MG.NE.0) THEN
            MLREE3=MDG(J)
            SEGACT MLREE3
            DO M=1,N
                  DG(J,M)=MLREE3.PROG(M)
            ENDDO
            SEGDES MLREE3
         ELSE
            DO M=1,N
                  DG(J,M)=0
            ENDDO
         ENDIF
      ENDDO

*      valeurs des paramètres non linéaires
      IF (K.LE.0) GOTO 9999
      DO I=1,L
            Q(I)=MLREE1.PROG(I)
      ENDDO


*     Pour chaque paramètres p_j, somme sur tous les points de mesure
*     de l'erreur d'estimation pondérée par les poids, et par la
*     dérivée par rapport à p_j
      DO J=1,K
            B(J)=0
            D(J)=0
      ENDDO
      DO IN=1,N
*           calcul écart pondéré entre les valeur visées et
*           l'estimation avec ce jeu de paramètres
            CALL SSCAL1(F,Q,IN,SC,L)
            Z = (PROG(IN)-G(IN)-SC) * MLREE4.PROG(IN)*MLREE4.PROG(IN)
*           sensibilité aux variations de chaque paramètre p_j, fois Z
            IF (L.LE.0) THEN
                  DO J=1,K
                        D(J)=D(J)+Z*DG(J,IN)
                  ENDDO
            ELSE
*                 si présence paramètres linéaires, priorité aux f_i
                  DO J=1,K
                        CALL SSCAL2 (DF,Q,IN,SC2,J,K,L,N)
                        B(J)=DG(J,IN)+SC2
                  ENDDO
                  DO J=1,K
                        D(J)=D(J)+Z*B(J)
                  ENDDO
            ENDIF
      ENDDO

*     Variation et erreur quadratique totales
      A=0.D0
      DO J=1,K
            MLREE2.PROG(J)=D(J)
            A=A+D(J)*D(J)
      ENDDO

      SEGDES MLREEL,MLREE1,FG,DFDG,MTABLE,MTAB1
      SEGDES MLREE4,MLREE2
      SEGSUP TRAV

 9999 CONTINUE
C      RETURN
      END