C LSQF SOURCE OF166741 25/02/20 21:16:55 12165 SUBROUTINE LSQF IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C======================================================================= C OPERATEUR LSQF C C FITT*EVOLUTION = LSQF COUR*EVOLUTION M*ENTIER (MOTCLE MM) C C M=NB D'INTERVALLE MINIMUM C C======================================================================= C PROGRAMMEUR : P.P. C======================================================================= C CHARACTER *72 TI CHARACTER*12 MOTX,MOTY C PARAMETER (NMOCLE=3) CHARACTER*4 MOTCLE(NMOCLE) LOGICAL LUNIF, LOPTI C -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC SMLREEL C POINTEUR ICOUR.MEVOLL,IFITT.MEVOLL POINTEUR JCOUR.KEVOLL,JFITT.KEVOLL POINTEUR KCABS.MLREEL,KCORD.MLREEL,KFABS.MLREEL,KFORD.MLREEL C DATA MOTCLE/'UNIF','OPTI','REDU'/ LUNIF=.TRUE. LOPTI=.FALSE. C C 1) LECTURE DES DONNEES GIBIANE C C C 1.1) LECTURE DE L'OBJET EVOLUTIO CONTENANT LA (LES) COURBE C CALL LIROBJ('EVOLUTIO',ICOUR,1,IRET) IF(IRET.EQ.0) GOTO 666 C C 1.2) LECTURE DE L'ENTIER C CALL LIRENT(MMIN,1,IRET) C IF(IRET.EQ.0) GOTO 666 C C 1.3) LECTURE DU MOT CLE C CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0) IF(IVAL.NE.0)THEN IF(IVAL.EQ.2)THEN LOPTI=.TRUE. CALL LIRENT(MFRAC,1,IRET) ENDIF IF(IVAL.EQ.3)THEN LUNIF=.FALSE. CALL LIRENT(MDIV,1,IRET) ENDIF ENDIF C C 2) VERIFICATION DE L'UNIFORMITE DES PAS DE TEMPS SUR LES C COURBE EN ENTRE C SEGACT, ICOUR N=ICOUR.IEVOLL(/1) DO 10 IE1=1,N JCOUR=ICOUR.IEVOLL(IE1) SEGACT, JCOUR KCABS=JCOUR.IPROGX SEGACT, KCABS DX=KCABS.PROG(2)-KCABS.PROG(1) JG=KCABS.PROG(/1) DDX=(KCABS.PROG(JG)-KCABS.PROG(1))/(JG-1) IF (ABS(DX-DDX)/DX.GT.1.D-3)THEN INTERR(1)=IE1 CALL ERREUR(576) SEGDES, KCABS,JCOUR,ICOUR GOTO 666 ENDIF SEGDES, KCABS,JCOUR 10 CONTINUE C C 3) CALCUL C C 3.1) CREATION DE L'OBJET RESULTAT C SEGINI, IFITT TI=ICOUR.IEVTEX IFITT.IEVTEX='L-S fitting de:'//TI(1:57) C C 3.2) LOOP SUR LES COURBES C DO 30 IE1=1,N C C 3.2.1) ACTIVATION DE LA COURBE ENTREE C JCOUR=ICOUR.IEVOLL(IE1) SEGACT, JCOUR ICOUL=JCOUR.NUMEVX KCABS=JCOUR.IPROGX KCORD=JCOUR.IPROGY SEGACT, KCABS,KCORD SEGDES, JCOUR C C 3.2.2) INITIALISATION DE LA COURBE SORTIE C SEGINI, JFITT IFITT.IEVOLL(IE1)=JFITT C WRITE(TI,'(A15,1X,I1)')'fitting niveau ',IE1 JFITT.KEVTEX=TI JFITT.NUMEVX=ICOUL JFITT.NUMEVY='REEL' JFITT.TYPX='LISTREEL' MOTX='Temps' JFITT.NOMEVX=MOTX(1:12) JFITT.TYPY='LISTREEL' WRITE(MOTY,'(A10,1X,I1)')'Modulation',IE1 JFITT.NOMEVY=MOTY(1:12) C C 3.2.3) TRAVAIL PROPREMENT DIT C JG=KCABS.PROG(/1) NPT=JG NPI=JG-1 IF(LUNIF)THEN M=MMIN ELSE M=MAX(MMIN,NPI/MDIV) ENDIF IF (NPI.GT.M)THEN C C 3.2.3) CAS OU LA COURBE ENTREE COMPREND PLUS DE POINT QUE LA C MODULATION (CAS STANDARD) C C 3.2.3.2) NOMBRE DE POINT MAX PAR INTERVALLE C DX=KCABS.PROG(2)-KCABS.PROG(1) NIN=NPI/M IF(NPI-M*NIN.GT.0)THEN NIN=NIN+1 JG=NPI/NIN+1 ELSE JG=M+1 ENDIF C C 3.2.3.1) ACTIVATION ABSC/ORDO RESULTAT C SEGINI, KFABS,KFORD C C 3.2.3.3) INITIALISATION DE LA BOUCLE SUR LES POINTS C KFABS.PROG(1)=KCABS.PROG(1) YFIN=ABS(KCORD.PROG(1)) KFORD.PROG(1)=YFIN IE2=1 IFIN=1 C C 3.2.3.4) DEBUT DE LA BOUCLE C 20 CONTINUE C C 3.2.3.5) INITIALISATION EN DEBUT DE NOUVEAU PAS C IDEB=IFIN YDEB=YFIN IF(IDEB.EQ.NPT)GOTO 25 IE2=IE2+1 C C (ON PASSE NECESSEREMENT PAR LA GRILLE SUPOSE) C IF(.NOT.LOPTI)THEN IREM=MOD(IDEB-1,NIN) IF(IREM.EQ.0)THEN NINB=NIN ELSE NINB=NIN-IREM ENDIF ENDIF C C 3.2.3.6) POINT DE RE-ENTRE DANS LE PAS (PB DE SOLUTION) C 21 IFIN=IDEB+NINB IF(IFIN.GT.NPT)THEN IFIN=NPT NINB=IFIN-IDEB ENDIF IF(NINB.EQ.1)THEN C C 3.2.3.7) CAS OU IL NE RESTE PLUS QU'UN SEUL POINT C YFIN=ABS(KCORD.PROG(IDEB+1)) XFIN=KCABS.PROG(IDEB+1) C C 3.2.3.8) CALCUL DES COEFF DE L'EQUATION DU SECOND DEGRE C ELSE XDEB=KCABS.PROG(IDEB) XFIN=KCABS.PROG(IFIN) A=DX*DX*NINB*(NINB+1)*(2*NINB+1)/6.D0 B=YDEB*DX*NINB*(NINB+1)/2.D0 C=YDEB*YDEB*NINB DO 22 IE3=1,NINB C=C-KCORD.PROG(IDEB+IE3)**2 22 CONTINUE C C 3.2.3.9) DELTA ET TEST C DELTA=B**2-A*C IF(DELTA.LT.0.D0)GOTO 23 C C 3.2.3.10) DETERMINATION DE LA SOLUTION CORRECTE C A1=(-B+SQRT(DELTA))/A A2=(-B-SQRT(DELTA))/A DDX=XFIN-XDEB YF1=A1*DDX+YDEB YF2=A2*DDX+YDEB IF(YF1.GT.0.D0)THEN YFIN=YF1 ELSEIF(YF2.GT.0.D0)THEN YFIN=YF2 ELSEIF(YF1.GT.(0.D0-YDEB*1.D-5))THEN YFIN=0.D0 ELSEIF(YF2.GT.(0.D0-YDEB*1.D-5))THEN YFIN=0.D0 ELSE GOTO 23 ENDIF ENDIF C C 3.2.3.11) STOCKAGE DU RESULTAT AVEC TEST DE DEPASSEMENT C IF(IE2.LE.JG)THEN KFABS.PROG(IE2)=XFIN KFORD.PROG(IE2)=YFIN ELSE JG=JG+1 KFABS.PROG(**)=XFIN KFORD.PROG(**)=YFIN ENDIF GOTO 20 C C 3.2.3.12) TRAITEMENT D'ERREUR: DIMINUTION DE L'INTERVALLE DE FITING C 23 NINB=NINB-1 GOTO 21 C 25 CONTINUE C C 3.2.4) CAS OU LA COURBE ENTREE COMPREND MOINS DE POINT QUE LA C MODULATION ELSE SEGINI, KFABS=KCABS SEGINI, KFORD DO 27 IE2=1,JG KFORD.PROG(IE2)=ABS(KCORD.PROG(IE2)) 27 CONTINUE ENDIF C C 3.3) STOCKAGE DE LA COURBE RESULTAT ET DESACTIVATION C SEGDES, KCABS,KCORD SEGDES, KFABS,KFORD JFITT.IPROGX=KFABS JFITT.IPROGY=KFORD SEGDES, JFITT 30 CONTINUE C C 4) DESACTIVATION ET RETOUR A GIBIANE C SEGDES, ICOUR,IFITT C CALL ECROBJ('EVOLUTIO',IFITT) C 666 CONTINUE RETURN END