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