Télécharger lsqf.eso

Retour à la liste

Numérotation des lignes :

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

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