C FIT SPEKTRALNEJ CIARY GAUSOVKOU PROGRAM CIARA PARAMETER (NKANAL=1500,NP=40) DIMENSION XI(NKANAL),YI(NKANAL),YT(NKANAL),ALFA(NKANAL) DIMENSION XINOUT(NP),STEP(NP) COMMON /COM/IDOLNA,IHORNA,XI,YI,ALFA,NGAUSS COMMON /CNVAR/NVAR COMMON /CIOUT/IOUT CHARACTER*1 YESNO C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NACITANIE NAMERANYCH INTENZIT C XI(I).....VLNOVA DLZKA I-TEHO KANALA C YI(I).....INTENZITA V I-TOM KANALI C I=1 11 READ(1,*,END=999)XI(I),YI(I) I=I+1 GOTO 11 C DO 11 I=1,IEND C XI(I)=0.0+FLOAT(I) 999 IEND=I-1 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C LISTING NAMERANYCH INTENZIT C 998 TYPE 101 101 FORMAT(' LISTING NAMERANYCH INTENZIT: YES-Y, NO-N ',$) ACCEPT 400,YESNO 400 FORMAT(A1) IF(YESNO.NE.'Y')GOTO 12 TYPE 401 401 FORMAT(' ZADAJ CISLO ZARIADENIA: 5-TERMINAL, 6-TLACIAREN ',$) ACCEPT*,IOUT1 WRITE(IOUT1,100)(XI(I),YI(I),I=1,IEND) 100 FORMAT(/' NAMERANE HODNOTY INTENZIT :'//3(' Y(', + F5.0,')=',F8.5)) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C GRAF NAMERANYCH INTENZIT C 12 TYPE 102 102 FORMAT(' GRAF NAMERANYCH INTENZIT: YES-Y, NO-N ',$) ACCEPT 400,YESNO IF(YESNO.NE.'Y')GOTO 13 TYPE 103 103 FORMAT(' CISLO PRVEHO KANALU: ',$) ACCEPT*,ID TYPE 104 104 FORMAT(' CISLO POSLENEHO KANALU: ',$) ACCEPT*,IH TYPE 401 ACCEPT*,IOUT1 WRITE(IOUT1,125) 125 FORMAT(//' VLNOVA DLZKA V NM:'/) YIMAX=YI(ID) DO 33 I=ID,IH IF(YI(I).GT.YIMAX)YIMAX=YI(I) 33 CONTINUE H=YIMAX/FLOAT(70) DO 34 I=ID,IH IYI=IFIX(YI(I)/H)+7 WRITE(IOUT1,105)XI(I) 105 FORMAT(1X,F5.0,T,'*') 34 CONTINUE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C VSTUP HRANIC INTERVALU NA KTOROM SA BUDE FITOVAT C 13 TYPE 106 106 FORMAT(/' VSTUP INTERVALU NA KTOROM SA BUDE FITOVAT '/ + ' V NANOMETROCH ZADAJ:'/' DOLNA HRANICA VLNOVYCH DLZOK: ',$) ACCEPT*,DVLN TYPE 108 108 FORMAT(' HORNA HRANICA VLNOVYCH DLZOK: ',$) ACCEPT*,HVLN TYPE 402 ACCEPT 400,YESNO IF(YESNO.EQ.'Y')GOTO 13 TYPE 109 109 FORMAT(' PRE TLAC VYSLEDKOV') TYPE401 ACCEPT*,IOUT WRITE(IOUT,140)DVLN,HVLN 140 FORMAT(' CIARA BUDE APROXIMOVANA V INTERVALE VLNOVYCH ', + 'DLZOK:'/' < ',F5.0,' NM, ',F5.0,' NM >') C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NAJDENIE ROZMEDZIA KANALOV PRE FITOVANIE C I=0 61 I=I+1 IF(XI(I).LT.DVLN)GOTO 61 IDOLNA=I 62 IF(XI(I).GE.HVLN)GOTO 63 I=I+1 GOTO 62 63 IHORNA=I C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NACITANIE PRIBLIZNYCH HODNOT PARAMETROV CIARY, KTORE C POSLUZIA AKO STARTOVACIE HODNOTY FITOVANIA C METODOU NAJMENSICH STVORCOV C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NACITANIE POCTU GAUSSOVIEK C 15 TYPE 110 110 FORMAT(/' ZADAJ POCET GAUSSOVIEK: ',$) ACCEPT*,NGAUSS NVAR=3*NGAUSS+1 IF(NVAR.GT.NP)GOTO 15 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C VYRATANIE VAHOVYCH KOEFICIENTOV DO METODY NAJM. STVORCOV C D=FLOAT(IHORNA-IDOLNA+1) DO 30 I=IDOLNA,IHORNA ALFA(I)=YI(I)/D C C PODLA POTREBY, VKUSU, INTUICIE JE MOZNE ZMENIT VAHOVE C KOEFICIENTY ALFA NAPR. NA 100./(D*YI(I)) C 30 CONTINUE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NACITANIE PARAMETROV PRE KAZDU GAUSSOVKU C 16 TYPE*,' ZADAVAJ PRIBLIZNE STARTOVACIE HODNOTY PARAMETROV.' DO 118 I=1,NGAUSS TYPE 111,I 111 FORMAT(/1X,I2,'. GAUSSOVKA'/1X,'-------------') TYPE 113 113 FORMAT(5X,'INTENZITA: ',$) ACCEPT*,XINOUT(3*I-2) TYPE 114 114 FORMAT(5X,'VLNOVA DLZKA V NM: ',$) ACCEPT*,XINOUT(3*I-1) TYPE 115 115 FORMAT(5X,'POLOSIRKA V NM: ',$) ACCEPT*,XINOUT(3*I) 118 CONTINUE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NACITANIE UROVNE SUMU KONTINUA C 18 TYPE116 116 FORMAT(/' UROVEN SUMU KONTINUA: ',$) ACCEPT*,XINOUT(NVAR) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C LISTING STARTOVACICH HODNOT PARAMETROV C 23 WRITE(IOUT,117) 117 FORMAT(///10X,'STARTOVACIE PRIBLIZNE HODNOTY ') WRITE(IOUT,126)(I,XINOUT(3*I-2),XINOUT(3*I-1), + XINOUT(3*I),I=1,NGAUSS),XINOUT(NVAR) 126 FORMAT(/( + 1X,I2,'. GAUSSOVKA'/1X,'-------------'/ + 5X,'INTENZITA: ',F7.3/ + 5X,'VLNOVA DLZKA: ',F9.4,' NM'/ + 5X,'POLOSIRKA: ',F9.4,' NM'/)/ + 2X,'SUM KONTINUA: ',F7.3/ + 2X,'-------------'/) IF(IOUT.NE.5)THEN TYPE 117 TYPE 126,(I,XINOUT(3*I-2),XINOUT(3*I-1),XINOUT(3*I), + I=1,NGAUSS),XINOUT(NVAR) ENDIF C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C UROBENIE ZMIEN AK JE TREBA C 20 TYPE 402 402 FORMAT(' CHCES NIECO ZMENIT ? YES-Y, NO-N: ',$) ACCEPT 400,YESNO IF(YESNO.NE.'Y')GOTO 17 TYPE 119 119 FORMAT(' POCET GAUSSOVIEK ? YES-Y, NO-N: ',$) ACCEPT 400,YESNO IF(YESNO.EQ.'Y')GOTO 15 TYPE 120 120 FORMAT(' UROVEN SUMU KONTINUA ? YES-Y, NO-N: ',$) ACCEPT400,YESNO IF(YESNO.EQ.'Y')GOTO 18 TYPE 121 121 FORMAT(' JEDNU GAUSSOVKU ? YES-Y, NO-N: ',$) ACCEPT400,YESNO IF(YESNO.NE.'Y')GOTO 19 TYPE303,NGAUSS 303 FORMAT(' CISLO GAUSSOVKY OD 1 PO ',I2,': ',$) ACCEPT*,I TYPE 111,I TYPE 113 ACCEPT*,XINOUT(3*I-2) TYPE 114 ACCEPT*,XINOUT(3*I-1) TYPE 115 ACCEPT*,XINOUT(3*I) GOTO 23 19 TYPE 122 122 FORMAT(' VSETKY GAUSSOVKY ? YES-Y, NO-N: ',$) ACCEPT400,YESNO IF(YESNO.EQ.'Y')GOTO 16 GOTO 20 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C VSTUPNE HODNOTY DLZKY KROKOV A VELKOST PRESNOSTI C 17 CONTINUE DO 219 I=1,NGAUSS STEP(3*I-2)=0.1 STEP(3*I-1)=0.1 STEP(3*I)=0.1 219 CONTINUE STEP(NVAR)=0.00001 EPS=1.0E-6 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NACITANIE POCTU OPTIMALIZACNYCH KROKOV C 40 TYPE 123 123 FORMAT(' MAX. POCET KROKOV OPTIMALIZACIE (100-10000): ',$) ACCEPT*,NMAX C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C VOLANIE SIMPLEXOVEJ PROCEDURY NA MINIMALIZACIU C SUCTU STVORCOV C CALL SMPLX(NVAR,XINOUT,STEP,EPS,NMAX,FOUT,2) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C VYPIS OPTIMALIZOVANYCH HODNOT C WRITE(IOUT,124) 124 FORMAT(/10X,' O P T I M A L I Z O V A N E H O D N O', + ' T Y'/) WRITE(IOUT,126)(I,XINOUT(3*I-2),XINOUT(3*I-1),XINOUT(3*I), + I=1,NGAUSS),XINOUT(NVAR) WRITE(IOUT,155)FOUT 155 FORMAT(/2X,'HODNOTA OPTIMALIZOVANEHO SUCTU STVORCOV: ', + 1P,G12.6/43X,'--------') C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C VOLBA POKRACOVANIA V OPTIMALIZACII C 41 TYPE 131 131 FORMAT(' CHCES POKRACOVAT V OPTIMALIZACII ? YES-Y, NO-N: ',$) ACCEPT400,YESNO IF(YESNO.NE.'Y')GOTO 42 TYPE 132,EPS 132 FORMAT(' CHCES ZLEPSIT TERAJSIU PRESNOST ',1P,G7.1,' ? ', + 'YES-Y, NO-N: ',$) ACCEPT400,YESNO IF(YESNO.NE.'Y')GOTO 40 TYPE 133 133 FORMAT(' POZADOVANA PRESNOST OPTIMALIZACIE: ',$) ACCEPT*,EPS GOTO 40 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C VOLBA GRAFICKEHO ZNAZORNENIA VYSLEDKOV C 42 TYPE 130 130 FORMAT(' CHCES GRAFICKE ZNAZORNENIE VYSLEDKOV ? YES-Y, ', + 'NO-N: ',$) ACCEPT400,YESNO IF(YESNO.NE.'Y')GOTO 43 TYPE 401 ACCEPT*,IOUT2 DO 44 I=IDOLNA,IHORNA FI=XINOUT(NVAR) DO 45 J=1,NGAUSS FI=FI+XINOUT(3*J-2)*EXP(-0.5*((XINOUT(3*J-1)-XI(I))/ + XINOUT(3*J))**2) 45 CONTINUE YT(I)=FI 44 CONTINUE YMAX=YI(IDOLNA) YMIN=YMAX DO 46 I=IDOLNA,IHORNA YMAX=AMAX1(YMAX,YI(I),YT(I)) YMIN=AMIN1(YMIN,YI(I),YT(I)) 46 CONTINUE WRITE(IOUT2,141) H=(YMAX-YMIN)/FLOAT(70) DO 47 I=IDOLNA,IHORNA IYI=IFIX((YI(I)-YMIN)/H)+9 IYT=IFIX((YT(I)-YMIN)/H)+9 WRITE(IOUT2,142)XI(I) 142 FORMAT(1X,F5.0,T,'*',T,'+') 47 CONTINUE 141 FORMAT(' NAMERANE INTENZITY: ***** '/ + ' FITOVANE INTENZITY: +++++ '/) TYPE 151 151 FORMAT(' TLAC OPTIMALIZOVANYCH HODNOT ? YES-Y, NO-N: ',$) ACCEPT400,YESNO IF(YESNO.NE.'Y')GOTO 41 WRITE(IOUT2,124) WRITE(IOUT2,126)(I,XINOUT(3*I-2),XINOUT(3*I-1),XINOUT(3*I), + I=1,NGAUSS),XINOUT(NVAR) WRITE(IOUT2,155)FOUT GOTO 41 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C ROZHODNUTIE O RESTARTE ULOHY C 43 TYPE 134 134 FORMAT(' RESTART ?? YES-Y, NO-N: ',$) ACCEPT 400,YESNO IF(YESNO.EQ.'Y')GOTO 998 STOP END C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DEFINICIA FUNKCIE SUCTU STVORCOV C FUNCTION FCN(X) PARAMETER (NP=40,NKANAL=1500) DIMENSION X(NP) DIMENSION XI(NKANAL),YI(NKANAL),ALFA(NKANAL) COMMON /COM/IDOLNA,IHORNA,XI,YI,ALFA,NGAUSS COMMON /CNVAR/N FCN=0. DO 10 I=IDOLNA,IHORNA FI=X(N) DO 11 J=1,NGAUSS FI=FI+X(3*J-2)*EXP(-0.5*((X(3*J-1)-XI(I))/X(3*J))**2) 11 CONTINUE FCN=FCN+ALFA(I)*(YI(I)-FI)**2 10 CONTINUE RETURN END C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C SUBROUTINE SMPLX(N,XINOUT,STEP,EPS,NMAX,FOUT,LPRT) PARAMETER (NP=40) DIMENSION X0(NP),X(NP,NP),XT(NP),X1(NP),X2(NP),X3(NP) DIMENSION STEP(NP),XINOUT(NP),F(NP) COMMON/CIOUT/IOUT DATA SHRINK,IPRINT /0.2,10/ NSTOP=NMAX CTX=0.666666 !FLOAT(N)/FLOAT(N+1) FOUT=FCN(XINOUT) F0=FOUT IF(LPRT.NE.0)WRITE(IOUT,3005)FOUT 3005 FORMAT(' POCIATOCNA HODNOTA FCN = ',1P,G10.4) NPRT=NSTOP/IPRINT DO 300 ISUR=1,N POM=XINOUT(ISUR) X0(ISUR)=POM DO 302 IBOD=1,N 302 X(IBOD,ISUR)=POM 300 X(ISUR,ISUR)=POM+STEP(ISUR) DO 310 IBOD=1,N DO 311 ISUR=1,N 311 XT(ISUR)=X(IBOD,ISUR) 310 F(IBOD)=FCN(XT) DO 24 I24=1,IPRINT DO 25 I25=1,NPRT HOLD=F0 IHOR=0 DO 40 IBOD=1,N IF(F(IBOD).LE.HOLD)GOTO 40 HOLD=F(IBOD) IHOR=IBOD 40 CONTINUE IF(IHOR.EQ.0)GOTO 6 F(IHOR)=F0 F0=HOLD DO 50 ISUR=1,N POM=X0(ISUR) X0(ISUR)=X(IHOR,ISUR) X(IHOR,ISUR)=POM 50 CONTINUE 6 CONTINUE DO 600 ISUR=1,N POM=0.0 DO 610 IBOD=1,N 610 POM=POM+X(IBOD,ISUR) 600 XT(ISUR)=POM/FLOAT(N)-X0(ISUR) DO 70 ISUR=1,N POM=X0(ISUR) POM1=XT(ISUR) X1(ISUR)=POM+2.*POM1 X2(ISUR)=POM+3.*POM1 70 X3(ISUR)=POM+CTX*POM1 F1=FCN(X1) IF(F1.LT.F0)THEN F2=FCN(X2) IF(F2.LT.F1)THEN DO 1200 ISUR=1,N 1200 X0(ISUR)=X2(ISUR) F0=F2 ELSE DO 1100 ISUR=1,N 1100 X0(ISUR)=X1(ISUR) F0=F1 ENDIF ELSE F3=FCN(X3) IF(F3.LT.F0)THEN DO 1300 ISUR=1,N 1300 X0(ISUR)=X3(ISUR) F0=F3 ELSE GOOD=F0 NAJLEP=0 DO 41 IBOD=1,N IF(F(IBOD).GE.GOOD)GOTO 41 GOOD=F(IBOD) NAJLEP=IBOD 41 CONTINUE IF(NAJLEP.EQ.0)GOTO42 F0=GOOD DO 43 ISUR=1,N 43 X0(ISUR)=X(NAJLEP,ISUR) 42 DO 21 ISUR=1,N POM=STEP(ISUR) POM1=X0(ISUR) DO 20 IBOD=1,N 20 POM=AMAX1(POM,ABS(POM1-X(IBOD,ISUR))) 21 STEP(ISUR)=POM*SHRINK DO 400 ISUR=1,N POM=X0(ISUR) DO 402 IBOD=1,N 402 X(IBOD,ISUR)=POM 400 X(ISUR,ISUR)=POM+STEP(ISUR) DO 410 IBOD=1,N DO 411 ISUR=1,N 411 XT(ISUR)=X(IBOD,ISUR) F(IBOD)=FCN(XT) 410 CONTINUE ENDIF ENDIF 25 CONTINUE IF(LPRT.NE.2)GOTO24 NTRY=I24*NPRT PRESN=ABS(F0-HOLD) WRITE(IOUT,3001)NTRY,NSTOP,F0,PRESN 3001 FORMAT(1X,I6,'. KROK Z MAX.',I6,2X,'FCN= ',1P,G10.4,2X, + 'PRESNOST= ',G7.1) IF(PRESN.LE.EPS)GOTO 999 24 CONTINUE 999 FOUT=F0 NAJLEP=0 DO 44 IBOD=1,N IF(F(IBOD).GE.FOUT)GOTO 44 FOUT=F(IBOD) NAJLEP=IBOD 44 CONTINUE IF(NAJLEP.EQ.0)THEN DO 92 ISUR=1,N 92 XINOUT(ISUR)=X0(ISUR) ELSE DO 93 ISUR=1,N 93 XINOUT(ISUR)=X(NAJLEP,ISUR) ENDIF IF(LPRT.NE.0)WRITE(IOUT,3006)FOUT,(XINOUT(I),I=1,N) 3006 FORMAT(' MINIMALNA HODNOTA FUNKCIE :',1P,G14.6/ + 0P,' SURADNICE MINIMA FUNKCIE :'/(F9.2,5X,F9.3,5X,F9.4)) EPS=PRESN RETURN END