C       GAUSSIAN.FOR - IJL (31-Jan-84)   VAX - 29-Jan-87
C       PROGRAM CREATES A FILES CONSISTING OF GAUSSIANS
C       DECORATING A STICKPLOT
C
        DIMENSION SPECT(1000),NU(1000),FREQ(50),WIDTH(50),AMPL(50)
        DOUBLE PRECISION FILNAM
        REAL SPECT,FREQ,WIDTH,AMPL,START,END,STEP,W1,X,ORIGIN,NU
        INTEGER NPEAKS,I,J,N
 100    FORMAT(///' Number of peaks in the synthetic spectrum: ',$)
        TYPE 100
 200    FORMAT(I2)
        ACCEPT 200,NPEAKS
 205    FORMAT(/' Frequency of the origin: ',$)
        TYPE 205
        READ (5,*) ORIGIN
                DO 300 I=1,NPEAKS
 210            FORMAT(///' Frequency for band ',I2,': ',$)
                TYPE 210,I
                READ (5,*) FREQ(I)
                FREQ(I)=FREQ(I)+ORIGIN
 220            FORMAT('+Width of peak (FWHM): ',$)
                TYPE 220
                READ (5,*) WIDTH(I)
                WIDTH(I)=WIDTH(I)/ALOG(16.)**.5   !  FWHM ===> SIGMA
 230            FORMAT('+Amplitude of the peak: ',$)
                TYPE 230
                READ (5,*) AMPL(I)
 300            CONTINUE
 400    FORMAT(//' Starting frequency for synthetic spectrum: ',$)
        TYPE 400
        READ (5,*) START
 410    FORMAT('+Ending frequency for the spectrum: ',$)
        TYPE 410
        READ (5,*) END
 420    FORMAT('+Number of wavenumber per step in the spectrum: ',$)
        TYPE 420
        READ (5,*) STEP
        N=INT(ABS(START-END)/STEP)
        IF (START.GT.END) STEP=-STEP
                DO 500 I=0,N
                W1=START+STEP*I
                        DO 480 J=1,NPEAKS
                        X=((W1-FREQ(J))/WIDTH(J))**2
                        IF (X.GT.20) GOTO 480
                        SPECT(I+1)=SPECT(I+1)+AMPL(J)*EXP(-X)
 480                    CONTINUE
                NU(I+1)=W1
 500            CONTINUE
        OPEN(UNIT=2,FILE='GAUSS.PRN',STATUS='NEW')
 550    FORMAT(F8.2,F20.8)
                DO 555 I=1,N+1
 555            WRITE (2,550) NU(I),SPECT(I)
        CLOSE(UNIT=2)
 560    FORMAT(///' File GAUSS.PRN has been generated.')
        TYPE 560
        END