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