Télécharger la plaquette Cast3M


fr en

Télécharger lsqf.eso

Retour à la liste

Numérotation des lignes : 

lsqf

  1. C LSQF      SOURCE    CHAT      05/01/13    01:25:42     5004
  2.       SUBROUTINE LSQF
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT  REAL*8(A-H,O-Z)
  5. C=======================================================================
  6. C    OPERATEUR LSQF
  7. C
  8. C    FITT*EVOLUTION = LSQF COUR*EVOLUTION M*ENTIER (MOTCLE MM)
  9. C
  10. C    M=NB D'INTERVALLE MINIMUM
  11. C
  12. C=======================================================================
  13. C    PROGRAMMEUR : P.P.
  14. C=======================================================================
  15. C
  16.       CHARACTER *72 TI
  17.       CHARACTER*12 MOTX,MOTY
  18. C
  19.       PARAMETER (NMOCLE=3)
  20.       CHARACTER*4 MOTCLE(NMOCLE)
  21.       LOGICAL LUNIF, LOPTI
  22. C
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC SMEVOLL
  27. -INC SMLREEL
  28. C
  29.       POINTEUR ICOUR.MEVOLL,IFITT.MEVOLL
  30.       POINTEUR JCOUR.KEVOLL,JFITT.KEVOLL
  31.       POINTEUR KCABS.MLREEL,KCORD.MLREEL,KFABS.MLREEL,KFORD.MLREEL
  32. C
  33.       DATA MOTCLE/'UNIF','OPTI','REDU'/
  34.       LUNIF=.TRUE.
  35.       LOPTI=.FALSE.
  36. C
  37. C     1) LECTURE DES DONNEES GIBIANE
  38. C
  39. C
  40. C     1.1) LECTURE DE L'OBJET EVOLUTIO CONTENANT LA (LES) COURBE
  41. C
  42.       CALL LIROBJ('EVOLUTIO',ICOUR,1,IRET)
  43.       IF(IRET.EQ.0) GOTO 666
  44. C
  45. C     1.2) LECTURE DE L'ENTIER
  46. C
  47.       CALL LIRENT(MMIN,1,IRET)
  48. C
  49.       IF(IRET.EQ.0) GOTO 666
  50. C
  51. C     1.3) LECTURE DU MOT CLE
  52. C
  53.       CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0)
  54.       IF(IVAL.NE.0)THEN
  55.         IF(IVAL.EQ.2)THEN
  56.           LOPTI=.TRUE.
  57.           CALL LIRENT(MFRAC,1,IRET)
  58.         ENDIF
  59.         IF(IVAL.EQ.3)THEN
  60.           LUNIF=.FALSE.
  61.           CALL LIRENT(MDIV,1,IRET)
  62.         ENDIF
  63.       ENDIF
  64. C
  65. C     2) VERIFICATION DE L'UNIFORMITE DES PAS DE TEMPS SUR LES
  66. C        COURBE EN ENTRE
  67. C
  68.       SEGACT, ICOUR
  69.       N=ICOUR.IEVOLL(/1)
  70.       DO 10 IE1=1,N
  71.         JCOUR=ICOUR.IEVOLL(IE1)
  72.         SEGACT, JCOUR
  73.         KCABS=JCOUR.IPROGX
  74.         SEGACT, KCABS
  75.         DX=KCABS.PROG(2)-KCABS.PROG(1)
  76.         JG=KCABS.PROG(/1)
  77.         DDX=(KCABS.PROG(JG)-KCABS.PROG(1))/(JG-1)
  78.         IF (ABS(DX-DDX)/DX.GT.1.D-3)THEN
  79.           INTERR(1)=IE1
  80.           CALL ERREUR(576)
  81.           SEGDES, KCABS,JCOUR,ICOUR
  82.           GOTO 666
  83.         ENDIF
  84.         SEGDES, KCABS,JCOUR
  85.  10     CONTINUE
  86. C
  87. C     3) CALCUL
  88. C
  89. C     3.1) CREATION DE L'OBJET RESULTAT
  90. C
  91.       SEGINI, IFITT
  92.       TI=ICOUR.IEVTEX
  93.       IFITT.IEVTEX='L-S fitting de:'//TI(1:57)
  94.  
  95. C
  96. C     3.2) LOOP SUR LES COURBES
  97. C
  98.       DO 30 IE1=1,N
  99. C
  100. C     3.2.1) ACTIVATION DE LA COURBE ENTREE
  101. C
  102.         JCOUR=ICOUR.IEVOLL(IE1)
  103.         SEGACT, JCOUR
  104.         ICOUL=JCOUR.NUMEVX
  105.         KCABS=JCOUR.IPROGX
  106.         KCORD=JCOUR.IPROGY
  107.         SEGACT, KCABS,KCORD
  108.         SEGDES, JCOUR
  109. C
  110. C     3.2.2) INITIALISATION DE LA COURBE SORTIE
  111. C
  112.         SEGINI, JFITT
  113.         IFITT.IEVOLL(IE1)=JFITT
  114. C
  115.         WRITE(TI,'(A15,1X,I1)')'fitting niveau ',IE1
  116.         JFITT.KEVTEX=TI
  117.         JFITT.NUMEVX=ICOUL
  118.         JFITT.NUMEVY='REEL'
  119.         JFITT.TYPX='LISTREEL'
  120.         MOTX='Temps'
  121.         JFITT.NOMEVX=MOTX(1:12)
  122.         JFITT.TYPY='LISTREEL'
  123.         WRITE(MOTY,'(A10,1X,I1)')'Modulation',IE1
  124.         JFITT.NOMEVY=MOTY(1:12)
  125. C
  126. C     3.2.3) TRAVAIL PROPREMENT DIT
  127. C
  128.         JG=KCABS.PROG(/1)
  129.         NPT=JG
  130.         NPI=JG-1
  131.         IF(LUNIF)THEN
  132.           M=MMIN
  133.         ELSE
  134.           M=MAX(MMIN,NPI/MDIV)
  135.         ENDIF
  136.         IF (NPI.GT.M)THEN
  137. C
  138. C     3.2.3) CAS OU LA COURBE ENTREE COMPREND PLUS DE POINT QUE LA
  139. C            MODULATION (CAS STANDARD)
  140. C
  141. C     3.2.3.2) NOMBRE DE POINT MAX PAR INTERVALLE
  142. C
  143.           DX=KCABS.PROG(2)-KCABS.PROG(1)
  144.           NIN=NPI/M
  145.           IF(NPI-M*NIN.GT.0)THEN
  146.             NIN=NIN+1
  147.             JG=NPI/NIN+1
  148.           ELSE
  149.             JG=M+1
  150.           ENDIF
  151. C
  152. C     3.2.3.1) ACTIVATION ABSC/ORDO RESULTAT
  153. C
  154.           SEGINI, KFABS,KFORD
  155. C
  156. C     3.2.3.3) INITIALISATION DE LA BOUCLE SUR LES POINTS
  157. C
  158.           KFABS.PROG(1)=KCABS.PROG(1)
  159.           YFIN=ABS(KCORD.PROG(1))
  160.           KFORD.PROG(1)=YFIN
  161.           IE2=1
  162.           IFIN=1
  163. C
  164. C     3.2.3.4) DEBUT DE LA BOUCLE
  165. C
  166.  20         CONTINUE
  167. C
  168. C     3.2.3.5) INITIALISATION EN DEBUT DE NOUVEAU PAS
  169. C
  170.             IDEB=IFIN
  171.             YDEB=YFIN
  172.             IF(IDEB.EQ.NPT)GOTO 25
  173.             IE2=IE2+1
  174. C
  175. C (ON PASSE NECESSEREMENT PAR LA GRILLE SUPOSE)
  176. C
  177.             IF(.NOT.LOPTI)THEN
  178.               IREM=MOD(IDEB-1,NIN)
  179.               IF(IREM.EQ.0)THEN
  180.                 NINB=NIN
  181.               ELSE
  182.                 NINB=NIN-IREM
  183.               ENDIF
  184.             ENDIF
  185. C
  186. C     3.2.3.6) POINT DE RE-ENTRE DANS LE PAS (PB DE SOLUTION)
  187. C
  188.  21         IFIN=IDEB+NINB
  189.             IF(IFIN.GT.NPT)THEN
  190.               IFIN=NPT
  191.               NINB=IFIN-IDEB
  192.             ENDIF
  193.             IF(NINB.EQ.1)THEN
  194. C
  195. C     3.2.3.7) CAS OU IL NE RESTE PLUS QU'UN SEUL POINT
  196. C
  197.               YFIN=ABS(KCORD.PROG(IDEB+1))
  198.               XFIN=KCABS.PROG(IDEB+1)
  199. C
  200. C     3.2.3.8) CALCUL DES COEFF DE L'EQUATION DU SECOND DEGRE
  201. C
  202.             ELSE
  203.               XDEB=KCABS.PROG(IDEB)
  204.               XFIN=KCABS.PROG(IFIN)
  205.               A=DX*DX*NINB*(NINB+1)*(2*NINB+1)/6.D0
  206.               B=YDEB*DX*NINB*(NINB+1)/2.D0
  207.               C=YDEB*YDEB*NINB
  208.               DO 22 IE3=1,NINB
  209.                 C=C-KCORD.PROG(IDEB+IE3)**2
  210.  22             CONTINUE
  211. C
  212. C     3.2.3.9) DELTA ET TEST
  213. C
  214.               DELTA=B**2-A*C
  215.               IF(DELTA.LT.0.D0)GOTO 23
  216. C
  217. C     3.2.3.10) DETERMINATION DE LA SOLUTION CORRECTE
  218. C
  219.               A1=(-B+SQRT(DELTA))/A
  220.               A2=(-B-SQRT(DELTA))/A
  221.               DDX=XFIN-XDEB
  222.               YF1=A1*DDX+YDEB
  223.               YF2=A2*DDX+YDEB
  224.               IF(YF1.GT.0.D0)THEN
  225.                 YFIN=YF1
  226.               ELSEIF(YF2.GT.0.D0)THEN
  227.                 YFIN=YF2
  228.               ELSEIF(YF1.GT.(0.D0-YDEB*1.D-5))THEN
  229.                 YFIN=0.D0
  230.               ELSEIF(YF2.GT.(0.D0-YDEB*1.D-5))THEN
  231.                 YFIN=0.D0
  232.               ELSE
  233.                 GOTO 23
  234.               ENDIF
  235.             ENDIF
  236. C
  237. C     3.2.3.11) STOCKAGE DU RESULTAT AVEC TEST DE DEPASSEMENT
  238. C
  239.             IF(IE2.LE.JG)THEN
  240.               KFABS.PROG(IE2)=XFIN
  241.               KFORD.PROG(IE2)=YFIN
  242.             ELSE
  243.               JG=JG+1
  244.               KFABS.PROG(**)=XFIN
  245.               KFORD.PROG(**)=YFIN
  246.             ENDIF
  247.             GOTO 20
  248. C
  249. C     3.2.3.12) TRAITEMENT D'ERREUR: DIMINUTION DE L'INTERVALLE DE FITING
  250. C
  251.  23         NINB=NINB-1
  252.             GOTO 21
  253. C
  254.  25         CONTINUE
  255. C
  256. C     3.2.4) CAS OU LA COURBE ENTREE COMPREND MOINS DE POINT QUE LA
  257. C            MODULATION
  258.  
  259.         ELSE
  260.           SEGINI, KFABS=KCABS
  261.           SEGINI, KFORD
  262.           DO 27 IE2=1,JG
  263.             KFORD.PROG(IE2)=ABS(KCORD.PROG(IE2))
  264.  27         CONTINUE
  265.         ENDIF
  266. C
  267. C     3.3) STOCKAGE DE LA COURBE RESULTAT ET DESACTIVATION
  268. C
  269.         SEGDES, KCABS,KCORD
  270.         SEGDES, KFABS,KFORD
  271.         JFITT.IPROGX=KFABS
  272.         JFITT.IPROGY=KFORD
  273.         SEGDES, JFITT
  274.  30     CONTINUE
  275. C
  276. C     4) DESACTIVATION ET RETOUR A GIBIANE
  277. C
  278.       SEGDES, ICOUR,IFITT
  279. C
  280.       CALL ECROBJ('EVOLUTIO',IFITT)
  281. C
  282.  666  CONTINUE
  283.       RETURN
  284.       END
  285.  
  286.  
  287.  
  288.  
  289.  

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