Télécharger la plaquette Cast3M


fr en

Télécharger pfi.eso

Retour à la liste

Numérotation des lignes : 

pfi

  1. C PFI       SOURCE    FANDEUR   22/05/02    21:15:29     11359          
  2.       SUBROUTINE PFI(L,ITF,LY,LQ,PHI,LPOI)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. -INC PPARAM
  6. -INC CCOPTIO
  7. -INC SMLREEL
  8. -INC SMTABLE
  9. * TABLEAUX DE TRAVAIL
  10.       SEGMENT TRAV
  11.           REAL*8 T(J)
  12.           REAL*8 S(I)
  13.           INTEGER MF(J)
  14.       ENDSEGMENT
  15. * TABLEAUX DES FONCTIONS  Fi ET G AUX POINTS Xj
  16.       SEGMENT FG
  17.           REAL*8 F(K,M)
  18.           REAL*8 G(M)
  19.       ENDSEGMENT
  20.       CHARACTER*8 BLANK
  21.       REAL*8 XVALRE
  22.       LOGICAL LOGRE
  23.       CHARACTER*8 MTYPR
  24. C----------------------------------------------------
  25. *     LISTE DES VALEURS DE Y
  26.       MLREEL=LY
  27.       SEGACT MLREEL
  28.       N=PROG(/1)
  29. *     LISTE DES VALEURS DES PARAMETRES LINEAIRES:LQ
  30.       JG=L
  31.       SEGINI MLREE2
  32.       LQ=MLREE2
  33. *     LISTE DES POIDS
  34.       MLREE3=LPOI
  35.       SEGACT MLREE3
  36. *     TABLE DES VALEURS DES FONCTIONS Fi ET G AUX POINTS Xj
  37.       MTABLE=ITF
  38.       SEGACT MTABLE
  39.       I=L*(L+1)/2
  40.       J=L
  41.       SEGINI TRAV
  42.       K=L
  43.       M=N
  44.       SEGINI FG
  45.  
  46.       LOGRE = .TRUE.
  47.       BLANK = '        '
  48. *     Valeur des fonctions linéaires F_i
  49.       CALL ACCTAB(MTABLE,'MOT     ',0,0.D0,'F',LOGRE,0,
  50.      &                   'TABLE   ',IVALRE,XVALRE,BLANK,LOGRE,MTB)
  51.       DO I=1,L
  52.          CALL ACCTAB(MTB,'ENTIER  ',I,0.D0,BLANK,LOGRE,0,
  53.      &                   'LISTREEL',IVALRE,XVALRE,BLANK,LOGRE,MFI)
  54.          MF(I)=MFI
  55.       ENDDO
  56.       DO I=1,L
  57.          MLREE1=MF(I)
  58.          SEGACT MLREE1
  59.          DO J=1,N
  60.               F(I,J)=MLREE1.PROG(J)
  61.          ENDDO
  62.          SEGDES MLREE1
  63.       ENDDO
  64.  
  65. *     Valeur de la fonction G
  66.       MTYPR='        '
  67.       CALL ACCTAB(MTABLE,'MOT     ',0,0.D0,'G',LOGRE,0,
  68.      &                   MTYPR,IVALRE,XVALRE,BLANK,LOGRE,MG)
  69.       IF (MG.NE.0) THEN
  70.          IF (MTYPR.NE.'LISTREEL') THEN
  71.             MOTERR(1:8)='G       '
  72.             MOTERR(9:16)='LISTREEL'
  73.             CALL ERREUR(800)
  74.             RETURN
  75.          ENDIF
  76.          MLREE1=MG
  77.          SEGACT MLREE1
  78.          DO J=1,N
  79.               G(J)=MLREE1.PROG(J)
  80.          ENDDO
  81.          SEGDES MLREE1
  82.       ELSE
  83.          DO J=1,N
  84.               G(J)=0
  85.          ENDDO
  86.       ENDIF
  87.  
  88. *     Calcul de l'erreur d'estimation
  89.       PHI=0.D0
  90.       IF (L.LT.1) THEN
  91.         DO IN=1,N
  92.           PHI=PHI+(MLREE3.PROG(IN)*(PROG(IN)-G(IN)))**2
  93.         ENDDO
  94.       ELSE
  95.         DO IN=1,N
  96.            PDS= MLREE3.PROG(IN)*MLREE3.PROG(IN)
  97.            Z=(PROG(IN)-G(IN))*PDS
  98.            M=0
  99.            DO I=1,L
  100.                 T(I)=T(I)+Z*F(I,IN)
  101.                 XX=PDS*F(I,IN)
  102.                 DO J=I,L
  103.                      M=M+1
  104.                      S(M)=S(M)+XX*F(J,IN)
  105.                 ENDDO
  106.            ENDDO
  107.         ENDDO
  108.         CALL SYSLIN(TRAV)
  109.         DO IN=1,N
  110.            CALL SSCAL1(F,T ,IN,SC,L)
  111.            PHI=PHI+(MLREE3.PROG(IN)*(G(IN)+SC-PROG(IN)))**2
  112.         ENDDO
  113.         DO I=1,L
  114.            MLREE2.PROG(I)=T(I)
  115.         ENDDO
  116.       ENDIF
  117.  
  118.       SEGDES,MLREEL,MTABLE,MLREE2,MLREE3
  119.       SEGDES,FG
  120.       SEGSUP TRAV
  121.  
  122. c      RETURN
  123.       END
  124.  
  125.  
  126.  

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