--- /dev/null
+C Last update : 11-2-1994
+C --------History:
+C 27-JAN-1994: DLL,DLL1 double prec.
+C 14-jan-1994: NAXIS=3 allowed in fits reading (for iraf multispec)
+C 7-jan-1994 : added BROAD command to broaden and redshift the
+C spectrum ( its fourier transform )
+C 7-12-1993 in fitta and fita ( fit to the anti trasf of ratio)
+C changed to fitting a un-normalized gaussian, D=gamma = line str.
+C is the gaussian peack !
+C
+C ******************************************************
+C PROGRAM S I G
+C ******************************************************
+C Velocity dispersion computation
+C By Marcello Galli
+C
+C This program uses Fourier Transform methods to fit
+C the spectrum of a galaxy against a template star spectrum.
+C
+C Input are the galaxy and star spectra.
+C
+C Output is sigma : the width of the Doppler broadening
+C function applied to the star spectrum to match the
+C galaxy spectrum.
+C
+C Correlation of galaxy and template, fourier transforms
+C and frequency filtered spectra can also be obtained.
+C
+C logical units 5,6,10 are used
+C
+C The "smongo V2.3-1" routines are called for plotting.
+C The old mongo routines are used in this version, I had problems
+C with smongo V2.3-1.
+C
+C Modified routines from "Numerical Recipes" are used.
+C
+C ******************************************************
+C ******************************************************
+C
+C WARNING !
+C
+C THIS PROGRAM IS NOT A INTENDED TO BE DISTRIBUTED TO
+C ANYONE; IT ISN'T WELL TESTED, DOCUMENTED AND DEBUGGED, AS
+C EVERY PROGRAM SHOULD BE. IT IS ONLY A WORKING TOOL, SUBJECT
+C TO A STATE OF COUNTINUOUS CHANGING, ONLY PARTIALLY DEBUGGED,
+C UNOPTIMIZED AND WITH SOME MINOR INNER INCONSISTENCE,
+C REDUNDANCY AND CONFUSION.
+C
+C FOR THIS REASON YOU ARE WARNED AGAINST A BLIND USE OF
+C THIS PROGRAM, AND SHOULD CAREFULLY TEST ANY PART OF
+C THE PROGRAM YOU WANT TO USE.
+C ******************************************************
+C
+C PROGRAM SIG
+C ---------------------------------------------------
+C main routine : reads input command and calls aaamain
+C initializes defaults and logical units numbers
+C ----------------------------------------------------
+ PARAMETER (NPTMX=10000) ! max number of pixels
+ PARAMETER (MXBF=10) ! Number of buffers
+ CHARACTER*80 COMANDO
+C
+ COMMON/TAPE/ N5,N6,N7
+C N5= input file number
+C N6= output file number
+C N7= output auxiliary file for log printing
+C
+ PARAMETER (NDEFMAX=10)
+ CHARACTER*80 STRINGA
+ CHARACTER*80 NAMVAL
+ CHARACTER*30 NOMEDEF
+ LOGICAL FLAGDEF
+ COMMON /DEFAULTS/ NOMEDEF(NDEFMAX),
+ 1 NAMVAL(NDEFMAX),
+ 2 VALDEF(NDEFMAX),NVALDEF(NDEFMAX),
+ 3 FLAGDEF(NDEFMAX)
+C NOMEDEF : description of default value
+C NAMVAL : character value for character type default s
+C VALDEF : numeric value for the default
+C NVALDEF : integer numeric value for the default
+C FLAGDEF : if true the default is active
+C
+C guess values for fitting:
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+C
+C parameters value:
+ COMMON /PARS/TEMPO
+C
+C Weights for fits and pixel number 1,2,3...
+ COMPLEX W1
+ COMMON /WEIGHT/W(NPTMX),W1(NPTMX),W2(NPTMX),PXL(NPTMX)
+C
+C ---------------------------------------------------
+C
+C ............................. some initial values
+ TEMPO=SECNDS(0.0)
+ DO 1 I=1,NPTMX
+ 1 PXL(I)=FLOAT(I-1) ! pxl from 0 to NPTMX-1
+ LGPK(1)=0
+ LGPK(2)=0
+ LGPK(3)=0
+ PK(1)=2. ! sigma
+ PK(2)=1. ! D
+ PK(3)=0. ! z
+ PK(4)=0. ! Noise
+C
+C DEFAULTS INITIALIZZATION:
+C
+ NOMEDEF(1)=' galaxy, template or both '
+ NAMVAL(1)='BOTH'
+ VALDEF(1)=0.0
+ NVALDEF(1)=0.0
+ FLAGDEF(1)=.FALSE.
+ NOMEDEF(2)=' polinomium order '
+ NAMVAL(2)=' '
+ VALDEF(2)=0.0
+ NVALDEF(2)=4
+ FLAGDEF(2)=.FALSE.
+ FLAGDEF(3)=.FALSE.
+ FLAGDEF(4)=.FALSE.
+ FLAGDEF(5)=.FALSE.
+ FLAGDEF(6)=.FALSE.
+ FLAGDEF(7)=.FALSE.
+ FLAGDEF(8)=.FALSE.
+ FLAGDEF(9)=.FALSE.
+ FLAGDEF(10)=.FALSE.
+C
+C LOGICAL UNITS INITIALIZZATION
+C ------------------------------------
+ N5=5
+ N6=6
+ N7=7
+C
+C ....................................COMMAND LOOP
+ 10 CONTINUE
+ CALL UPPERC(COMANDO) ! reads command
+C ------------------
+C ....................................... DCL COMMAND ( $ )
+C ------------------
+C if the command begins with $ it is spawned to DCL
+ IF(COMANDO(1:1).EQ.'$') THEN
+ STRINGA=COMANDO(2:)
+ ISTATUS=LIB$SPAWN(STRINGA)
+C ----------------
+C ....................................... COMMENT ( ! )
+C ----------------
+C if the command begins with ! it is comment
+ ELSE IF(COMANDO(1:1).EQ.'!') THEN
+ STRINGA=COMANDO(2:)
+ WRITE(N6,1000) STRINGA
+ 1000 FORMAT(/1X,A78/)
+C ---------
+C ------------------------------- => VIDEO
+C ---------
+C reset: command from terminal
+ ELSE IF(COMANDO.EQ.'VIDEO') THEN
+ CLOSE(UNIT=8,ERR=100)
+ 100 N5=5
+ N6=6
+C ----------
+C ------------------------------- => FILE NAME
+C ----------
+ ELSE IF(INDEX(COMANDO,'.').GT.0) THEN
+ OPEN(UNIT=8,FILE=COMANDO,READONLY,FORM='FORMATTED',
+ 1 STATUS='OLD',ERR=200)
+ N5=8
+ GOTO 210 ! if a file name (with a '.')
+ 200 CONTINUE ! use this file (on unit 8)
+ WRITE(N6,2000) COMANDO ! for input
+ 2000 FORMAT(' ERROR! Wrong file name:'/1X,A79)
+ 210 CONTINUE
+ ELSE
+C ---------------
+C ------------------------------- => other commands
+C ---------------
+ CALL AAAMAIN(COMANDO) ! call main
+ ENDIF
+ GOTO 10
+ END
+C
+ SUBROUTINE AAAMAIN(COMANDO)
+C -----------------------------------------------------------
+C interprets each command, calling the corresponding routines
+C -----------------------------------------------------------
+ CHARACTER*(*) COMANDO
+C
+C ARRAYS ETC. ETC.
+C
+C T0,TL0 : input template : counts and lambda
+C G0,GL0 : input galaxy : counts and lambda
+C G,GL,T,TL : auxiliary vectors for galaxy and template
+C ttdum: work array for sub contin
+C GW,GLW,TW,TLW : auxiliary vectors for complex fitting
+C C,CL : used for correlation
+C PXL : 0,1,2,..NPNTMX-1 : used for x axis when lambda are missing
+C PFT,PFG,PFS,PFA : for the power spectra of the first 4 buffers
+C FT,FG are the transforma of template and galaxy:FS of division
+C FF1,FF2 : Complex transform work array
+C ANTI is the transform of FS
+C
+C NLAMT = number of lambda points for template
+C NLAMG = number of points for galaxy spectrum
+C NEWN = number of points of the fourier transform
+C NMAX=NPTMX = max number of lambda points
+C MAXBUF=MXBF =max number of buffers (1=temp,2=gal,3=corr,4=anti)
+C ----------------------------------------------------------
+C
+C Number of commands ..........................
+ PARAMETER (NCDMX=72)
+C Max number of pixels ..........................
+ PARAMETER (NPTMX=10000)
+C Number of buffers
+ PARAMETER (MXBF=10)
+C Number of default values
+ PARAMETER (NDEFMAX=10)
+C
+C Guess values for parameter for fitting curves
+C LGPK(i)>=1 if GPK(i) is set ; PK are the parameters
+C PK= sigma, (D=gamma), z, medium power noise
+C DLL=delta lambda/lambda * c= unit used for z and sigma
+C = 299792.458( (lambda2-lambda1)/lambda1)( equi log. lambda scale)
+C ENNE = number of points
+C LISTA = numbers of parameters to vary
+C NL = number of parameters to be varied
+C NPK = Tot number of parameters
+ REAL*8 DLL,DLL1
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+C parameters value:
+ COMMON /PARS/ TEMPO
+C Auxiliary space for fits: W not yet utilized (to contain weights)
+C pxl(nptmx) contains 1,2,3,4,5..... for plotting axis
+ COMPLEX W1
+ COMMON /WEIGHT/W(NPTMX),W1(NPTMX),W2(NPTMX),PXL(NPTMX)
+C
+ COMMON/TAPE/ N5,N6,N7
+C N5= input file number
+C N6= output file number
+C N7= output auxiliary file for log printing
+C
+C DEFAULT VAUES COMMON:
+C NOMEDEF : description of default value
+C NAMVAL : character value for character type default s
+C VALDEF : numeric value for the default
+C NVALDEF : integer numeric value for the default
+C FLAGDEF: if true the default is active
+ CHARACTER*80 NAMVAL
+ CHARACTER*30 NOMEDEF
+ LOGICAL FLAGDEF
+ COMMON /DEFAULTS/ NOMEDEF(NDEFMAX),
+ 1 NAMVAL(NDEFMAX),
+ 2 VALDEF(NDEFMAX),NVALDEF(NDEFMAX),
+ 3 FLAGDEF(NDEFMAX)
+C
+ EXTERNAL GAUSZ,GAUSZC,GAUSZA
+C ! space for spectra
+ DIMENSION TL0(NPTMX),T0(NPTMX),GL0(NPTMX),G0(NPTMX)
+ DIMENSION CL(NPTMX),C(NPTMX)
+ DIMENSION BUF(NPTMX,MXBF),NDIMBUF(MXBF),ALBUF(NPTMX,MXBF)
+ EQUIVALENCE (NDIMBUF(1),NLAMT),(NDIMBUF(2),NLAMG)
+ DATA NLAMT,NLAMG /1,1/
+ EQUIVALENCE (BUF(1,1),T0(1)) , (BUF(1,2),G0(1))
+ EQUIVALENCE (BUF(1,3),C(1) )
+ EQUIVALENCE (ALBUF(1,1),TL0(1)),(ALBUF(1,2),GL0(1))
+ EQUIVALENCE (ALBUF(1,3),CL(1))
+
+C ! space for transforms
+ COMPLEX BUFC(NPTMX,MXBF)
+ COMPLEX FT(NPTMX),FG(NPTMX),FS(NPTMX),ANTI(NPTMX),FNORM
+ DIMENSION NDIMBUFC(MXBF)
+ DATA NEWN /1/
+C ndimbufc not used now, and passed only to routine algebra, to be tested
+C EQUIVALENCE (NEWN,NDIMBUFC(1))
+ EQUIVALENCE (BUFC(1,1),FT(1) ) , (BUFC(1,2),FG(1))
+ EQUIVALENCE (BUFC(1,3),FS(1) ) , (BUFC(1,4),ANTI(1))
+C ! buffer names for plotting
+ CHARACTER*20 TITOLO
+ CHARACTER*20 BUFTIT(MXBF)
+ CHARACTER*20 BUFTITC(MXBF)
+ CHARACTER*20 TITOLOI /'-IMM '/
+ CHARACTER*20 TITOLOR /'-REAL '/
+ DATA NBUSED/3/ ! Number of active buffer titles
+ DATA BUFTIT(1),BUFTIT(2),BUFTIT(3)
+ 1 /'Template ','Galaxy ','Correlation '/
+ DATA NBCUSED/4/ ! number of active complex buffer titles
+ DATA BUFTITC(1),BUFTITC(2),BUFTITC(3),BUFTITC(4)
+ 1 /'F-Template ','F-Galaxy ','FG/FT ','Anti '/
+C
+ DIMENSION TL(NPTMX),T(NPTMX),GL(NPTMX),G(NPTMX)
+ DIMENSION TTDUM(NPTMX) ! work array for contin
+ DIMENSION TLW(2*NPTMX),TW(2*NPTMX),GLW(2*NPTMX),GW(2*NPTMX)
+ COMPLEX FF1(NPTMX),FF2(NPTMX) ! work arrays
+ DIMENSION PFT(NPTMX),PFG(NPTMX),PFS(NPTMX),PFA(NPTMX) ! power for bufc
+C
+C
+ CHARACTER*1 YN
+ CHARACTER*80 TEMPFILE,GALFILE
+ CHARACTER*80 COMAND1,COMANDI(NCDMX)
+ CHARACTER*80 COMAND2
+ DATA COMANDI/'STOP','END','TEMPLATE','GALAXY','CONTSUB',
+ 1 'PRINT','MEANSUB','LOG','COSBELL','FOURIER',
+ 2 'DIVIDE','VERIFY','FSHIFT','ALL','WINDOW',
+ 3 'ANTI','CORREL','HELP','CIRCOR','CORRELATION',
+ 4 'NORMALIZE','FILTER','SHIFT','LEFT','SEGMENT',
+ 5 'CONVOLUTION','DECONVOLUTION','CSHIFT','POWER','WIENER',
+ 6 'BANDFILTER','INPUT','BOTH','SEGMENT1','RIGHT',
+ 7 'SHRINK','DOUBLE','ADD','GAUSS','PIECECONT',
+ 8 'TEMP','GAL','LOGSCALE','TYPE','INFOUR',
+ 9 'BUFFER','BUF','PLOT','FITA','FITTA',
+ A 'FITS','FITG','CONTNORM','FITC','FCORR',
+ B 'SET','DEFAULT','RED','SETCUT','GAUSSFILTER',
+ C 'GAUSSBELL','EXPAND','BFCORR','DIVISION','FDOUBLE',
+ D 'FT','ALGEBRA','REDSHIFT','CSHIFTF','FFT',
+ E 'INFITS','BROAD'/
+C
+ CHARACTER*20 NOME/' FIT-ANTI'/
+C
+ DATA NMAX,MAXBUF,NEWN/NPTMX,MXBF,1/
+C
+C --------------------------------------------
+ 1400 FORMAT(' TEMPLATE or GALAXY ?')
+ 1401 FORMAT(' TEMPLATE, GALAXY or BOTH?')
+ 1402 FORMAT(' TEMPLATE, GALAXY, BOTH or CORRELATION ?')
+ 1403 FORMAT(' TEMPLATE, GALAXY, BOTH or ANTI ?')
+ 1440 FORMAT(' TEMPLATE, GALAXY, CORRELATION, or ALL? POWER,'
+ 1 ' ANTI or FOURIER ?')
+ 1444 FORMAT(' TEMPLATE, GALAXY, or ALL transforms ?')
+ 1450 FORMAT(' ALL , POWER (and ANTI) or FOURIER ?')
+ 1460 FORMAT(' TEMPLATE, GALAXY OR DIVIDE ?')
+ 1461 FORMAT(' TEMPLATE, GALAXY BOTH OR DIVIDE ?')
+ 2600 FORMAT(' TEMPLATE,GALAXY or ALL')
+C --------------------------------------------
+C
+ GOTO 11 ! to execute a command
+C
+C -------------------------------------------------------
+ 10 CONTINUE ! exit to main
+ TEMPO0=SECNDS(TEMPO)
+ TEMPO=TEMPO+TEMPO0
+ WRITE(N6,1000) COMANDO,TEMPO0
+ 1000 FORMAT(/' Command:',A80/' executed in ',G12.5,' sec.',
+ 1 ' Enter new command.')
+ RETURN ! TO MAIN to read a new command
+C
+C ================================= begins IF on commands
+C
+ 11 CONTINUE ! sometimes loops here from a command
+C
+ TEMPO=TEMPO+SECNDS(TEMPO) !sets zero time for this command
+C
+C ----------------
+C .......................................... STOPS
+C ----------------
+ IF(COMANDO.EQ.COMANDI(1).OR.COMANDO.EQ.'FINE') THEN
+ STOP
+C
+C --------------------------------
+C ................................READS INPUT FITS FORMAT (INFITS)
+C --------------------------------
+ ELSE IF( COMANDO.EQ.COMANDI(71) ) THEN
+ CALL INFITS(NMAX,MAXBUF,NDIMBUF,ALBUF,BUF,TL,T)
+C
+C ---------------------
+C .........................................READS INPUT (INPUT)
+C ---------------------
+ ELSE IF( COMANDO.EQ.COMANDI(32) ) THEN
+ 15 WRITE(N6,2610)
+ 2610 FORMAT(' TEMPLATE,TEMP,GALAXY,GAL,BUFFER,BUF,'
+ 1 ' ALL, ANTI or FOURIER ? (END=stop input)')
+ CALL UPPERC(COMAND1)
+ WRITE(N6,*)COMAND1
+ IF(COMAND1(1:1).EQ.'E') GOTO 10
+C ................... template,galaxy,temp,gal :
+ IF(COMAND1.EQ.COMANDI(3).OR.COMAND1.EQ.COMANDI(4).
+ 1 OR.COMAND1.EQ.COMANDI(41).OR.COMAND1.EQ.COMANDI(42)) THEN
+ KF=1
+ IF(COMAND1.EQ.COMANDI(41).OR.COMAND1.EQ.COMANDI(42))KF=2
+ IF(COMAND1(1:4).EQ.'TEMP') THEN
+C ....................... Temp, template
+ CALL LEGGE(NLAMT,NMAX,TL0,T0,GL0,G0,FT,FG,FS,KF)
+ ELSE
+C ....................... Gal , Galaxy
+ CALL LEGGE(NLAMG,NMAX,GL0,G0,GL0,G0,FT,FG,FS,KF)
+ ENDIF
+C ...........................ALL
+ ELSE IF(COMAND1.EQ.COMANDI(14)) THEN
+ KF=3
+ CALL LEGGE(NLAMT,NMAX,TL0,T0,GL0,G0,FT,FG,FS,KF)
+ NLAMG=NLAMT
+C ........................... ANTI
+ ELSE IF(COMAND1.EQ.COMANDI(16)) THEN
+ KF=4
+ CALL LEGGE(NEWN,NMAX,TL0,T0,GL0,G0,ANTI,ANTI,ANTI,KF)
+C .......................... BUF , buffer
+ ELSE IF(COMAND1.EQ.COMANDI(46).OR.COMAND1.EQ.COMANDI(47))THEN
+ KF=1
+ IF(COMAND1.EQ.COMANDI(47)) KF=2
+ WRITE(N6,2620) MAXBUF
+ 2620 FORMAT(' Give buffer number '/
+ 1 ' (1=temp,2=gal,3=corr, MAX ',I5,' buffers)')
+ READ(N5,*,ERR=500) NUMBUF
+ IF(NUMBUF.LE.0.OR.NUMBUF.GT.MAXBUF) GOTO 550
+ CALL LEGGE(NNNN,NMAX,TL0,BUF(1,NUMBUF),GL0,G0,FT,FG,FS,KF)
+ NDIMBUF(NUMBUF)=NNNN
+C ........................... fourier
+ ELSE IF(COMAND1.EQ.COMANDI(10)) THEN
+ WRITE(N6,2600)
+ CALL UPPERC(COMAND2)
+ KF=4
+ IF(COMAND2.EQ.COMANDI(14)) KF=5
+ IF(COMAND2.EQ.COMANDI(4)) THEN
+ CALL LEGGE(NEWN,NMAX,TL0,T0,GL0,G0,FG,FG,FS,KF)
+ ELSE
+ CALL LEGGE(NEWN,NMAX,TL0,T0,GL0,G0,FT,FG,FS,KF)
+ ENDIF
+ ELSE IF(IFINDC(NCDMX,COMAND1,COMANDI).GT.0) THEN
+ COMANDO=COMAND1 ! it's a new command out of read loop
+ GOTO 11
+ ENDIF
+ GOTO 15
+C ---------------------------
+C .................................. PRINTS DATA TO PLOT (PRINT)
+C ---------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(6)) THEN
+ WRITE(N6,1440)
+ CALL UPPERC(COMAND1)
+C
+ IF(COMAND1.EQ.COMANDI(3)) THEN
+ CALL PRINTA(TL0,T0,NLAMT)
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+ CALL PRINTA(GL0,G0,NLAMG)
+ ELSE IF(COMAND1.EQ.COMANDI(20)) THEN
+ CALL PRINTA(CL,C,NLAMT)
+ ELSE IF(COMAND1.EQ.COMANDI(14)) THEN
+ IF(NLAMT.NE.NLAMG) WRITE(N6,1442)NLAMT,NLAMG
+ 1442 FORMAT(' WARNING!'/
+ 1 ' Template and galaxy dimensions are inconsistent:',2I10)
+ CALL PRINTP(TL0,T0,G0,C,NLAMT)
+C
+ ELSE IF(COMAND1.EQ.COMANDI(29)) THEN
+ CALL PRINTP(TL0,PFT,PFG,PFS,NEWN)
+ ELSE IF(COMAND1.EQ.COMANDI(16)) THEN
+ CALL PRINTC(ANTI,NEWN)
+C
+ ELSE IF(COMAND1.EQ.COMANDI(10)) THEN
+C
+C Fourier transform printing
+ WRITE(N6,1444)
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.EQ.COMANDI(3)) THEN
+ CALL PRINTC(FT,NEWN)
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+ CALL PRINTC(FS,NEWN)
+ ELSE IF(COMAND1.EQ.COMANDI(14)) THEN
+ CALL PRINTF(FT,FG,FS,NEWN)
+ ENDIF
+C
+ ELSE
+ GOTO 550
+ ENDIF
+C
+C ---------------------------
+C .................................. TYPES DATA (TYPE)
+C ---------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(44)) THEN
+ WRITE(N6,1450)
+ CALL UPPERC(COMAND1)
+ 145 WRITE(N6,1451)NLAMG,NLAMT
+ 1451 FORMAT(' Enter the first and last point to type',
+ 1 ' (0=all,<0 quit ,max:',2I6,')')
+ READ(N5,*,ERR=500) N1,N2
+ IF(N1.LT.0) GOTO 10
+ IF(N1.EQ.0) N1=1
+ IF((N2.GT.NLAMT.AND.N2.GT.NLAMG).OR.N2.LE.0)
+ 1 N2=MAX(NLAMT,NLAMG)
+C
+ IF(COMAND1.EQ.COMANDI(14)) THEN
+ WRITE(N6,1452)
+ 1452 FORMAT(' I ',6X,'TL0',12X,'GL0',13X,'T0',13X,'G0',
+ 1 13X,'C' //)
+ WRITE(N6,1453) (J,TL0(J),GL0(J),T0(J),G0(J),C(J),J=N1,N2)
+ 1453 FORMAT(1X,I4,5G15.4)
+ GOTO 145
+ ELSE IF(COMAND1.EQ.COMANDI(29).OR.COMAND1.EQ.COMANDI(16))THEN
+ WRITE(N6,1454)
+ 1454 FORMAT(' I ',6X,'PFT',12X,'PFG',12X,'PFS',9X,
+ 1 'REAL_ANTI',9X,'IMM_ANTI')
+ WRITE(N6,1455) (J,PFT(J),PFG(J),PFS(J),ANTI(J),J=N1,N2)
+ 1455 FORMAT(1X,I5,5G15.4)
+ GOTO 145
+ ELSE IF(COMAND1.EQ.COMANDI(10)) THEN
+ WRITE(N6,1456)
+ 1456 FORMAT(' I ',10X,'FT',20X,'FG',20X,'FS')
+ WRITE(N6,1457) (J,FT(J),FG(J),FS(J),J=N1,N2)
+ 1457 FORMAT(1X,I5,6G12.3)
+ GOTO 145
+C
+ ELSE
+ GOTO 550
+ ENDIF
+C ---------------------------
+C .................................. PLOTS DATA (PLOT)
+C ---------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(48)) THEN
+ 16 WRITE(N6,1510)
+ 1510 FORMAT(' TEMPLATE, GALAXY, BOTH, ANTI, POWERT ,POWERG, POWERS,',
+ 1 ' POWERA,'/
+ 1 ' CORREL, BUFFER, BUFFERC or FOURIER ? E,END = stop plotting')
+ CALL UPPERC(COMAND1)
+ IF(COMAND1(1:1).EQ.'E') GOTO 10
+C
+ A1=0.0
+ A2=0.0
+ A3=0.0
+ A4=0.0
+ KF0=0
+ KF1=1
+C .............................. Buffer
+ IF(COMAND1.EQ.COMANDI(46)) THEN
+ WRITE(N6,2620) MAXBUF
+ READ(N5,*,ERR=500) NUMBUF
+ IF(NUMBUF.LE.0.OR.NUMBUF.GT.MAXBUF) GOTO 550
+ TITOLO=BUFTIT(NUMBUF)
+ NL=NDIMBUF(NUMBUF)
+ CALL PLOTTA(NL,PXL,TL0,BUF(1,NUMBUF),T,
+ 1 A1,A2,A3,A4,TITOLO,KF0)
+C .............................. Bufferc : complesso
+ ELSE IF(COMAND1.EQ.'BUFC') THEN
+ 25 WRITE(N6,1520)
+ READ(N5,*,ERR=500) NUMBUF
+ IF(NUMBUF.EQ.0.OR.ABS(NUMBUF).GT.MAXBUF) GOTO 16
+ TITOLO=BUFTITC(ABS(NUMBUF)) ! nome del buffer
+ LBIANCO=INDEX(TITOLO,' ')-1 ! lunghezza nome (finisce con ' ')
+ IF(NUMBUF.GT.0) THEN
+ TITOLO=TITOLO(1:LBIANCO)//TITOLOR
+ DO 27 I=1,NEWN
+ T(I)=REAL(BUFC(I,NUMBUF))
+ 27 CONTINUE
+ ELSE
+ TITOLO=TITOLO(1:LBIANCO)//TITOLOI
+ NUMBUF=-NUMBUF
+ DO 29 I=1,NEWN
+ T(I)=AIMAG(BUFC(I,NUMBUF))
+ 29 CONTINUE
+ ENDIF
+ A1=0.0
+ A2=0.0
+ A3=0.0
+ A4=0.0
+ CALL PLOTTA(NEWN,PXL,PXL,T,T,A1,A2,A3,A4,TITOLO,KF1)
+ GOTO 25
+C
+C .............................. Template
+ ELSE IF(COMAND1.EQ.COMANDI(3)) THEN
+ CALL PLOTTA(NLAMT,PXL,TL0,T0,T,A1,A2,A3,A4,COMAND1,KF0)
+C .............................. Galaxy
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+ CALL PLOTTA(NLAMG,PXL,GL0,G0,T,A1,A2,A3,A4,COMAND1,KF0)
+C ............................. Both template and Galaxy
+ ELSE IF(COMAND1.EQ.COMANDI(33)) THEN
+ KF3=3
+ CALL PLOTTA(NLAMT,PXL,TL0,T0,G0,A1,A2,A3,A4,COMAND1,KF3)
+C ............................... Anti (real)
+ ELSE IF(COMAND1.EQ.COMANDI(16)) THEN
+ NEWN2=NEWN/2 ! (first point(z=0) in newn/2+1)
+ DO 30 I=1,NEWN2
+ TL(I+NEWN2)=I-1
+ T(I+NEWN2)=REAL(ANTI(I))
+ TL(I)=I-1-NEWN2
+ T(I)=REAL(ANTI(NEWN2+I))
+ 30 CONTINUE
+ CALL PLOTTA(NEWN,PXL,TL,T,T,A1,A2,A3,A4,COMAND1,KF0)
+C .............................. Correlation
+ ELSE IF(COMAND1.EQ.COMANDI(17)) THEN
+ NEWNT2=NLAMT/2 ! (first point(z=0) in n/2+1)
+ DO 21 I=1,NEWNT2
+ TL(I+NEWNT2)=I-1
+ TL(I)=I-1-NEWNT2
+ 21 CONTINUE
+ NDUM=NLAMT-MOD(NLAMT,2) ! corr. calcola un numero pari di shift
+ CALL PLOTTA(NDUM ,TL, CL,C,T,A1,A2,A3,A4,COMAND1,KF1)
+C CALL PLOTTA(NLAMT,PXL,CL,C,T,A1,A2,A3,A4,COMAND1,KF1)
+C ............................. Power template,galaxy,temp/gal,anti
+ ELSE IF(COMAND1.EQ.'POWERT') THEN
+ NEWN2=NEWN/2 ! (first point(z=0) in newn/2+1)
+ DO 22 I=1,NEWN2
+ TL(I+NEWN2)=I-1
+ T(I+NEWN2)=PFT(I)
+ TL(I)=I-1-NEWN2
+ T(I)=PFT(NEWN2+I)
+ 22 CONTINUE
+ CALL PLOTTA(NEWN,PXL,TL,T,T,A1,A2,A3,A4,COMAND1,KF0)
+C CALL PLOTTA(NEWN,PXL,PXL,PFT,T,A1,A2,A3,A4,COMAND1,KF1)
+ ELSE IF(COMAND1.EQ.'POWERG') THEN
+ NEWN2=NEWN/2 ! (first point(z=0) in newn/2+1)
+ DO 24 I=1,NEWN2
+ TL(I+NEWN2)=I-1
+ T(I+NEWN2)=PFG(I)
+ TL(I)=I-1-NEWN2
+ T(I)=PFG(NEWN2+I)
+ 24 CONTINUE
+ CALL PLOTTA(NEWN,PXL,TL,T,T,A1,A2,A3,A4,COMAND1,KF0)
+C CALL PLOTTA(NEWN,PXL,PXL,PFG,T,A1,A2,A3,A4,COMAND1,KF1)
+ ELSE IF(COMAND1.EQ.'POWERS') THEN
+ NEWN2=NEWN/2 ! (first point(z=0) in newn/2+1)
+ DO 26 I=1,NEWN2
+ TL(I+NEWN2)=I-1
+ T(I+NEWN2)=PFS(I)
+ TL(I)=I-1-NEWN2
+ T(I)=PFS(NEWN2+I)
+ 26 CONTINUE
+ CALL PLOTTA(NEWN,PXL,TL,T,T,A1,A2,A3,A4,COMAND1,KF0)
+ ELSE IF(COMAND1.EQ.'POWERA') THEN
+ NEWN2=NEWN/2 ! (first point(z=0) in newn/2+1)
+ DO 28 I=1,NEWN2
+ TL(I+NEWN2)=I-1
+ T(I+NEWN2)=PFA(I)
+ TL(I)=I-1-NEWN2
+ T(I)=PFA(NEWN2+I)
+ 28 CONTINUE
+ CALL PLOTTA(NEWN,PXL,TL,T,T,A1,A2,A3,A4,COMAND1,KF0)
+C CALL PLOTTA(NEWN,PXL,PXL,PFS,T,A1,A2,A3,A4,COMAND1,KF1)
+C .............................. Fourier
+ ELSE IF(COMAND1.EQ.COMANDI(10)) THEN
+ NEWN2=NEWN/2 ! (first point(z=0) in newn/2+1)
+ 31 WRITE(N6,1520)
+ 1520 FORMAT(' Enter 1,2,3,4 for REAL temp,gal,s,anti,...',
+ 1 ' -1,-2 .. IMM (0 TO end)')
+ READ(N5,*,ERR=500) NUMBUF
+ IF(NUMBUF.EQ.0.OR.ABS(NUMBUF).GT.MAXBUF) GOTO 16
+ TITOLO=BUFTITC(ABS(NUMBUF)) ! nome del buffer
+ LBIANCO=INDEX(TITOLO,' ')-1 ! lunghezza nome (finisce con ' ')
+ IF(NUMBUF.GT.0) THEN
+ TITOLO=TITOLO(1:LBIANCO)//TITOLOR
+ DO 32 I=1,NEWN2
+ TL(I+NEWN2)=I-1
+ TL(I)=I-1-NEWN2
+ T(I+NEWN2)=REAL(BUFC(I,NUMBUF))
+ T(I)=REAL(BUFC(NEWN2+I,NUMBUF))
+ 32 CONTINUE
+ ELSE
+ TITOLO=TITOLO(1:LBIANCO)//TITOLOI
+ NUMBUF=-NUMBUF
+ DO 33 I=1,NEWN2
+ TL(I+NEWN2)=I-1
+ TL(I)=I-1-NEWN2
+ T(I+NEWN2)=AIMAG(BUFC(I,NUMBUF))
+ T(I)=AIMAG(BUFC(NEWN2+I,NUMBUF))
+ 33 CONTINUE
+ ENDIF
+ A1=0.0
+ A2=0.0
+ A3=0.0
+ A4=0.0
+ CALL PLOTTA(NEWN,PXL,TL,T,T,A1,A2,A3,A4,TITOLO,KF0)
+C CALL PLOTTA(NEWN,PXL,PXL,T,T,A1,A2,A3,A4,TITOLO,KF1)
+ GOTO 31
+ ELSE IF(IFINDC(NCDMX,COMAND1,COMANDI).GT.0) THEN
+ COMANDO=COMAND1 ! it's a new command out of read loop
+ GOTO 11
+ ENDIF
+ GOTO 16
+C
+C ----------------------------------
+C .......................... GAUSS FUNCTION IN TEMPLATE (GAUSS)
+C ----------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(39)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) THEN
+ CALL GAUSS(T0,N,NLAMT,NLAMG,NEWN,NMAX)
+ NLAMT=N
+ ENDIF
+ IF(COMAND1.NE.COMANDI(3)) THEN
+ CALL GAUSS(G0,N,NLAMT,NLAMG,NEWN,NMAX)
+ NLAMG=N
+ ENDIF
+C
+C -------------------------
+C ...................................... TESTS INPUT DATA (VERIFY)
+C -------------------------
+ ELSE IF ( COMANDO.EQ.COMANDI(12)) THEN
+ CALL VERIFY(TL0,T0,NLAMT,GL0,GL,NLAMG)
+C
+C -------------------------
+C .................................. LOGARITMIC SPECTRUM (LOG)
+C -------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(8)) THEN
+ WRITE(N6,1401)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(33)
+ 1 .AND.COMAND1.NE.COMANDI(4))
+ 1 GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) CALL LOGSCA(T0,NLAMT)
+ IF(COMAND1.NE.COMANDI(3)) CALL LOGSCA(G0,NLAMG)
+C
+C --------------------------
+C ..................................... EXPAND WITH ZEROES(EXPAND)
+C --------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(62)) THEN
+ WRITE(N6,1401)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+ NP1=0 ! Interactive usage
+ IF(COMAND1.EQ.COMANDI(3))
+ 1 CALL EXPAND(TL0,T0,NLAMT,NP1,NMAX,PXL)
+ IF(COMAND1.EQ.COMANDI(4))
+ 2 CALL EXPAND(GL0,G0,NLAMG,NP1,NMAX,PXL)
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+C For "Both" it is used in a non-interactive way
+ WRITE(N6,1395)
+ 1395 FORMAT(' Enter the new number of points')
+ READ(N5,*,ERR=500) NP1
+ WRITE(N6,*) NP1
+ CALL EXPAND(TL0,T0,NLAMT,NP1,NMAX,PXL)
+ CALL EXPAND(GL0,G0,NLAMG,NP1,NMAX,PXL)
+ ENDIF
+C
+C -------------------------
+C ..................................... SQUARE WINDOWING (WINDOW)
+C -------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(15)) THEN
+ WRITE(N6,1401)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+ NP1=-1
+ NP2=-1
+ IF(COMAND1.EQ.COMANDI(3))
+ 1 CALL WINDOW(TL0,T0,T,NLAMT,NP1,NP2,PXL)
+ IF(COMAND1.EQ.COMANDI(4))
+ 2 CALL WINDOW(GL0,G0,G,NLAMG,NP1,NP2,PXL)
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+C For "Both" window is used in a non-interactive way
+ WRITE(N6,1398)
+ 1398 FORMAT(' Enter the first and last point number to be conserved')
+ READ(N5,*,ERR=500) NP1,NP2
+ WRITE(N6,*) NP1,NP2
+ CALL WINDOW(TL0,T0,T,NLAMT,NP1,NP2,PXL)
+ CALL WINDOW(GL0,G0,G,NLAMG,NP1,NP2,PXL)
+ ENDIF
+C
+C -------------------------
+C ..................................... SET SPECTRUM VALUES (SET)
+C -------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(56)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ NP1=-1
+ NP2=-1
+ ANPP=0.0
+ IF(COMAND1.EQ.COMANDI(3))
+ 1 CALL SET(TL0,T0,T,NLAMT,NP1,NP2,ANPP,PXL)
+ IF(COMAND1.EQ.COMANDI(4))
+ 2 CALL SET(GL0,G0,G,NLAMG,NP1,NP2,ANPP,PXL)
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+C For "Both" window is used in a non-interactive way
+ WRITE(N6,1399)
+ 1399 FORMAT(' Enter the first, last point to set and value')
+ READ(N5,*,ERR=500) NP1,NP2,ANPP
+ WRITE(N6,*) NP1,NP2,ANPP
+ IF(NLAMT.LE.1)NLAMT=NP2
+ IF(NLAMG.LE.1)NLAMG=NP2
+ CALL SET(TL0,T0,T,NLAMT,NP1,NP2,ANPP,PXL)
+ CALL SET(GL0,G0,G,NLAMG,NP1,NP2,ANPP,PXL)
+ ENDIF
+C
+C ---------------------------
+C ..................................... CUT EMISSION PEAKS (SETCUT)
+C ---------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(59)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ PEAKMX=0.0 ! Num of standard dev above wich spectrum is cut
+ NPCK=0 ! num of peak widths which are flattened
+ VALUE=0.0 ! value assigned to flatted points
+ IF(COMAND1.EQ.COMANDI(3))
+ 1 CALL SETCUT(TL0,T0,T,NLAMT,PXL,PEAKMX,NPCK,VALUE)
+ IF(COMAND1.EQ.COMANDI(4))
+ 2 CALL SETCUT(GL0,G0,G,NLAMG,PXL,PEAKMX,NPCK,VALUE)
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+C For "Both" window is used in a non-interactive way
+ WRITE(N6,1397)
+ 1397 FORMAT(' Enter the sig treshold, flatting width, and value')
+ READ(N5,*,ERR=500) PEAKMX,NPCK,VALUE
+ WRITE(N6,*) PEAKMX,NPCK,VALUE
+ CALL SETCUT(TL0,T0,T,NLAMT,PXL,PEAKMX,NPCK,VALUE)
+ CALL SETCUT(GL0,G0,G,NLAMG,PXL,PEAKMX,NPCK,VALUE)
+ ENDIF
+C
+C -----------------------------------
+C ................................ SUBTRACTS THE CONTINUUM (CONTSUB)
+C DIVIDES BY THE CONTINUUM (CONTNORM)
+C -----------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(5).OR.COMANDO.EQ.COMANDI(53)) THEN
+ WRITE(N6,1401)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ IF(COMANDO.EQ.COMANDI(5)) THEN
+ K1=0 ! continuum subtraction
+ ELSE
+ K1=1 ! continuum normalization
+ ENDIF
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+ WRITE(N6,1478) ! for both: interactive usage
+ 1478 FORMAT(' Enter the polinomium order',
+ 1 ' (0=INTERACTIVE )>')
+ IF(FLAGDEF(2)) THEN
+ K=NVALDEF(2)
+ ELSE
+ READ(N5,*,ERR=500) K
+ WRITE(N6,*) K
+ ENDIF
+ ELSE
+ K=-1
+ ENDIF
+ IF(COMAND1.NE.COMANDI(4)) THEN
+ WRITE(N6,1485)
+ CALL CONTIN(TL0,T0,T,TL,NLAMT,K,K1,PXL,TTDUM)
+ ENDIF
+ IF(COMAND1.NE.COMANDI(3)) THEN
+ WRITE(N6,1486)
+ CALL CONTIN(GL0,G0,G,GL,NLAMG,K,K1,PXL,TTDUM)
+ ENDIF
+C
+C -------------------------------------------
+C .................... PIECEWISE CONTINUUM SUBTRACTION (PIECECONT)
+C -------------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(40)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+C
+ WRITE(N6,1480) NLAMT,NLAMG
+ 1480 FORMAT('Template and galaxy are dimensioned:',2I5/
+ 1 ' Enter the polinomium order,'
+ 2 ' the number of intervals and the overlap fraction.')
+ READ(N5,*,ERR=500) KPOL,KINT,KOVER
+ WRITE(N6,*) KPOL,KINT,KOVER
+C Else interactive usage
+ ELSE
+ KPOL=-1
+ KINT=-1
+ KOVER=-1
+ ENDIF
+C
+ IF(COMAND1.NE.COMANDI(4)) THEN
+ WRITE(N6,1485)
+ 1485 FORMAT(' Subtracting continuum from TEMPLATE..')
+ CALL CONTINP(TL0,T0,T,NLAMT,KPOL,KINT,KOVER)
+ ENDIF
+ IF(COMAND1.NE.COMANDI(3)) THEN
+ WRITE(N6,1486)
+ 1486 FORMAT(' Subtracting continuum from GALAXY..')
+ CALL CONTINP(GL0,G0,G,NLAMG,KPOL,KINT,KOVER)
+ ENDIF
+C
+C ------------------------------------
+C ......................... SUBTRACTS THE MEDIUM VALUE (MEANSUB)
+C ------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(7)) THEN
+ WRITE(N6,1401)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) CALL MEANSUB(T0,NLAMT)
+ IF(COMAND1.NE.COMANDI(3)) CALL MEANSUB(G0,NLAMG)
+C
+C ------------------------------------------
+C ..................... NORMALIZES TO THE MEDIUM VALUE (NORMALIZE)
+C ------------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(21)) THEN
+ WRITE(N6,1401)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+ K=1 ! non interactive usage for both
+ ELSE
+ K=-1
+ ENDIF
+ IF(COMAND1.NE.COMANDI(4)) CALL MEANORM(T0,NLAMT,K)
+ IF(COMAND1.NE.COMANDI(3)) CALL MEANORM(G0,NLAMG,K)
+C
+C ------------------------------
+C ............................. COSINE BELL FUNCTION (COSBELL)
+C ------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(9)) THEN
+ WRITE(N6,1500)
+ 1500 FORMAT(' Enter fraction of data to mask (default 5%)')
+ READ(N5,*,ERR=500) FRACTION
+ IF(FRACTION.LE.0.) FRACTION=5.0
+ WRITE(N6,*) FRACTION
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+ KCOS=0 ! per both non cerca i diversi da 0
+ ELSE
+ KCOS=1
+ ENDIF
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ IF(COMAND1.NE.COMANDI(4))
+ 1 CALL COSBELL(PXL,T0,NLAMT,FRACTION,KCOS)
+ IF(COMAND1.NE.COMANDI(3))
+ 1 CALL COSBELL(PXL,G0,NLAMG,FRACTION,KCOS)
+ WRITE(N6,1600) FRACTION,COMAND1
+ 1600 FORMAT(1X,E12.5,' of: ',A20,' masked.')
+C
+C ------------------------------
+C ............................. GAUSS MASKING (GAUSSBELL)
+C ------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(61)) THEN
+ WRITE(N6,1550)
+ 1550 FORMAT(' Enter fraction of data to mask (def.5%) and width')
+ READ(N5,*,ERR=500) FRACTION,FRACSIG
+ IF(FRACTION.LE.0.) FRACTION=5.0
+ IF(FRACSIG.LE.0.) FRACSIG=MAX(NLAMT,NLAMG)*FRACTION/300.
+ WRITE(N6,*) FRACTION,FRACSIG
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+ KCOS=0 ! non cerca i diversi da 0
+ ELSE
+ KCOS=1
+ ENDIF
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ IF(COMAND1.NE.COMANDI(4))
+ 1 CALL GAUSSBELL(PXL,T0,NLAMT,FRACTION,FRACSIG,KCOS)
+ IF(COMAND1.NE.COMANDI(3))
+ 1 CALL GAUSSBELL(PXL,G0,NLAMG,FRACTION,FRACSIG,KCOS)
+ WRITE(N6,1600) FRACTION,COMAND1
+C
+C ---------------------------------
+C ............................... SPECTRA ARE LEFT ADJUSTED (LEFT)
+C ---------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(24)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(33)
+ 1 .AND.COMAND1.NE.COMANDI(4))
+ 1 GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) CALL LEFT(TL0,T0,NLAMT)
+ IF(COMAND1.NE.COMANDI(3)) CALL LEFT(GL0,G0,NLAMG)
+C ---------------------------------
+C .............................. SPECTRA ARE RIGHT ADJUSTED (RIGHT)
+C ---------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(35)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(33)
+ 1 .AND.COMAND1.NE.COMANDI(4))
+ 1 GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) CALL RIGHT(TL0,T0,NLAMT)
+ IF(COMAND1.NE.COMANDI(3)) CALL RIGHT(GL0,G0,NLAMG)
+C ---------------------------------
+C .............................. SPECTRA ARE SHRINKED (SHRINK)
+C ---------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(36)) THEN
+ WRITE(N6,1401)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(33)
+ 1 .AND.COMAND1.NE.COMANDI(4))
+ 1 GOTO 550
+ WRITE(N6,1650) NLAMT,NLAMG
+ 1650 FORMAT(' Enter the first and last remaining points(now:',2I6)
+ READ(N5,*,ERR=500) NK1,NK2
+ WRITE(N6,*) NK1,NK2
+ IF(COMAND1.NE.COMANDI(4)) CALL SHRINK(TL0,T0,NLAMT,NK1,NK2)
+ IF(COMAND1.NE.COMANDI(3)) CALL SHRINK(GL0,G0,NLAMG,NK1,NK2)
+C ---------------------------------
+C .............................. DOPPLER SHIFT THE SPECTRA (SHIFT)
+C ----------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(23)) THEN
+C Logaritmin lambda scale is needed
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(33)
+ 1 .AND.COMAND1.NE.COMANDI(4))
+ 1 GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) CALL SHIFT(TL0,T0,TL,T,NLAMT)
+ IF(COMAND1.NE.COMANDI(3)) CALL SHIFT(GL0,G0,GL,G,NLAMG)
+C -------------------------------------------------------
+C .............RED SHIFT THE SPECTRA BY AN INTEGER NUM. OF PIXELS(RED)
+C -------------------------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(58)) THEN
+C Logaritmin lambda scale is needed
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(33)
+ 1 .AND.COMAND1.NE.COMANDI(4))
+ 1 GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) CALL RED(TL0,T0,TL,T,NLAMT)
+ IF(COMAND1.NE.COMANDI(3)) CALL RED(GL0,G0,GL,G,NLAMG)
+C ------------------------------------
+C .............................. RED SHIFT THE SPECTRA (REDSHIFT)
+C ------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(68)) THEN
+C Logaritmin lambda scale is needed
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(33)
+ 1 .AND.COMAND1.NE.COMANDI(4))
+ 1 GOTO 550
+ K=-10
+ ZETA=0 ! the subroutine will ask for these values
+ IF(COMAND1.NE.COMANDI(4))
+ 1 CALL REDSHIFT(TL0,T0,TL,T,NLAMT,K,ZETA,PXL)
+ IF(COMAND1.NE.COMANDI(3))
+ 1 CALL REDSHIFT(GL0,G0,GL,G,NLAMG,K,ZETA,PXL)
+C
+C ----------------------------------------------------
+C ... ..........BROADENING AND REDSHIFT UNING THE THANSFORM (BROAD)
+C ----------------------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(72)) THEN
+ KBUF=NASKBUF(N5,N6,MAXBUF,NBCUSED,BUFTITC)
+ IF(KBUF.LE.0) GOTO 500
+ IF(TL0(1).LE.100.) CALL LEGGESCAL(TL0,NLAMT,1) ! wrong lam. scale
+ DLL1=DBLE(TL0(2))/DBLE(TL0(1))
+ DLL=299792.458D0*( DBLE(TL0(2))-DBLE(TL0(1)) )/DBLE(TL0(1))
+ CALL BROAD(N5,N6,N7,NEWN,NMAX,BUFC(1,KBUF),DLL1)
+C
+C ---------------------------------
+C .............................. CIRCULAR SHIFT (CSHIFT)
+C ----------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(28)) THEN
+C Logaritmin lambda scale is needed
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(33)
+ 1 .AND.COMAND1.NE.COMANDI(4))
+ 1 GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) CALL CSHIFT(TL0,T0,TL,T,NLAMT)
+ IF(COMAND1.NE.COMANDI(3)) CALL CSHIFT(GL0,G0,GL,G,NLAMG)
+C
+C -----------------------------------
+C .............................. TRANSFORM CIRCULAR SHIFT (CSHIFTF)
+C ------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(69)) THEN
+ WRITE(N6,1651)
+ 1651 FORMAT(' Enter 1,2,3,4 for REAL temp,gal,s,anti,...')
+ READ(N5,*,ERR=500) NUMBUF
+ IF(NUMBUF.GT.0.AND.NUMBUF.LE.MAXBUF) THEN
+ CALL CSHIFTF(BUFC(1,NUMBUF),FF1,NEWN)
+ ELSE
+ WRITE(N6,1652) MAXBUF+1
+ 1652 FORMAT(' ERROR! Wrong buffer number, must be: >0 and <',I5)
+ ENDIF
+C
+C ------------------------------------
+C ......................... ADD A CONSTANT VALUE (ADD)
+C ------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(38)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ IF(COMAND1.NE.COMANDI(4)) THEN
+ 1655 FORMAT(' Adding to the TEMPLATE')
+ WRITE(N6,1655)
+ CALL ADD(T0,NLAMT)
+ ENDIF
+ IF(COMAND1.NE.COMANDI(3)) THEN
+ 1656 FORMAT(' Adding to the GALAXY')
+ WRITE(N6,1656)
+ CALL ADD(G0,NLAMG)
+ ENDIF
+C
+C ------------------------------------
+C ......................... DOUBLES THE NUMBER OF POINTS (DOUBLE)
+C ------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(37)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ WRITE(N6,1670)
+ 1670 FORMAT(' Enter fitting polynomial order (<9 ; -1:sinc)')
+ READ(N5,*,ERR=500) K
+ WRITE(N6,*) K
+ K=K+1
+ IF(K.EQ.0) THEN
+ WRITE(N6,1675)
+ 1675 FORMAT(' For sinc enter 1/interpolation error (def=1000000)')
+ READ(N5,*,ERR=500) SINCERR
+ IF(SINCERR.LE.0)SINCERR=1000000.
+ ENDIF
+ IF(COMAND1.NE.COMANDI(4))
+ 1 CALL DOUBLE(TL0,T0,TL,T,NLAMT,NMAX,K,PXL,SINCERR)
+ IF(COMAND1.NE.COMANDI(3))
+ 1 CALL DOUBLE(GL0,G0,GL,G,NLAMG,NMAX,K,PXL,SINCERR)
+C
+C -------------------------------------
+C ......................... DOUBLES THE NUMBER OF POINTS (FDOUBLE)
+C -------------------------------------
+C By adding zero hight freq. to the transforms.
+ ELSE IF (COMANDO.EQ.COMANDI(65)) THEN
+ WRITE(N6,1461)
+ CALL UPPERC(COMAND1)
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ K=0
+ IF(COMAND1.EQ.COMANDI(3)) THEN
+ K=1 ! Template
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+ K=2 ! Galaxy
+ ELSE IF(COMAND1.EQ.COMANDI(11)) THEN
+ K=3 ! Divide
+ ELSE IF(COMAND1.EQ.COMANDI(33)) THEN
+ KNEWN2=NEWN ! Both template and galaxy
+ CALL FDOUBLE(BUFC(1,1),KNEWN2,NMAX)
+ KNEWN2=NEWN
+ CALL FDOUBLE(BUFC(1,2),KNEWN2,NMAX)
+ NEWN=KNEWN2
+ ELSE
+ GOTO 550 ! Input error loop again
+ ENDIF
+ CALL FDOUBLE(BUFC(1,K),NEWN,NMAX)
+C
+C ----------------------------------------------
+C ................ PUTS LAMBDA INTO A LOGARITMIC SCALE (LOGSCALE)
+C ----------------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(43)) THEN
+ WRITE(N6,1401)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.NE.COMANDI(3).AND.COMAND1.NE.COMANDI(4)
+ 1 .AND.COMAND1.NE.COMANDI(33)) GOTO 550
+ WRITE(N6,1670)
+ IF(FLAGDEF(2)) THEN
+ K=NVALDEF(2)
+ ELSE
+ READ(N5,*,ERR=500) K
+ ENDIF
+ WRITE(N6,*) K
+C input as the polinomium order is transformed of numb. of pol.coeff.
+ K=K+1
+ IF(K.EQ.0) THEN
+ WRITE(N6,1675)
+ READ(N5,*,ERR=500) SINCERR
+ IF(SINCERR.LE.0)SINCERR=1000000.
+ ENDIF
+ WRITE(N6,1671) NLAMT,NLAMG
+ 1671 FORMAT(' Enter the new number of points (0 saves the olds:',
+ 1 I5,1x,I5,' )' )
+ READ(N5,*,ERR=500) NK
+ WRITE(N6,*) NK
+ IF(COMAND1.EQ.COMANDI(33)) THEN
+ TGLLA=TL0(1) ! for "BOTH" uses the same lambda
+ TGLLB=TL0(NLAMT) ! scale for template and galaxy
+ ENDIF
+C for not "both" or bad lambda scale ask for log scale
+C logscal will ask for good scale when called,
+ IF((COMAND1.EQ.COMANDI(3).AND.TL0(1).LE.10.).OR.
+ 1 (COMAND1.EQ.COMANDI(4).AND.GL0(1).LE.10.).OR.
+ 1 (COMAND1.EQ.COMANDI(33).AND.(GL0(1).LE.10..OR.TL0(1).LE.10.))
+ 1 ) THEN
+ WRITE(N6,1672) TL0(1),TL0(NLAMT),GL0(1),GL0(NLAMT)
+ 1672 FORMAT(' Template and galaxy first,last lambda(defaults):'/
+ 1 4(1X,G16.4)/
+ 2 ' Enter first, last lambda (<=0,<=0):default;(>0,<=0:l.step)')
+ READ(N5,*,ERR=500) TGLLA,TGLLB
+ WRITE(N6,*) TGLLA,TGLLB
+ IF(TGLLA.GT.0.0.AND.TGLLB.LE.0.0) THEN
+ WRITE(N6,1673)
+ 1673 FORMAT(' Enter L2/L1, or L2 (one can be 0)')
+ READ(N5,*,ERR=500) AL2L1,AL2
+ WRITE(N6,*) AL2L1,AL2
+ ENDIF
+ ENDIF
+C
+ IF(COMAND1.NE.COMANDI(4))
+ 1 CALL LOGSCAL(TL0,T0,TL,T,NLAMT,NMAX,K,NK,TGLLA,TGLLB,
+ 2 AL2L1,AL2,PXL,SINCERR)
+ IF(COMAND1.NE.COMANDI(3))
+ 1 CALL LOGSCAL(GL0,G0,GL,G,NLAMG,NMAX,K,NK,TGLLA,TGLLB,
+ 2 AL2L1,AL2,PXL,SINCERR)
+C
+C --------------------------------
+C .............................. TEMPLATE AND GALAXY FFT (FOURIER)
+C --------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(10)) THEN
+ 200 CALL TRASF(T0,NLAMT,G0,NLAMG,NMAX,FT,FG,NEWN)
+C
+C ----------------------------------
+C .............................. BRUTE FORCE FOURIER TRANSFORM (FT)
+C ----------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(66)) THEN
+ WRITE(N6,1401)
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.EQ.COMANDI(33).OR.
+ 1 COMAND1.EQ.COMANDI(4).OR.COMAND1.EQ.COMANDI(3)) THEN
+ WRITE(N6,1677) NLAMT,NLAMG
+ 1677 FORMAT(' Enter the new number of points, now:',2I6)
+ READ(N5,*,ERR=500) NNUOVO
+ ELSE
+ GOTO 550
+ ENDIF
+ IF(COMAND1.NE.COMANDI(4))
+ 1 CALL BRUTEFT(TL0,T0,TL,T,NLAMT,FT,NNUOVO,NMAX)
+ IF(COMAND1.NE.COMANDI(3))
+ 1 CALL BRUTEFT(GL0,G0,GL,G,NLAMG,FG,NNUOVO,NMAX)
+ NEWN=NNUOVO
+C
+C ---------------------------------
+C .......................... FFT OF A COMPLEX BUFFER (FFT)
+C ---------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(70)) THEN
+ WRITE(N6,1674) MAXBUF
+ 1674 FORMAT(' Give input and output buffer :'/
+ 1 ' 1,2,3,4,..=FT_templ,Gal,division,anti...(max:',I5,')')
+ READ(N5,*,ERR=500) NUMBUF1,NUMBUF2
+ IF(NUMBUF1.LE.0.OR.NUMBUF1.GT.MAXBUF) GOTO 500
+ IF(NUMBUF2.LE.0.OR.NUMBUF2.GT.MAXBUF) GOTO 500
+ WRITE(N6,1676)
+ 1676 FORMAT(' DIRECT transform or ANTI ?')
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.EQ.'ANTI') THEN
+ WRITE(N6,1776)
+ 1776 FORMAT(' Inverse transform')
+ NFFTFLAG=-1
+ ELSE
+ WRITE(N6,1775)
+ 1775 FORMAT(' Direct transform')
+ NFFTFLAG=1
+ ENDIF
+ WRITE(N6,1777) BUFTITC(NUMBUF1),BUFTITC(NUMBUF2),NUMBUF1,NUMBUF2
+ 1777 FORMAT(' OF:',A20,' ==>',A20,' Buffer num.:',I5,' ==>',I5)
+ DO 77 I=1,NEWN
+ 77 FF1(I)=BUFC(I,NUMBUF1)
+ CALL FOUR1(FF1,NEWN,NFFTFLAG)
+ IF(NFFTFLAG.EQ.1) THEN
+ DO 78 I=1,NEWN ! No normalization for direct transform
+ 78 BUFC(I,NUMBUF2)=FF1(I)
+ ELSE
+ FNORM=CMPLX(NEWN) ! normalizing inverse transform
+ DO 79 I=1,NEWN
+ 79 BUFC(I,NUMBUF2)=FF1(I)/FNORM
+ ENDIF
+C
+C ---------------------------------
+C .......................... FREQUENCY FILTERING (FILTER)
+C ---------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(22)) THEN
+ WRITE(N6,1678) MAXBUF
+ 1678 FORMAT(' Enter 1,2,3,4.. : Fourier Temp.,Gal,division,anti..',
+ 1 ' max:',I5)
+ READ(N5,*,ERR=500) NUMBUF
+ IF(NUMBUF.LE.0.OR.NUMBUF.GT.MAXBUF) GOTO 500
+ WRITE(N6,1679) BUFTITC(NUMBUF),NUMBUF
+ 1679 FORMAT(' Filtering:',A20,' Buffer Num.:',I5)
+ K=0
+ K1=-1
+ K2=-1
+ AK1=1.
+ CALL FILTER(BUFC(1,NUMBUF),FF1,NEWN,K,K1,K2,AK1,PXL,T)
+C
+C ------------------------------------------
+C ..................... GAUSS FREQUENCY FILTERING (GAUSSFILTER)
+C ------------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(60)) THEN
+ WRITE(N6,1403)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ K=2 ! 2 Is for gaussfiltering ; 1:bandfilter
+ WRITE(N6,1436)
+ 1436 FORMAT(' Enter the gauss width ')
+ READ(N5,*,ERR=500) AK1
+ WRITE(N6,*) AK1
+ K1=1 ! unused by gauss filteing
+ K2=NEWN
+C
+ IF(COMAND1.EQ.COMANDI(3)) THEN
+C The template is transformed, filtered and antitrasformed
+ CALL TRASF1(TL0,T0,NLAMT,NMAX,FT,NEWN)
+C
+ CALL FILTER(FT,FF1,NEWN,K,K1,K2,AK1,PXL,T)
+C
+ DO 41 I=1,NEWN
+ 41 FF1(I)=FT(I)
+ CALL FOUR1(FF1,NEWN,-1)
+ DO 42 I=1,NLAMT
+ 42 T0(I)=REAL(FF1(I))/NEWN
+C
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+C The galaxy is transformed, filtered and antitrasformed
+ CALL TRASF1(GL0,G0,NLAMG,NMAX,FG,NEWN)
+C
+ CALL FILTER(FG,FF1,NEWN,K,K1,K2,AK1,PXL,G)
+C
+ DO 43 I=1,NEWN
+ 43 FF1(I)=FG(I)
+ CALL FOUR1(FF1,NEWN,-1)
+ DO 44 I=1,NLAMG
+ 44 G0(I)=REAL(FF1(I))/NEWN
+C
+ ELSE IF(COMAND1.EQ.COMANDI(16)) THEN
+C The division S is transformed,filtered and antitrasformed
+ DO 45 I=1,NEWN
+ 45 FF2(I)=ANTI(I)
+ CALL FOUR1(FF2,NEWN,1)
+C
+ CALL FILTER(FF2,FF1,NEWN,K,K1,K2,AK1,PXL,T)
+C
+ CALL FOUR1(FF2,NEWN,-1)
+ DO 46 I=1,NEWN
+ 46 ANTI(I)=FF2(I)
+C
+ ELSE IF(COMAND1.EQ.COMANDI(33)) THEN
+C in this case transforms both in a single array
+ CALL TRASF(T0,NLAMT,G0,NLAMG,NMAX,FT,FG,NEWN)
+C Template filtering and antitransform
+ CALL FILTER(FT,FF1,NEWN,K,K1,K2,AK1,PXL,T)
+ DO 47 I=1,NEWN
+ 47 FF1(I)=FT(I)
+ CALL FOUR1(FF1,NEWN,-1)
+ DO 48 I=1,NLAMT
+ 48 T0(I)=REAL(FF1(I))/NEWN
+C Galaxy filtering and antitransform
+ CALL FILTER(FG,FF1,NEWN,K,K1,K2,AK1,PXL,G)
+ DO 49 I=1,NEWN
+ 49 FF1(I)=FG(I)
+ CALL FOUR1(FF1,NEWN,-1)
+ DO 50 I=1,NLAMG
+ 50 G0(I)=REAL(FF1(I))/NEWN
+ ELSE
+ GOTO 550
+ ENDIF
+C
+C ------------------------------------------
+C ..................... BAND FREQUENCY FILTERING (BANDFILTER)
+C ------------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(31)) THEN
+ WRITE(N6,1402)
+ IF(FLAGDEF(1)) THEN
+ COMAND1=NAMVAL(1)
+ ELSE
+ CALL UPPERC(COMAND1)
+ ENDIF
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ K=1
+ WRITE(N6,1466)
+ 1466 FORMAT(' Enter low and high frequency limits (1 : freq=0)')
+ READ(N5,*,ERR=500) K1,K2
+ WRITE(N6,*) K1,K2
+C
+ IF(COMAND1.EQ.COMANDI(3)) THEN
+C The template is transformed, bandfiltered and antitrasformed
+ CALL TRASF1(TL0,T0,NLAMT,NMAX,FT,NEWN)
+C
+C K1 AND K2, input as last saved freq., are used as number
+C of frequency to eliminate, considering that 1=freq 0 ,and
+C N/2+1 - last freq, are not included in K1 and K2
+ K1=K1-1
+ MEZZO=NEWN/2+1
+ K2=MEZZO-K2+1
+C
+ CALL FILTER(FT,FF1,NEWN,K,K1,K2,AK1,PXL,T)
+C
+ DO 56 I=1,NEWN
+ 56 FF1(I)=FT(I)
+ CALL FOUR1(FF1,NEWN,-1)
+ DO 57 I=1,NLAMT
+ 57 T0(I)=REAL(FF1(I))/NEWN
+C
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+C The galaxy is transformed, bandfiltered and antitrasformed
+ CALL TRASF1(GL0,G0,NLAMG,NMAX,FG,NEWN)
+C
+C K1 AND K2, input as last saved freq., are used as number
+C of frequency to eliminate, considering that 1=freq 0 ,and
+C N/2+1 - last freq, are not included in K1 and K2
+ K1=K1-1
+ MEZZO=NEWN/2+1
+ K2=MEZZO-K2+1
+C
+ CALL FILTER(FG,FF1,NEWN,K,K1,K2,AK1,PXL,G)
+C
+ DO 66 I=1,NEWN
+ 66 FF1(I)=FG(I)
+ CALL FOUR1(FF1,NEWN,-1)
+ DO 67 I=1,NLAMG
+ 67 G0(I)=REAL(FF1(I))/NEWN
+C
+ ELSE IF(COMAND1.EQ.COMANDI(20)) THEN
+C The correlation is transformed, bandfiltered and antitrasformed
+ CALL TRASF1(CL,C,NLAMT,NMAX,FF2,NEWN)
+C
+C K1 AND K2, input as last saved freq., are used as number
+C of frequency to eliminate, considering that 1=freq 0 ,and
+C N/2+1 - last freq, are not included in K1 and K2
+ K1=K1-1
+ MEZZO=NEWN/2+1
+ K2=MEZZO-K2+1
+C
+ CALL FILTER(FF2,FF1,NEWN,K,K1,K2,AK1,PXL,T)
+C
+ CALL FOUR1(FF2,NEWN,-1)
+ DO 69 I=1,NLAMG
+ 69 C(I)=REAL(FF2(I))/NEWN
+C
+ ELSE IF(COMAND1.EQ.COMANDI(33)) THEN
+C in this case transforms both in a single array
+ CALL TRASF(T0,NLAMT,G0,NLAMG,NMAX,FT,FG,NEWN)
+C
+C K1 AND K2, input as last saved freq., are used as number
+C of frequency to eliminate, considering that 1=freq 0 ,and
+C N/2+1 - last freq, are not included in K1 and K2
+ K1=K1-1
+ MEZZO=NEWN/2+1
+ K2=MEZZO-K2+1
+C
+C Template filtering and antitransform
+ CALL FILTER(FT,FF1,NEWN,K,K1,K2,AK1,PXL,T)
+ DO 58 I=1,NEWN
+ 58 FF1(I)=FT(I)
+ CALL FOUR1(FF1,NEWN,-1)
+ DO 61 I=1,NLAMT
+ 61 T0(I)=REAL(FF1(I))/NEWN
+C Galaxy filtering and antitransform
+ CALL FILTER(FG,FF1,NEWN,K,K1,K2,AK1,PXL,G)
+ DO 59 I=1,NEWN
+ 59 FF1(I)=FG(I)
+ CALL FOUR1(FF1,NEWN,-1)
+ DO 62 I=1,NLAMG
+ 62 G0(I)=REAL(FF1(I))/NEWN
+ ELSE
+ GOTO 550
+ ENDIF
+C
+C ------------------------------------
+C .......................... DOPPLER SHIFT THE TRANSFORM (FSHIFT)
+C ------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(13)) THEN
+C All lambda intervals are supposed to be equal, as they should be.
+ WRITE(N6,1700)
+ 1700 FORMAT(' TEMPLATE, GALAXY or DIVISION ?')
+ CALL UPPERC(COMAND1)
+ IF(COMAND1.EQ.COMANDI(3)) THEN
+ DELTAL=TL0(2)-TL0(1)
+ CALL FSHIFT(FT,FF1,NEWN,DELTAL)
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+ DELTAL=GL0(2)-GL0(1)
+ CALL FSHIFT(FG,FF1,NEWN,DELTAL)
+ ELSE IF(COMAND1(1:4).EQ.COMANDI(11)(1:4)) THEN
+ DELTAL=TL0(2)-TL0(1)
+ CALL FSHIFT(FS,FF1,NEWN,DELTAL)
+ ENDIF
+C
+C --------------------------------------
+C .................... MULTIPLIES THE TRANSFORMS (CORREL)
+C --------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(17)) THEN
+ IF(NEWN.LE.0) THEN
+ WRITE(N6,1660)
+ 1660 FORMAT(' ERROR! - Transforms with zero dimensions -',
+ 1 ' I assume command: FOURIER')
+ GOTO 200
+ ENDIF
+ CALL CORRELA(FG,FT,FS,NEWN)
+C
+C
+C --------------------------------------
+C .................... CROSS CORRELATION BY FFT (FCORR)
+C BLUE CORRELATION (BFCORR)
+C --------------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(55).OR.COMANDO.EQ.COMANDI(63))THEN
+ IF(NEWN.LE.0) THEN
+ WRITE(N6,1660)
+ GOTO 200
+ ENDIF
+C the strim is extended to avoid overlap and circular cross-corr
+ N2=MAX(NLAMT,NLAMG)
+ N22=N2*2
+C makes n22 an integer power of 2
+ KN22=2
+ DO 71 I=1,30
+ KN22=KN22*2
+ IF(KN22.GE.N22) GOTO 711
+ 71 CONTINUE
+ 711 N22=KN22
+ WRITE(N6,1771) N22
+ 1771 FORMAT(' Stream extended with zeroes to:',I6,' points')
+ IF(N22.GT.NPTMX) THEN
+ WRITE(N6,1772) N22
+ 1772 FORMAT(' ERROR! Not enought space for',I8,
+ 1 'points; increase NPNTMX')
+ GOTO 10
+ ENDIF
+ DO 72 I=NLAMT+1,N22
+ 72 T0(I)=0.0
+ DO 73 I=NLAMG+1,N22
+ 73 G0(I)=0.0
+ IF(COMANDO.EQ.COMANDI(55)) THEN ! shift to red
+ CALL CORREL(G0,T0,N22,FF1,FF2,NMAX)
+ ELSE ! shift to blue
+ CALL CORREL(T0,G,N22,FF1,FF2,NMAX)
+ ENDIF
+ K=1
+ DO 74 I=1,N22/2
+ C(K)=REAL(FF1(I))
+ C(K+1)=AIMAG(FF1(I))
+ K=K+2
+ 74 CONTINUE
+ DO 75 I=1,NLAMT
+ 75 CL(I)=299792.458*(TL0(I)-TL0(1))/TL0(1)
+ K=NLAMT/3
+ CALL MAXPRINT(C,CL,K,N6,CMAX,KCMAX)
+C
+C ----------------------------------
+C ......................... CIRCULAR CROSS CORRELATION (CIRCOR)
+C ----------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(19)) THEN
+C I suppose that the galaxy and template have the same lambda
+C in a logaritmic scale
+ CALL CORRTG(TL0,T0,G0,CL,C,NLAMT)
+C
+C ---------------------------------
+C .............................. CROSS CORRELATION (CORRELATION)
+C ---------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(20)) THEN
+C I suppose that the galaxy and template have the same lambda
+C in a logaritmic scale
+C The correlation peak is fitted by a gauss function.
+C And can be bandfiltered in frequency domain
+ CALL CRXCOR(TL0,T0,G0,CL,C,NLAMT,T,G,PXL,FF1,FF2,NEWN,NMAX)
+C
+C -------------------------------
+C CONVOLUTION (CONVOLUTION)
+C -------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(26)) THEN
+C T0, the response function is supposed
+C to have its zero in NLAMT/2+1
+ CALL CIRCON(T0,NLAMT,GL0,G0,NLAMG,CL,C,FF1,FF2,NMAX,1)
+C
+C -------------------------------
+C DECONVOLUTION (DECONVOLUTION)
+C Not tested ? doesn't work?
+C -------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(27)) THEN
+ CALL CIRCON(T0,NLAMT,GL0,G0,NLAMG,CL,C,FF1,FF2,NMAX,-1)
+C
+C -------------------------------
+C ..................................DIVIDES THE TRANSFORMS (DIVIDE)
+C ..................................DIVIDES THE TRANSFORMS (DIVISION)
+C CUTTING EXTREME VALUES
+C -------------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(11).OR.COMANDO.EQ.COMANDI(64)) THEN
+ IF(NEWN.LE.0) THEN
+ WRITE(N6,1660)
+ GOTO 200
+ ENDIF
+ IF(COMANDO.EQ.COMANDI(64)) THEN ! for commannd: division
+ SIGDIV=-1.0 ! kills extreme values
+ NDIVCUT=-1
+ CALL DIVCUT(FS,NEWN,SIGDIV,NDIVCUT)
+ ELSE ! command :divide
+ CALL DIV(FT,FG,FS,NEWN)
+ ENDIF
+C
+C ---------------------------
+C ............................. POWER SPECTRA (POWER)
+C ---------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(29)) THEN
+ CALL POWER(FT,PFT,NEWN)
+ CALL POWER(FG,PFG,NEWN)
+ CALL POWER(FS,PFS,NEWN)
+ CALL POWER(ANTI,PFA,NEWN)
+C
+C ---------------------------
+C ............................. WIENER FILTERING (WIENER)
+C ---------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(30)) THEN
+ CALL WIENER(TL,T,GL,G,PFG,FS,FF1,NEWN)
+C
+C ---------------------------
+C ............................. ANTI-TRANSFORM (ANTI)
+C ---------------------------
+ ELSE IF (COMANDO.EQ.COMANDI(16)) THEN
+ IF(NEWN.LE.0) THEN
+ WRITE(N6,1660)
+ GOTO 200
+ ENDIF
+ WRITE(N6,1800)
+ 1800 FORMAT(' TEMPLATE, GALAXY or DIVIDE ?')
+ CALL UPPERC(COMAND1)
+C the input typing is excluded from the timing
+ TEMPO=TEMPO+SECNDS(TEMPO)
+ IF(COMAND1.EQ.COMANDI(3)) THEN
+ DO 80 I=1,NEWN
+ 80 ANTI(I)=FT(I)
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+ DO 81 I=1,NEWN
+ 81 ANTI(I)=FG(I)
+ ELSE IF(COMAND1.EQ.COMANDI(11)) THEN
+ DO 82 I=1,NEWN
+ 82 ANTI(I)=FS(I)
+ ELSE
+ GOTO 550
+ ENDIF
+ CALL FOUR1(ANTI,NEWN,-1)
+C Normalizes (FOUR1 has no normalization)
+ FNORM=CMPLX(NEWN)
+ DO 85 I=1,NEWN
+ 85 ANTI(I)=ANTI(I)/FNORM
+C
+ IF(COMAND1.NE.COMANDI(11)) THEN
+ WRITE(N6,1802) COMAND1
+ 1802 FORMAT(' Put the real part in ',A20,' ? (Y/N)')
+ READ(N5,1803,ERR=500)YN
+ 1803 FORMAT(A)
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') THEN
+ IF(COMAND1.EQ.COMANDI(3)) THEN
+ NLAMT=NEWN
+ DO 87 I=1,NLAMT
+ 87 T0(I)=REAL(ANTI(I))
+ ELSE IF(COMAND1.EQ.COMANDI(4)) THEN
+ NLAMG=NEWN
+ DO 88 I=1,NLAMG
+ 88 G0(I)=REAL(ANTI(I))
+ ENDIF
+ ENDIF
+ ENDIF
+C
+C --------------------------------------------------
+C ........... PIECEWISE CONT.SUB. TRANSFORM AND DIVIDE (SEGMENT)
+C --------------------------------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(25)) THEN
+ CALL SEGMENT(TL0,T0,TL,T,NLAMT,GL0,G0,GL,G,NLAMG,
+ 1 FT,FG,FS,ANTI,NMAX,NEWN,PXL)
+C
+C
+C --------------------------------------------------
+C ........... PIECEWISE CONT.SUB. TRANSFORM AND DIVIDE (SEGMENT1)
+C --------------------------------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(34)) THEN
+ CALL SEGMENT1(TL0,T0,TL,T,NLAMT,GL0,G0,GL,G,NLAMG,
+ 1 FT,FG,FS,ANTI,NMAX,NEWN,PXL)
+C
+C
+C -------------------------------------
+C ........................ FITS REAL ANTI BY A REDSHIFTED GAUSS
+C not interactive (FITA)
+C interactive (FITTA)
+C -------------------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(49).OR.COMANDO.EQ.COMANDI(50)) THEN
+C Shift anti to have 0 in the middle+1 of the antitransform
+ N1=NEWN/2
+ DO 90 I=1,N1
+ TL(I)= REAL(I-1-N1)
+ TL(I+N1)=REAL(I-1)
+ T(I)= REAL(ANTI(I+N1))
+ T(I+N1)=REAL(ANTI(I))
+ GL(I)=1. ! Weights for fitting
+ GL(I+N1)=1.
+ 90 CONTINUE
+ INTERAC=0
+ IF(COMANDO.EQ.COMANDI(50)) INTERAC=1
+ NPK=3
+ IF(PK(2).EQ.0.0) PK(2)=1. ! to avoid overflow
+ IF(PK(1).LE.0.0) PK(1)=1. ! guess value if absurd sigma
+ LISTA(1)=1 ! parameters 1:sig
+ LISTA(2)=2 ! 2: D
+ LISTA(3)=3 ! 3: z
+ LISTA(4)=4 ! are varied, pk 4 ignored
+ NL=3 ! num of pk to vary. (but here npk=3 :pk(4) is hidden)
+ DLL=299792.458D0* (DBLE(TL0(2))-DBLE(TL0(1)))/DBLE(TL0(1))
+ CALL FITA(NEWN,TL,T,GL,G,INTERAC,GAUSZ,NOME,PXL) ! normalized gauss
+C CALL FITA(NEWN,TL,T,GL,G,INTERAC,GAUSZA,NOME,PXL) ! unnorm gauss
+ SIGMA=PK(1)*DLL
+C ZETA=PK(3)*DLL ! WRONG ! good only for low zeta (first order approx)
+ DLL1=DBLE(TL0(2))/DBLE(TL0(1))
+ ZETA=(DLL1**PK(3)-1.D0)*299792.458D0
+ WRITE(N6,5200)PK(1),PK(2),PK(3),PK(4),SIGMA,ZETA,DLL
+C
+C -----------------------------------
+C ............................ FITTING THE CROSS CORRELATION PEAK
+C ( FITC )
+C -----------------------------------
+C ..................... fitting the cross correlation peak
+C with a NORMALIZED gaussian function
+C ZERO LAG IS IN VALUE N/2+1, left blue shift
+ ELSE IF (COMANDO.EQ.COMANDI(54)) THEN
+ NPK=4 ! 4 parameters
+ LISTA(1)=1 ! first is sigma
+ LISTA(2)=2 ! second is D=max of exp
+ LISTA(3)=3 ! third is z
+ LISTA(4)=4 ! last is a constant y shift (due to bad contsub)
+ DLL=299792.458D0* (DBLE(TL0(2))-DBLE(TL0(1)))/DBLE(TL0(1))
+ NL=4 ! all parameters are varied
+ DO 92 I=1,NLAMT
+ TL(I)=I-NLAMT/2-1 ! cross correlation abscissa, 0 in i=N/2+1
+ 92 GL(I)=1.0 ! All points the same weight
+ INTER=1 ! Interactive fit
+ CALL FITA(NLAMT,TL,C,GL,T,INTER,GAUSZC,NOME,PXL)
+ SIGMA=PK(1)*DLL
+C ZETA=PK(3)*DLL ! WRONG ! good only for low zeta (first order approx)
+ DLL1=DBLE(TL0(2))/DBLE(TL0(1))
+ ZETA=(DLL1**PK(3)-1.D0)*299792.458D0
+ WRITE(N6,5200)PK(1),PK(2),PK(3),PK(4),SIGMA,ZETA,DLL
+ 5200 FORMAT(' sigma(pixels):',G12.4,' D:',G12.4/
+ 1 ' zeta(pixels):',G12.4,' y-const:',G12.4/
+ 2 ' SIGMA,ZETA(Km/sec):',2G15.5, ' Km/sec/pixel:',G15.5)
+C ------------------------------------
+C FITS complex FG,with GAUSS*EXP(-iz)
+C fit to FG (FITS)
+C fit to FS (FITG)
+C ------------------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(51).OR.COMANDO.EQ.COMANDI(52)) THEN
+ INTERAC=1
+ NEWN2=2*NEWN
+C Equi ln lambda scale is assumed
+ IF(TL0(1).GT.2.) THEN
+ DLL=299792.458D0*(DBLE(TL0(2))-DBLE(TL0(1)))/DBLE(TL0(1))
+ ELSE
+ DLL=1.D0
+ ENDIF
+ IF(DLL.LE.0.D0) DLL=1.D0
+ IF(COMANDO.EQ.COMANDI(51)) THEN
+ CALL FITS(NEWN,TL,T,GL,G,NEWN2,TLW,TW,GLW,GW,FS,INTERAC,PXL)
+ ELSE
+ CALL FITG(NEWN,TL,T,GL,G,NEWN2,TLW,TW,GLW,GW,FG,FT,INTERAC,PXL)
+ ENDIF
+C
+C ---------------------------------------
+C .......................... ALGEBRIC OPERATION ON SPECTRA (ALGEBRA)
+C ---------------------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(67)) THEN
+ NNN=NLAMT
+ CALL ALGEBRA(NMAX,MAXBUF,BUF,BUFC,NDIMBUF,NDIMBUFC,NEWN,NNN)
+C
+C ----------------------------
+C ................................. SET DEFAULT VALUE (DEFAULT)
+C ----------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(57)) THEN
+ CALL SETDEF
+C
+C ---------------------------
+C ................................. HELP (HELP)
+C ---------------------------
+ ELSE IF(COMANDO.EQ.COMANDI(18)) THEN
+ WRITE(N6,5300) COMANDI
+ 5300 FORMAT(' Allowed commands:'/(1X,A20))
+C
+C ---------------------------
+C ..................................... LAST CHOICE
+C ---------------------------
+ ELSE
+ 550 WRITE(N6,5500)
+ 5500 FORMAT(' !!!!ERROR: COMMAND NOT RECOGNIZED, type HELP for help')
+C
+ ENDIF
+C ================================= END IF on commands
+ GOTO 10
+C
+ 500 CONTINUE
+ WRITE(N6,5001)
+ 5001 FORMAT(' !!! INPUT ERROR - Give command again !')
+ GOTO 10
+ 100 CONTINUE
+ WRITE(N6,5000)
+ 5000 FORMAT(' !!!!ERROR IN FILE OPENING')
+ GOTO 10
+ END
+C
+ SUBROUTINE ADD(T,N)
+C ------------------------------------------------------------
+C Add a constant value to the spectrum
+C ------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION T(N)
+C
+ AMAX=-1.E38
+ AMIN=1.E38
+ AMED=0.0
+ DO 10 I=1,N
+ IF(T(I).LT.AMIN) AMIN=T(I)
+ IF(T(I).GT.AMAX) AMAX=T(I)
+ AMED=AMED+T(I)
+ 10 CONTINUE
+ AMED=AMED/N
+ 15 WRITE(N6,1000) AMAX,AMIN,AMED
+ 1000 FORMAT(' Max value:',E12.5,' min :',E12.5,' medium:',E12.5/
+ 1 ' Enter the value to add ')
+ READ(N5,*,ERR=550) ADDING
+ DO 20 I=1,N
+ 20 T(I)=T(I)+ADDING
+ WRITE(N6,3000) ADDING
+ 3000 FORMAT(' Added:',E12.5)
+ RETURN
+ 550 WRITE(N6,9000)
+ 9000 FORMAT(' READING ERROR ! ')
+ GOTO 15
+ END
+C
+ SUBROUTINE ALGEBRA(NMAX,MAXBUF,BUF,BUFC,NDIMBUF,NDIMBUFC,
+ 1 NEWN,NNN)
+C ------------------------------------------------------------
+C Algebric operations on spectra or on transforms
+C ------------------------------------------------------------
+ COMMON/TAPE/N5,N6,N7
+ DIMENSION BUF(NMAX,MAXBUF)
+ COMPLEX BUFC(NMAX,MAXBUF)
+ DIMENSION NDIMBUF(MAXBUF), NDIMBUFC(MAXBUF)
+C
+ CHARACTER*1 YN,CR
+ LOGICAL RFLAG/.TRUE./
+ COMPLEX COSTC
+C
+C Each buffer has its dimension in NDIMBUF, but here
+C simply NNN (for real) and NEWN (for complex) are used.
+C after the following simple tests:
+ NC=MAX(NEWN,NDIMBUFC(1),NDIMBUFC(2),NDIMBUFC(3))
+ IF(NC.GT.NMAX) NC=NMAX
+ NR=MAX(NNN,NDIMBUF(1),NDIMBUF(2))
+C
+ 10 CONTINUE ! input loop
+C
+ N1R=1
+ N2R=NR
+ N1C=1
+ N2C=NC
+ WRITE(N6,1000) N1R,N2R,N1C,N2C
+ 1000 FORMAT(' Algebra on real range:',2I5,' complex range:',2I5/
+ 1 ' Enter:'/
+ 2 ' R: real algebra flag'/
+ 2 ' C: complex algebra flag'/
+ 3 ' N: change range'/
+ 4 ' I: initialize a buffer'/
+ 4 ' A: add to a constant'/
+ 5 ' M: multiply by a constant'/
+ 5 ' =: fills a buffer'/
+ 6 ' +: sums spectra or transform'/
+ 7 ' -: subtracts spectra or transforms'/
+ 8 ' *: multiplies '/
+ 9 ' /: divides'/
+ A ' E,0: end and returns')
+C
+ IF(RFLAG) THEN
+ WRITE(N6,1100)
+ 1100 FORMAT(' NOW PERFORMING REAL ALGEBRA ON SPECTRA')
+ ELSE
+ WRITE(N6,1200)
+ 1200 FORMAT(' NOW PERFORMING COMPLEX ALGEBRA ON TRANSFORMS')
+ ENDIF
+C
+ READ(N5,2000) YN
+ 2000 FORMAT(A)
+ CALL UPCASE(YN)
+C
+C in all these options enlarge output buffer dimension if needed
+ IF(YN.EQ.'I'.OR.YN.EQ.'A'.OR.YN.EQ.'M'.OR.YN.EQ.'='.OR.
+ 1 YN.EQ.'+'.OR.YN.EQ.'-'.OR.YN.EQ.'*'.OR.YN.EQ.'/') THEN
+ IF(RFLAG)THEN
+ IF(NDIMBUF(NB1).LT.N2R) THEN
+ NDIMBUF(NB1)=N2R
+ WRITE(N6,3210) NB1,N2R
+ ENDIF
+ 3210 FORMAT(' Buffer:',I3,' extended to',I4,' values')
+ ELSE
+ IF(NDIMBUFC(NB1).LT.N2R) THEN
+ NDIMBUFC(NB1)=N2R
+ WRITE(N6,3210) NB1,N2R
+ ENDIF
+ ENDIF
+ ENDIF
+C
+ IF(YN.EQ.'R') THEN
+ RFLAG=.TRUE.
+ ELSE IF(YN.EQ.'C') THEN
+ RFLAG=.FALSE.
+ ELSE IF(YN.EQ.'E'.OR.YN.EQ.'0') THEN
+ RETURN
+C
+ ELSE IF(YN.EQ.'N') THEN
+ IF(RFLAG) THEN
+ WRITE(N6,3000) NR,NMAX,N1R,N2R
+ 3000 FORMAT(' Actual dim:',I5,' Max dim:',I5,
+ 1 ' Enter new limits, now:',2I5)
+ READ(N5,*,ERR=500) N1R,N2R
+ IF(N1R.LE.0) N1R=1
+ IF(N2R.GT.NMAX) N2R=NR
+ ELSE
+ WRITE(N6,3000) NC,NMAX,N1C,N2C
+ READ(N5,*,ERR=500) N1C,N2C
+ IF(N1C.LE.0) N1C=1
+ IF(N2C.GT.NMAX) N2C=NC
+ ENDIF
+C
+ ELSE IF(YN.EQ.'A') THEN
+ CALL ALGASK(2,NB1,NB2,NB3,1,COSTR,COSTC,RFLAG,MAXBUF)
+ IF(RFLAG) THEN
+ DO 20 I=N1R,N2R
+ 20 BUF(I,NB1)=BUF(I,NB2)+COSTR
+ WRITE(N6,2200) NB1,NB2,COSTR
+ 2200 FORMAT(' Now: buf(',I5,' )= buf(',I5,') + ',2G15.5)
+ ELSE
+ DO 22 I=N1C,N2C
+ 22 BUFC(I,NB1)=BUF(I,NB2)+COSTC
+ WRITE(N6,2200) NB1,NB2,COSTC
+ ENDIF
+C
+ ELSE IF(YN.EQ.'M') THEN
+ CALL ALGASK(2,NB1,NB2,NB3,1,COSTR,COSTC,RFLAG,MAXBUF)
+ IF(RFLAG) THEN
+ DO 24 I=N1R,N2R
+ 24 BUF(I,NB1)=BUF(I,NB2)*COSTR
+ WRITE(N6,2400) NB1,NB2,COSTR
+ 2400 FORMAT(' Now: buf(',I5,' )= buf(',I5,') * ',2G15.5)
+ ELSE
+ DO 26 I=N1C,N2C
+ 26 BUFC(I,NB1)=BUF(I,NB2)+COSTC
+ WRITE(N6,2400) NB1,NB2,COSTC
+ ENDIF
+C
+ ELSE IF(YN.EQ.'I') THEN
+ CALL ALGASK(1,NB1,NB2,NB3,1,COSTR,COSTC,RFLAG,MAXBUF)
+ IF(RFLAG) THEN
+ DO 30 I=N1R,N2R
+ 30 BUF(I,NB1)=COST
+ WRITE(N6,3200) NB1,COSTR
+ 3200 FORMAT(' Now: buf(',I5,' )= ',2G15.5)
+ ELSE
+ DO 32 I=N1C,N2C
+ 32 BUFC(I,NB1)=COSTC
+ WRITE(N6,3200) NB1,COSTC
+ ENDIF
+C
+ ELSE IF(YN.EQ.'=') THEN
+ CALL ALGASK(2,NB1,NB2,NB3,0,COSTR,COSTC,RFLAG,MAXBUF)
+ IF(RFLAG) THEN
+ DO 34 I=N1R,N2R
+ 34 BUF(I,NB1)=BUF(I,NB2)
+ ELSE
+ DO 36 I=N1C,N2C
+ 36 BUFC(I,NB1)=BUFC(I,NB2)
+ ENDIF
+ WRITE(N6,3400) NB1,NB2
+ 3400 FORMAT(' Now: buf(',I5,' )= buf(',I5,')')
+C
+ ELSE IF(YN.EQ.'+') THEN
+ CALL ALGASK(3,NB1,NB2,NB3,0,COSTR,COSTC,RFLAG,MAXBUF)
+ IF(RFLAG) THEN
+ DO 40 I=N1R,N2R
+ 40 BUF(I,NB1)=BUF(I,NB2)+BUF(I,NB3)
+ ELSE
+ DO 42 I=N1C,N2C
+ 42 BUFC(I,NB1)=BUFC(I,NB2)+BUFC(I,NB2)
+ ENDIF
+ WRITE(N6,4000) NB1,NB2,NB3
+ 4000 FORMAT(' Now: buf(',I5,' )= buf(',I5,') + buf(',I5,' )')
+C
+ ELSE IF(YN.EQ.'*') THEN
+ CALL ALGASK(3,NB1,NB2,NB3,0,COSTR,COSTC,RFLAG,MAXBUF)
+ IF(RFLAG) THEN
+ DO 44 I=N1R,N2R
+ 44 BUF(I,NB1)=BUF(I,NB2)*BUF(I,NB3)
+ ELSE
+ DO 46 I=N1C,N2C
+ 46 BUFC(I,NB1)=BUFC(I,NB2)*BUFC(I,NB2)
+ ENDIF
+ WRITE(N6,4400) NB1,NB2,NB3
+ 4400 FORMAT(' Now: buf(',I5,' )= buf(',I5,') * buf(',I5,' )')
+C
+ ELSE IF(YN.EQ.'-') THEN
+ CALL ALGASK(3,NB1,NB2,NB3,0,COSTR,COSTC,RFLAG,MAXBUF)
+ IF(RFLAG) THEN
+ DO 60 I=N1R,N2R
+ 60 BUF(I,NB1)=BUF(I,NB2)-BUF(I,NB3)
+ ELSE
+ DO 62 I=N1C,N2C
+ 62 BUFC(I,NB1)=BUFC(I,NB2)-BUFC(I,NB3)
+ ENDIF
+ WRITE(N6,6000) NB1,NB2,NB3
+ 6000 FORMAT(' Now: buf(',I5,' )= buf(',I5,') - buf(',I5,' )')
+C
+ ELSE IF(YN.EQ.'/') THEN
+ CALL ALGASK(3,NB1,NB2,NB3,0,COSTR,COSTC,RFLAG,MAXBUF)
+ IF(RFLAG) THEN
+ DO 64 I=N1R,N2R
+ IF (BUF(I,NB3).NE.0.0) THEN
+ BUF(I,NB1)=BUF(I,NB2)/BUF(I,NB3)
+ ELSE
+ BUF(I,NB1)=0.0
+ ENDIF
+ 64 CONTINUE
+ ELSE
+ DO 66 I=N1C,N2C
+ IF(BUFC(I,NB3).NE.0.0) THEN
+ BUFC(I,NB1)=BUFC(I,NB2)/BUFC(I,NB3)
+ ELSE
+ BUFC(I,NB1)=0.0
+ ENDIF
+ 66 CONTINUE
+ ENDIF
+ WRITE(N6,6400) NB1,NB2,NB3
+ 6400 FORMAT(' Now: buf(',I5,' )= buf(',I5,') / buf(',I5,' )')
+C
+ ELSE
+ WRITE(N6,5000) YN
+ 5000 FORMAT(' ERROR! UNRECOGNIZED COMMAND:',A2,' reenter!')
+ ENDIF
+C
+ GOTO 10
+ 500 WRITE(N6,5500)
+ 5500 FORMAT(' ERROR ! ERROR ! ERROR !')
+ GOTO 10
+ END
+C
+ SUBROUTINE ALGASK(K1,NB1,NB2,NB3,K2,COSTR,COSTC,RFLAG,MAXBUF)
+C ----------------------------------------------------------
+C Used by routine Algebra to ask for constants and buf. numbers
+C ----------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ COMPLEX COSTC
+ LOGICAL RFLAG
+C
+ 10 CONTINUE
+ WRITE(N6,1000) MAXBUF
+ 1000 FORMAT(' Buffers are: 1=template , 2=galaxy, 3=division or corr',
+ 1 '4=anti, max:',I5/
+ 2 ' enter n1,n2,n3 in => buf(n1)= buf(n2) +*/- buf(n3)')
+ IF(K1.EQ.1) THEN
+ READ(N5,*,ERR=500) NB1
+ IF(NB1.GT.MAXBUF.OR.NB1.LE.0) GO TO 500
+ ELSE IF(K1.EQ.2) THEN
+ READ(N5,*,ERR=500) NB1,NB2
+ IF(NB1.GT.MAXBUF.OR.NB1.LE.0) GO TO 500
+ IF(NB2.GT.MAXBUF.OR.NB2.LE.0) GO TO 500
+ ELSE
+ READ(N5,*,ERR=500) NB1,NB2,NB3
+ IF(NB1.GT.MAXBUF.OR.NB1.LE.0) GO TO 500
+ IF(NB2.GT.MAXBUF.OR.NB2.LE.0) GO TO 500
+ IF(NB3.GT.MAXBUF.OR.NB3.LE.0) GO TO 500
+ ENDIF
+C
+ IF(K2.LE.0) RETURN
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter constant (real or complex)')
+ IF(RFLAG) THEN
+ READ(N5,*,ERR=500)COSTR
+ ELSE
+ READ(N5,*,ERR=500)COSTC
+ ENDIF
+C
+ RETURN
+ 500 WRITE(N6,5000)
+5000 FORMAT(' ERROR ! ERROR ! reenter input !')
+ GOTO 10
+ END
+C
+ SUBROUTINE BROAD(N5,N6,N7,N,NMAX,B,DLL1)
+C -----------------------------------------------------
+C Multiplies B(N), the complex fourier transform of a spectrum,
+C By an input given redshifted broadening function:
+C g*exp( 2 pi i s/n v/c) exp(-1/2 ( 2 pi s/n s/c)**2)
+C g,s,v are asked to the user.
+C N5= input unit, N6=output unit, N7= log unit (unused)
+C NMAX= real dimension of B
+C -------------------------------------------------------
+ PARAMETER C=299792.458D0
+ PARAMETER DUEPI=6.283185307D0 ! C and DUEPI may be real*4 ?
+ REAL*8 DLL1
+ COMPLEX B(NMAX) ,COMPLESSO
+ LOGICAL GOODSCALE
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+C
+ GOODSCALE=.TRUE. ! need lambda scale to convert from
+ IF(DLL1.LE.0.0) THEN ! inner "pixel" unit to km/sec
+ WRITE(N6,900) DLL1
+ 900 FORMAT(' WARNING, lambda scale not available, lambda2/lambda1=',
+ 1 G15.8/' Give sigma and v in PIXEL')
+ GOODSCALE=.FALSE.
+ ELSE
+ WRITE(N6,910) DLL1,DLL
+ 910 FORMAT(' l2/l1=',G15.8,' km/sec/pixel=',G15.8)
+ ENDIF
+C
+ NERR=0 ! input error counter
+ 10 CONTINUE ! input error loop
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter sigma, v (km/sec) , gamma')
+ READ(N5,*,ERR=100) SS,VV,G
+ GOTO 150
+ 100 NERR=NERR+1
+ WRITE(N6,1100) NERR
+ 1100 FORMAT(1X,I2,' INPUT ERROR ! Try again ')
+ IF(NERR.GT.3) GOTO 10
+ WRITE(N6,1200)
+ 1200 FORMAT(' ERROR AGAIN ! Command aborted ')
+ RETURN
+ 150 CONTINUE
+C convert to pixel
+ IF(GOODSCALE) THEN ! convert from km/sec to "pixel" units
+ S=SS/DLL
+ IF(VV.EQ.0.) THEN
+ V=0.
+ ELSE
+ V= LOG(VV/C+1.D0)/LOG(DLL1)
+ ENDIF
+ ELSE ! NO CONVERSION "pixel" units are assumed
+ S=SS
+ V=VV
+ ENDIF
+ WRITE(N6,1300) S,V,G
+ 1300 FORMAT(' In "pixel" units: sigma=',G15.7,' v=',G15.7,
+ 1 ' gamma=',G15.5)
+C
+C The values of the discrete transform are ordered in this way:
+C B(1):freq 0 , B(2):freq 1 ...b(n):freq n-1=freq (-1)
+C
+ N2=N/2
+ DUEPIS=(DUEPI*S)/N
+ DUEPIV=(DUEPI*V)/N
+ ESP=-0.5*(DUEPIS*DUEPIS)
+C
+ B(1)=B(1)*CMPLX(G,0.0)
+C
+ DO 20 I=2,N2
+ FREQ=I-1
+ FACT=G*EXP(ESP*(FREQ*FREQ))
+ ARG=DUEPIV*FREQ
+ REALE=COS(ARG)*FACT
+ AIMA=SIN(ARG)*FACT
+ COMPLESSO=CMPLX(REALE,AIMA)
+ B(I)=B(I)*COMPLESSO
+C when freq=>-freq ===> real=>real,imm=>-imm ( complex conj.)
+ B(N-I+2)=B(N-I+2)*CONJG(COMPLESSO)
+ 20 CONTINUE
+C
+ FREQ=N2
+ FACT=G*EXP(ESP*(FREQ*FREQ))
+ ARG=DUEPIV*FREQ
+ B(N2+1)=FACT*B(N2+1)*CMPLX(COS(ARG),SIN(ARG))
+C
+ RETURN
+ END
+C
+ SUBROUTINE BRUTEFT(TL0,T0,TL,DTL,N,FT,NNUOVO,NMAX)
+C ------------------------------------------------------
+C Brute force Fourier Transform. This is used as a trick
+C to interpolate data to equilog interval, without
+C altering the fourier spectrum.
+C ------------------------------------------------------
+ DIMENSION TL0(N),T0(N),TL(N),DTL(N)
+ COMPLEX FT(NMAX)
+ REAL*8 PI,REALE,AIMM,ELLE,DLN,DLNUOVO,ESSE
+ DATA PI/3.141592653589793/
+C
+ IF(NNUOVO.LE.0) THEN
+ WRITE(N6,1000) NNUOVO,N
+ 1000 FORMAT(' Requested number of points:',I5,' Set to:',I6)
+ NNUOVO=N
+ ENDIF
+C
+ CALL EVEN(NNUOVO,NEVEN,NMAX)
+ NNUOVO=NEVEN
+ IF(NNUOVO.GT.NMAX) THEN
+ NNUOVO=512
+ WRITE(N6,2000) NNUOVO
+ 2000 FORMAT(' Too many requested points , increase MAXPT',
+ 1 ' trasf. limited to:',I5)
+ ENDIF
+C
+C Log interval
+ DL=LOG10(DBLE(TL0(N))/DBLE(TL0(1)))/(N-1)
+ DLN=DL*N
+ DLNUOVO=DL*NNUOVO
+C
+ WRITE(N6,3000) N,NNUOVO,DL
+ 3000 FORMAT(' Transforming: points:',I6,' freq:',I6,' Dlog:',G15.5)
+C Log lambda scale
+ TL(1)=0.0
+ DO 10 I=1,N
+ TL(I)=LOG10(DBLE(TL0(I))/DBLE(TL0(1)))
+ 10 CONTINUE
+C
+C T0*d(LOG TL0) for each T0
+ DTL(1)=T0(1)*(TL(2)-TL(1))
+ DTL(N)=T0(N)*(TL(N)-TL(N-1))
+ DO 20 I=2,N-1
+ DTL(I)=T0(I)*0.5*(TL(I+1)-TL(I-1))
+ 20 CONTINUE
+C
+C Integration, for each freq. value
+ DO 30 I=1,NNUOVO ! loops on fourier component
+ ESSE=DBLE((I-1)*N)/DBLE(NNUOVO)
+ ARG=(2.D0*PI)*ESSE/DLN
+ REALE=0.0D0
+ AIMM=0.0D0
+ DO 40 J=1,N ! sums over input T0 values
+ ELLE=TL(J)
+ REALE=REALE+DTL(J)*COS(ARG*ELLE)
+ AIMM=AIMM +DTL(J)*SIN(ARG*ELLE)
+ 40 CONTINUE
+ FT(I)=CMPLX(REALE,AIMM)/DL
+C ########################## per prove
+C write(99,9999) i,TL(i),dtl(i),arg,reale/DL,aimm/DL
+C write(6,9999) i,TL(i),dtl(i),arg,reale/DL,aimm/DL
+C9999 format(1x,I3,
+C 1 ' tl:',G12.5,'dtl:',g12.5,'arg:',g12.5' ft:',2g12.5)
+C ########################## per prove
+ 30 CONTINUE
+C
+ RETURN
+ END
+C
+ SUBROUTINE CIRCON(T0,NT,SL0,S0,NS,CL,C,FG,ANTI,NMAX,K)
+C ------------------------------------------------------
+C Convolution by using fourier transform
+C T0 is the response function, S0 the data, C the output
+C If K=1 convolution, if K=-1 deconvolution
+C ------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION T0(NT),SL0(NS),S0(NS)
+ DIMENSION CL(NMAX),C(NMAX)
+ DIMENSION ANTI(NMAX)
+ COMPLEX FG(NMAX)
+C
+ IF(NT.GT.NS) WRITE(N6,1000) NT
+ 1000 FORMAT(' !!!! ERROR',
+ 1 ': Template cannot have here more values than galaxy:',2I6)
+C
+C chek if ns is an integer power of two
+C otherwise the arrays are extended with zeroes
+C
+ KS=2
+ 30 CONTINUE
+ IF(NS.EQ.KS) GOTO 400
+ IF(NS.LT.KS) GOTO 300
+ KS=KS*2
+ GO TO 30
+ 300 CONTINUE
+C
+ WRITE(N6,2000)NS,KS
+ 2000 FORMAT(' The original dimension of ',I4,
+ 1 ' has been extended to ',I4)
+ IF(KS.GT.NMAX) WRITE(N6,3000) NMAX
+ 3000 FORMAT(' ERROR! Increase the maximum dimension, which is:',I5)
+C
+C Increasing S0 and SL0, to obtain NS values.
+C Log lambda scale is supposed, in adding missing lambda values
+ DELTL=SL0(NS)/SL0(NS-1)
+ DO 40 I=NS+1,KS
+ S0(I)=0.0
+ SL0(I)=SL0(I-1)*DELTL
+ 40 CONTINUE
+C
+C The response function is stored in CL, in wrap around order,
+C assuming that the zero is in T0(NT/2+1)
+C
+ 400 NS=KS
+C Zero in CL(1), positive values into CL(2,3 ..NT/2+1)
+ N1=NT/2
+ DO 10 I=N1+1,NT
+ CL(I-N1)=T0(I)
+ 10 CONTINUE
+C
+C Negative values into CL(KS,KS-1 ...KS-NT/2+1)
+ DO 15 I=N1,1,-1
+ CL(KS+I-N1)=T0(I)
+ 15 CONTINUE
+C
+C Other CL values are filled with zeroes
+ DO 17 I=NT-N1+1,KS-N1
+ CL(I)=0.0
+ 17 CONTINUE
+C
+ CALL CONVLV(S0,KS,CL,K,ANTI,FG,NMAX)
+C
+ DO 20 I=1,KS
+ C(I)=ANTI(I)
+ CL(I)=SL0(I)
+ 20 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE CONTIN(AL0,A0,A,PESI,NI,K,K1,PXL,AA)
+C ------------------------------------------------------
+C This routine subtract the continuum fron the spectrum.
+C A polynomial fit in used to represent the continuum
+C The maximum order for the polinomium is 20
+C Only the non zero part of the spectrum is treated.
+C
+C K is the polinomium order (if <=0 interactive usage )
+C
+C K1=1 => divides by the continuum, otherwise subtracts
+C A0,AL0: input spectrum - In fitting PXL is used instead of
+C AL0, to avoid too big numbers (and overflow)
+C AA: modified spectrum
+C A: continuum
+C PESI: weigths for continuum calculation
+C ------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ EXTERNAL POLY
+ PARAMETER (NMAX=20)
+ DIMENSION AL0(NI),A0(NI),A(NI),PXL(NI),AA(NI),PESI(NI)
+ DIMENSION DUM(NMAX,NMAX),DUM1(NMAX),DUM2(NMAX)
+ DIMENSION COEFF(NMAX)
+ CHARACTER*1 YN
+ CHARACTER*20 NOME
+ CHARACTER*20 NOME1/'CONTINUUM '/
+ CHARACTER*20 NOME2/'CONT-SUB '/
+ CHARACTER*20 NOME3/'CONT-NORM '/
+C
+ DO 1 I=1,NI
+ PESI(I)=1.
+ 1 AA(I)=A0(I)
+C
+C Looks for N1,N2 the first and last non-zero values
+C
+ N1=1
+ N2=NI
+ DO 5 I=1,NI
+ IF(AA(I).NE.0.0) GOTO 105
+ 5 CONTINUE
+C All data are zero, no warning and goes on computing.
+ GOTO 205
+ 105 N1=I
+ 205 CONTINUE
+ DO 7 I=NI,1,-1
+ IF(AA(I).NE.0.0) GO TO 107
+ 7 CONTINUE
+C All data are zero, no warning and goes on computing.
+ GOTO 207
+ 107 N2=I
+ 207 CONTINUE
+C Computes NNI, the number of non-zero values
+ NNI=N2-N1+1
+C The following (null) part of the spectrum is used only for output
+ DO 8 I=1,N1-1
+ 8 A(I)=0.0
+ DO 9 I=N2+1,NI
+ 9 A(I)=0.0
+C
+C
+ NMAX1=NMAX-1
+C .................................... fit loop
+ 10 CONTINUE
+C
+ IF(K.GT.0.AND.K.LE.NMAX1) THEN ! test pol. order, if bad reads it
+ MFIT=K
+ ELSE
+ WRITE(N6,1000)NMAX1,NMAX1
+ 1000 FORMAT(' Enter the polinomium order (<=',I5,
+ 1 '),-1=>QUIT, >',I5,'=>interactive usage)')
+ READ(N5,*,ERR=550) MFIT
+ ENDIF
+C
+ 110 MFIT=MFIT+1 ! MFIT is the number of pol. coefficients=1+ pol. order
+C
+ IF (MFIT.GT.NMAX) THEN ! shift to interactive usage
+ WRITE (N6,5000) NMAX1
+ 5000 FORMAT(1X,I5,' Is the maximun value')
+ WRITE(N6,1001)
+ 1001 FORMAT(' Now interactive usage.')
+ K=0
+ GOTO 10
+ ELSE IF(MFIT.LE.0) THEN ! quit
+ GO TO 500
+ ENDIF
+C
+ WRITE(N6,1500)
+ 1500 FORMAT(' Polinomial fitting the spectum ..... ')
+C Pxl is used in fit instead of AL0 to avoid overflow
+ CALL FITTA1(PXL(N1),AA(N1),PESI(N1),NNI,COEFF,MFIT,
+ 1 DUM,DUM1,DUM2,CHISQ,POLY)
+ WRITE(N6,2000) CHISQ,(COEFF(J),J=1,MFIT)
+ 2000 FORMAT(' Chisquare=',E12.5,' Coefficients: C0+C1*x+C2*x**2+..'/
+ 1 5(1X,E12.5))
+C
+C Computes the continuum
+ DO 20 I=N1,N2
+ A(I)=COEFF(1)
+ DO 20 J=2,MFIT
+ A(I)=A(I)+COEFF(J)*PXL(I)**(J-1)
+ 20 CONTINUE
+C
+ IF(K.LE.0) GOTO 350 ! for interactive way subtracts only on reqest
+ 200 IF(K1.NE.1) THEN
+C Subtracts the continuum
+ WRITE(N6,2500)
+ 2500 FORMAT(' Subtracting continuum ...')
+ DO 30 I=N1,N2
+ 30 AA(I)=AA(I)-A(I)
+ ELSE
+C Divides by the continuum
+ WRITE(N6,2600)
+ 2600 FORMAT(' Dividing by continuum ...')
+ DO 35 I=N1,N2
+ IF(A(I).NE.0.0) AA(I)=AA(I)/A(I)
+ 35 CONTINUE
+ ENDIF
+ 350 CONTINUE
+C
+C ................................... begin interactive part
+ IF(K.LE.0) THEN
+ 37 CONTINUE
+ WRITE(N6,3000) ! Plotting the continuum
+ 3000 FORMAT(' - : subtract, A :plot continuum, B: print cont.')
+ WRITE(N6,3100)
+ 3100 FORMAT(' P: plot cont.subtracted, S:print cont-sub,'/
+ 1 ' C: compute contin., E:end, Q:quit, R:reset'/
+ 2 ' T:type, F: spectrum zone=continuum,',
+ 3 ' Z: set to 0/1'/' W:weights, U: plot weights')
+ READ(N5,3001,ERR=550) YN
+ 3001 FORMAT(A)
+ IF(YN.EQ.'A'.OR.YN.EQ.'a') THEN
+ XMAX=0.0
+ XMIN=0.0 ! ===========> PLOT CONTINUUM
+ YMAX=0.0
+ YMIN=0.0
+ KPLOT=2
+ CALL PLOTTA(NI,PXL,AL0,A0,A,XMAX,XMIN,YMAX,YMIN,NOME1,KPLOT)
+C ! Printing the continuum
+ ELSE IF(YN.EQ.'B'.OR.YN.EQ.'b') THEN
+ CALL PRINTA(AL0,A,NI)
+ ELSE IF(YN.EQ.'P'.OR.YN.EQ.'p') THEN
+ XMAX=0.0
+ XMIN=00.
+ YMAX=0.0 ! ============> PLOT CONTINUUM subtracted
+ YMIN=0.0
+ KPLOT=2
+ IF(K1.EQ.1) THEN
+ NOME=NOME3
+ ELSE
+ NOME=NOME2
+ ENDIF
+ CALL PLOTTA(NI,PXL,AL0,A0,AA,XMAX,XMIN,YMAX,YMIN,NOME,KPLOT)
+ ELSE IF(YN.EQ.'S'.OR.YN.EQ.'s') THEN
+ CALL PRINTA(AL0,A,NI) ! ======> PRINT SPECTRUM
+ ELSE IF(YN.EQ.'C'.OR.YN.EQ.'c') THEN
+ GOTO 10 ! ======> FIT AGAIN
+ ELSE IF(YN.EQ.'-') THEN
+ GOTO 200 ! ======> SUBTRACT CONTINUUM
+ ELSE IF(YN.EQ.'Q'.OR.YN.EQ.'q') THEN
+ RETURN ! ======> QUIT
+ ELSE IF(YN.EQ.'E'.OR.YN.EQ.'e') THEN
+ GOTO 499 ! ======> SAVE AND RETURN
+ ELSE IF(YN.EQ.'R'.OR.YN.EQ.'r') THEN
+ WRITE(N6,3500)
+ 3500 FORMAT(' Resetting spectrum to its initial value ...')
+ DO 39 J=1,NI
+ 39 AA(J)=A0(J) ! ======> RESET SPECTRUN
+ ELSE IF(YN.EQ.'T'.OR.YN.EQ.'t') THEN
+ WRITE(N6,4000) NI ! ======> TYPE
+ 4000 FORMAT(' Enter first and last value to type (max:',I5,' )')
+ READ(N5,*,ERR=37) J1,J2
+ IF(J1.GT.J2.OR.J1.LE.0.OR.J2.GT.NI) GOTO 37
+ WRITE(N6,4100)
+ 4100 FORMAT(' pixel ',3X,'lambda',5X,'spectrum',6X,'now',
+ 1 6X,'continuum',6X,' weight')
+ WRITE(N6,4200) (J,AL0(J),A0(J),AA(J),A(J),PESI(J),J=J1,J2)
+ 4200 FORMAT(1X,I6,5G12.3)
+ ELSE IF(YN.EQ.'Z'.OR.YN.EQ.'z') THEN
+ WRITE(N6,4001) NI ! =======> CHANGE TO 0/1
+ 4001 FORMAT(' Enter first and last value to set 0(max:',I5,' )')
+ READ(N5,*,ERR=37) J1,J2
+ IF(J1.GT.J2.OR.J1.LE.0.OR.J2.GT.NI) THEN
+ WRITE(N6,4011) J1,J2
+ 4011 FORMAT(' ERROR! Inconsistent values given:',2I5)
+ GOTO 37
+ ENDIF
+ DO 41 J=J1,J2
+ IF(K1.NE.1) THEN
+ AA(J)=0.0
+ ELSE
+ AA(J)=1.
+ ENDIF
+ 41 CONTINUE
+ ELSE IF(YN.EQ.'F'.OR.YN.EQ.'f') THEN
+ WRITE(N6,4001) NI ! =======> CHANGE TO CONTINUUM
+ 4002 FORMAT(' Enter first and last value to set (max:',I5,' )')
+ READ(N5,*,ERR=37) J1,J2
+ IF(J1.GT.J2.OR.J1.LE.0.OR.J2.GT.NI) THEN
+ WRITE(N6,4011) J1,J2
+ GOTO 37
+ ENDIF
+ DO 43 J=J1,J2
+ 43 AA(J)=A(J)
+ ELSE IF(YN.EQ.'W'.OR.YN.EQ.'w') THEN ! ========> WEIGHTS FOR CONT.COMP.
+ 44 WRITE(N6,4001) NI
+ READ(N5,*,ERR=37) J1,J2
+ IF(J1.GT.J2.OR.J1.LE.0.OR.J2.GT.NI) THEN
+ WRITE(N6,4011) J1,J2
+ GOTO 37
+ ENDIF
+ WRITE(N6,4005) J1,J2
+ 4005 FORMAT(' enter weight for data from:',I5,' to ',I5)
+ READ(N5,*,ERR=37) DDUM
+ DO 45 J=J1,J2
+ 45 PESI(J)=DDUM
+ GOTO 44
+ ELSE IF(YN.EQ.'U'.OR.YN.EQ.'u') THEN
+ XMAX=0.0
+ XMIN=0.0 ! ===========> PLOT WEIGHTS + SPECTRUM
+ YMAX=0.0
+ YMIN=0.0
+ KPLOT=2
+ CALL PLOTTA(NI,PXL,AL0,PESI,A0,XMAX,XMIN,YMAX,YMIN,
+ 1 NOME1,KPLOT)
+ ELSE
+ GOTO 550 ! ==============> UNRECOGNIZED COMMAND
+ ENDIF
+ GOTO 37 ! To terminal inquire again
+ ENDIF
+C ............................ end of interactive part
+ 499 DO 40 I=N1,N2
+ 40 A0(I)=AA(I)
+C
+ 500 RETURN
+ 550 WRITE(N6,9000)
+ 9000 FORMAT(' INPUT ERROR! ')
+ GOTO 37
+ END
+C
+ SUBROUTINE CONTINP(TL0,T0,T,NT,K,K1,K2)
+C ------------------------------------------------------
+C Piecewise continuum subtraction
+C K is the polinomium order to represent the continuum
+C K1 is the number of segments in which the data are divided
+C to be represented with a polinomium
+C If (K.OR.K1)=<0 interactive subtraction in each segmant
+C and ask for plot in each segment.
+C K2 is the fraction of data of near segments used in polynomial
+C fit for a segment, to reduce discontinuity at segment boundaries
+C Moreover, at user choice, the fit of a segment can be
+C merged with the fit of the preceeding segment to smooth
+C the boundary discontinuity (this is the default for non
+C interactive usage of this routine)
+C ------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL0(NT),T0(NT),T(NT)
+ EXTERNAL POLY
+ PARAMETER (NMAX=20)
+ DIMENSION DUM(NMAX,NMAX),DUM1(NMAX),DUM2(NMAX)
+ DIMENSION COEFF(NMAX)
+ CHARACTER*1 YN
+C
+C NEACH=0 if no count has been done
+ NEACH=0
+C
+ IF(K1.GE.0.AND.K1.LT.NT) THEN
+ NSEG=K1
+ ELSE
+C
+ 10 CONTINUE
+ WRITE(N6,1000)NT
+ 1000 FORMAT(' Data are dimensioned:',I5/
+ 1 ' Enter the number of intervals (=0 = Exit; <0=quit)')
+ READ(N5,*) NSEG
+C Exit and Quit :
+ IF(NSEG.EQ.0.AND.NEACH.GT.0) GOTO 500
+ IF(NSEG.LE.0) RETURN
+C
+C Ending the if on K1 value
+ ENDIF
+C Cheeks and asks for the polinomium order
+ 15 CONTINUE
+C IF(K.GT.0.AND.K.LT.NMAX) THEN
+ IF(K.GT.0.AND.K.LT.5) THEN ! frozen to 5 to avoid overflow
+ MFIT=K ! see contin for a corrective action
+ ELSE
+C
+ 17 NMAX1=NMAX-1
+ WRITE(N6,1100)NMAX1
+C 1100 FORMAT(' Enter the polinomium order (<=',I5,')')
+ 1100 FORMAT(' Enter the polinomium order (<= 4) ',I5)
+ READ(N5,*) MFIT
+ IF(MFIT.LT.0.OR.MFIT.GE.NMAX) GOTO 17
+ ENDIF
+C
+C MFIT is the number of pol. coefficients=1+ pol. order
+ MFIT=MFIT+1
+C
+C Computes the dimension of each segment
+C
+ NEACH=NT/NSEG
+ WRITE(N6,1200) NSEG,NEACH
+ 1200 FORMAT(' Data divided into',I4,' segments of ',I5,' points.')
+ NLAST=NEACH+(NT-NEACH*NSEG)
+ IF(NLAST.NE.NEACH) WRITE(N6,1300) NLAST
+ 1300 FORMAT(' Last segment has ',I5,' points.')
+ IF(NEACH.LT.MFIT+3) THEN
+ WRITE(N6,1350)
+ 1350 FORMAT(' Inconsistent data! Not enought point in each segment',
+ 1 'for the polinomium order')
+C Turns to interactive usage:
+ K=0
+ K1=0
+ GOTO 10
+ ENDIF
+C
+ IF(K2.GE.0.AND.K2.LE.100) THEN
+ NFRAC=K2
+ ELSE
+ 19 WRITE(N6,1353)
+ 1353 FORMAT(' Enter the overlap fraction for near segments')
+ READ(N5,*) NFRAC
+ IF(NFRAC.LT.0.OR.NFRAC.GT.100) THEN
+ WRITE(N6,1355)
+ 1355 FORMAT(' YOU MUST GIVE A NUMBER BETWEEN 0 AND 100 !')
+ GOTO 19
+ ENDIF
+ ENDIF
+ NFRAC=NEACH*NFRAC/100.
+C
+C Asks for merging of a fit with the fit of the preceeding segment
+C For non-interactive usage
+ IF(NSEG.NE.K1.OR.MFIT.NE.K+1) THEN
+ WRITE(N6,1360)
+ 1360 FORMAT(' Do you want to smooth boudary discontinuity ?'
+ 1 '(Y/N)')
+ READ(N5,1361) YN
+ 1361 FORMAT(A)
+ ELSE
+ YN='Y'
+ ENDIF
+C
+C .......... The following loop is on segmants NSEG
+C
+ DO 30 NSTEP=1,NSEG
+C N1,N2: bounds for each segment
+C N11,N22 : bounds including overlap fraction
+ N1=(NSTEP-1)*NEACH+1
+ IF(NSTEP.EQ.1) THEN
+ N=NEACH
+ N2=N1+N-1
+ NN=N+NFRAC
+ N11=N1
+C N22=N2+NFRAC
+ ELSE IF(NSTEP.EQ.NSEG) THEN
+ N=NLAST
+ N2=N1+N-1
+ NN=N+NFRAC
+ N11=N1-NFRAC
+C N22=N2
+ ELSE
+ N=NEACH
+ N2=N1+N-1
+ NN=N+NFRAC+NFRAC
+ N11=N1-NFRAC
+C N22=N2+NFRAC
+ ENDIF
+C Polinomyal fit for the segment
+ CALL FITTA(TL0(N11),T0(N11),NN,COEFF,MFIT,
+ 1 DUM,DUM1,DUM2,CHISQ,POLY)
+ WRITE(N6,2000) CHISQ,(COEFF(J),J=1,MFIT)
+ 2000 FORMAT(' Chisquare=',E12.5,' Coefficients: C0+C1*x+C2*x**2+..'/
+ 1 5(1X,E12.5))
+C
+C Computes the continuum
+ DO 40 I=N1,N2
+ T(I)=COEFF(1)
+ DO 40 J=2,MFIT
+ T(I)=T(I)+COEFF(J)*TL0(I)**(J-1)
+ 40 CONTINUE
+C
+C Smoothing of boudary between segments.
+C The fit for this segmen is summed to the fit of the
+C previus segment with weights proportional to the
+C boundary distance
+ IF((YN.EQ.'Y'.OR.YN.EQ.'y').AND.NSTEP.NE.1) THEN
+ ANORM=1./(N1-N11)
+ DO 44 I=N11+1,N1-1
+ TT=COEFF(1)
+ DO 45 J=2,MFIT
+ 45 TT=TT+COEFF(J)*TL0(I)**(J-1)
+ T(I)=ANORM*(TT*(I-N11)+T(I)*(N1-I))
+ 44 CONTINUE
+ ENDIF
+C
+ 30 CONTINUE
+C ................. End of the loop on segments
+C
+C For non-interactive usage
+ IF(NSEG.NE.K1.OR.MFIT.NE.K+1) THEN
+ WRITE(N6,3000)
+ 3000 FORMAT(' Do you want a printing for the continuum?'
+ 1 '(Y/N)')
+ READ(N5,3001) YN
+ 3001 FORMAT(A)
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') CALL PRINTA(TL0,T,NT)
+ ENDIF
+C
+C Subtracts the continuum
+ DO 50 I=1,NT
+ 50 T(I)=T0(I)-T(I)
+C
+ IF(NSEG.NE.K1.OR.MFIT.NE.K+1) THEN
+ WRITE(N6,3100)
+ 3100 FORMAT(' Do you want a continuum-subtracted printing ?'
+ 1 '(Y/N)')
+ READ(N5,3001) YN
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') CALL PRINTA(TL0,T,NT)
+ ENDIF
+C
+ IF(NSEG.EQ.K1.AND.MFIT.EQ.K+1) THEN
+ 500 DO 60 I=1,NT
+ 60 T0(I)=T(I)
+ RETURN
+ ENDIF
+ GOTO 10
+ END
+C
+C
+ SUBROUTINE CORRELA(FT,FS,FG,N)
+C ------------------------------------------------------
+C Multiplies two fourier transform obtaining the
+C transform of their correlation function.
+C ------------------------------------------------------
+ COMPLEX FT(N),FS(N),FG(N)
+ DO 10 I=1,N
+ 10 FG(I)=FT(I)*CONJG(FS(I))
+ RETURN
+ END
+C
+ SUBROUTINE CORRTG(TL,T,S,CL,C,N)
+C --------------------------------------------------------
+C Circular Cross Correlation
+C --------------------------------------------------------
+ DIMENSION TL(N),T(N),S(N),CL(N),C(N)
+C
+ DO 10 I=0,N-1
+ C(I+1)=0.0
+ DO 20 J=1,N
+ K=MOD(J+I,N)
+ C(I+1)=C(I+1)+T(J)*S(K)
+ 20 CONTINUE
+ 10 CONTINUE
+C CL should be the doppler shift in km/sec
+C delta lambda/lambda=z => v=c*z=c*delta lamb/lamb
+ DO 30 I=1,N
+ CL(I)=(TL(I)-TL(1))/TL(I)*299792.458
+ 30 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE COSBELL(AL,A,N,F,K)
+C ------------------------------------------------
+C Applies a cosine bell function window to A(AL)
+C F is the fraction (%) of data which are modified
+C F refers to the non zero part of the data stream
+C if K<=0 doesn't look for first and last non 0 points
+C ------------------------------------------------
+ DIMENSION AL(N),A(N)
+ REAL*8 ARG,PI,DENOM,AF
+ DATA PI/3.141592653589793/
+C
+C Looks for N1,N2 the first and last non-zero values
+C
+ N1=1
+ N2=N
+ IF( K.LE.0) GOTO 300 ! in this case non lookka i NE.0
+ DO 5 I=1,N
+ IF(A(I).NE.0.0) GOTO 105
+ 5 CONTINUE
+C All data are zero, no warning and goes on computing.
+ GOTO 205
+ 105 N1=I
+ 205 CONTINUE
+ DO 7 I=N,1,-1
+ IF(A(I).NE.0.0) GO TO 107
+ 7 CONTINUE
+C All data are zero, no warning and goes on computing.
+ GOTO 207
+ 107 N2=I
+ 207 CONTINUE
+C
+ 300 DSTEP=AL(2)-AL(1)
+ NF=F/100.*(N2-N1-1) ! buono per n pari?
+ AF=F/100.D0*(AL(N2)-AL(N1)-DSTEP)
+ DENOM=PI/AF
+C
+ DO 10 I=N1,N1+NF
+ ARG=(AL(I)-AL(N1))*DENOM
+ 10 A(I)=A(I)*0.5D0*(1.D0-COS(ARG))
+ DO 20 I=N2-NF,N2
+ ARG=(AL(N2)-AL(I))*DENOM
+ 20 A(I)=A(I)*0.5D0*(1.D0-COS(ARG))
+C
+ RETURN
+ END
+C
+ SUBROUTINE CRXCOR(TL,T,G,CL,C,N,PESI,YC,PXL,FT,ANTI,NEWN,NMX)
+C -----------------------------------------------------------
+C Properly normalized cross correlation
+C T and G are supposed to share the same dimension and lambda
+C Work.array: pesi=weights for fita (YC=computed Y by fita)
+C YC= used also by filter (to plot)
+C PXL=0,1,2,3 ... N-1 ( used by fita )
+C FT,ANTI: work array for filtering.
+C NMX: max num of points available
+C -----------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL(N),T(N),G(N),CL(N),C(N),PXL(N)
+ COMPLEX FT(N),ANTI(N)
+ DIMENSION PESI(N),YC(N)
+ CHARACTER*1 YN
+ CHARACTER*20 NOME/'Correlation'/
+ EXTERNAL GAUSZC,GAUSZC1
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+ REAL*8 DLL1,ZETA
+C
+ N2=N/2
+C
+C ============================= for only red shifted galaxy ===
+C 5 DO 10 I=1,N
+C C(I)=0.0
+C K=I-1
+C DO 20 J=1,N-K
+C C(I)=C(I)+T(J)*G(J+K)
+C 20 CONTINUE
+C C(I)=C(I)/(N-K)
+C 10 CONTINUE
+C CL should be the doppler shift in km/sec
+C delta lambda/lambda=z => v=c*z=c*delta lamb/lamb
+C DO 30 I=1,N
+C CL(I)=299792.458*(TL(I)-TL(1))/TL(1)
+C 30 CONTINUE
+C
+C N3=N/3
+C Find and print the max values (on the first n/3=n3 values)
+C CALL MAXPRINT(C,CL,N3,N6,CMAX,KCMAX)
+C **************************************** TO INSERT AND TEST TO
+C HAVE BLUE SHIFT ALSO
+ 5 CONTINUE
+ DO 10 I=1,N2
+ K=I-1
+ C(N2+I)=0.0
+ C(N2-K)=0.0
+ DO 20 J=1,N-K
+ 20 C(N2+I)=C(N2+I)+T(J)*G(J+K) ! to red
+ DO 21 J=1,N-I
+ 21 C(N2-K)=C(N2-K)+T(J+I)*G(J) ! to blue
+ C(N2+I)=C(N2+I)/(N-K)
+ C(N2-K)=C(N2-K)/(N-I)
+ 10 CONTINUE
+C zero lag is in N/2+1
+ CL(N2+1)=0.0
+ DO 30 I=2,N2
+ CL(N2+I)=299792.458*(TL(I)-TL(1))/TL(1)
+ CL(N2-I+2)=-CL(N2+I)
+ 30 CONTINUE
+ CL(1)=-299792.458*(TL(N2+1)-TL(1))/TL(1)
+ N3=N/3
+C Find and print the max values (on the cantral n/3=n3 values)
+ CALL MAXPRINTC(C,CL,N,N3,N6,CMAX,KCMAX)
+C
+C **********************************************************
+C
+C rescaling of the cross correlation for easier plotting
+ IF(CMAX.GT.0.0) THEN
+ DO 35 I=1,N
+ 35 C(I)=C(I)/CMAX
+ ENDIF
+C
+ 80 CONTINUE
+C ..................... PLOTTING the cross correlation
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter: P=plot ,F=fit.rout., B=bandfilter, E=return,'
+ 1 ' T=type, C= corr.again')
+ READ(N5,3000) YN
+ 3000 FORMAT(A)
+ IF(YN.EQ.'e'.OR.YN.EQ.'E') THEN
+ RETURN
+ ELSE IF(YN.EQ.'C'.OR.YN.EQ.'c') THEN
+ GOTO 5
+ ELSE IF(YN.EQ.'P'.OR.YN.EQ.'p') THEN
+ XMAX=0.0 ! recomputes max and min
+ XMIN=0.0 ! over n data, not n2=n/2
+ YMAX=0.0
+ YMIN=0.0
+ KPLOT=1
+ CALL PLOTTA(N,PXL,CL,C,C,XMAX,XMIN,YMAX,YMIN,NOME,KPLOT)
+C
+C ..................... fitting the cross correlation peak
+ ELSE IF(YN.EQ.'F'.OR.YN.EQ.'f') THEN
+ NPK=4 ! 4 parameters
+ LISTA(1)=1 ! first is sigma
+ PK(1)=5. ! Guess value (pixels)
+ LISTA(2)=2 ! second is D=max of exp
+C ! guess is the max gausz value=max corr. value *sqrt(pi)*sigma
+C ! Cmax has been renormalized to 1
+ PK(2)=1.7724538*PK(1) * 1.
+ LISTA(3)=3 ! third is z
+ PK(3)=KCMAX-N2-1 ! note: z=0 is in pixel n/2-1
+C PK(3)=KCMAX-1 ! guess is the corr. lag z (pxl begins from 0)
+ LISTA(4)=4 ! fourth is a y-constant often present,
+ PK(4)=0.1 ! due to the bad cont. sub.
+ DLL=(299792.458D0* (DBLE(TL(2))-DBLE(TL(1))))/DBLE(TL(1))
+ NL=4 ! all parameters are varied
+ ENNE=N ! needed by GAUSZC1 throught /guesspk/
+ DO 70 I=1,N ! All points the same weight
+ 70 PESI(I)=1.0
+ INTER=1 ! Interactive fit
+ CALL FITA(N,PXL,C,PESI,YC,INTER,GAUSZC1,NOME,PXL)
+ SIGMA=PK(1)*DLL
+C ZETA=PK(3)*DLL ! WRONG ! good only for low zeta (first order approx)
+ DLL1=DBLE(TL(2))/DBLE(TL(1))
+ ZETA=(DLL1**PK(3)-1.D0)*299792.458D0
+ WRITE(N6,5000) PK(1),PK(2),PK(3),PK(4),SIGMA,ZETA,DLL
+ 5000 FORMAT(' sigma(pixels):',G13.5,' D:',G13.5/
+ 1 ' zeta(pixels):',G13.5,' y-const:',G13.5/
+ 2 ' SIGMA,ZETA(Km/sec):',2G15.6,' Km/sec/pixel:',G12.6)
+C
+C ....................................... band filter in freq.domain
+ ELSE IF(YN.EQ.'B'.OR.YN.EQ.'b') THEN
+C The correlation is transformed, bandfiltered and antitrasformed
+ CALL TRASF1(CL,C,N,NMX,FT,NEWN)
+C
+C K1 AND K2, input as last saved freq., are used as number
+C of frequency to eliminate, considering that 1=freq 0 ,and
+C N/2+1 - last freq, are not included in K1 and K2
+ K1=K1-1
+ MEZZO=NEWN/2+1
+ K2=MEZZO-K2+1
+ KFILT=0
+C
+ CALL FILTER(FT,ANTI,NEWN,KFILT,K1,K2,AK1,PXL,YC) ! anti,YC : work array
+C
+ DO 68 I=1,NEWN
+ 68 ANTI(I)=FT(I)
+ CALL FOUR1(ANTI,NEWN,-1)
+ DO 69 I=1,N
+ 69 C(I)=REAL(ANTI(I))/NEWN
+ ELSE IF (YN.EQ.'T'.OR.YN.EQ.'t') THEN
+ WRITE(N6,5100) N
+ 5100 FORMAT(' Enter the first and last point to see, max:',I5)
+ READ(N5,*,ERR=80) KT1,KT2
+ IF(KT1.LE.0) KT1=1
+ IF(KT2.GT.N.OR.KT2.LE.0) KT2=N
+ WRITE(N6,5200) (PXL(J),CL(J),C(J),J=KT1,KT2)
+ 5200 FORMAT(' pixel:',G12.4,' Km/sec:',G12.4,' Corr:',G12.4)
+ ENDIF
+ GOTO 80
+ END
+C
+ SUBROUTINE CSHIFT(TL0,T0,TL,T,N)
+C ------------------------------------------------------------
+C Circular shift by a given number of points
+C ------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL0(N),T0(N),TL(N),T(N)
+ CHARACTER*1 YN
+C
+C Logaritmic scale is assumed
+c DELTAL=TL0(2)/TL0(1)
+ 10 CONTINUE
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter the number of poit (>0 redshift,0=quit)')
+ READ(N5,*) NZ
+ IF(NZ.EQ.0) RETURN
+C
+ DO 20 I=1,N
+ N1=I+NZ
+ N1=MOD(N1,N)
+C If negative (blue shift) sums to N
+ IF(N1.LE.0)N1=N1+N
+C TL(N1)=TL0(I) ! doesn't move lambda values
+ 20 T(N1)=T0(I)
+C
+ 500 CONTINUE
+ DO 50 I=1,N
+ TL0(I)=TL(I)
+ T0(I)=T(I)
+ 50 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE CSHIFTF(FT,FTDUM,M)
+C ------------------------------------------------------------
+C Circular shift FT(M) , complex, by a given number of points
+C FTDUM: WORK array
+C ------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ COMPLEX FT,FTDUM
+ DIMENSION FT(M),FTDUM(M)
+C
+ 10 WRITE(N6,1000) M
+ 1000 FORMAT(' Enter points to shift (<0 LEFT)',
+ 1 ' and dimension, (now:',I5,')')
+ READ(N5,*,ERR=550) NZ,N
+ IF(NZ.EQ.0) RETURN
+ IF(N.LE.0) N=M
+C
+ DO 20 I=1,N
+ N1=I+NZ
+ N1=MOD(N1,N)
+ IF(N1.LE.0)N1=N1+N ! If negative (blue shift) sums to N
+ 20 FTDUM(N1)=FT(I)
+C
+ DO 50 I=1,N
+ FT(I)=FTDUM(I)
+ 50 CONTINUE
+C
+ RETURN
+C
+ 550 WRITE(N6,5500)
+ 5500 FORMAT(' INPUT ERROR!')
+ GOTO 10
+ END
+C
+ SUBROUTINE CUT(AL1,AL2,NI,NO,A,AL)
+C ------------------------------------------
+C NEVER USED NOR TESTED !
+C Reduces A(AL) to the interval AL1<=AL<=AL2
+C NI : input dimension of A,AL
+C NO : output dimension of A,AL
+C ------------------------------------------
+C
+ DIMENSION A(NI),AL(NI)
+C
+C Looks for the point AL1
+C
+ K1=1
+ DO 10 I=1,NI
+ IF(AL(I).LE.AL1) GO TO 10
+ K1=I-1
+ GO TO 100
+ 10 CONTINUE
+ 100 CONTINUE
+C
+C Looks for the point AL2
+C
+ K2=NI
+ DO 20 I=NI,1,-1
+ IF(AL(I).GE.AL2) GO TO 20
+ K2=I+1
+ GO TO 200
+ 20 CONTINUE
+ 200 CONTINUE
+C
+C The vector AL(NI) and A(NI) are compressed
+C
+ NO=K2-K1+1
+ DO 30 I=1,NO
+ A(I)=A(K1+I-1)
+ AL(I)=AL(K1+I-1)
+ 30 CONTINUE
+C
+ RETURN
+ END
+C
+ SUBROUTINE DIV(FT,FG,FS,NK)
+C ----------------------------------------
+C Divides two complex vectors
+C a minimum (real) value for the quotient can be forced
+C to reduce the division increased noise
+C ---------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ COMPLEX FT(NK),FG(NK),FS(NK)
+C
+ 10 WRITE(N6,1000)
+ 1000 FORMAT(' Enter the maximum absolute value for denom(0=none)')
+ READ(N5,*,ERR=10) GMAX
+C
+ IF(GMAX.LT.0.0) GMAX=0.0
+C
+ DO 20 I=1,NK
+ AMOD=ABS(FT(I))
+ IF(AMOD.GT.GMAX) THEN
+ FS(I)=FG(I)/FT(I)
+ ELSE
+ WRITE(N6,2000) I,AMOD,GMAX
+ 2000 FORMAT(' Value number:',I5,'=FS/',1PE15.6,
+ 1 ' is too great, new value:',1PE15.6)
+ FS(I)=CMPLX(GMAX,0.0)
+ ENDIF
+ 20 CONTINUE
+C Cutoff on max value for real and imm part of FS
+ 22 WRITE(N6,3000)
+ 3000 FORMAT(' Enter the maximum value for real,imm FG (0=none)')
+ READ(N5,*,ERR=22) GMAX
+C
+ IF(GMAX.LE.0.0) RETURN
+C
+ 24 WRITE(N6,3010)
+ 3010 FORMAT(' Enter the new value for data above maximum ')
+ READ(N5,*,ERR=24) GMAX1
+C
+ DO 30 I=1,NK
+ AR=REAL(FS(I))
+ AI=AIMAG(FS(I))
+ IF(ABS(AR).LE.GMAX.AND.ABS(AI).LE.GMAX) GOTO 30
+ IF(ABS(AR).GT.GMAX) AR=SIGN(GMAX1,AR)
+ IF(ABS(AI).GT.GMAX) AI=SIGN(GMAX1,AI)
+ WRITE(N6,4000) I,FS(I),AR,AI
+ 4000 FORMAT(' Value :',I5,2(1X,1PE12.3),
+ 1 ', CHANGED TO:',2(1X,1PE12.3))
+ FS(I)=CMPLX(AR,AI)
+ 30 CONTINUE
+C
+ RETURN
+ END
+C
+ SUBROUTINE DIVCUT(F,N,SIG,NMEAN)
+C ------------------------------------------
+C In F set to mean value the values exceeding
+C Sig times the standard deviation
+C of the mean over nmean values
+C -------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ COMPLEX F(N)
+ COMPLEX TOT,FF
+C
+ IF(SIG.EQ.0.0) SIG=3. ! defaults
+ IF(NMEAN.EQ.0) NMEAN=N/50
+C
+ 10 IF(SIG.LE.0) THEN
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter the allowed number of sigma, for deviation')
+ READ(N5,*,ERR=500) SIG
+ WRITE(N6,*) SIG
+ ENDIF
+ IF(NMEAN.LE.0.OR.NMEAN.GT.N) THEN
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter the allowed number of points for average')
+ READ(N5,*,ERR=500) NMEAN
+ WRITE(N6,*) NMEAN
+ ENDIF
+C
+ NVARIED=0 ! counters for printing
+ NIMM=0
+ NREAL=0
+ DO 20 I=1,N
+ TOT=0.0
+ N1=MAX(1,I-NMEAN/2)
+ N2=MIN(N,I+NMEAN/2)
+ DO 30 J=N1,N2 ! mean
+ 30 TOT=TOT+F(J)
+ NUM=N2-N1+1
+ IF(NUM.LE.0) GOTO 20
+ TOT=TOT/NUM
+ DEVR=0.0
+ DEVI=0.0
+ DO 40 J=N1,N2 ! std for real and imm parts
+ FF=F(J)-TOT
+ DEVR=DEVR+REAL(FF)**2
+ DEVI=DEVI+AIMAG(FF)**2
+ 40 CONTINUE
+ DEVR=SQRT(DEVR/NUM)
+ DEVI=SQRT(DEVI/NUM)
+ AR=REAL(F(I))
+ AI=AIMAG(F(I))
+ TR=REAL(TOT)
+ TI=AIMAG(TOT)
+ SOGLIAR=DEVR*SIG
+ SOGLIAI=DEVI*SIG
+ IF(ABS(AR-TR).GT.SOGLIAR.OR.ABS(AI-TI).GT.SOGLIAI) THEN
+ NVARIED=NVARIED+1
+ IF(ABS(AR-TR) .GT. SOGLIAR) THEN
+ AR=TR
+ NREAL=NREAL+1
+ ENDIF
+ IF(ABS(AI-TI) .GT. SOGLIAI) THEN
+ AI=TI
+ NIMM=NIMM+1
+ ENDIF
+ WRITE(N6,3000) I,F(I),AR,AI,DEVR,DEVI
+ 3000 FORMAT(1X,I5,1X,2G11.3,'=>',2G11.3,' dev:',2G11.3)
+ F(I)=CMPLX(AR,AI)
+ ENDIF
+ 20 CONTINUE
+ WRITE(N6,4000) NVARIED,NIMM,NREAL
+ 4000 FORMAT(' Total of',I5,' points varied:',I5,' real changed',
+ 1 I5,' imm.')
+ RETURN
+ 500 WRITE(N6,5000)
+ 5000 FORMAT(' INPUT ERROR ! REENTER')
+ GOTO 10
+ END
+C
+ SUBROUTINE DOUBLE(TL0,T0,TL,T,N,NMAX,K,PXL,SINCERR)
+C ---------------------------------------------------------
+C The spectrum is piecewise interpolated by a polinomium
+C of order K-1 . In this way a new point is added between
+C each pair of points and at the end of the spectrum.
+C Output is a spectrum enlarged to 2*N points.
+C If K=0 the Wittaker sinc interpolation is used.
+C SINCERR IS 1/error in sinc interpolation.
+C ---------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ DIMENSION TL0(NMAX),T0(NMAX),TL(NMAX),T(NMAX),PXL(NMAX)
+ REAL*8 DELTAL
+C
+ N2=2*N
+ IF(N2.GT.NMAX) THEN
+ WRITE(N6,1000) NMAX,N2
+ 1000 FORMAT(' ERROR!! Execution impossible, the value of NMAX:',
+ 1 I6,' must be increased to ',I6)
+ RETURN
+ ENDIF
+ 100 IF(K.GT.N.OR.K.LT.0) THEN
+ WRITE(N6,1100) K
+ 1100 FORMAT(I5,': invalid value for polinomium order! REENTER')
+ READ(N5,*) K
+ GOTO 100
+ ENDIF
+ IF(ERROR.LT.0.0.AND.K.EQ.0) THEN
+ WRITE(N6,1150) SINCERR
+ 1150 FORMAT(' Enter 1/FRACT. ERROR, DEF=1000000.')
+ READ(N5,*)SINCERR
+ ENDIF
+ IF(K.EQ.0.AND.SINCERR.LE.0.) SINCERR=1000000.
+C
+ ERROR=0.0
+ TERROR=0.0
+C Saves the spectrum in T,TL
+ DO 10 I=1,N
+ TL(I)=TL0(I)
+ 10 T(I)=T0(I)
+C ........... Sets lambda scale and T0 new values
+ WRITE(N6,1200)
+ 1200 FORMAT(' Log. lambda scale assumed for new lambda values')
+C New Lambda interval (equilogaritmic lambda scale)
+ IF(TL0(1).EQ.0.0) THEN
+ DELTAL=1.D0 ! in this case bad lambda scale
+ ELSE
+ DELTAL=DBLE(TL0(2))/DBLE(TL0(1))
+ ENDIF
+C
+ IF(DELTAL.LE.1.D0) THEN ! Bad lambda scale (or fictious one)
+ WRITE(N6,1300)
+ 1300 FORMAT(' BAD LAMBDA SCALE !, assumed lambda = 0,1,2,3..')
+ ELSE ! Instead for good lambda scale:
+ DELTAL=DSQRT(DELTAL)
+ ENDIF
+C
+C Store the data in T0,in the new positions
+ DO 20 I=1,N
+ 20 T0(2*I-1)=T(I)
+C
+ IF(K.GT.0) THEN ! ----- polinomial interpolation -----
+C Sets the new lambda values
+ IF(DELTAL.LE.1.D0) THEN ! Bad lambda scale
+ DO 23 I=1,N
+ 23 TL(I)=PXL(2*I-1) ! assign to TL the TL0 fictious lam.scale
+ DO 25 I=1,N2
+ 25 TL0(I)=PXL(I)
+ ELSE ! good lambda scale (TL not reassigned)
+ DO 27 I=2,N2,2
+ TL0(I-1)=TL(I/2)
+ 27 TL0(I)=TL0(I-1)*DELTAL
+ ENDIF
+C
+ DO 30 I=2,N2,2 ! loop on new T0 points to compute
+ I1=MAX(1,I/2-K/2+1) ! Finds the first and last point for interpolation
+ I2=I1+K-1
+ IF(I2.GT.N) THEN
+ I2=N
+ I1=N-K+1
+ ENDIF
+C Interpolated value at TL0(I)
+ CALL POLINT(TL(I1),T(I1),K,TL0(I),T0(I),ERR)
+C
+ IF(ERR.GT.ERROR) ERROR=ERR
+ TERROR=TERROR+ERR
+ 30 CONTINUE
+ ELSE ! ------ Wittaker sinc interpolation -----
+ TSAMPLE=2. ! sampling interval for T0 (in the new scale)
+ DO 35 I=1,N ! fictious lambda scale in TL0
+ 35 TL0(I)=PXL(2*I-1) ! that is : TL0 = 0,2,4,6, ....
+ DO 40 I=2,N2,2 !................ LOOP on T0 value to found
+ ALAMBDA=I-1 ! with fictious lambda= 1,3,5,7 ...
+C T0(I)=WITTC(T,TL0,ALAMBDA,N,TSAMPLE,SINCERR) ! periodic sinc
+ T0(I)=WITT(T,TL0,ALAMBDA,N,TSAMPLE)
+ 40 CONTINUE
+C Now sets new lambda values
+ IF(DELTAL.GE.1.D0) THEN ! For bad lambda scale
+ DO 45 I=1,N2
+ 45 TL0(I)=PXL(I)
+ ELSE ! Log lambda scale
+ DO 50 I=2,N2,2
+ TL0(I-1)=TL(I/2)
+ 50 TL0(I)=TL0(I-1)*DELTAL
+ ENDIF
+ ENDIF ! ............................( end of if on polin. or sinc)
+C
+ IF(K.GT.0) THEN ! for polinomial interp.
+ TERROR=TERROR/N2
+ WRITE(N6,3000) N,N2,TERROR,ERROR
+ 3000 FORMAT(' Data increased from:',I5,' to:',I5,' values.',
+ 1 ' Medium and max. interp. error:',
+ 2 E12.5,1x,E12.5)
+C
+ ELSE ! for sinc interpolation
+ WRITE(N6,3500) N,N2,SINCERR
+ 3500 FORMAT(' Data increased from:',I5,' to:',I5,
+ 1 ' Sinc interp. error=1./',G12.5)
+ ENDIF
+ N=N2
+ RETURN
+ END
+C
+ SUBROUTINE EVEN(N,NEWN,NMAX)
+C --------------------------------------------------------
+C NEWN is computed as the first integer power of 2 after N
+C --------------------------------------------------------
+ COMMON /TAPE/N5,N6,N7
+C
+ K=2
+ 30 CONTINUE
+ IF(N.EQ.K) GOTO 400 ! OK, N is an integer power of two.
+ IF(N.LT.K) GOTO 300 ! OK, next integer power of two found.
+ K=K*2
+ GO TO 30
+C
+ 300 CONTINUE
+ WRITE(N6,2000)N,K
+ 2000 FORMAT(' The original dimension of ',I6,
+ 1 ' must be the a power of 2:',I6)
+ IF(K.GT.NMAX) WRITE(N6,3000) NMAX
+ 3000 FORMAT(' ERROR! Increase the maximum dimension, which is:',I5)
+C
+ 400 NEWN=K
+ RETURN
+ END
+C
+ SUBROUTINE EXPAND(AL,A,N,NEWN,NMAX,PXL)
+C --------------------------------------------------------
+C embeds the spectrum into a vector filled with 0.0
+C N is the old number of points
+C NEWN the new number of points , if <= interactive usage,
+C if <=N is the number of points to add at both ends of spectrum
+C NMAX the max dimension of A,AL
+C --------------------------------------------------------
+ COMMON/TAPE/ NN5,NN6,NN7
+ DIMENSION AL(NMAX),A(NMAX),PXL(NMAX)
+ REAL*8 STEP,RAPP
+C
+ 10 CONTINUE
+ IF(NEWN.GT.NMAX.OR.NEWN.LE.0) THEN
+ WRITE(N6,1000) NEWN,NMAX
+ 1000 FORMAT(' Num.of points(',I5,' )> max:',I5,
+ 1 ' REENTER ( <=0: exit )')
+ READ(N5,*,ERR=500) NEWN
+ IF(NEWN.LE.0) RETURN
+ GOTO 10
+ ENDIF
+C
+ IF(NEWN.LE.N) THEN ! change num. of points to add to
+ NEWN=2*NEWN+N ! new nun of points
+ GOTO 10
+ ENDIF
+C
+ KN1=(NEWN-N)/2 ! num of points added before the spectrum
+ KN2=N+KN1+1 ! first point added after the spectrum
+ KSCAL=0
+ CALL LEGGESCAL(AL,N,KSCAL) ! test lambda scale
+ IF(AL(2)-AL(1).EQ.AL(3)-AL(2)) THEN ! linear scale
+ RAPP=0.0D0
+ STEP=AL(2)-AL(1)
+ WRITE(N6,3000) STEP
+ 3000 FORMAT(' Linear lambda scale assumed, step:',G15.5)
+ ELSE
+ STEP=0.0
+ IF(AL(1).EQ.0.0) THEN
+ RAPP=1.D0
+ ELSE
+ RAPP=DBLE(AL(2))/DBLE(AL(1))
+ ENDIF
+ WRITE(N6,4000) RAPP
+ 4000 FORMAT(' Log. lambda scale assumed with ratio:',G15.5)
+ ENDIF
+C shift values to right by KN1 points
+ DO 20 I=N,1,-1
+ AL(I+KN1)=AL(I)
+ 20 A(I+KN1)=A(I)
+C set first KN1 points
+ DO 30 I=KN1,1,-1
+ A(I)=0.0
+ IF(RAPP.GT.0.0D0) THEN
+ AL(I)=AL(I+1)/RAPP
+ ELSE
+ AL(I)=AL(I+1)-STEP
+ ENDIF
+ 30 CONTINUE
+C set last points from KN2 to NEWN
+ DO 40 I=KN2,NEWN
+ A(I)=0.0
+ IF(RAPP.GT.0.0D0) THEN
+ AL(I)=AL(I-1)*RAPP
+ ELSE
+ AL(I)=AL(I-1)+STEP
+ ENDIF
+ 40 CONTINUE
+ WRITE(N6,6000) N,NEWN,KN1,NEWN-N-KN1,KN2,NEWN
+ 6000 FORMAT(' Spectrum extended from',I6,' to',I6,'points'/
+ 1 ' first',I5,' and last',I5,' points are 0; from',I6,' to',I6)
+ N=NEWN
+ RETURN
+ 500 WRITE(N6,7000)
+ 7000 FORMAT(' INPUT ERROR REENTER!')
+ GOTO 10
+ END
+C
+ SUBROUTINE FDOUBLE(F,N,NMAX)
+C --------------------------------------------------------
+C Doubles the number of points by adding zeroes to the
+C upper frequency end of the fourier transform
+C --------------------------------------------------------
+ COMMON /TAPE/ N5,N6,N7
+ COMPLEX F(NMAX)
+C
+ N2=N*2
+C
+ IF(N2.GT.NMAX) THEN
+ WRITE(N6,1000) N2,NMAX
+ 1000 FORMAT(' ERROR! requested number of points:',I6,
+ 1 ' must be less than:',I6,' nothing done!')
+ RETURN
+ ENDIF
+C move n/2 point , starting from point N.
+C ( qui potrebbe partire ance dal primo, non sovrappone raddoppiando)
+ DO 10 I=N,N/2+1,-1
+ 10 F(N2+I-N)=F(I)
+ DO 20 I=N/2+2,N2-N/2 ! zero central points
+ F(I)=CMPLX(0.0,0.0)
+ 20 CONTINUE
+ N=N2
+ RETURN
+ END
+C
+ SUBROUTINE FILTER(FT,FT1,N,K,K1,K2,AK1,PXL,T)
+C --------------------------------------------------------
+C Filter in the transform domain,
+C modifying user-chosen frequencies.
+C K=0 => Interactive usage
+C K=1 => Low and high band filter (Freq < K1 suppressed)
+C (Freq > K2 suppressed)
+C K=2 => Gauss filtering (AK1 is the gaussian width )
+C K=3 => Set immaginary part to 0.0
+C PXL=0,1,2,..n-1
+C --------------------------------------------------------
+ COMMON/TAPE/ NN5,NN6,NN7
+ DIMENSION PXL(N),T(N) ! T => work array for plotting
+ COMPLEX FT(N),FT1(N)
+ CHARACTER*1 YN
+ CHARACTER*20 NOME,NOMER,NOMEI
+ REAL*8 ADUM,PI,ASIG,FACT ! controllare che servono in doppia
+ DATA PI /3.14159265358979323846/
+ DATA NOMER,NOMEI/'FT-corr-real','FT-corr-imm'/
+C Options flag: list, reset, plot, quit, band filter, plot real-imm.
+ DATA N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11
+ 1 /1,2,3,4,5,6,7,8,9,10,11/
+C
+ MEZZO=N/2+1
+C
+ 1 CONTINUE
+ DO 5 I=1,N
+ 5 FT1(I)=FT(I)
+C Non interactive usage
+ IF(K.EQ.1) GOTO 200 ! to bandfilter
+ IF(K.EQ.2) GOTO 400 ! to gaussfilter
+ IF(K.EQ.3) GOTO 800 ! to set imm part to zero
+C ...................... interactive usage loop
+ 10 WRITE(NN6,1000) N,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11
+ 1000 FORMAT(' Enter (-n): number to be modified',
+ 1 ' (max -',I5,') or:'/
+ 2 1X, ' 0=OK.Exit,',T40,I3,'=List,'/
+ 2 1X,I3,'=Reset,', T40,I3,'=Print,'/
+ 3 1X,I3,'=Quit,' , T40,I3,'=bandfilter,'/
+ 3 1X,2I3,'=Plot real,imm' ,T40,I3,'=gaussfilter,'/
+ 5 1X,I3,'= imm=0 ', T40,I3,'=bandset, '/
+ 6 1X,I3,'=cut peaks')
+ READ(NN5,*,ERR=500) NF1
+C Save and return
+ 110 IF(NF1.EQ.0) THEN
+ 111 DO 50 I=1,N
+ FT(I)=FT1(I)
+ 50 CONTINUE
+ RETURN
+ ENDIF
+C Lists data
+ IF(NF1.EQ.N1) THEN
+ WRITE(NN6,1100)
+ 1100 FORMAT(' Enter the first and last number to list')
+ READ(NN5,*,ERR=500) NF1,NF2
+ IF(NF1.GT.0.AND.NF2.LE.N.AND.NF1.LE.NF2) THEN
+ WRITE(NN6,2000) (J,FT1(J),J=NF1,NF2)
+ 2000 FORMAT(' Value:',I5,3X,E20.13,3X,E20.13)
+ GOTO 10
+ ELSE
+ GOTO 110
+ ENDIF
+ ENDIF
+C Reset
+ IF(NF1.EQ.N2) GOTO 1
+C PRINT
+ IF(NF1.EQ.N3) CALL PRINTC(FT1,N)
+C Plot
+ IF(NF1.EQ.N6.OR.NF1.EQ.N7) THEN
+ XMAX=0.0
+ XMIN=0.0
+ YMAX=0.0
+ YMIN=0.0
+ KPLOT=1 ! interactive plot
+ IF(NF1.EQ.N6) THEN ! plots real part
+ DO 51 I=1,N
+ T(I)=REAL(FT1(I))
+ 51 CONTINUE
+ NOME=NOMER
+ ELSE ! plots imm part
+ DO 52 I=1,N
+ T(I)=AIMAG(FT1(I))
+ 52 CONTINUE
+ NOME=NOMEI
+ ENDIF
+ CALL PLOTTA(N,PXL,PXL,T,T,XMAX,XMIN,YMAX,YMIN,NOME,KPLOT)
+ ENDIF
+C Quit
+ IF(NF1.EQ.N4) RETURN
+C Change a value
+ IF(NF1.LT.0.AND.-NF1.LE.N) THEN
+ NF1=-NF1
+ NF11=NF1
+ DO 55 I=NF11,N
+ WRITE(NN6,3000) I,FT1(I)
+ 3000 FORMAT(' Num:',I5,
+ 1 ' OLD value is:',1X,E12.5,1X,E12.5,
+ 2 ' enter num and new value')
+ READ(NN5,*,ERR=500) NUMI,FREAL,FIMM
+C
+ IF(NUMI.EQ.0) THEN
+ GOTO 10
+ ELSE IF(NUMI.EQ.I) THEN
+ FT1(I)=CMPLX(FREAL,FIMM)
+ WRITE(NN6,3001) I,FT1(I)
+ 3001 FORMAT(' Num:',I5,' Set to:',2G15.5)
+ ELSE
+C WRITE(NN6,3500) NUMI,I
+C 3500 FORMAT(' No changes:',I5,' not equal to ',I5)
+ NF1=NUMI
+ GOTO 110
+ ENDIF
+C
+ 55 CONTINUE
+ ENDIF
+C Low and high band pass filter
+ IF(NF1.EQ.N5) THEN
+C Band filter: assuming that zero frequency is in fg(1),N is even
+ NDUM21=N/2+1
+ WRITE(NN6,4000) NDUM21
+ 4000 FORMAT(' Enter K1,K2 low & high freq.lim.(from 1 to ',I5,'),',
+ 1 '(freq < K1 ; > K2 => 0.0)')
+ READ(NN5,*,ERR=500) K1,K2
+C K1 AND K2, input as last saved freq., are used as number
+C of frequency to eliminate, considering that 1=freq 0 ,and
+C N/2+1 - last freq, are not included in K1 and K2
+ K1=K1-1
+ MEZZO=N/2+1
+ K2=MEZZO-K2+1
+ 200 CONTINUE
+ IF(K1.GE.0) THEN
+ IF(K1.GT.N/2) K1=N/2
+ FT1(1)=0.0
+ DO 60 I=1,K1
+ FT1(I+1)=0.0
+ FT1(N-I+1)=0.0
+ 60 CONTINUE
+ ENDIF
+ IF(K2.GT.0) THEN
+ IF(K2.GT.N/2) K2=N/2
+ FT1(MEZZO)=0.0
+ DO 70 I=1,K2-1
+ FT1(MEZZO+I)=0.0
+ FT1(MEZZO-I)=0.0
+ 70 CONTINUE
+ ENDIF
+C non interactive usage
+ IF(K.EQ.1) GOTO 111
+ ENDIF
+C
+ IF(NF1.EQ.N8) THEN
+ WRITE(NN6,5000) AK1
+ 5000 FORMAT(' Enter the gauss width ',
+ 1 '(in lamb.pixel, now:',G12.5,') and max (0=>1)')
+ READ(NN5,*,ERR=500) AK1,AK2
+ 400 IF(AK1.LE.0.) THEN
+ WRITE(NN6,5100) AK1
+ 5100 FORMAT(' ERROR! value must be >0,',G12.5,' is not good')
+ K=0 ! change to interactive usage
+ GOTO 10
+ ENDIF
+C
+ ASIG= -2.D0* (PI/N)**2 * (DBLE(AK1)**2)
+ IF(AK2.EQ.0.0) THEN
+ FACT=1.D0
+ ELSE
+ FACT=AK2
+ ENDIF
+ WRITE(NN6,5200) FACT,AK1
+ 5200 FORMAT(' Transf. * trasf.gauss funct. with max:',
+ 1 G12.5,' sigma:',G12.5)
+C
+ FT1(1)=FACT*FT1(1)
+ DO 80 I=2,MEZZO-1
+ ADUM=FACT*EXP( DBLE(I-1)**2 *ASIG )
+ FT1(I)=ADUM*FT1(I)
+ FT1(N-I+2)=ADUM*FT1(N-I+2)
+ 80 CONTINUE
+ FT1(MEZZO)=FT1(MEZZO)*FACT*EXP(DBLE(MEZZO-1)**2 *ASIG )
+C
+ IF(K.EQ.2) GOTO 111 ! non interactve, to save and return
+ ENDIF
+ IF(NF1.EQ.N9) THEN ! set imm part to 0.0
+ 800 DO 85 I=1,N
+ FT1(I)=CMPLX(REAL(FT1(I)),0.0)
+ 85 CONTINUE
+ IF(K.EQ.3) GOTO 111 ! exit for non interactive usage
+ ENDIF
+ IF(NF1.EQ.N10) THEN ! BAND SET
+ WRITE(NN6,5300) N
+ 5300 FORMAT(' Enter range: n1,n2 ( 1 to ',I5,
+ 1 ' ) and their (real,imm) values')
+ READ(NN5,*,ERR=500) NF1,NF2,FREAL,FIMM
+ IF(NF1.GT.NF2.OR.NF1.LE.0.OR.NF2.GT.N) GOTO 500
+ DO 87 I=NF1,NF2
+ FT1(I)=CMPLX(FREAL,FIMM)
+ 87 CONTINUE
+ WRITE(NN6,5310) NF1,NF2,FREAL,FIMM
+ 5310 FORMAT(' From:',I5,' to: ', I5,' =>',2G15.5)
+ ENDIF
+C
+ IF(NF1.EQ.N11) THEN ! CUTTING PEAKS
+ WRITE(NN6,6000)N,N/100
+ 6000 FORMAT(' Enter range to change,( def.: 1 :',I5,
+ 1 ' ) num.points to average, (def:',I5,' )'/
+ 2 ' sig treshold (def 3 ) and max iterations (def 10)')
+ READ(NN5,*,ERR=500) K1,K2,K3,AK1,K4
+ IF(K1.LE.0.OR.K1.GT.N) K1=1
+ IF(K2.LE.0.OR.K2.GT.N) K2=N ! defaults
+ IF(K3.LE.0) K3=N/100.
+ IF(K3.GT.N) K3=N
+ IF(AK1.LE.0.0) AK1=3.
+ IF(K4.LE.0) K4=10
+ WRITE(NN6,6100) K1,K2,K3,AK1,K4
+ 6100 FORMAT(' Range:',2I5,' average on:',I5,' points,',
+ 1 ' sig thres.:',G13.5,' maxiter:',I5)
+ CALL RUNMC(N,K1,K2,K3,AK1,K4,FT1)
+ ENDIF
+C
+ GOTO 10 ! ................... TO main (interactive usage) loop
+ 500 WRITE(NN6,5500)
+ 5500 FORMAT(/' ERROR READING INPUT ! REENTER !!!!'/)
+ GOTO 10
+ END
+C
+ SUBROUTINE FITA(N,X,Y,PESI,YC,INTER,FUNCZ,NAME,PXL)
+C -------------------------------------------------------------
+C Prepare parameters and accepts command for interactive fit
+C options. Routine FITAW is called for weights calculation,
+C routine FITAF to call the "numerical recipes"'s subroutines
+C for non linear fit of:
+C Y(x)=funcz( x, pk del common /guesspk/ )
+C FUNCZ computes y(pk,x), dy/dpk(x,pk)
+C INPUT:X(n),Y(n), FUNCZ: funtion to fit
+C WORK.ARRAY: PESI,YC
+C If inter=1 then an interactive fit is done
+C pesi are used as weights for Y in the fitting routine,
+C (usually weights=1/error**2 ).
+C an initial value for then must be given in input, and their
+C value can be computed here.
+C
+C lista is the number of parameters to change
+C alpha is the hessian matrix/2 , covar its inverse matrix
+C (covariance matrix)
+C .........................................................
+C in yc=(c/sigma/sqrt(pi)) *D *exp(-c**2*(x-z)**2/sigma**2)
+C parameters are pk(3) = sigma , D , z
+C real part of the anti-transform to a gauss+redshift
+C --------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C Guess values for parameter for fitting curves
+C LGPK(i)>=1 if GPK(i) is set
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+C
+ EXTERNAL FUNCZ
+ DIMENSION X(N),Y(N),PESI(N),YC(N),PXL(N)
+C WARNING ! the number of parameters is in a lot of places defined
+C in different ways
+ DATA NPK3/4/ ! Must be the max num of parameters
+ DIMENSION DYDA(4) ! derivatives when calling funcz
+ CHARACTER YN*1 ,NAME *(*)
+ CHARACTER *20 NAMEP/' Weights(dots=Y)'/
+ LOGICAL YCEXIST
+ REAL*8 DLL1
+C
+C ............................. fixing default values
+C FOR PK(i) Initial guess values : IN COMMON /GUESSPK/ , if any, or:
+C mantains the older values
+ N1F=1
+ N2F=N
+ YCEXIST=.FALSE. ! YC=Y computed does't exist yet
+C
+ IF(NPK.LE.0) NPK=NPK3
+ IF(NL.LE.0) NL=NPK
+ MAXITER=10
+ CONVERG=0.01
+ NWTYPE=1 ! Initial: equal weights
+ NPRINT=100 ! max printed matter
+ NZERO=0 ! low freq. filter limit
+ NZEROC=0 ! " " " " for imm.part.
+ DO 5 I=1,NPK
+ IF(LGPK(I).GT.0) PK(I)=GPK(I)
+ IF(LISTA(I).LE.0.OR.LISTA(I).GT.NPK) LISTA(I)=I
+ 5 CONTINUE
+C
+ IF(INTER.LE.0) THEN ! non interactive usage va dritto al fit
+ NPRINT=3
+ YN='F'
+ GOTO 200
+ ENDIF
+C .........................................................
+C ................... INTERACTIVE USAGE LOOP ..........
+C .........................................................
+ 1 CONTINUE
+ WRITE(N6,9001)
+ 9001 FORMAT(/' FITTING ROUTINE Enter:'/
+ 2 ' P: plot., G: param., '/
+ 2 ' C: limits by coord. L: limits by num.,'/
+ 1 ' I: iterations, F: fit, '/
+ 1 ' W: weights, A: Loops on C , '/
+ 2 ' Z: low.freq.filt. X: as Z but for complex'/
+ 3 ' T: type, S: print' /
+ 6 ' E,0:end, ')
+ READ(N5,6500,ERR=1) YN
+ 6500 FORMAT(A)
+C
+ 2 CONTINUE ! .................. loop entry without asking
+C
+ IF(YN.EQ.'E'.OR.YN.EQ.'e'.OR.YN.EQ.'0') THEN
+ RETURN
+C =========> Loops on limits
+ ELSE IF(YN.EQ.'A'.OR.YN.EQ.'a') THEN
+ IF(LIMIT1.LE.0) LIMIT1=100 ! printing def values
+ IF(LIMIT2.LE.0) LIMIT2=200
+ IF(LIMIT3.LE.0) LIMIT3=10
+ IF(LIMITITER.LE.0) LIMITITER=4
+ IF(NWDUM.LE.0) NWDUM=2
+ WRITE(N6,3000)LIMIT1,LIMIT2,LIMIT3,LIMITITER,NWDUM,NPRTD,
+ 1 IGUESS
+ 3000 FORMAT(' Enter coord range: from, to, by',3I5,/
+ 1 18X,' num.weight iter., and weight type,:',2I5/
+ 2 18X,' print flag:',I5,' pk reset flag:',I5)
+ READ(N5,*,ERR=500)LIMIT1,LIMIT2,LIMIT3,LIMITITER,NWDUM,NPRTD,
+ 1 IGUESS
+ IF(LIMIT1.LE.0) LIMIT1=100
+ IF(LIMIT2.LE.0) LIMIT2=200 ! testing input values
+ IF(LIMIT3.LE.0) LIMIT3=10
+ IF(LIMITITER.LE.0) LIMITITER=4
+ IF(NWDUM.LE.0) NWDUM=2
+ WRITE(N6,3100) LIMIT1,LIMIT2,LIMIT3,LIMITITER,NWDUM,NPRTD
+ 3100 FORMAT(' From ',I5,' to ',I5,' step',I5/
+ 1 ' Weight iterations: ',I5,' weight type:',I5,
+ 2 ' Print flag:',I5)
+ IF(IGUESS.GT.0) THEN
+ 31 WRITE(N6,3110) (LGPK(J),GPK(J),J=1,NPK)
+ 3110 FORMAT(' Enter paramater number and guess (0=exit)',
+ 1 ' Now:'/' Sigma: pk num 1 :',I5,5X,G15.5/
+ 1 ' D : pk num 2 :',I5,5X,G15.5/
+ 1 ' zeta : pk num 3 :',I5,5X,G15.5/
+ 1 ' N : pk num 4 :',I5,5X,G15.5)
+ READ(N5,*,ERR=500) NDUM,DUM
+ IF(NDUM.LE.0.OR.NDUM.GT.NPK) GOTO 310
+ LGPK(NDUM)=NDUM
+ GPK(NDUM)=DUM
+ GOTO 31
+ ENDIF
+ 310 CONTINUE
+C
+ DO 30 I=LIMIT1,LIMIT2,LIMIT3 ! ........... Loops on limits
+C
+C Reset pk values to initial pk guess values
+ IF(IGUESS.GT.0) THEN
+ DO 32 IJ=1,NPK
+ IF(LGPK(IJ).GT.0) PK(IJ)=GPK(IJ)
+ 32 CONTINUE
+ ENDIF
+C
+ AN1=-I
+ AN2=I
+ N1=(AN1-X(1))/(X(2)-X(1)) + 1
+ N2=(AN2-X(1))/(X(2)-X(1)) + 1
+ IF(N2.LE.N1) GOTO 500
+ IF(N1.LE.0) N1=1
+ IF(N2.GT.N) N2=N
+ N2=N2-N1+1 ! changed to number of points to fit
+ N1F=N1
+ N2F=N2
+ WRITE(N6,9016) N1F,N2F
+C
+ NWTYPE1=1 ! all points the same weight
+ CALL FITAW(NWTYPE1,X,Y,YC,PESI,PXL,N,N1F,N2F,YCEXIST,FUNCZ)
+ IF(NZERO.GT.0) CALL ZERO(N,NZERO1,NZERO,PESI,0.0)
+ IF(NZEROC.GT.0) CALL ZERO(N,NZEROC1,NZEROC,PESI,0.0)
+ CALL FITAF(X(N1F),Y(N1F),YC(N1F),PESI(N1F),N2F,FUNCZ,MAXITER,
+ 1 NPRTD,CONVERG)
+ YCEXIST=.TRUE. ! recomputed by fitaf
+C minimum printing guaranted (if nprtd=0 fitaf doesn't print)
+ DLL1=DLL/299792.458D0+1.D0 ! =TL(2)/TL(1)
+ VZETA=(DLL1**PK(3)-1.D0)*299792.458D0
+C DVZETA=(DLL1**FORERR(3)-1.D0)*299792.458D0 ! this is wrong:
+C dv=v-(dll1**(pk(3)+dpk(3))-1)*c
+ DVZETA=DLL*FORERR(3) ! this may be abbastanza buona
+ VSIGMA=DLL*PK(1)
+ DVSIGMA=DLL*FORERR(1)
+ GAMMA=PK(2)
+ DGAMMA=FORERR(2)
+C
+ J=0
+ WRITE(N6,5551) I,J,VZETA,VSIGMA,PK(2),EXP(PK(2)),
+ 1 CHISQ/(N2F-NL),Q ! nl=num of varied param.npk=nun.param
+ WRITE(N7,5550) I,J,VZETA,VSIGMA,PK(2),EXP(PK(2)),
+ 1 CHISQ/(N2F-NL),Q
+C
+ DO 35 J=1,LIMITITER
+ CALL FITAW(NWDUM,X,Y,YC,PESI,PXL,N,N1F,N2F,YCEXIST,FUNCZ)
+ IF(NZERO.GT.0) CALL ZERO(N,NZERO1,NZERO,PESI,0.0)
+ IF(NZEROC.GT.0) CALL ZERO(N,NZEROC1,NZEROC,PESI,0.0)
+ CALL FITAF(X(N1F),Y(N1F),YC(N1F),PESI(N1F),N2F,FUNCZ,MAXITER,
+ 1 NPRTD,CONVERG)
+ YCEXIST=.TRUE. ! recomputed by fitaf now!
+ DLL1=DBLE(DLL)/299792.458D0+1.D0 ! =TL(2)/TL(1)
+ VZETA=(DLL1**PK(3)-1.D0)*299792.458D0
+ VSIGMA=DLL*PK(1)
+ WRITE(N6,5551) I,J,VZETA,VSIGMA,PK(2),EXP(PK(2)),
+ 1 CHISQ/(N2F-NL),Q
+ WRITE(N7,5550) I,J,VZETA,VSIGMA,PK(2),EXP(PK(2)),
+ 1 CHISQ/(N2F-NL),Q
+ 5550 FORMAT(' Lim:+- ==>',I5,' iter:',I2,
+ 1 ' z:',F6.0,' sigma:',F6.0,' D,exp D:',2G12.5,
+ 2 'chi2/(n-npk):',G12.5,' Q:',G12.5)
+ 5551 FORMAT(' Lim:+- ==>',I5,' iter:',I2,
+ 1 ' z:',F6.0,' sigma:',F6.0,' D,exp D:',2G12.5/
+ 2 ' chi2/(n-npk):',G12.5,' Q:',G12.5)
+ 35 CONTINUE
+C minimum printing guaranted (if nprtd=0 fitaf doesn't print)
+C BUT double printing in most cases !
+ DLL1=DBLE(DLL)/299792.458D0+1.D0 ! =TL(2)/TL(1)
+ VZETA=(DLL1**PK(3)-1.D0)*299792.458D0
+C DVZETA=(DLL1**FORERR(3)-1.D0)*299792.458D0
+ DVZETA=DLL*FORERR(3)
+ VSIGMA=DLL*PK(1)
+ DVSIGMA=DLL*FORERR(1)
+ GAMMA=PK(2)
+ DGAMMA=FORERR(2)
+ IF(ABS(GAMMA).LT.20.) THEN
+ EXPGAM=EXP(GAMMA) ! To avoid overflow in some cases
+ ELSE
+ EXPGAM=999999999999.
+ ENDIF
+ IF(ABS(GAMMA+DGAMMA).LT.20.) THEN
+ EXPGAMdum=EXP(GAMMA)+DGAMMA ! To avoid overflow in some cases
+ ELSE
+ EXPGAMdum=999999999999.
+ ENDIF
+
+ DEXPGAM=ABS( EXPGAM - EXPGAMDUM )
+C EXPGAM=EXP(GAMMA)
+C DEXPGAM=ABS( EXPGAM - EXP(GAMMA+DGAMMA) )
+ WRITE(N6,5552,ERR=30) VZETA,DVZETA,VSIGMA,DVSIGMA,
+ 1 GAMMA,DGAMMA,EXPGAM,DEXPGAM,CHISQ/(N2F-NL),
+ 2 SQRT(AVERERR2),Q,CHIFACTOR
+ WRITE(N7,5552,ERR=30) VZETA,DVZETA,VSIGMA,DVSIGMA,
+ 1 GAMMA,DGAMMA,EXPGAM,DEXPGAM,CHISQ/(N2F-NL),
+ 2 SQRT(AVERERR2),Q,CHIFACTOR
+ 5552 FORMAT(/' v=cz(Km/sec): ',F7.0,' +- ',G8.2,
+ 1 5X,' sigma:',6X,F5.0,' +- ',G8.2/
+ 2 ' gamma=D:',G12.5,' +-',G12.5,
+ " ' exp D:',G12.5,'+-',G12.5/
+ 3 3X,' Chi2/(n-npk):',G12.5,' aver.err:',G12.5/
+ 4 3X,' Q:',G12.5,' sigmafit**2/errors**2 :',G12.5)
+ NDUM=(N1F-1)*(X(2)-X(1))+X(1)
+ NDUM1=(NZERO1-1)*(X(2)-X(1))+X(1)
+ WRITE(N6,5554) N2F,NL,NDUM1,NDUM,NWTYPE
+ WRITE(N7,5554) N2F,NL,NDUM1,NDUM,NWTYPE
+C
+ 30 CONTINUE
+ IF(IGUESS.GT.0) THEN ! saves these pk for next call to fita
+ DO 36 IJ=1,NPK
+ LGPK(IJ)=0
+ 36 CONTINUE
+ ENDIF
+C =========> Fitting
+ ELSE IF(YN.EQ.'F'.OR.YN.EQ.'f') THEN
+ INTER=1 ! interactive usage defined,(su stampa di piu' con questo)
+ 200 CONTINUE ! entry from non-interactive usage
+ IF(NZERO.GT.0) CALL ZERO(N,NZERO1,NZERO,PESI,0.0)
+ IF(NZEROC.GT.0) CALL ZERO(N,NZEROC1,NZEROC,PESI,0.0)
+ CALL FITAF(X(N1F),Y(N1F),YC(N1F),PESI(N1F),N2F,FUNCZ,MAXITER,
+ 1 NPRINT,CONVERG)
+ YCEXIST=.TRUE. ! YC recomputed by firaf
+C minimum printing guaranted (if nprtd=0 fitaf doesn't print)
+ DLL1=DBLE(DLL)/299792.458D0+1.D0 ! =TL(2)/TL(1)
+ VZETA=(DLL1**PK(3)-1.D0)*299792.458D0
+C DVZETA=(DLL1**FORERR(3)-1.D0)*299792.458D0 ! WRONG !
+ DVZETA=DLL*FORERR(3)
+ VSIGMA=DLL*PK(1)
+ DVSIGMA=DLL*FORERR(1)
+ GAMMA=PK(2)
+ DGAMMA=FORERR(2)
+ IF(ABS(GAMMA).LT.20.) THEN
+ EXPGAM=EXP(GAMMA) ! To avoid overflow in some cases
+ ELSE
+ EXPGAM=999999999999.
+ ENDIF
+ IF(ABS(GAMMA+DGAMMA).LT.20.) THEN
+ EXPGAMdum=EXP(GAMMA)+DGAMMA ! To avoid overflow in some cases
+ ELSE
+ EXPGAMdum=999999999999.
+ ENDIF
+ DEXPGAM=ABS( EXPGAM - EXPGAMDUM )
+ WRITE(N6,5552) VZETA,DVZETA,VSIGMA,DVSIGMA,
+ 1 GAMMA,DGAMMA,EXPGAM,DEXPGAM,CHISQ/(N2F-NL),
+ 2 SQRT(AVERERR2),Q,CHIFACTOR
+ WRITE(N7,5552) VZETA,DVZETA,VSIGMA,DVSIGMA,
+ 1 GAMMA,DGAMMA,EXPGAM,DEXPGAM,CHISQ/(N2F-NL),
+ 2 SQRT(AVERERR2),Q,CHIFACTOR
+ WRITE(N6,5553) CHISQ/(N2F-NL)*CHIFACTOR
+ WRITE(N7,5553) CHISQ/(N2F-NL)*CHIFACTOR
+ 5553 FORMAT(20X,' chi2*chifact.=',G12.5)
+ NDUM=(N1F-1)*(X(2)-X(1))+X(1)
+ NDUM1=(NZERO1-1)*(X(2)-X(1))+X(1)
+ WRITE(N6,5554) N2F,NL,NDUM1,NDUM,NWTYPE
+ WRITE(N7,5554) N2F,NL,NDUM1,NDUM,NWTYPE
+ 5554 FORMAT(' fitted points:',I5,' n par.:',I2,' low.lim:',
+ 1 I5,' high lim:',I5,' weight type:',I2)
+C
+C =========> limits change
+ ELSE IF(YN.EQ.'L'.OR.YN.EQ.'l') THEN
+ YCEXIST=.FALSE.
+ WRITE(N6,9010) N1F,N2F
+ 9010 FORMAT(' Enter the first and num of values to fit',
+ 1 ' Now:',2I5,'(<=0 goes on)')
+ READ(N5,*,ERR=1) N1,N2
+ IF(N1.LE.0.OR.N2.LE.0) GOTO 1
+ N1F=N1
+ N2F=MIN(N-N1+1,N2)
+C N2F=N2-N1+1
+ YN='W'
+ GOTO 2 ! to change weights (with new limits)
+C =========> coord lim. change
+ ELSE IF(YN.EQ.'C'.OR.YN.EQ.'c') THEN
+ YCEXIST=.FALSE.
+ WRITE(N6,9015) NINT( N1F *ABS(X(2)-X(1))+X(1)),
+ 1 NINT((N1F+N2F-1)*ABS(X(2)-X(1))+X(1))
+ 9015 FORMAT(' Enter coord of first and last value to fit',
+ 1 ' Now:',2I5,'(<=0 goes on)')
+ READ(N5,*,ERR=1) AN1,AN2
+ N1=(AN1-X(1))/(X(2)-X(1)) + 1
+ N2=(AN2-X(1))/(X(2)-X(1)) + 1
+ IF(N2.LE.N1) GOTO 1
+ IF(N1.LE.0) N1=1
+ IF(N2.GT.N) N2=N
+ N2=N2-N1+1 ! changed to number of points to fit
+ N1F=N1
+ N2F=N2
+ WRITE(N6,9016) N1F,N2F
+ 9016 FORMAT(' First point to fit:',I6,' Num.of points:',I6)
+ YN='W'
+ GOTO 2 ! to change weights (with new limits)
+C
+C
+C =======> par change
+ ELSE IF(YN.EQ.'G'.OR.YN.EQ.'g') THEN
+ YCEXIST=.FALSE.
+ WRITE(N6,9020) NL
+ 9020 FORMAT(' Enter the number of parameters to vary, now:',I3)
+ READ(N5,*,ERR=1) NLNEW
+ IF(NLNEW.LE.0.OR.NLNEW.GT.NPK) GOTO 1
+ WRITE(N6,9025) (LISTA(J),J=1,NL)
+ 9025 FORMAT(' The following parameters were varied:',(5(1X,I5)))
+ WRITE(N6,9030) (I,PK(I),I=1,NPK)
+ 9030 FORMAT(' Enter number of par. to vary and guess value: ',
+ 1 '(0 0 to go on)'
+ 2 /1X,I4,G15.5,' sigma'/1X,I4,G15.5,' D or ln D'
+ 3 /1X,I4,G15.5,' z '/ 1X,I4,G15.5,' power noise')
+ DO 3 I=1,NLNEW
+ READ(N5,*,ERR=1) N1 ,PAR
+ IF(N1.LE.0.OR.N1.GT.NPK) GOTO 1
+ LISTA(I)=N1
+ PK(N1)=PAR
+ 3 CONTINUE
+ NL=NLNEW
+C =======> iteration parameters change
+ ELSE IF (YN.EQ.'I'.OR.YN.EQ.'i') THEN
+ YCEXIST=.FALSE.
+ WRITE(N6,9040) MAXITER
+ 9040 FORMAT(' Enter max iteration, now:',I5)
+ READ(N5,*,ERR=1) MAXITER
+ IF (MAXITER.LE.0) MAXITER=50
+ WRITE(N6,9050) CONVERG
+ 9050 FORMAT(' Enter the convergency parameter, now:',G15.5)
+ READ(N5,*,ERR=1) CONVERG
+ IF(CONVERG.LE.0) CONVERG=0.01
+ WRITE(N6,9051) NPRINT
+ 9051 FORMAT(' Enter the print parameter, now:',I10)
+ READ(N5,*,ERR=1) NPRINT
+C =======> low freq filter
+ ELSE IF (YN.EQ.'Z'.OR.YN.EQ.'z'.OR.YN.EQ.'x'.OR.YN.EQ.'X') THEN
+ WRITE(N6,9053) N
+ 9053 FORMAT(' Enter low freq filter limit (max:',I5,
+ 1 ' ,<0 reset,0=default 10 )' )
+ READ(N5,*,ERR=1) AZDUM
+ NZERO=(AZDUM-X(1))/(X(2)-X(1)) +1
+ IF(NZERO.EQ.0 )NZERO=10 ! corrections to nzero
+ IF(AZDUM.LT.0) THEN
+ NZERO=0
+ NZERO1=0
+ NZEROC=0
+ NZEROC1=0
+ WRITE(N6,9054) NZERO1,NZERO
+ GOTO 1
+ ENDIF
+ IF(NZERO.GT.N) GOTO 1
+ AZDUM=(NZERO-1)*(X(2)-X(1))+X(1) ! corrected input value
+ NZERO1=(-AZDUM-X(1))/(X(2)-X(1)) +1
+ WRITE(N6,9054) NZERO1,NZERO
+ 9054 FORMAT(' I will zero weights in range:',2I5)
+ IF(YN.EQ.'X'.OR.YN.EQ.'x') THEN ! imm part if complex
+ NZEROC=NZERO+N/2
+ NZEROC1=NZERO1+N/2
+ WRITE(N6,9054) NZEROC1,NZEROC
+ ELSE
+ NZEROC=0
+ NZEROC1=0
+ ENDIF
+C
+C =======> weight change
+ ELSE IF (YN.EQ.'W'.OR.YN.EQ.'w') THEN
+ 89 WRITE(N6,9055) NWTYPE
+ 9055 FORMAT(' Enter weight option (now:',I3,'),'/
+ 1 ' 0= old values, 10=plot,', ' 9= set range values'/
+ 1 ' 1= 1., 2= abs(yfit)/(abs(yfit)+abs(y-yfit))'/
+ 2 ' 3=yfit/(y-yfit), 4= (complex): Pow yf/(Pyf+P(y-yf))'/
+ 2 ' 5=2 (y-yf)=>fit y 6= (complex): 4 P(y-yf) => fit'/
+ 2 ' 7=2 =>()**2'/
+ 3 ' 11= (complex): set freq. range'/
+ 3 ' 12= (complex, fitg only )=11 and 1/average( abs(FT))'
+ 4 )
+ READ(N5,*,ERR=1) NWDUM
+ IF(NWDUM.LE.0.) THEN
+ GOTO 1 ! interactive loop
+C
+ ELSE IF(NWDUM.EQ.10) THEN ! plot PESI
+ 150 WRITE(N6,9057)
+ 9057 FORMAT(' Do you want a plot for weights+function ? ',
+ 1 '(Y/N or W:weights only)')
+ READ(N5,6500,ERR=1) YN
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') THEN
+ XMAX=0. ! Y dots + Pesi continuous line
+ XMIN=0.
+ YMAX=0.
+ YMIN=0.
+ KFPLOT=2
+ CALL PLOTTA(N2F,X(N1F),X(N1F),Y(N1F),PESI(N1F),
+ 1 XMAX,XMIN,YMAX,YMIN,NAMEP,KFPLOT)
+ ELSE IF(YN.EQ.'W'.OR.YN.EQ.'w') THEN
+ XMAX=0. ! Pesi - continuous line
+ XMIN=0.
+ YMAX=0.
+ YMIN=0.
+ KFPLOT=1
+ CALL PLOTTA(N2F,X(N1F),X(N1F),PESI(N1F),Y(N1F),
+ 1 XMAX,XMIN,YMAX,YMIN,NAMEP,KFPLOT)
+ ENDIF
+ ELSE ! SET PESI
+ NWTYPE=NWDUM
+ CALL FITAW(NWTYPE,X,Y,YC,PESI,PXL,N,N1F,N2F,YCEXIST,FUNCZ)
+ ENDIF
+C
+C
+C =========> plot
+ ELSE IF(YN.EQ.'P'.OR.YN.EQ.'p') THEN
+ XMAX=0.0
+ XMIN=0.0
+ YMAX=0.0
+ YMIN=0.0
+ IF(.NOT.YCEXIST) THEN
+ DO 65 I=N1F,N1F+N2F-1
+ CALL FUNCZ(X(I),PK,YC(I),DYDA,NPK)
+ 65 CONTINUE
+ YCEXIST=.TRUE.
+ ENDIF
+ KFPLOT=2
+ CALL PLOTTA(N2F,X(N1F),X(N1F),Y(N1F),YC(N1F),
+ 1 XMAX,XMIN,YMAX,YMIN,NAME,KFPLOT)
+C =========> print
+ ELSE IF(YN.EQ.'S'.OR.YN.EQ.'s') THEN
+ IF(.NOT.YCEXIST) THEN
+ DO 66 I=N1F,N1F+N2F-1
+ CALL FUNCZ(X(I),PK,YC(I),DYDA,NPK)
+ 66 CONTINUE
+ YCEXIST=.TRUE.
+ ENDIF
+ CALL PRINTP(X,Y,YC,PESI)
+C ===========> Type
+ ELSE IF(YN.EQ.'T'.OR.YN.EQ.'t') THEN
+ IF(.NOT.YCEXIST) THEN
+ DO 67 I=N1F,N1F+N2F-1
+ CALL FUNCZ(X(I),PK,YC(I),DYDA,NPK)
+ 67 CONTINUE
+ YCEXIST=.TRUE.
+ ENDIF
+ 90 WRITE(N6,9000)
+ 9000 FORMAT(' Enter the first and last number to see ',
+ 1 '(<=0 to quit)')
+ READ(N5,*,ERR=500) N1,N2
+ IF(N1.LE.0.OR.N2.LE.0) GOTO 1
+ WRITE(N6,9500) (I,X(I),Y(I),YC(I),Y(I)-YC(I),I=N1,N2)
+ 9500 FORMAT(' n. ',10X,' X ',15X,' Y ',5X,' Y comp',
+ 1 15X,' Y-Ycomp.'/(1X,I5,4(1X,G15.5)) )
+ GOTO 90
+C
+ ENDIF
+C
+ GOTO 1 ! to ask for a new option (interactive usage)
+ 500 CONTINUE
+ WRITE(N6,5555)
+ 5555 FORMAT(' INPUT ERROR ! Command not executed !!!!!!')
+ GOTO 1
+ END
+C
+ SUBROUTINE FITAF(X,Y,YC,PESI,N,FUNCZ,MAXITER,NPRINT,CONVERG)
+C ---------------------------------------------------------
+C call numerical recies to fit and loops until converged:
+C CHI2 decreasing and:
+C ( delta chi2 < converg or (delta chi2)/chi2<0.00001
+C or chi2 < 1.e-12 )
+C Maxiter :max iterations
+C Nprint: print flag
+C funcz: function to fit
+C --------------------------------------------------------
+ DIMENSION X(N),Y(N),PESI(N),YC(N)
+ PARAMETER (MAXNPK=4)
+ COMMON/TAPE/ N5,N6,N7
+ REAL*8 DLL1
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+ EXTERNAL FUNCZ
+ DIMENSION ALPHA(MAXNPK,MAXNPK),COVAR(MAXNPK,MAXNPK)
+ DIMENSION BETA(MAXNPK),DPK(MAXNPK)
+ DIMENSION DYDA(MAXNPK)
+C
+ IF(NPK.GT.MAXNPK) THEN
+ WRITE(N6,1000) NPK
+ 1000 FORMAT(' ERROR IN SUBROUTINE FITAF ! TOO MANY PARAMETERS ')
+ NPK=MAXNPK
+ ENDIF
+C
+ ALAMBDA=-1.
+C Initialization call
+C npk is the number of par, nl the number of pars to vary,
+C addressed by lista(1..nl) ; they are: pk(lista(1..nl))
+C pesi are = 1/sig**2 in chisquare=sum ( (y-yc)**2/sig**2 )
+C
+ CALL MRQMIN(X,Y,PESI,N,PK,DPK,NPK,LISTA,
+ 1 NL,COVAR,ALPHA,BETA,MAXNPK,CHISQ,FUNCZ,ALAMBDA)
+ CHISQ1=CHISQ
+C ................ iterating until convergency reached
+ DO 20 I=1,MAXITER
+ CALL MRQMIN(X,Y,PESI,N,PK,DPK,NPK,LISTA,
+ 1 NL,COVAR,ALPHA,BETA,MAXNPK,CHISQ,FUNCZ,ALAMBDA)
+C
+ IF(NPRINT.GT.2) THEN
+ DUMQ=(N-NL/2.)
+ Q=GAMMQ(DUMQ,CHISQ/2.) ! integral of chi**2 distrib until this chi
+ WRITE(N6,1050) I,CHISQ/(N-NL),Q,(PK(J),J=1,NPK)
+ 1050 FORMAT(/1X,20('-'),'> ITER.:',I3,' CHI**2/(n-npk)=',G12.5,
+ 1 ' Q=',G12.5/
+ 2 ' sigma=',G12.5,' D=',G12.5,' z=',G12.5,' Np=',G12.5)
+ ENDIF
+ IF(NPRINT.GT.4) THEN
+ WRITE(N6,1100) ALAMBDA
+ 1100 FORMAT(20X,' lambda=',G15.5)
+ WRITE(N6,5500)(LISTA(J),PK(LISTA(J)),DPK(J),BETA(J),J=1,NL)
+ 5500 FORMAT(' Parameter:',I3,1X,G15.5,' delta:',G15.5,
+ 1 ' gradient:',G15.5)
+C WRITE(N6,3500) (LISTA(J),SQRT(COVAR(J,J)),J=1,NL)
+C DO 30 II=1,NL
+C WRITE(N6,4000) (LISTA(II),(COVAR(J,II),J=1,NL))
+ 4000 FORMAT( ' Covariance :'1X,I5,4(1X,G12.4) )
+C 30 CONTINUE
+C DO 35 II=1,NL
+C WRITE(N6,5000) (LISTA(II),(ALPHA(J,II),J=1,NL))
+ 5000 FORMAT( ' Hess./2=(cov)**(-1):'1X,I5,4(1X,G12.4) )
+C 35 CONTINUE
+ ENDIF
+C
+ IF( CHISQ.LT.1.E-12 .OR. (
+ 1 CHISQ.LT.CHISQ1 .AND. ( CHISQ1-CHISQ.LT.CONVERG
+ 2 .OR. (CHISQ1-CHISQ)/CHISQ .LT. 0.00001 )
+ 3 ) ) THEN
+ IF (NPRINT.GT.0) WRITE(N6,2000)
+ 2000 FORMAT(/30X,20('-')/29X,' CONVERGENCY REACHED.'/30X,20('-'))
+ GOTO 100
+ ENDIF
+ CHISQ1=CHISQ
+ 20 CONTINUE ! .......... iteration loop
+C
+ IF (NPRINT.GT.0) THEN
+ WRITE(N6,3000)
+ 3000 FORMAT(/25X,35('-')/24X,' WARNING! Convergency NOT reached !'
+ 1 /25X,35('-'))
+ ELSE
+ WRITE(N6,3001)
+ 3001 FORMAT(' Convergency not reached.')
+ ENDIF
+C
+ 100 CONTINUE
+C evaluate erro matrix
+ ALAMBDA=0.0
+ CALL MRQMIN(X,Y,PESI,N,PK,DPK,NPK,LISTA,
+ 1 NL,COVAR,ALPHA,BETA,MAXNPK,CHISQ,FUNCZ,ALAMBDA)
+C
+C formal errors from covariance matrix
+ DO 36 J=1,NPK
+C FORERR(J)=SQRT(COVAR(LISTA(J),LISTA(J)) ) mrqmin reorders covar
+ FORERR(J)=SQRT(COVAR(J,J))
+ 36 CONTINUE
+C
+ DUMQ=(N-NL/2.)
+ Q=GAMMQ(DUMQ,CHISQ/2.) ! integral of chi**2 distrib until this chi
+C
+ IF(NPRINT.GT.0) THEN
+C
+ WRITE(N6,1050) I,CHISQ/(N-NL),Q,(PK(J),J=1,NPK)
+ DO 37 II=1,NL
+ WRITE(N6,4000) (LISTA(II),(COVAR(J,II),J=1,NL))
+ 37 CONTINUE
+ WRITE(N6,3500) (J, FORERR(J),J=1,NL)
+ 3500 FORMAT( ' Formal errors.:',4(1X,I3,1X,G12.4) )
+C DO 39 II=1,NL
+C WRITE(N6,5000) (LISTA(II),(ALPHA(J,II),J=1,NL))
+C 39 CONTINUE
+C
+C ZETA=PK(3)*DLL ! WRONG ! good only for low zeta (first order approx)
+ DLL1=DBLE(DLL)/299792.458D0+1.D0 ! =TL(2)/TL(1)
+ VZETA=(DLL1**PK(3)-1.D0)*299792.458D0
+ DVZETA=DLL*FORERR(3)
+ VSIGMA=DLL*PK(1)
+ DVSIGMA=DLL*FORERR(1)
+ GAMMA=PK(2)
+ DGAMMA=FORERR(2)
+ WRITE(N6,5550) VZETA,DVZETA,VSIGMA,DVSIGMA,GAMMA,DGAMMA
+ WRITE(N7,5550) VZETA,DVZETA,VSIGMA,DVSIGMA,GAMMA,DGAMMA
+ 5550 FORMAT(' z(Km/sec):',F7.0,'+-',G7.1,
+ 1 ' sigma:',F5.0,'+-',G7.1,' D:',G12.5,'+-',G12.5)
+C
+ ENDIF
+C
+C .........................................................
+C WARNING ! weights are filtering functions,
+C with no statistical sense CHI SQUARE AND
+C FORMAL ERRORS MAY BE ! Estimate of a
+C factor to change chi into a real chi ( maybe..?)
+C
+C computes Y fitted values
+ DO 70 I=1,N
+ CALL FUNCZ(X(I),PK,YC(I),DYDA,NPK)
+ 70 CONTINUE
+C
+ SOMMA0=0.0
+ SOMMA1=0.0
+C sum of 1/pesi=assumed error**2 and y-yfit **2=error estimate
+C chifactor= ( used error**2 / (y-yfit)**2 )
+ DO 71 I=1,N
+ SOMMA0=SOMMA0+(YC(I)-Y(I))**2
+ IF(pesi(i).ne.0.0) SOMMA1=SOMMA1 + ABS(1./PESI(I))
+ 71 CONTINUE ! sum 1/pesi =( assumed error) **2
+ AVERERR2=SOMMA0/N
+ IF(SOMMA1.NE.0.0.AND.SOMMA0.NE.0. ) THEN
+ CHIFACTOR=SOMMA1/SOMMA0 !possible factor for chi**2
+ ELSE
+ CHIFACTOR=0.
+ ENDIF
+C .................................
+ RETURN
+ END
+C
+ SUBROUTINE FITAW(NWTYPE,X,Y,YC,PESI,PXL,N,N1F,N2F,YCEXIST,
+ 1 FUNCZ)
+C ----------------------------------------------------------
+C Defines weights for subroutine FITA
+C depending on nwtype
+C For option 12 ( used by FITG complex), needs in W2 abs(FT)
+C ----------------------------------------------------------
+ PARAMETER (NPTMX=10000)
+ PARAMETER (MAXNPK=4)
+ DIMENSION DYDA(MAXNPK)
+ DIMENSION X(N),Y(N),YC(N),PESI(N),PXL(N)
+ LOGICAL YCEXIST
+ EXTERNAL FUNCZ
+ COMMON/TAPE/ N5,N6,N7
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+ COMPLEX W1
+ COMMON /WEIGHT/W(NPTMX),W1(NPTMX),W2(NPTMX)
+C
+C
+ NFINAL=N1F+N2F-1
+C
+C ..................... noise computation
+C infer noise from a fit of selected zones of Y
+C (supposed to be a power spectrum)
+ IF(NWTYPE.EQ.5) THEN
+ WRITE(N6,9100) N
+ 9100 FORMAT(' Enter first and num of values EXCLUDED from',
+ 1 ' noise comp.(dim y:',I6,')'/
+ 2 ' 0 => give coord of first and last value, -1=>exit')
+ READ(N5,*,ERR=500) N1,N2
+ IF(N1.LT.0.OR.N2.LT.0) GOTO 499 ! RETURN
+ N2=MIN(N2,N-N1+1)
+ IF(N1.EQ.0) THEN
+ WRITE(N6,9102)
+ 9102 FORMAT(' Enter coord. limits')
+ READ(N5,*,ERR=500) AN1,AN2
+ N1=(AN1-X(1))/(X(2)-X(1)) + 1
+ N2=(AN2-X(1))/(X(2)-X(1)) + 1
+ IF(N2.LE.N1) GOTO 500
+ IF(N1.LE.0) N1=1
+ IF(N2.GT.N) N2=N
+ N2=N2-N1+1
+ ENDIF
+ WRITE(N6,9104) N1,N2+N1-1,N
+ 9104 FORMAT(' Fitting from 1 to ',I5,
+ 1 ' and from:',I5,' to:',I5)
+C Wheights for the fit, to exclude zone 1-n1 , n1+n2-n
+ DO 91 I=1,N1-1
+ 91 PESI(I)=1.
+ DO 92 I=N1+N2,N
+ 92 PESI(I)=1.
+ DO 93 I=N1,N1+N2-1
+ 93 PESI(I)=1000000000.
+C fitting a straignt line to y in selected zones
+ CALL FIT(PXL,Y,N,PESI,1,B,A,SIGB,SIGA,CHI2,Q)
+ WRITE(6,9106) A,SIGA,B,SIGB,CHI2
+ 9106 FORMAT(' A*i+B => A:',G12.4,' +- ',G12.4,' B:',G12.4,
+ 1 ' +- ',G12.4,' chi2:',G12.4)
+ ENDIF
+C
+C Computes power spectrum for Y complex, supposing
+C that the first N/2 values contain the real part,
+C the last N/2 the imm. part.
+C A fit to a selected zone of the pow. spectrum
+C is used to estimate the noise.
+C
+ IF(NWTYPE.EQ.6) THEN
+ WRITE(N6,9100) N/2
+ READ(N5,*,ERR=500) N1,N2
+ IF(N1.LT.0.OR.N2.LT.0) GOTO 500
+ N2=MIN(N2,N/2-N1+1)
+ IF(N1.EQ.0) THEN
+ WRITE(N6,9102)
+ READ(N5,*,ERR=500) AN1,AN2
+ N1=(AN1-X(1))/(X(2)-X(1)) + 1
+ N2=(AN2-X(1))/(X(2)-X(1)) + 1
+ IF(N2.LE.N1) GOTO 500
+ IF(N1.LE.0) N1=1
+ IF(N2.GT.N/2) N2=N/2
+ N2=N2-N1+1
+ ENDIF
+ WRITE(N6,9104) N1,N2+N1-1,N/2
+ DO 94 I=1,N1-1
+ 94 PESI(I)=1.
+ DO 95 I=N1+N2,N/2
+ 95 PESI(I)=1.
+ DO 96 I=N1,N1+N2-1
+ 96 PESI(I)=1000000000.
+ YCEXIST=.FALSE. ! Yc is used here as a work. array
+ DO 97 I=1,N/2
+ ICON=MOD(I+N/2,N) ! place of the complex conj.
+ YC(I)=Y(I)**2+Y(ICON)**2
+ 97 CONTINUE
+C fitting a straignt line to power y in selected zones
+ CALL FIT(PXL,YC,N/2,PESI,1,B,A,SIGB,SIGA,CHI2,Q)
+ WRITE(6,9106) A,SIGA,B,SIGB,CHI2
+ ENDIF
+C
+C ......... different wheight options
+C
+ IF(NWTYPE.EQ.1) THEN ! all weights are equal
+ DO 10 I=N1F,NFINAL
+ 10 PESI(I)=1.
+C
+ ELSE IF(NWTYPE.LE.7) THEN ! all cases in which must compute YC
+ IF(.NOT.YCEXIST) THEN ! computes Y fitted values
+ DO 11 I=N1F,NFINAL
+ CALL FUNCZ(X(I),PK,YC(I),DYDA,NPK)
+ 11 CONTINUE
+ YCEXIST=.TRUE.
+ ENDIF
+ YMIN=YC(N1F) ! min & max Yc value
+ YMAX=YC(N2F+N1F-1)
+ DO 12 I=N1F,NFINAL
+ IF(YMIN.GT.YC(I)) YMIN=YC(I)
+ IF(YMAX.LT.YC(I)) YMAX=YC(I)
+ 12 CONTINUE
+ IF(YMIN.EQ.0.0) YMIN=YMAX/1.E6
+ IF(YMIN.EQ.0.0) YMIN=1. ! And all weights will be 1
+C
+ IF(NWTYPE.EQ.2.OR.NWTYPE.EQ.5) THEN
+ DO 13 I=N1F,NFINAL ! pesi=abs(yfit/(abs y+abs(y-yfit))
+ ABSYC=ABS(YC(I)-YMIN)
+ IF(NWTYPE.EQ.2) THEN
+ ABSY=ABSYC+ABS(Y(I)-YC(I)) ! noise as Y-Yc
+ ELSE
+ ABSY=ABSYC+ABS(A*PXL(I)+B) ! noise as a straight line
+ ENDIF
+ IF(ABSY.EQ.0.0) THEN
+ PESI(I)=0.
+ ELSE
+ PESI(I)=ABSYC/ABSY
+ ENDIF
+ 13 CONTINUE
+C
+ ELSE IF(NWTYPE.EQ.7) THEN
+ DO 31 I=N1F,NFINAL ! pesi=(yfit)**2/(Y**2+(y-yfit)**2)
+ ABSYC=(YC(I)-YMIN)**2
+ ABSY=ABSYC+(Y(I)-YC(I))**2 ! noise as Y-Yc
+ IF(ABSY.EQ.0.0) THEN
+ PESI(I)=0.
+ ELSE
+ PESI(I)=ABSYC/ABSY
+ ENDIF
+ 31 CONTINUE
+C
+ ELSE IF(NWTYPE.EQ.3.OR.NWTYPE.EQ.6) THEN
+ DO 14 I=N1F,NFINAL ! pesi = yfit/(y-yfit)
+ ABSYC=YC(I)-YMIN
+ ABSYCY=ABS(Y(I)-YC(I))
+ IF (ABSYCY.EQ.0.0) THEN
+ PESI(I)=0.
+ ELSE
+ PESI(I)=ABSYC/ABSYCY
+ ENDIF
+ 14 CONTINUE
+ ELSE IF(NWTYPE.EQ.4) THEN ! pesi= wiener type
+ DO 15 I=N1F,NFINAL
+ ICON=MOD(I+N/2,N) ! find complex conj. in the array
+ ANUM=YC(I)**2+YC(ICON)**2
+ IF(NWTYPE.EQ.4) THEN ! noise as pow(y-yc)
+ DENOM=ANUM+(Y(I)-YC(I))**2 + (Y(ICON)-YC(ICON))**2
+ ELSE
+ NPXL=MOD(I-1,N/2) ! pxl in fit begins from 0
+ DENOM=ANUM+ABS(A*NPXL+B) ! noise as a straight line
+ ENDIF
+ IF(DENOM.EQ.0.) THEN
+ PESI(I)=0.
+ ELSE
+ PESI(I)=ANUM/DENOM
+ ENDIF
+ 15 CONTINUE
+ ENDIF
+C
+C Sets a range of weights to a given value
+ ELSE IF(NWTYPE.EQ.9) THEN
+ 44 WRITE(N6,9058)
+ 9058 FORMAT(
+ 1 ' Enter coord-range to set and weight=1/sqrt(err)(0=ex)')
+ READ(N5,*,ERR=500) AN1,AN2,DUM
+ N1=(AN1-X(1))/(X(2)-X(1)) + 1
+ N2=(AN2-X(1))/(X(2)-X(1)) + 1
+ IF(N2.LE.N1) GOTO 499 ! RETURN
+ IF(N1.LE.0) N1=1
+ IF(N2.GT.N) N2=N
+ DO 45 I=N1,N2
+ 45 PESI(I)=DUM
+ WRITE(N6,9059) N1,N2,DUM
+ 9059 FORMAT(' Weights from:',I5,' to:',I5,' set to:',G15.5)
+ GOTO 44
+C
+ ELSE IF(NWTYPE.EQ.11.OR.NWTYPE.EQ.12) THEN
+C 11-12 for complex fit : set frequency range
+C 11 : set pesi=1 for allowed frequency
+C 12 : set insead pesi=1/average(abs(FT))
+C
+ NN4=N/4 ! i.e. if n=2048 then points 0:512 = freq -512 -1
+ NN2=N/2 ! points 513:1024 = freq 0 511 for real part
+ WRITE(N6,9060) NN4 ! pnts 1025 : ... = imm part=-512 -511 ...
+ 9060 FORMAT(' Enter freq. range to use (from 0 to',I5,')')
+ READ(N5,*,ERR=500) AN1,AN2
+ IF(AN1.LT.0.) AN1=0.
+ IF(AN2.GT.NN4) AN2=NN4
+C
+ N1=NN4+1-AN2
+ N2=NN4+1-AN1
+ N3=NN4+1+AN1
+ N4=NN4+1+AN2
+ IF(N4.GT.NN2) N4=NN2
+ IF(N1.LE.0) N1=1
+C Zero pesi in unused zones
+ DO 46 I=1,N1-1
+ 46 PESI(I)=0.
+ DO 47 I=N2+1,N3-1
+ 47 PESI(I)=0.
+ DO 48 I=N4+1,NN2
+ 48 PESI(I)=0.
+C
+ IF(NWTYPE.EQ.11) THEN ! PESI=1 in used zones
+ DO 49 I=N1,N2
+ 49 PESI(I)=1.
+ DO 50 I=N3,N4
+ 50 PESI(I)=1.
+ ELSE ! NWTYPE=12, PESI=1/AVERAGE(ABS(FT))
+ 51 WRITE(N6,9064) NN2
+ 9064 FORMAT(' Enter rum mean window(def.10, max:',I5,')')
+ READ(N5,*,ERR=51) NSTEP10
+ IF(NSTEP10.LE.0.OR.NSTEP10.GT.NN2) NSTEP10=10
+C
+ CALL RUNMC1(NSTEP10,NN2,N1,N2,W2,PESI) !pesi=run.mean of W2
+ DO 52 I=N1,N2 ! between N1:N2
+ IF(PESI(I).NE.0.)PESI(I)=1./PESI(I)
+ 52 CONTINUE !ABS(FT) placed in W2 by FITG
+ CALL RUNMC1(NSTEP10,NN2,N3,N4,W2,PESI)
+ DO 53 I=N3,N4
+ IF(PESI(I).NE.0.0) PESI(I)=1./PESI(I)
+ 53 CONTINUE
+ ENDIF
+C Pesi for Imm. part
+ DO 54 I=1,NN2
+ 54 PESI(I+NN2)=PESI(I)
+C
+ WRITE(N6,9066) N1-1,N2+1,N3-1,N4+1,NN2,
+ 1 -NN4-1,N1-2-NN4,N2-NN4,N3-2-NN4,NN2-NN4-1,NN2
+ 9066 FORMAT(' weights=0 between: 0',I5, ' ; ',2I5,' ; ',
+ 1 2I5/ ' frequency:'2I5,' ; ',2I5,' ; ',2I5)
+ WRITE(N6,9068) N1,N2,N3,N4,
+ 1 N1-NN4-1,N2-NN4-1,N3-NN4-1,N4-NN4-1
+ 9068 FORMAT(' Weights set between:',2I5,' ; ',2I5/
+ 1 ' frequency:',2I5,' ; ',2I5)
+C
+C ......................................................
+ ENDIF ! if on different weighting options: NWTYPE
+C ......................................................
+ 499 RETURN
+ 500 WRITE(N6,5000)
+ 5000 FORMAT(' INPUT ERROR ! ')
+ RETURN
+ END
+C
+ SUBROUTINE FITG(N,TL,T,SL,S,N2,TLW,TW,SLW,SW,FS,FT,KINT,PXL)
+C -----------------------------------------------------
+C calls fita to fit FG with : FT*GAUS*EXP(IZ)
+C KINT=1 is passed to fita to have an interactive fit
+C TL,T,SL,S, : work. arrays passed to fita
+C TW,TLW,SL,SLW :work. arrays passed to fita for complex fits
+C ----------------------------------------------------
+ PARAMETER (NPTMX=10000)
+ COMMON/TAPE/ N5,N6,N7
+ COMPLEX W1 ! weight pass weigths to fit functions and fitaw
+ COMMON /WEIGHT/W(NPTMX),W1(NPTMX),W2(NPTMX)
+ REAL*8 DLL,DLL1
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+ DIMENSION TL(N),T(N),SL(N),S(N)
+ DIMENSION TLW(N2),TW(N2),SLW(N2),SW(N2)
+ DIMENSION PXL(N)
+ COMPLEX FS(N),FT(N)
+ CHARACTER*1 YN
+ CHARACTER*20 NOME/' FIT-Fgal'/
+ CHARACTER*20 NOME1/' FIT-Fgal-LnPow'/
+ CHARACTER*20 NOME2/' FIT-Fgal_Pow'/
+ EXTERNAL GAUSG,PARABG,GAUSGT
+ REAL PI/3.14159265/
+C
+ IF(N.LE.3) THEN
+ WRITE(N6,999) N
+ 999 FORMAT(' ERROR! fourier transform with only ',I3,' points !')
+ RETURN
+ ENDIF
+C
+ N1=N/2
+ ENNE=REAL(N)
+C
+ 1 CONTINUE ! loop on different way of fitting
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter:'/
+ 1 6X,' E,0 => end fitting,'/
+ 2 6X,' P => parabolic fit to ln(abs(FG)),'/
+ 3 6X,' X => exp fit to abs(FG),'/
+ 4 6X,' C => complex fit to FG.' )
+ READ(N5,2000) YN
+ 2000 FORMAT(A)
+ IF(YN.EQ.'E'.OR.YN.EQ.'e'.OR.YN.EQ.'0') THEN
+ RETURN
+C parabolic fit to the module to have sigma and D
+C ................................................
+ ELSE IF(YN.EQ.'P'.OR.YN.EQ.'p') THEN
+ DO 20 I=1,N1
+C frequencies
+ TL(I)=REAL(I-1-N1)
+ TL(I+N1)=REAL(I-1)
+C modules
+ T(I)=ABS(FS(I+N1))
+ T(I+N1)=ABS(FS(I))
+C Template log abs passed via COMMON weight
+ AADUM=ABS(FT(I+N1))
+ IF(AADUM.EQ.0.0) AADUM=1.E-30
+ W2(I)=LOG(AADUM)
+ AADUM=ABS(FT(I))
+ IF(AADUM.EQ.0.0) AADUM=1.E-30
+ W2(I+N1)=LOG(AADUM)
+C initial weights for fitting
+ SL(I)=1.
+ SL(I+N1)=1.
+ 20 CONTINUE
+C find min , but >0 , abs value
+ AMIN=0.0
+ DO 21 I=1,N
+ IF(T(I).GT.0.0.AND.AMIN.GT.T(I) ) AMIN=T(I)
+ 21 CONTINUE
+ IF(AMIN.LE.0.0) AMIN=1.
+ DO 22 I=1,N
+ IF(T(I).GT.0.0) THEN
+ T(I)=LOG(T(I))
+ ELSE
+ T(I)=AMIN
+ ENDIF
+ 22 CONTINUE
+C
+ NPK=2 ! 2 parameters are used
+ LISTA(1)=1 ! first is sigma
+ LISTA(2)=2 ! second is D
+ NL=2 ! 2 parameters are varied
+ IF(PK(2).GT.0.0) PK(2)=LOG(PK(2)) ! This is a ln fit
+ CALL FITA(N,TL,T,SL,S,KINT,PARABG,NOME1,PXL)
+ D=EXP(PK(2))
+ SIGMA=PK(1)*DLL
+ WRITE(N6,3000) PK(1),PK(2),D,SIGMA
+ 3000 FORMAT(' sigma/c=',G15.5,' ln D=',G15.5/' D=',G15.5,
+ 1 ' sigma(km/sec)=',G15.5)
+ PK(2)=D ! reset pk from ln
+C
+C exp fitting to the module to have sigma and D
+C ................................................
+ ELSE IF(YN.EQ.'X'.OR.YN.EQ.'x') THEN
+ DO 25 I=1,N1
+C frequencies
+ TL(I)=REAL(I-1-N1)
+ TL(I+N1)=REAL(I-1)
+C modules
+ T(I)=ABS(FS(I+N1))
+ T(I+N1)=ABS(FS(I))
+C Template abs passed via COMMON weight
+ W2(I)=ABS(FT(I+N1))
+ W2(I+N1)=ABS(FT(I))
+C initial weights for fitting
+ SL(I)=1.
+ SL(I+N1)=1.
+ 25 CONTINUE
+ NPK=4 ! 4 pk are used
+ LISTA(1)=1 ! first is sigma
+ LISTA(2)=2 ! second d
+ LISTA(3)=4 ! fourth is the mean power noise
+ NL=3 ! 3 pk are varied
+ LISTA(4)=3 ! pk(3)=z is not changed (power isn't z dep.)
+ CALL FITA(N,TL,T,SL,S,KINT,GAUSGT,NOME2,PXL)
+ SIGMA=PK(1)*DLL
+ WRITE(N6,3500) PK(1),PK(2),SIGMA,PK(4),DLL
+ 3500 FORMAT(' sigma/c=',G15.5,' D=',G15.5/
+ 1 ' sigma(km/sec)=',G15.5,' power noise:',G15.5,
+ 2 ' Km/sec/pixel:',G12.4)
+C
+C Fitting the real and imm part of FG=FT*exp(..)
+C ................................................
+ ELSE IF(YN.EQ.'C'.OR.YN.EQ.'c') THEN
+ DO 40 I=1,N1
+C fases (first N1 negative values, then N1 positive
+C then N1 neg. imm, last N1 positive imm )
+ TLW(I)=REAL(I-1-N1)
+ TLW(I+N)=TLW(I) + N
+ TLW(I+N1)=REAL(I-1)
+ TLW(I+N1+N)=TLW(I+N1) + N
+C real and imm. part as a single string of lenght 2*N
+ TW(I)= REAL(FS(I+N1))
+ TW(I+N)=AIMAG(FS(I+N1))
+ TW(I+N1)= REAL(FS(I))
+ TW(I+N1+N)=AIMAG(FS(I))
+C complex FT (to be passed by common /weight/ to GAUSG routine)
+ W1(I)=FT(I+N1)
+ W1(I+N1)=FT(I)
+ W2(I)=ABS(W1(I)) ! needed by fitaW for weight type nwtype=12
+ W2(I+N1)=ABS(W1(I+N1) )
+ SLW(I)=1. ! weights
+ SLW(I+N1)=1.
+ SLW(I+N)=1.
+ SLW(I+N+N1)=1.
+ 40 CONTINUE
+C
+ NPK=3 ! 3 parameters
+ LISTA(1)=1 ! sigma
+ LISTA(2)=2 ! D
+ LISTA(3)=3 ! z
+ NL=3 ! 3 parameters varied
+ CALL FITA(N2,TLW,TW,SLW,SW,KINT,GAUSG,NOME,PXL)
+C Z=PK(3)*DLL ! WRONG ! good only for low zeta (first order approx)
+ DLL1=DBLE(DLL)/299792.458D0+1.D0 ! =TL0(2)/TL0(1)
+ Z=(DLL1**PK(3)-1.D0)*299792.458D0
+ SIGMA=PK(1)*DLL
+ WRITE(N6,5000) PK(1),PK(2),PK(3),Z,SIGMA,DLL
+ 5000 FORMAT(' sigma/c=',G15.5,' D=',G15.5,' Z=',G15.5/
+ 1 ' Z, sigma(km/sec)=',2G15.5,' Km/sec/pixel:',G12.4)
+C READ(N5,*)
+C
+ ENDIF
+C .......................................................
+ GOTO 1 ! to choose an other way of fitting
+C
+ END
+C
+ SUBROUTINE FITS(N,TL,T,SL,S,N2,TLW,TW,SLW,SW,FG,KINT,PXL)
+C -----------------------------------------------------
+C calls fita to fit the ln sqrt(power spectrum), the power spectrum
+C power specrum+noise or complex FG
+C KINT=1 is passed to fita to have an interactive fit
+C TL,T,SL,S, : work. arrays passed to fita
+C TW,TLW,SL,SLW :work. arrays passed to fita for complex fits
+C ----------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C Fit parameters and guess values:
+C LGPK(i)>=1 if GPK(i) is set ; PK are the parameters
+ REAL*8 DLL,DLL1
+ COMMON /GUESSPK/ENNE,DLL,GPK(4),LGPK(4),PK(4),NL,NPK,LISTA(4)
+ 1 ,CHISQ,Q,FORERR(4),CHIFACTOR,AVERERR2
+ DIMENSION TL(N),T(N),SL(N),S(N)
+ DIMENSION TLW(N2),TW(N2),SLW(N2),SW(N2)
+ DIMENSION PXL(N)
+ COMPLEX FG(N)
+ CHARACTER*1 YN
+ CHARACTER*20 NOME/' FIT-ln-Abs-FS'/
+ CHARACTER*20 NOME1/' FIT-FS'/
+ CHARACTER*20 NOME2/' FIT-Abs-FS'/
+ CHARACTER*20 NOME3/' FIT-Pow+FS+N'/
+ CHARACTER*20 NOME4/' FIT-Ln(Pow(FS+N))'/
+ EXTERNAL PARAB,GAUSC,GAUS,GAUS2,GAUS2N,GAUS2NL
+ REAL PI/3.14159265/
+C
+ IF(N.LE.3) THEN
+ WRITE(N6,999) N
+ 999 FORMAT(' ERROR! fourier transform with only ',I3,' points !')
+ RETURN
+ ENDIF
+C
+ N1=N/2
+ ENNE=REAL(N)
+C
+ 1 CONTINUE ! loop on different way of fitting
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter:'/
+ 1 6X,' E,0 => end fitting,'/
+ 2 6X,' P => parabolic fit to ln(abs(FS=FG/FT)),'/
+ 3 6X,' X => exp fit to abs(FS=FG/FT),'/
+ 4 6X,' C => complex fit to FS=FG/FT,'/
+ 5 6X,' N => Pow(exp+NOISE) fit to Pow(fg/ft),'/
+ 6 6X,' L => LN(Pow(exp+NOISE)) fit to LN(Pow(fg/ft)).')
+ READ(N5,2000) YN
+ 2000 FORMAT(A)
+ IF(YN.EQ.'E'.OR.YN.EQ.'e'.OR.YN.EQ.'0') THEN
+ RETURN
+ ELSE IF(YN.EQ.'P'.OR.YN.EQ.'p') THEN
+C parabolic fit to the module to have sigma and D
+C ................................................
+ DO 20 I=1,N1
+C frequencies
+ TL(I)=REAL(I-1-N1)
+ TL(I+N1)=REAL(I-1)
+C modules
+ T(I)=ABS(FG(I+N1))
+ T(I+N1)=ABS(FG(I))
+ SL(I)=1. ! weights
+ SL(I+N1)=1.
+ 20 CONTINUE
+C find min , but >0 , abs value
+ AMIN=0.0
+ DO 21 I=1,N
+ IF(T(I).GT.0.0.AND.AMIN.GT.T(I) ) AMIN=T(I)
+ 21 CONTINUE
+ IF(AMIN.LE.0.0) AMIN=1.
+ DO 22 I=1,N
+ IF(T(I).GT.0.0) THEN
+ T(I)=LOG(T(I))
+ ELSE
+ T(I)=AMIN
+ ENDIF
+ 22 CONTINUE
+C
+ NPK=2 ! 2 parameters are used
+ LISTA(1)=1 ! first is sigma
+ LISTA(2)=2 ! second is D
+ NL=2 ! 2 parameters are varied
+ IF(PK(2).GT.0.0) PK(2)=LOG(PK(2)) ! This is a ln fit
+ CALL FITA(N,TL,T,SL,S,KINT,PARAB,NOME,PXL)
+ D=EXP(PK(2))
+ SIGMA=PK(1)*DLL
+ WRITE(N6,3000) PK(1),PK(2),D,SIGMA,DLL
+ 3000 FORMAT(' sigma/c=',G15.5,' ln D=',G15.5/' D=',G15.5/
+ 1 ' sigma(km/sec)=',G15.5,' Km/sec/pixel:',G15.5)
+ PK(2)=D ! reset pk from ln
+C READ(N5,*)
+C exp fitting to ABS(FG/FT=FS) to have sigma and D
+C ................................................
+ ELSE IF(YN.EQ.'X'.OR.YN.EQ.'x') THEN
+ DO 25 I=1,N1
+C frequencies
+ TL(I)=REAL(I-1-N1)
+ TL(I+N1)=REAL(I-1)
+C modules
+C T(I)=FG(I+N1)*CONJG(FG(I+N1))
+C T(I+N1)=FG(I)*CONJG(FG(I))
+ T(I)=ABS(FG(I+N1))
+ T(I+N1)=ABS(FG(I))
+ SL(I)=1. ! weights
+ SL(I+N1)=1.
+ 25 CONTINUE
+ NPK=4 ! 4 pk are used
+ LISTA(1)=1 ! first is sigma
+ LISTA(2)=2 ! second d
+ LISTA(3)=4 ! fourth is the mean power noise
+ NL=3 ! 3 pk are varied
+ LISTA(4)=3 ! pk(3)=z is not changed (power isn't z dep.)
+C CALL FITA(N,TL,T,SL,S,KINT,GAUS2,NOME2,PXL)
+ CALL FITA(N,TL,T,SL,S,KINT,GAUS,NOME2,PXL)
+ SIGMA=PK(1)*DLL
+ WRITE(N6,3500) PK(1),PK(2),SIGMA,PK(4),DLL
+ 3500 FORMAT(' sigma/c=',G15.5,' D=',G15.5/
+ 1 ' sigma(km/sec)=',G15.5,' power noise:',G15.5,
+ 2 ' Km/sec/pixel:',G15.5)
+C READ(N5,*)
+C
+C exp+NOISE fitting to power=ft/fs*conj(ft/fs) to have sigma and D,Z,noise
+C ................................................
+ ELSE IF(YN.EQ.'N'.OR.YN.EQ.'n') then
+ DO 30 I=1,N1
+C frequencies
+ TL(I)=REAL(I-1-N1)
+ TL(I+N1)=REAL(I-1)
+C modules
+ T(I)=FG(I+N1)*CONJG(FG(I+N1))
+ T(I+N1)=FG(I)*CONJG(FG(I))
+ SL(I)=1. ! weights
+ SL(I+N1)=1.
+ 30 CONTINUE
+ NPK=4 ! 4 pk are used
+ LISTA(1)=1 ! first is sigma
+ LISTA(2)=2 ! second d
+ LISTA(3)=3 ! pk(3)=z arise in interference term
+ LISTA(4)=4 ! fourth is the mean power noise
+ IF(PK(4).EQ.0.0) PK(4)=PK(2)*0.0001 ! Or fita will found sing.matrix
+ IF(PK(4).EQ.0.0) PK(4)=0.0001
+ NL=4 ! 4 pk are varied
+ CALL FITA(N,TL,T,SL,S,KINT,GAUS2N,NOME3,PXL)
+ DLL1=DLL/299792.458D0+1.D0 ! =TL0(2)/TL0(1)
+ Z=(DLL1**PK(3)-1.D0)*299792.458D0
+ SIGMA=PK(1)*DLL
+ WRITE(N6,3600) PK(1),PK(2),PK(3),PK(4),Z,SIGMA,DLL
+ 3600 FORMAT(' sigma/c=',G15.5,' D=',G15.5,' Z=',G15.5,
+ 1 ' N=',G12.4/
+ 1 ' Z, sigma(km/sec)=',2G15.5,' Km/sec/pixel:',G12.4)
+C READ(N5,*)
+C
+C exp+NOISE fitting to LN (power=ft/fs*conj(ft/fs) ) =>sigma and D,Z,noise
+C ................................................
+ ELSE IF(YN.EQ.'L'.OR.YN.EQ.'l') THEN
+ DO 35 I=1,N1
+C frequencies
+ TL(I)=REAL(I-1-N1)
+ TL(I+N1)=REAL(I-1)
+C modules
+ T(I)=LOG(FG(I+N1)*CONJG(FG(I+N1)))
+ T(I+N1)=LOG(FG(I)*CONJG(FG(I)))
+ SL(I)=1. ! weights
+ SL(I+N1)=1.
+ 35 CONTINUE
+ NPK=4 ! 4 pk are used
+ LISTA(1)=1 ! first is sigma
+ LISTA(2)=2 ! second d
+ LISTA(3)=3 ! pk(3)=z arise in interference term
+ LISTA(4)=4 ! fourth is the mean power noise
+ IF(PK(4).EQ.0.0) PK(4)=PK(2)*0.0001 ! Or fita will found sing.matrix
+ IF(PK(4).EQ.0.0) PK(4)=0.0001
+ NL=4 ! 4 pk are varied
+ CALL FITA(N,TL,T,SL,S,KINT,GAUS2NL,NOME4,PXL)
+ DLL1=DLL/299792.458D0+1.D0 ! =TL0(2)/TL0(1)
+ Z=(DLL1**PK(3)-1.D0)*299792.458D0
+ SIGMA=PK(1)*DLL
+ WRITE(N6,3600) PK(1),PK(2),PK(3),PK(4),Z,SIGMA,DLL
+C READ(N5,*)
+C Fitting the real and imm part of FG
+C ................................................
+ ELSE IF(YN.EQ.'C'.OR.YN.EQ.'c') THEN
+ DO 40 I=1,N1
+C fases (first N1 negative values, then N1 positive
+C then N1 neg. imm, last N1 positive imm )
+ TLW(I)=REAL(I-1-N1)
+ TLW(I+N)=TLW(I) + N
+ TLW(I+N1)=REAL(I-1)
+ TLW(I+N1+N)=TLW(I+N1) + N
+C real and imm. part as a single string of lenght 2*N
+ TW(I)= REAL(FG(I+N1))
+ TW(I+N)=AIMAG(FG(I+N1))
+ TW(I+N1)= REAL(FG(I))
+ TW(I+N1+N)=AIMAG(FG(I))
+C initial weights for fitting
+ SLW(I)=1.
+ SLW(I+N)=1.
+ SLW(I+N1)=1.
+ SLW(I+N1+N)=1.
+ 40 CONTINUE
+C
+ NPK=3 ! 3 parameters
+ LISTA(1)=1 ! sigma
+ LISTA(2)=2 ! D
+ LISTA(3)=3 ! z
+ NL=3 ! 3 parameters varied
+ CALL FITA(N2,TLW,TW,SLW,SW,KINT,GAUSC,NOME1,PXL)
+C Z=PK(3)*DLL ! WRONG ! good only for low zeta (first order approx)
+ DLL1=DLL/299792.458D0+1.D0 ! =TL0(2)/TL0(1)
+ Z=(DLL1**PK(3)-1.D0)*299792.458D0
+ SIGMA=PK(1)*DLL
+ WRITE(N6,5000) PK(1),PK(2),PK(3),Z,SIGMA,DLL
+ 5000 FORMAT(' sigma/c=',G15.5,' D=',G15.5,' Z=',G15.5/
+ 1 ' Z, sigma(km/sec)=',2G15.5,' Km/sec/pixel:',G12.4)
+C READ(N5,*)
+ ENDIF
+C
+ GOTO 1 ! to fitting type loop
+C
+ END
+C
+ SUBROUTINE FSHIFT(FT,FT1,N,DELTA)
+C ------------------------------------------------------------
+C Doppler shift the fourier transform by z = d (log lambda)
+C ------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ REAL*8 ARG,ARGS,ARGC,PERIOD,DUEPID
+ COMPLEX FT(N),FT1(N)
+ CHARACTER*1 YN
+C
+ DUEPID=(6.28318530717959/DELTA)/N
+C
+ 10 CONTINUE
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter Z=d(Log lambda). (0=exit)')
+ READ(N5,*) Z
+ IF(Z.EQ.0.0) RETURN
+ PERIOD=DUEPID * Z
+C DO 20 I=1,N/2
+ DO 20 I=0,N-1
+C FT multiplied by I-1,not I, due to FFT routine intending I=0,N-1
+ I1=I+1
+ ARG=I*PERIOD
+ ARGC=DCOS(ARG)
+ ARGS=DSIN(ARG)
+ FT1(I1)=FT(I1)*CMPLX(ARGC,ARGS)
+ 20 CONTINUE
+C For the following see i.e. Brault White Astr.Astroph 13:169(71)
+C due to the shift in lambda this simmetry is required?
+C DO 25 I=N/2+1,N
+C 25 FT1(I)=FT(I)*CMPLX(COS(I*PERIOD),-SIN(I*PERIOD))
+ WRITE(N6,2000)
+ 2000 FORMAT(' Do you want to print the shifted transform? '
+ 1 '(Y/N)')
+ READ(N5,2001) YN
+ 2001 FORMAT(A)
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') CALL PRINTC(FT1,N)
+ WRITE(N6,3000)
+ 3000 FORMAT(' Are you satisfied with this shift?'
+ 1 '(Y/N)')
+ READ(N5,2001) YN
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') GOTO 500
+C
+ GOTO 10
+C
+ 500 CONTINUE
+ DO 50 I=1,N
+ FT(I)=FT1(I)
+ 50 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE GAUS(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C EXP FIT TO A POWER SPECTRUM :
+C y= D *exp( 2(-(sigma/c)*(pi/n)*z)**2 + pow noise
+C parameters are pk(1,2, = sigma/C,D,Pn ; enne=numb. of x values
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ DATA PI/3.141592653589793/
+C
+ EXPP= EXP(-2.*(PK(1)*PI*X/ENNE)**2)
+ Y = PK(2) * EXPP +PK(4)
+ DYDA(1)= - 4.* PK(1) * (PI*X/ENNE)**2 *PK(2)*EXPP
+ DYDA(2)= EXPP
+ DYDA(3)= 0.0 ! power isn't z dependent
+ DYDA(4)= 1.
+ RETURN
+ END
+C
+ SUBROUTINE GAUS2(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C EXP FIT TO A POWER SPECTRUM :
+C y=( D *exp( 2(-(sigma/c)*(pi/n)*z)**2 )**2 + pow noise
+C parameters are pk(1,2, = sigma/C,D,Z,Pn ; enne=numb. of x values
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ PARAMETER PI=3.141592653589793
+C
+ EXPP= EXP(-(2.*PK(1)*PI*X/ENNE)**2)
+ Y = PK(2)**2 * EXPP +PK(4)
+ DYDA(1)= - 2.* PK(1) * (2.*PI*X/ENNE)**2*PK(2)**2*EXPP
+ DYDA(2)= EXPP * 2.*PK(2)
+ DYDA(3)= 0.0 ! power isn't z dependent
+ DYDA(4)= 1.
+ RETURN
+ END
+C
+ SUBROUTINE GAUS2N(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C (EXP+NOISE)**2 FIT TO A POWER SPECTRUM :
+C y=( D *exp( 2(-(sigma/c)*(pi/n)*z)**2 + noise )**2
+C parameters are pk(1,2, = sigma/C,D,Z,Pn ; enne=numb. of x values
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ PARAMETER PI=3.141592653589793
+C
+ EXPP= EXP(- ( (2.*PI*X/ENNE)*PK(1) )**2)
+ EXP0= EXP(-2.*( PI*X/ENNE *PK(1) )**2)
+ COSSZ= 2.*COS( (2.*PI*X/ENNE)*PK(3) )
+ DCOSSZ=-(2.*PI*X/ENNE)*2.*SIN( (2.*PI*X/ENNE)*PK(3) )
+ Y = PK(2)**2 * EXPP +
+ 1 PK(4)**2 +
+ 2 PK(2)*PK(4) * EXP0 * COSSZ
+ DYDA(1)= - 2.* PK(1) * (2.*PI*X/ENNE)**2 *PK(2)**2*EXPP
+ 1 - 4.* PK(1) * ( PI*X/ENNE)**2
+ 2 *PK(2)*PK(4)*EXP0*COSSZ
+ DYDA(2)= 2. *PK(2) *EXPP + PK(4)*EXP0*COSSZ
+ DYDA(3)= PK(2)*PK(4)*EXP0*DCOSSZ
+ DYDA(4)= 2.*PK(4) + PK(2)*EXP0*COSSZ
+ RETURN
+ END
+C
+ SUBROUTINE GAUS2NL(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C LN(EXP+NOISE)**2 FIT TO A POWER SPECTRUM :
+C y=LN(( D *exp( 2(-(sigma/c)*(pi/n)*z)**2 + noise )**2 )
+C parameters are pk(1,2, = sigma/C,D,Z,Pn ; enne=numb. of x values
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ PARAMETER PI=3.141592653589793
+C
+ EXPP= EXP(- ( (2.*PI*X/ENNE)*PK(1) )**2)
+ EXP0= EXP(-2.*( PI*X/ENNE *PK(1) )**2)
+ COSSZ= 2.*COS( (2.*PI*X/ENNE)*PK(3) )
+ DCOSSZ=-(2.*PI*X/ENNE)*2.*SIN( (2.*PI*X/ENNE)*PK(3) )
+ Y = PK(2)**2 * EXPP +
+ 1 PK(4)**2 +
+ 2 PK(2)*PK(4) * EXP0 * COSSZ
+ DYDA(1)= - 2.* PK(1) * (2.*PI*X/ENNE)**2 *PK(2)**2*EXPP
+ 1 - 4.* PK(1) * ( PI*X/ENNE)**2
+ 2 *PK(2)*PK(4)*EXP0*COSSZ
+ DYDA(2)= 2. *PK(2) *EXPP + PK(4)*EXP0*COSSZ
+ DYDA(3)= PK(2)*PK(4)*EXP0*DCOSSZ
+ DYDA(4)= 2.*PK(4) + PK(2)*EXP0*COSSZ
+C Turn into a log spectrum fit
+ DYDA(1)=DYDA(1)/Y
+ DYDA(2)=DYDA(2)/Y
+ DYDA(3)=DYDA(3)/Y
+ DYDA(4)=DYDA(4)/Y
+ Y=LOG(Y)
+ RETURN
+ END
+C
+ SUBROUTINE GAUSSBELL(AL,A,N,F,SIG,KCOS)
+C ------------------------------------------------
+C Applies a gauss bell function window to A(AL)
+C F is the fraction (%) of data which are modified
+C F refers to the non zero part of the data stream
+C SIG is the gauss width
+C If Kcos <=0 doesn't look for .NE. 0 points
+C ------------------------------------------------
+ DIMENSION AL(N),A(N)
+C
+C Looks for N1,N2 the first and last non-zero values
+C
+ N1=1
+ N2=N
+ IF(KCOS.LE.0) GOTO 300
+ DO 5 I=1,N
+ IF(A(I).NE.0.0) GOTO 105
+ 5 CONTINUE
+C All data are zero, no warning and goes on computing.
+ GOTO 205
+ 105 N1=I
+ 205 CONTINUE
+ DO 7 I=N,1,-1
+ IF(A(I).NE.0.0) GO TO 107
+ 7 CONTINUE
+C All data are zero, no warning and goes on computing.
+ GOTO 207
+ 107 N2=I
+ 207 CONTINUE
+C
+ 300 CONTINUE
+ NF=F/100.*(N2-N1+1)
+ DENOM=0.5/(SIG*SIG)
+C
+ DO 10 I=N1,N1+NF-1
+ 10 A(I)=A(I)*EXP(-DENOM*(AL(I)-AL(N1+NF-1))**2)
+ DO 20 I=N2-NF+1,N2
+ 20 A(I)=A(I)*EXP(-DENOM*(AL(N2-NF+1)-AL(I))**2)
+C
+ RETURN
+ END
+C
+ SUBROUTINE GAUSC(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C complex gauss+redshift and its derivatives
+C y= D *exp( 2(-(sigma/c)*(pi/n)*z)**2 +ix(2piz/n)
+C parameters are pk(1,2,3) = sigma,D,z ; enne=numb. of x values
+C C IS SET=1 ; X is measured in pixels =>
+C z=z*c*(dlambda/lambda) , sigma=sigma*c*(dlambda/lambda)
+C dlambda/lambda e' lo shift di 1 pixel
+C Howewer this routine hasn't been optimized, ANZI!
+C (A log fit will be computationally shorter)
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ PARAMETER PI=3.141592653589793
+C
+ AN=ENNE
+ SIG=PK(1)
+ D=PK(2)
+ Z=PK(3)
+C LAST x, after there are the imm parts
+ AN1=ENNE/2-1
+ S=X
+C
+ IF(S.GT.AN1) THEN
+C We are dealing with the imm. part
+ S=S-AN
+ EXPP= EXP(-2.*(SIG*PI*S/AN)**2)
+ COSS= COS( 2.*PI*S*Z/AN)
+ SINN= SIN( 2.*PI*S*Z/AN)
+ Y= D* EXPP * SINN
+ DYDA(1)= - 4.*SIG * (S*PI/AN)**2 *D* EXPP*SINN
+ DYDA(2)= EXPP*SINN
+ DYDA(3)= D*EXPP*COSS*2.*PI*S/AN
+ ELSE
+C real part
+ EXPP= EXP(-2.*(SIG*PI*S/AN)**2)
+ COSS= COS( 2.*PI*S*Z/AN)
+ SINN= SIN( 2.*PI*S*Z/AN)
+ Y= D* EXPP * COSS
+ DYDA(1)= - 4.*SIG * (S*PI/AN)**2 *D* EXPP*COSS
+ DYDA(2)= EXPP*COSS
+ DYDA(3)= - D*EXPP*SINN*2.*PI*S/AN
+C
+ ENDIF
+ RETURN
+ END
+C
+ SUBROUTINE GAUSG(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C complex gauss+redshift and its derivatives
+C y= D *exp( 2(-(sigma/c)*(pi/n)*z)**2 +ix(2piz/n)
+C parameters are pk(1,2,3) = sigma,D,z ; enne=numb. of x values
+C C IS SET=1 ; X is measured in pixels =>
+C z=z*c*(dlambda/lambda) , sigma=sigma*c*(dlambda/lambda)
+C dlambda/lambda e' lo shift di 1 pixel
+C Howewer this routine hasn't been optimized, ANZI!
+C (A log fit will be computationally shorter)
+C W1 contains the complex FT
+C -----------------------------------------------------------
+ PARAMETER (NPTMX=10000)
+ COMPLEX W1
+ COMMON /WEIGHT/W(NPTMX),W1(NPTMX),W2(NPTMX)
+ DIMENSION PK(N),DYDA(N)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ PARAMETER PI=3.141592653589793
+C
+ AN=ENNE
+ SIG=PK(1)
+ D=PK(2)
+ Z=PK(3)
+C LAST x, after there are the imm parts
+ AN1=ENNE/2-1
+ S=X
+C
+ IF(S.GT.AN1) THEN
+C We are dealing with the imm. part
+ S=S-AN
+ K=S+ENNE/2+1
+ REALT=REAL(W1(K))
+ AIMAGT=AIMAG(W1(K))
+ EXPP= EXP(-2.*(SIG*PI*S/AN)**2)
+ COSS= COS( 2.*PI*S*Z/AN)
+ SINN= SIN( 2.*PI*S*Z/AN)
+ SRCI=(SINN*REALT+COSS*AIMAGT)
+C
+ Y= D* EXPP * SRCI
+ DYDA(1)= - 4.*SIG * (S*PI/AN)**2 *D* EXPP*SRCI
+ DYDA(2)= EXPP*SRCI
+ DYDA(3)= D*EXPP*2.*PI*S/AN * (COSS*REALT-SINN*AIMAGT)
+ ELSE
+C real part
+ K=S+ENNE/2+1
+ REALT=REAL(W1(K))
+ AIMAGT=AIMAG(W1(K))
+ EXPP= EXP(-2.*(SIG*PI*S/AN)**2)
+ COSS= COS( 2.*PI*S*Z/AN)
+ SINN= SIN( 2.*PI*S*Z/AN)
+ CRSI=(COSS*REALT-SINN*AIMAGT)
+C
+ Y= D* EXPP * CRSI
+ DYDA(1)= - 4.*SIG * (S*PI/AN)**2 *D* EXPP*CRSI
+ DYDA(2)= EXPP*CRSI
+ DYDA(3)= - D*EXPP*2.*PI*S/AN * (SINN*REALT+COSS*AIMAGT)
+C
+ ENDIF
+ RETURN
+ END
+C
+ SUBROUTINE GAUSGT(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C EXP FIT TO A POWER SPECTRUM :
+C y= T* D *exp(2 (-(sigma/c)*(pi/n)*z)**2 + pow noise
+C parameters are pk(1,2, = sigma/C,D,Pn ; enne=numb. of x values
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ PARAMETER (NPTMX=10000)
+ COMPLEX W1
+ COMMON /WEIGHT/W(NPTMX),W1(NPTMX),W2(NPTMX)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ PARAMETER PI=3.141592653589793
+C
+ K=X+ENNE/2+1
+ EXPP=W2(K)* EXP(-2.*(PK(1)*PI*X/ENNE)**2)
+ Y = PK(2) * EXPP +PK(4)
+ DYDA(1)= - 4.* PK(1) * (PI*X/ENNE)**2 *EXPP
+ DYDA(2)= EXPP
+ DYDA(3)= 0.0 ! power isn't z dependent
+ DYDA(4)= 1.
+ RETURN
+ END
+C
+ SUBROUTINE GAUSS(T,N,NLAMT,NLAMG,NEWN,NMAX)
+C ---------------------------------------------------------
+C Generates in T a normalized gauss function
+C ---------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION T(NMAX)
+ REAL*8 W,W2,ANORM,X
+C REAL*8 PI ! mettendo d0 sotto e' gia real*8
+ PARAMETER PI=3.141592653589793D0
+C DATA PI/3.141592653589793/
+C REAL*4 PI
+C DATA PI/3.1415927/
+C
+ 100 WRITE(N6,1000) NLAMT,NLAMG,NEWN,NMAX
+ 1000 FORMAT(' Template, galaxy, fourier and max dimensions are:',4I5/
+ 1 ' Enter the number of points (EVEN) and the width (points)')
+ READ(N5,*) N,W
+ IF(N.GT.NMAX) THEN
+ WRITE(N6,2000) NMAX
+ 2000 FORMAT(' ERROR! Maximum value allowed for N is:',I5)
+ GOTO 100
+ ENDIF
+ IF(MOD(N,2).NE.0) THEN
+ WRITE(N6,2200) N
+ 2200 FORMAT(' ERROR! ',I5,' IS NOT AN EVEN NUMBER')
+ GOTO 100
+ ENDIF
+C
+ ANORM=1.D0/(SQRT(2.D0*PI)*W)
+ W2=W*W
+C The point x=0 is in i=n/2+1. (CIRCON will put it in wrap around order)
+ T(N/2+1)=ANORM
+ DO 30 I=N/2+2,N,1
+ X=I-(N/2.+1)
+ T(I)=EXP(-(X**2)/W2/2.D0)*ANORM
+ T(N-I+2)=T(I)
+ 30 CONTINUE
+ X=N/2.0
+ T(1)= EXP(-(X**2)/W2/2.D0)*ANORM
+C
+C Wrap around order: The point x=0 is in i=1, x<0 is in i=n,n/2+2,-1
+C T(1)=ANORM
+C DO 10 I=2,N/2+1
+C X=I-1
+C 10 T(I)=EXP(-(X**2)/W2/2.)*ANORM
+C DO 20 I=2,N/2
+C 20 T(N-I+2)=T(I)
+C
+ RETURN
+ END
+C
+ SUBROUTINE GAUSZ(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C NORMALIZED gauss+redshift and its derivatives
+C y=(c/sigma/sqrt(2pi)) *D *exp(-c**2*(x-z)**2/2sigma**2)
+C parameters are pk(1,2,3)=sigma,D,z
+C C IS SET=1 ; X is measured in pixels =>
+C z=z*c*(dlambda/lambda) , sigma=sigma*c*(dlambda/lambda)
+C dlambda/lambda e' lo shift di 1 pixel
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ PARAMETER PI=3.141592653589793
+C
+ F1=1./SQRT(PI*2.)/PK(1)
+ F2=EXP(-0.5*( (X-PK(3))/PK(1) )**2 )
+C
+ Y= PK(2) * F1 * F2
+ DYDA(1)= PK(2) * F1 * F2 * (( (X-PK(3))/PK(1) )**2 -1.)/PK(1)
+ DYDA(2)= F1 * F2
+ DYDA(3)= PK(2) * F1 * F2 * (X-PK(3))/PK(1)**2
+C
+ RETURN
+ END
+C
+ SUBROUTINE GAUSZA(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C UNNORMALIZED gauss+redshift and its derivatives
+C y= D *exp(-c**2*(x-z)**2/2sigma**2)
+C parameters are pk(1,2,3)=sigma,D,z
+C C IS SET=1 ; X is measured in pixels =>
+C z=z*c*(dlambda/lambda) , sigma=sigma*c*(dlambda/lambda)
+C dlambda/lambda e' lo shift di 1 pixel
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ PARAMETER PI=3.141592653589793
+C
+ F2=EXP(-0.5*( (X-PK(3))/PK(1) )**2 )
+C
+ Y= PK(2) * F2
+ DYDA(1)= PK(2) * F2 * (( (X-PK(3))/PK(1) )**2 )/PK(1)
+ DYDA(2)= F2
+ DYDA(3)= PK(2) * F2 * (X-PK(3))/PK(1)**2
+C
+ RETURN
+ END
+C
+ SUBROUTINE GAUSZC(X,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C gauss+redshift+cons and its derivatives
+C used to fit the cross correlation:
+C y=(c/sigma/sqrt(2pi)) *D *exp(-c**2*(x-z)**2/2sigma**2)+Cost
+C parameters are pk(1,2,3,4)=sigma,D,z,Cost
+C C IS SET=1 ; X is measured in pixels =>
+C z=z*c*(dlambda/lambda) , sigma=sigma*c*(dlambda/lambda)
+C dlambda/lambda e' lo shift di 1 pixel
+C -----------------------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ PARAMETER PI=3.141592653589793
+C
+ F1=1./SQRT(2.*PI)/PK(1)
+ F2=EXP(-0.5*( (X-PK(3))/PK(1) )**2 )
+C
+ Y= PK(2) * F1 * F2 + PK(4)
+ DYDA(1)= PK(2) * F1 * F2 * (( (X-PK(3))/PK(1) )**2 -1.)/PK(1)
+ DYDA(2)= F1 * F2
+ DYDA(3)= PK(2) * F1 * F2 * (X-PK(3))/PK(1)**2
+ DYDA(4)= 1.
+C
+ RETURN
+ END
+C
+ SUBROUTINE GAUSZC1(X0,PK,Y,DYDA,N)
+C -----------------------------------------------------------
+C Differences from GAUSZ :
+C x,z measured from pixel num. ENNE/2+1 assumed as zero ref.point
+C but input X0=pixel number=PXL= 0,1,2 ...ENNE
+C gauss+redshift+cons and its derivatives
+C used to fit the cross correlation:
+C y=(c/sigma/sqrt(2pi)) *D *exp(-c**2*(x-z)**2/2sigma**2)+Cost
+C parameters are pk(1,2,3,4)=sigma,D,z,Cost
+C C IS SET=1 ; X is measured in pixels starting from 0 =>
+C z=z*c*(dlambda/lambda) , sigma=sigma*c*(dlambda/lambda)
+C dlambda/lambda e' lo shift di 1 pixel
+C -----------------------------------------------------------
+ COMMON/GUESSPK/ENNE
+ DIMENSION PK(N),DYDA(N)
+ PARAMETER PI=3.141592653589793
+C
+ X=X0-ENNE/2
+C
+ F1=1./SQRT(2.*PI)/PK(1)
+ F2=EXP(-0.5*( (X-PK(3))/PK(1) )**2 )
+C
+ Y= PK(2) * F1 * F2 + PK(4)
+ DYDA(1)= PK(2) * F1 * F2 * (( (X-PK(3))/PK(1) )**2 -1.)/PK(1)
+ DYDA(2)= F1 * F2
+ DYDA(3)= PK(2) * F1 * F2 * (X-PK(3))/PK(1)**2
+ DYDA(4)= 1.
+C
+ RETURN
+ END
+C
+ FUNCTION IFINDC(N,COMANDO,COMANDI)
+C ----------------------------------------------------------------
+C returns the number of the string comando in the array comandi(n)
+C ----------------------------------------------------------------
+ CHARACTER*(*) COMANDO,COMANDI(N)
+ DO 10 I=1,N
+ IF(COMANDO.NE.COMANDI(I)) GOTO 10
+ IFINDC=I
+ RETURN
+ 10 CONTINUE
+ IFINDC=0
+ RETURN
+ END
+C
+ SUBROUTINE INFITS(NMAX,MAXBUF,NDIMBUF,ALBUF,BUF,TL,T)
+C ---------------------------------------------------------
+C Routine presa da diskfits1.for , modificato. 10-6-1993
+C This routine reads fits format, written with 512 or 2880
+C byte records. A real fits file (records of 2880), when
+C mouved from Unix to Vax, often looses its record structure
+C and becomes a 512-records file.
+C Pay attention to the byte ordering! (reversed in Vax VMS)
+C BUF(nmax,maxbuf)= where the read spectra will be put
+C ( in an user chosen vector of this array):
+C 1=template, 2=galaxy, 3= correlation .....
+C ndimbuf(maxbuf) = number of lambda points
+C albuf(maxbuf) = lambda for each point
+C TL,T= working arrays
+C --------------------------------------------------------
+ DIMENSION NDIMBUF(MAXBUF),BUF(NMAX,MAXBUF),ALBUF(NMAX,MAXBUF)
+ DIMENSION TL(NMAX),T(NMAX)
+ COMMON/TAPE/N5,N6,N7
+C
+ PARAMETER (MAXBYTES=2880) ! maximum bytes in a record
+ PARAMETER (MAXREC=50) ! max number of records
+ PARAMETER (MAXNUM=MAXBYTES*MAXREC) ! Max bytes for fits file
+ DATA MXREC,MXNUM/MAXREC,MAXNUM/
+C
+ CHARACTER*1 A(MAXBYTES*MAXREC) ! Input buffer for a single record
+ DIMENSION IA(MAXBYTES*MAXREC/4) ! same but as integer*4 (32bits)
+ INTEGER*2 IA2(MAXBYTES*MAXREC/2) ! as integer*2 (16 bits)
+ EQUIVALENCE(A(1),IA(1),IA2(1))!A is used as real,32 or 16 bit int
+C
+ CHARACTER*40 FILE ! I/O file names
+ CHARACTER*50 FILEHEAD
+ CHARACTER*7 HEADER
+ DATA HEADER /'HEADER_'/
+C
+C .................. Header parameters :
+C
+ COMMON /FITSPAR/ NPAR,PARNAM(20),IACTIVE(20),ITYPE(20),
+ 1 PARVAL1(20),IPARVAL2(20),PARVAL3(20),PARVAL4(20),
+ 2 NCARD(20)
+ CHARACTER*8 PARNAM,PARVAL4
+ LOGICAL PARVAL1,IACTIVE
+ REAL*8 PARVAL3,BSCALE,BZERO,CRVAL1,CRPIX1,CDELT1
+C npar = numero parametri descritti nel common
+C ( L'ultimo e' sempre END )
+C parnam = nome parametri
+C iactive= true se il parametro e' stato interpretato
+C ITYPE=1,2,3,4 : logical, integer, real, char,
+C parval1,parval2,3,4 = valore parametro, logical,integer etc.
+C ncard = scheda in cui e' il parametro
+C
+ EQUIVALENCE(PARVAL3(6),BSCALE)
+ EQUIVALENCE(PARVAL3(7),BZERO)
+ EQUIVALENCE(IPARVAL2(3),NAXIS)
+ EQUIVALENCE(IPARVAL2(4),NAXIS1)
+ EQUIVALENCE(IPARVAL2(5),NAXIS2)
+ EQUIVALENCE(IPARVAL2(15),NAXIS3)
+ EQUIVALENCE(IPARVAL2(2),BITPIX)
+ INTEGER BITPIX
+ EQUIVALENCE(PARVAL3(14),CRVAL1)
+ EQUIVALENCE(PARVAL3(10),CRPIX1)
+ EQUIVALENCE(PARVAL3(12),CDELT1)
+C ................................................
+C
+C ............... buffer number to store read spectrum
+ 10 WRITE(N6,1000,ERR=10) MAXBUF
+ 1000 FORMAT(' Enter: 1 =read template, 2=galaxy ,3...(max:',I4,')',
+ 1 ' <=0 to exit')
+ READ(N5,*) NB
+ IF(NB.LE.0.OR.NB.GT.MAXBUF) THEN
+ WRITE(N6,1010) NB
+ 1010 FORMAT(' Exiting from input routine: input value:',I4)
+ RETURN
+ ENDIF
+C ...................................................
+C ............... Input fits file
+ NERROR=0 ! Error counter
+ 11 IF(NERROR.GT.4) THEN
+ WRITE(N6,1011) NERROR
+ 1011 FORMAT(' TOO MANY ERRORS !!!! ',I2)
+ GOTO 10
+ ENDIF
+ WRITE(N6,2000)
+ 2000 FORMAT(' Give fits file name')
+ READ(N5,'(A)',ERR=11) FILE
+C
+ MXBBLK=512 ! assuming this record lenght
+ MXWBLK=MXBBLK/4 ! number of 32bits (4 bytes word) for block
+C
+C ............... apre unita' input
+ OPEN (UNIT=1,FORM='UNFORMATTED',READONLY,
+ 1 RECL=MXWBLK,RECORDTYPE='FIXED',STATUS='OLD',
+ 2 BLOCKSIZE=MXBBLK,FILE=FILE,ERR=150)
+C
+ GOTO 100
+ 150 NERROR=NERROR+1
+ WRITE(N5,1500)
+ 1500 FORMAT(' Open error! I try 2880 bytes records ....')
+ MXBBLK=2880
+ MXWBLK=MXBBLK/4
+ OPEN (UNIT=1,FORM='UNFORMATTED',READONLY,
+ 1 RECL=MXWBLK,RECORDTYPE='FIXED',STATUS='OLD',
+ 2 BLOCKSIZE=MXBBLK,FILE=FILE,ERR=155)
+ GOTO 100
+ 155 NERROR=NERROR+1
+ WRITE(N5,1555)
+ 1555 FORMAT(' OPEN ERROR AGAIN! FILE NOT READ!')
+ GOTO 11
+ 100 CONTINUE
+C ...............................
+C
+ CALL KEYINIT ! fits keyword initialization
+C
+C
+C .............. Reads all the fits file
+C
+ DO 15 I=1,MXREC
+ READ(1,END=160) (A(J+(I-1)*MXBBLK),J=1,MXBBLK)
+ WRITE(6,1560) I,MXBBLK
+ 1560 FORMAT(' Reading record',I3,' , bytes read:',I5)
+ 15 CONTINUE
+ WRITE(6,1600) MXREC
+ 1600 FORMAT(' WARNING! EOF NOT ENCOUNTERD ! INCREASE MAXREC!',I5)
+ 160 CONTINUE
+ CLOSE(UNIT=1,ERR=161)
+ 161 NRECORD=I-1
+ NSCHEDE=NRECORD*MXBBLK/80.
+C looks for parameters in header
+ CALL HEADEXAM(A,1,NSCHEDE)
+ IF(.NOT.IACTIVE(NPAR)) PAUSE ' PAUSE: end card not fount'
+C number of records of 2880 bytes (=36 cards) for header:
+ NRHEAD=NCARD(NPAR)/36
+ IF(MOD(NCARD(NPAR),36).NE.0) NRHEAD=NRHEAD+1
+ NIDATI=NRHEAD*2880+1 ! byte di inizio dati
+C
+C ........................writes the HEADER................
+C
+ NSCHEDE=NCARD(NPAR) ! num.schede:posto nell'header dell'END
+ FILEHEAD=HEADER//FILE
+ WRITE(N6,2400) FILEHEAD
+ 2400 FORMAT(' Enter 1 to show the header,'/,
+ 1 ' 2 for header in file:',A50/' 3 for both')
+ READ(N5,*,ERR=200) IEADER
+ IF(IEADER.EQ.2.OR.IEADER.EQ.3) THEN
+ OPEN(UNIT=11,ERR=190,FORM='FORMATTED',
+ 1 STATUS='NEW',FILE=FILEHEAD)
+ CALL WRITEH(11,A,NSCHEDE) ! header on unit 11
+ CLOSE(UNIT=11)
+ ENDIF
+ GOTO 191
+ 190 WRITE(N6,*)' Error in opening file 11 data not written'
+ 191 IF(IEADER.EQ.1.OR.IEADER.EQ.3)
+ 1 CALL WRITEH(N6,A,NSCHEDE) ! header on unit 6
+C number of data:
+ 200 IF(.NOT.(IACTIVE(2).AND.IACTIVE(4)
+ 1 .AND.IACTIVE(6).AND.IACTIVE(7) ) )
+ 2 PAUSE ' Fits keyword missing in header '
+ IF(NAXIS.EQ.1) THEN
+ NVALUES=NAXIS1
+ ELSE IF(NAXIS.EQ.2) THEN
+ NVALUES=NAXIS1*NAXIS2 ! number of data for the frame
+ ELSE IF(NAXIS.EQ.3) THEN
+ NVALUES=NAXIS1*NAXIS2*NAXIS3
+ ELSE
+ WRITE(N6,3980) NAXIS
+ 3980 FORMAT(' ERROR !, NAXIS=',I3,' not allowed',
+ 1 ' NAXIS=1 assumed')
+ NVALUES=NAXIS1
+ ENDIF
+C
+ NBYTES=NVALUES*BITPIX/8 ! total number of bytes for data
+C
+ IF(NVALUES.GT.NMAX) THEN
+ WRITE(N6,3990) NVALUES,NMAX
+ 3990 FORMAT(' ERROR ! , ',I4,' numbers in fits file,',
+ 1 ' increase NPTMX parameter, now:',I4/ 'Some data ignored')
+ NVALUES=NMAX
+ ENDIF
+ CALL NULL(T,NVALUES) ! Zero output buffer
+C
+C WRITE(N6,4000) NIDATI,NBYTES
+ 4000 FORMAT(' primo byte di dati:',I5,' bytes TOT:',I5)
+C ................ DATA HANDLING ......................
+C change the order of bytes, following FITS prescriptions
+C passed to cset as int (not char)here to avoid "by descriptor" passing
+ IF(BITPIX.EQ.16) THEN
+ INIZDAT=(NIDATI-1)/2+1
+C TYPE*,' primo dato (int.2):',INIZDAT
+ CALL RIBALTA2(A,NIDATI,NBYTES)
+ CALL CSET2(T,NVALUES,IA2(INIZDAT),BSCALE,BZERO)
+ ELSE IF(BITPIX.EQ.32) THEN
+C CALL RIBALTA2(A(NIDATI),NBYTES)
+ INIZDAT=(NIDATI-1)/4+1
+C TYPE*,' primo dato (int.4):',INIZDAT
+ CALL RIBALTA4(A,NIDATI,NBYTES)
+ CALL CSET4(T,NVALUES,IA(INIZDAT),BSCALE,BZERO)
+ ELSE
+ PAUSE ' PAUSE: only bitpix 16 or 32 allowed'
+ ENDIF
+C
+C ................. Lambda scale and intensity
+ NDIMBUF(NB)=NVALUES
+ DO 70 I=1,NVALUES
+ BUF(I,NB)=T(I)
+ ALBUF(I,NB)= CRVAL1+(I-1)*CDELT1
+ 70 CONTINUE
+C
+ IF(CRVAL1.LT.5..AND.ALBUF(NVALUES,NB).LT.10.) THEN
+ WRITE(N6,7000)
+ 7000 FORMAT(' Assuming an input log lambda scale')
+
+ DO 75 I=1,NVALUES
+ ALBUF(I,NB)=10.0**(ALBUF(I,NB))
+ 75 CONTINUE
+ ENDIF
+C Tests lambda scale
+ KSCAL=0 ! test scale and ask lambda if a wrong scale is found
+ CALL LEGGESCAL(ALBUF(1,NB),NVALUES,KDUM)
+C
+C ............... To test :
+C type 9999,(j,albuf(j,nb),buf(j,nb),j=1,nvalues)
+C9999 format( 1x,I5,1x, G15.10, 1x,G20.10)
+C ...........................
+ GOTO 10
+C
+ END
+C
+ SUBROUTINE CSET2(C,N,IA,BSCALE,BZERO) ! a part of infits routine
+C -------------------------------------------------
+C integer *2 data converted to real*8
+C -------------------------------------------------
+ DIMENSION C(N),IA(N)
+ INTEGER*2 IA
+ REAL*8 BSCALE,BZERO
+ DO 10 I=1,N
+ C(I)=IA(I)*BSCALE+BZERO
+ 10 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE CSET4(C,N,IA,BSCALE,BZERO) ! a part of infits routine
+C -------------------------------------------------
+C integer *4 data converted to real*8
+C -------------------------------------------------
+ DIMENSION C(N),IA(N)
+ INTEGER*4 IA
+ REAL*8 BSCALE,BZERO
+C TYPE*,' setting data to real: Values:',N
+C TYPE*,' bscale,bzero:',BSCALE,BZERO
+ DO 10 I=1,N
+ C(I)=IA(I)*BSCALE+BZERO
+ 10 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE HEADEXAM(A,N1,N2) ! a part of infits routine
+C ----------------------------------------------
+C esamina un record di header per interpretare i
+C parametri definiti nel common
+C Dalle schede N1 alla N2
+C ----------------------------------------------
+ CHARACTER*80 A(N2)
+C ...................................................
+ COMMON /FITSPAR/ NPAR,PARNAM(20),IACTIVE(20),ITYPE(20),
+ 1 PARVAL1(20),IPARVAL2(20),PARVAL3(20),PARVAL4(20),
+ 2 NCARD(20)
+ CHARACTER*8 PARNAM,PARVAL4
+ LOGICAL PARVAL1,IACTIVE
+ REAL*8 PARVAL3,BSCALE,BZERO,CRVAL1,CRPIX1,CDELT1
+C npar = numero parametri descritti nel common
+C parnam = nome parametri
+C iactive= true se il parametro e' stato interpretato
+C ITYPE=1,2,3,4 : logical, integer, real, char,
+C parval1,parval2,3,4 = valore parametro, logical,integer etc.
+C ncard = scheda in chui e' il parametro
+C
+ EQUIVALENCE(PARVAL3(6),BSCALE)
+ EQUIVALENCE(PARVAL3(7),BZERO)
+ EQUIVALENCE(IPARVAL2(3),NAXIS)
+ EQUIVALENCE(IPARVAL2(4),NAXIS1)
+ EQUIVALENCE(IPARVAL2(5),NAXIS2)
+ EQUIVALENCE(IPARVAL2(15),NAXIS3)
+ EQUIVALENCE(IPARVAL2(2),BITPIX)
+ INTEGER BITPIX
+ EQUIVALENCE(PARVAL3(14),CRVAL1)
+ EQUIVALENCE(PARVAL3(10),CRPIX1)
+ EQUIVALENCE(PARVAL3(12),CDELT1)
+C ...................................................
+C
+C
+C loop sulle schede dell'header
+ DO 10 I=N1,N2
+ DO 20 J=1,NPAR-1 ! L'ultimo parametro e' END trattato a parte
+ IF(A(I)(1:8).EQ.PARNAM(J)) THEN
+ IACTIVE(J)=.TRUE.
+ NCARD(J)=I
+ IF(ITYPE(J).EQ.1) THEN ! Logical
+ IF(A(I)(30:30).EQ.'T') THEN
+ PARVAL1(J)=.TRUE.
+ ELSE
+ PARVAL1(J)=.FALSE.
+ ENDIF
+ ELSE IF(ITYPE(J).EQ.2) THEN ! Integer
+ READ(A(I),2000) IPARVAL2(J)
+ 2000 FORMAT(10X,2I20.0)
+ ELSE IF(ITYPE(J).EQ.3) THEN ! Real
+ READ(A(I),3000) PARVAL3(J)
+ 3000 FORMAT(10X,2E20.0)
+ ELSE IF(ITYPE(J).EQ.4) THEN ! Character
+ READ(A(I),4000) PARVAL4(J)
+ 4000 FORMAT(11X,A8)
+ ENDIF
+ GOTO 10
+ ENDIF
+ 20 CONTINUE
+C
+ IF(A(I)(1:8).EQ.PARNAM(NPAR)) THEN ! END found
+ IACTIVE(NPAR)=.TRUE.
+ PARVAL1(NPAR)=.TRUE.
+ IPARVAL2(NPAR)=I ! Num Scheda ove e' 'END'
+ NCARD(NPAR)=I
+ RETURN ! END interrompe l'analisi
+ ENDIF
+ 10 CONTINUE
+C
+ RETURN
+ END
+C
+ SUBROUTINE KEYINIT ! a part of infits routine
+C -----------------------------------------
+C Inizializza il common dei parametri fits
+C -----------------------------------------
+ COMMON /FITSPAR/ NPAR,PARNAM(20),IACTIVE(20),ITYPE(20),
+ 1 PARVAL1(20),IPARVAL2(20),PARVAL3(20),PARVAL4(20),
+ 2 NCARD(20)
+ CHARACTER*8 PARNAM,PARVAL4
+ LOGICAL PARVAL1,IACTIVE
+ REAL*8 PARVAL3,BSCALE,BZERO,CRVAL1,CRPIX1,CDELT1
+C npar = numero parametri descritti nel common
+C L'ultimo e;' sempre END
+C parnam = nome parametri
+C iactive= true se il parametro e' stato interpretato
+C ITYPE=1,2,3,4 : logical, integer, real, char,
+C parval1,parval2,3,4 = valore parametro, logical,integer etc.
+C ncard = scheda in chui e' il parametro
+C
+ EQUIVALENCE(PARVAL3(6),BSCALE)
+ EQUIVALENCE(PARVAL3(7),BZERO)
+ EQUIVALENCE(IPARVAL2(3),NAXIS)
+ EQUIVALENCE(IPARVAL2(4),NAXIS1)
+ EQUIVALENCE(IPARVAL2(5),NAXIS2)
+ EQUIVALENCE(IPARVAL2(15),NAXIS3)
+ EQUIVALENCE(IPARVAL2(2),BITPIX)
+ INTEGER BITPIX
+ EQUIVALENCE(PARVAL3(14),CRVAL1)
+ EQUIVALENCE(PARVAL3(10),CRPIX1)
+ EQUIVALENCE(PARVAL3(12),CDELT1)
+C PARNAM(1)='SIMPLE'
+ ITYPE(1)=1
+ PARNAM(2)='BITPIX'
+ ITYPE(2)=2
+ PARNAM(3)='NAXIS'
+ ITYPE(3)=2
+ PARNAM(4)='NAXIS1'
+ ITYPE(4)=2
+ PARNAM(5)='NAXIS2'
+ ITYPE(5)=2
+ PARNAM(6)='BSCALE'
+ ITYPE(6)=3
+ PARNAM(7)='BZERO'
+ ITYPE(7)=3
+ PARNAM(8)='COMMENT'
+ ITYPE(8)=4
+ PARNAM(9)='HISTORY'
+ ITYPE(9)=4
+ PARNAM(10)='CRPIX1'
+ ITYPE(10)=3
+ PARNAM(11)='CRPIX2'
+ ITYPE(11)=3
+ PARNAM(12)='CDELT1'
+ ITYPE(12)=3
+ PARNAM(13)='CDELT2'
+ ITYPE(13)=3
+ PARNAM(14)='CRVAL1'
+ ITYPE(14)=3
+ PARNAM(15)='NAXIS3'
+ ITYPE(15)=2
+C ............... qui si puo' aggiungere definizione di altri param.
+ PARNAM(16)='END' ! L'ULTIMO DEVE ESSERE SEMPRE
+ ITYPE(16)=1 ! END.
+C
+ NPAR=16
+C
+ ENTRY KEYRESET
+C
+ DO 10 I=1,NPAR
+ 10 IACTIVE(I)=.FALSE.
+C
+ RETURN
+ END
+C
+ SUBROUTINE NULL(A,N) ! a part of infits routine
+C -----------------------
+ DIMENSION A(N)
+ DO 10 I=1,N
+ 10 A(I)=0.0
+ RETURN
+ END
+C
+ SUBROUTINE RIBALTA2(A,INIZ,N) ! a part of infits routine
+C ----------------------------------------------
+C riblata i bytes secondo lo standard fits
+C bytes 1,2 => 2,1 (parole di 2 bytes)
+C ----------------------------------------------
+ CHARACTER*1 A(*),DUM
+ TYPE*,' ribalto i dati a 2 a 2 , primo byte:',INIZ
+ DO 10 I=INIZ,N+INIZ-1,2
+ DUM=A(I)
+ A(I)=A(I+1)
+ A(I+1)=DUM
+ 10 CONTINUE
+C TYPE*,' ribaltati: numero bytes:',N
+ RETURN
+ END
+C
+ SUBROUTINE RIBALTA4(A,INIZ,N) ! a part of infits routine
+C ----------------------------------------------
+C ribalta i bytes secondo lo standard fits
+C bytes: 1,2,3,4 => 4,3,2,1 ( parole di 4 bytes )
+C ----------------------------------------------
+ CHARACTER*1 A(*),DUM,DUM1
+C TYPE*,' ribalto a 4 a 4 i bytes di dati'
+C TYPE*,' primo byte:',INIZ
+ DO 10 I=INIZ,N+INIZ-2,4
+ DUM=A(I)
+ A(I)=A(I+3)
+ A(I+3)=DUM
+ DUM1=A(I+1)
+ A(I+1)=A(I+2)
+ A(I+2)=DUM1
+ 10 CONTINUE
+C TYPE*,' ribaltati: numero bytes:',N
+ RETURN
+ END
+C
+ SUBROUTINE WRITEH(NT,B,NCARDS) ! a part of infits routine
+C -------------------------------------
+C writes header on unit NT
+C -------------------------------------
+ CHARACTER *80 B(NCARDS)
+C
+ WRITE(NT,1000)
+ 1000 FORMAT(///10X,' Header :')
+ LASTCARD=NCARDS
+C DO 10 I=1,NCARDS
+C IF(B(I)(1:3).EQ.'END') THEN
+C LASTCARD=I
+C GOTO 100
+C ENDIF
+C 10 CONTINUE
+ 100 WRITE(NT,2000) (B(J),J=1,LASTCARD)
+ 2000 FORMAT(1X,A80)
+ RETURN
+ END
+C
+ SUBROUTINE LEFT(TL,T,N)
+C -----------------------------------------------------------
+C The spectrum is left adjusted
+C -----------------------------------------------------------
+ DIMENSION TL(N),T(N)
+C
+C Find the first non zero point
+ DO 10 I=1,N
+ IF(T(I).NE.0.0) GO TO 100
+ 10 CONTINUE
+ RETURN
+ 100 K=I-1
+ DO 20 I=1,N-K
+ TL(I)=TL(I+K)
+ T(I)=T(I+K)
+ 20 CONTINUE
+ DO 30 I=N-K+1,N
+ TL(I)=0.0
+ 30 T(I)=0.0
+ N=N-K
+ RETURN
+ END
+C
+ SUBROUTINE LEGGE(N,NMAX,TL0,T0,SL0,S0,FT,FS,FG,KF)
+C --------------------------------------------
+C Lettura files di input
+C depending on KF : input format
+C --------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION T0(NMAX),TL0(NMAX),SL0(NMAX),S0(NMAX)
+ COMPLEX FT(NMAX),FS(NMAX),FG(NMAX)
+ CHARACTER*80 FILE
+ CHARACTER*1 YN
+ CHARACTER*50 FORMATO(5)
+ DATA FORMATO/
+ 1 ' num lambda_TL0 intensity_T0 ',
+ 2 ' num intensity_T0 ',
+ 3 ' num lambda intensity_T0 intessity_S0 ',
+ 4 ' num real_FT imm_FT ',
+ 5 ' num real_FT imm_FT real_FS imm_FS r_FG Imm_FG'/
+C '12345678901234567890123456789012345678901234567890
+C
+ NRETRY=0 ! num riprove per errore nome file
+ GOTO 100
+C Bad file name error
+ 1 CONTINUE
+ WRITE(N6,1000) FILE
+ 1000 FORMAT(' ERROR!, bad file name:',A20)
+ NRETRY=NRETRY+1
+ IF(NRETRY.GT.2) RETURN ! max si puo' sbagliare 2 volte
+ GOTO 100
+C
+C Bad format number error
+ 2 CONTINUE
+ WRITE(N6,1002) KF
+ 1002 FORMAT(' ERROR! bad format number:',I5/
+ 1 ' ENTER FORMAT NUMBER (0 TO EXIT):')
+ READ(N5,*) KF
+ IF(FK.LE.0) RETURN
+ GOTO 100
+C Reading file error
+ 3 CONTINUE
+ CLOSE (UNIT=10,ERR=30)
+ 30 WRITE(N6,1004) FILE,J
+ 1004 FORMAT(' ERROR! In reading file:',A20,' record:',I6/
+ 1 ' give YES to continue NO to read again with different format')
+ READ(N5,1100,ERR=30) YN
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') THEN
+ N=J-1
+ RETURN
+ ENDIF
+ GOTO 2
+C Too many points error
+ 4 WRITE(N6,1006) I,FILE
+ 1006 FORMAT(' !!!!!ERROR : TOO MANY INPUT POINTS:',
+ 1 I5,' data read from file:'/A80)
+ CLOSE (UNIT=10)
+ N=J
+ RETURN
+C Open file error
+ 5 CONTINUE
+ WRITE(N6,1008) FILE
+ 1008 FORMAT(' ERROR! Open error in file:',A20)
+ NRETRY=NRETRY+1
+ IF(NRETRY.GT.2) RETURN ! max si puo' sbagliare 2 volte
+ GOTO 100
+C .............................................
+C ............................. Input file name
+C .............................................
+ 100 WRITE(N6,2000)
+ 2000 FORMAT(' Enter input file name')
+ READ(N5,1100,ERR=1) FILE
+ 1100 FORMAT(A)
+ WRITE(N6,1101) FILE
+ 1101 FORMAT(' Reading from file : ',A40)
+C
+ 102 IF(KF.LE.0.OR.KF.GT.5) GOTO 2
+ OPEN(UNIT=10,FILE=FILE,READONLY,FORM='FORMATTED',
+ 1 STATUS='OLD',ERR=5)
+C
+ IF(KF.EQ.1) THEN
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ DO 10 J=1,NMAX
+ READ(10,*,END=500,ERR=3) I,TL0(J),T0(J)
+ 10 CONTINUE
+ GOTO 4
+ ELSE IF(KF.EQ.2) THEN
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ DO 15 J=1,NMAX
+ READ(10,*,END=500,ERR=3) I,T0(J)
+ 15 TL0(J)=J
+ GOTO 4
+ ELSE IF(KF.EQ.3) THEN
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ DO 17 J=1,NMAX
+ READ(10,*,END=500,ERR=3) I,TL0(J),T0(J),S0(J)
+ 17 SL0(I)=TL0(I)
+ GOTO 4
+ ELSE IF(KF.EQ.4) THEN
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ DO 20 J=1,NMAX
+ READ(10,*,END=500,ERR=3) I,A1,A2
+ FT(I)=CMPLX(A1,A2)
+ 20 CONTINUE
+ GOTO 4
+ ELSE IF(KF.EQ.5) THEN
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ READ(10,*,ERR=3)
+ DO 25 J=1,NMAX
+C READ(10,*,END=500,ERR=3) I,FT(I),FS(I),FG(I)!*doesn't work with
+C complex unless written: ( real , imm )
+ READ(10,*,END=500,ERR=3) I,A1,A2,A3,A4,A5,A6
+ FT(I)=CMPLX(A1,A2)
+ FS(I)=CMPLX(A3,A4)
+ FG(I)=CMPLX(A5,A6)
+ 25 CONTINUE
+ GOTO 4
+ ENDIF
+ GOTO 2
+C
+ 500 CONTINUE
+ CLOSE (UNIT=10)
+ N=J-1
+ WRITE(N6,5000) N,FILE,FORMATO(KF)
+ 5000 FORMAT(/' Read ',I6,' data from file:'A50/
+ 1 ' FORMAT : ',A50//)
+C Test lambda scale and,if bad, ask for
+ IF(K.GT.3) RETURN ! for fourier input no lambda test
+ KSCAL=0
+ CALL LEGGESCAL(TL0,N,KSCAL)
+ IF(KF.EQ.3) THEN ! for both template and galaxy check GL0 also
+ DO 50 I=1,N
+ IF(TL0(I).NE.SL0(I)) SL0(I)=TL0(I)
+ 50 CONTINUE
+ ENDIF
+C
+ RETURN
+ END
+C
+ SUBROUTINE LEGGESCAL(TL0,N,K)
+C ------------------------------------------------
+C if a "pixel type" lambda scale if found then
+C ask for a linear lambda scale
+C IF K=1 ask for scale in any way
+C ------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL0(N)
+ REAL*8 ALAMBDA0,ALAMBDA1,ALAMSTP
+C
+C If this spectrum has't a lambda scale builds it
+ 10 CONTINUE
+ IF((TL0(1).GT.100..AND.TL0(N).GT.100.).AND.K.NE.1) RETURN
+ WRITE(N6,1200)
+ 1200 FORMAT(' This spectrum hasn''t a good lambda scale.'/
+ 1 ' Enter the first lambda value (=0:exit;<0:log)')
+ READ(N5,*,ERR=500) ALAMBDA0
+ IF(ALAMBDA0.EQ.0.0D0) RETURN
+ IF(ALAMBDA0.GT.0.0D0) THEN
+ WRITE(N6,1300)
+ 1300 FORMAT(' Enter the (LINEAR) lambda step (0: exit,',
+ 1 ' <0 :last lambda)')
+ READ(N5,*,ERR=500) ALAMSTP
+ IF(ALAMSTP.EQ.0.0) RETURN
+ IF(ALAMSTP.LT.0.0) ALAMSTP=-(ALAMSTP+ALAMBDA0)/(N-1)
+ TL0(1)=ALAMBDA0
+ DO 5 I=2,N
+ 5 TL0(I)=ALAMBDA0+ALAMSTP*(I-1)
+ WRITE(N6,1400) ALAMBDA0,TL0(N),ALAMSTP
+ 1400 FORMAT(' Firts,last lambda and l2-l1:'/1X,3G20.10)
+ ELSE IF(ALAMBDA0.LT.0.0D0) THEN
+ WRITE(N6,1500)
+ 1500 FORMAT(' LOG SCALE: enter first,second lambda',
+ 1 '(first=<0:Return, second<0 =last lam.)')
+ READ(N5,*,ERR=500) ALAMBDA0,ALAMBDA1
+ IF(ALAMBDA0.LE.0.0.OR.ALAMBDA1.EQ.0.0) RETURN
+ IF(ALAMBDA1.LT.0.0) THEN
+ ALAMBDA1=-ALAMBDA1
+ ALAMSTP=(ALAMBDA1/ALAMBDA0)**(1./(N-1.))
+ ALAMBDA1=ALAMBDA0*ALAMSTP
+ ELSE
+ ALAMSTP=ALAMBDA1/ALAMBDA0
+ ENDIF
+ TL0(1)=ALAMBDA0
+ TL0(2)=ALAMBDA1
+ DO 20 I=3,N
+ 20 TL0(I)=TL0(I-1)*ALAMSTP
+ WRITE(N6,1600) ALAMBDA0,ALAMBDA1,TL0(N),ALAMSTP
+ 1600 FORMAT(' Firts,second,last lambda and l2/l1:'/1X,4G20.10)
+ ENDIF
+ RETURN
+ 500 WRITE(N6,5000)
+ 5000 FORMAT(' READ ERROR !, INPUT AGAIN !!!!!! ')
+ GOTO 10
+ END
+C
+ SUBROUTINE LOGSCA(A0,N)
+C ------------------------------------------
+C Spectrum into log spectrum
+C ------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION A0(N)
+C
+C Looks for the minimun value
+ K=1
+ DO 5 I=1,N
+ IF(A0(I).LT.SHIFT) SHIFT=A0(I)
+ 5 CONTINUE
+C Rise the spectrum to avoid negative values
+ IF(SHIFT.LT.0.) THEN
+ WRITE(N6,1000) SHIFT
+ 1000 FORMAT(' Some data are less than zero, all spectrum summed to',
+ 1 E12.5)
+ DO 7 I=1,N
+ 7 A0(I)=A0(I)-SHIFT
+ ENDIF
+C Renormalizes the spectrum
+ CALL MEANORM(A0,N,1)
+C Transforms to LOG10
+ DO 10 I=1,N
+ IF(A0(I).EQ.0.) GOTO 10
+ A0(I)=LOG10(A0(I))
+ 10 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE LOGSCAL(TL0,T0,TL,T,N,NMAX,K,NEWN,
+ 1 TLA,TLB,AL2L1,AL2,PXL,SINCERR)
+C ---------------------------------------------------------
+C To transform the spectrum in a lambda log scale it is
+C piecewise interpolated by a polinomium
+C of order K-1 , a new lambda logaritmic interval is used
+C to divide the lambda range in NEWN points.
+C If K=0 Wittaker sinc interpolation is used
+C Output is a spectrum of NEWN points
+C If TLA,TLB>= use these as first and last lambda values,
+C OR AL1L2=L2/L1 , if given, or AL2=lambda(2), if given
+C Otherwise TL0(1),TL0(N), if these are not good limits
+C asks for first lambda value and lambda interval
+C sincerr is 1/error in the interpolation sinc law
+C ---------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ DIMENSION TL0(NMAX),T0(NMAX),TL(NMAX),T(NMAX),PXL(NMAX)
+ REAL*8 DELTAL,FIRSTL,ALASTL,ALAMBDA0,ALAMSTP
+ REAL*8 ALAM,ALAM1,DELTN
+C
+ IF(NEWN.LE.0) NEWN=N
+ IF(NEWN.GT.NMAX) THEN
+ WRITE(N6,1000) NMAX,NEWN
+ 1000 FORMAT(' ERROR!! Execution impossible, the value of NMAX:',
+ 1 I6,' must be increased to ',I6)
+ RETURN
+ ENDIF
+ 100 IF(K.GT.N.OR.K.LT.0) THEN
+ WRITE(N6,1100) K-1
+ 1100 FORMAT(I5,': invalid value for polinomium order! REENTER')
+ READ(N5,*) K
+ K=K+1
+ GOTO 100
+ ENDIF
+C
+ ERROR=0.0
+ TERROR=0.0
+C If this spectrum has't a lambda scale builds it
+ KSCAL=0
+ CALL LEGGESCAL(TL0,N,KSCAL)
+C
+C IF(TL0(1).LE.10.0.OR.TL0(N).LE.0.0) THEN
+C WRITE(N6,1200)
+C 1200 FORMAT(' This spectrum has''t a good lambda scale.'/
+C 1 ' Enter the first lambda value (<=0 to exit)')
+C READ(N5,*) ALAMBDA0
+C IF(ALAMBDA0.LE.0.0) RETURN
+C WRITE(N6,1300)
+C 1300 FORMAT(' Enter the (LINEAR) lambda step (<=0 to exit)')
+C READ(N5,*) ALAMSTP
+C IF(ALAMSTP.LE.0.0) RETURN
+C TL0(1)=ALAMBDA0
+C DO 5 I=2,N
+C 5 TL0(I)=ALAMBDA0+ALAMSTP*(I-1)
+C ENDIF
+C Saves the spectrum in T,TL
+ DO 10 I=1,N
+ TL(I)=TL0(I)
+ 10 T(I)=T0(I)
+C New Lambda interval (equilogaritmic lambda scale)
+C Uses TLA,TLB as first and last lambda,
+C if <=0 then TL0(1),TL0(N) are used
+ IF(TLA.GT.0.0.AND.TLB.GT.TLA) THEN
+ FIRSTL=TLA
+ ALASTL=TLB
+ DELTAL=(ALASTL/FIRSTL)**(1./(NEWN-1))
+ ELSE IF(TLB.LE.0.0.AND.TLA.GT.0.0.AND.AL2L1.GT.0.0) THEN
+ FIRSTL=TLA
+ DELTAL=AL2L1
+ ALASTL=FIRSTL*DELTAL**(NEWN-1)
+ ELSE IF(TLB.LE.0.0.AND.TLA.GT.0.0.AND.AL2.GT.0.0) THEN
+ FIRSTL=TLA
+ DELTAL=DBLE(AL2)/DBLE(TLA)
+ ALASTL=FIRSTL*DELTAL**(NEWN-1)
+ ELSE
+ FIRSTL=TL0(1)
+ ALASTL=TL0(N)
+ DELTAL=(ALASTL/FIRSTL)**(1./(NEWN-1))
+ ENDIF
+C
+ IF(K.GT.0) THEN ! POLINOMIAL INTERPOLATION ...................
+C
+C First,last and central point for interpolation
+ I1=1
+ I2=K
+ IC=K/2+1
+ IF(IC.LT.1) IC=1
+C Computes the new interpolated values
+ ALAM=FIRSTL/DELTAL
+ DO 30 I=1,NEWN
+C New lambda value
+C TL0(I)=FIRSTL*DELTAL**(I-1) ! Warning !
+C L'importante e' avere sempre lo stesso
+C rapporto fra lambda successive; anche se
+C si accumula errore e' lo stesso, solo che
+C alla fine (a TL0(NEWN)), si arriva ad un
+C lambda un po piu'piccolo o piu' grande.
+C TL0(I)=TL0(I-1)*DELTAL ! Questo sarebbe meglio, ma veramente
+C ! questo o quello sopradanno gli stessi valori ....
+ ALAM1=ALAM*DELTAL ! mi faccio la scala lambda in doppia
+ TL0(I)=REAL(ALAM1) ! precisione, ma mi sa che e'
+ ALAM=ALAM1 ! superfluo.....
+C
+C If passed over TL(ic) change popint for interpolation
+ 300 IF(TL0(I).GT.TL(IC).AND.I2.LT.N) THEN
+ IC=IC+1
+ I1=I1+1
+ I2=I2+1
+ GOTO 300
+ ENDIF
+C Interpolated value at TL0(I)
+ CALL POLINT(TL(I1),T(I1),K,TL0(I),T0(I),ERR)
+C
+ IF(T0(I).NE.0.0) ERR=ERR/T0(I)*100.
+ IF(ERR.GT.ERROR) ERROR=ERR
+ TERROR=TERROR+ERR
+ 30 CONTINUE
+C
+ TERROR=TERROR/NEWN
+ WRITE(N6,3000) N,NEWN,K-1,K-2,TERROR,ERROR
+ 3000 FORMAT(' Data changed from:',I5,' to:',I5,' lambda values.'/
+ 1 ' Medium and maximum % interpolation error:'/
+ 2 ' ( % difference between polinomial of order ',
+ 3 I3,' and ',I3,' )'/
+ 4 E12.5,1x,E12.5)
+C
+ ELSE ! WITTAKER SINC INTERP ......
+C ! Really, it does't work ...
+C IF(SINCERR.LE.0) THEN
+C WRITE(N6,2000)
+C 2000 FORMAT(' Enter 1/error in sinc interpolation')
+C READ(N5,*)SINCERR
+C IF(SINCERR.LE.0.0) SINCERR=1000000.
+C ENDIF
+C
+ DELTLN=LOG(DELTAL)
+ TL0(1)=0 ! Log lambda scale in TL0, in units of ln(deltal)
+ DO 40 I=2,N
+ TL0(I)=LOG(DBLE(TL(I))/FIRSTL)/DELTLN
+ 40 CONTINUE
+C
+ T0(1)=T(1) ! first value unchanged
+ TSCALE=1.
+ DO 45 I=2,NEWN
+C T0(I)=WITTC(T,TL0,PXL(I),N,TSCALE,SINCERR)
+ T0(I)=WITT(T,TL0,PXL(I),N,TSCALE)
+ 45 CONTINUE
+C
+ TL0(1)=FIRSTL ! now set true lambda scale in Amstrong
+ DO 50 I=2,NEWN-1
+ 50 TL0(I)=FIRSTL*DELTAL**(I-1)
+ TL0(NEWN)=ALASTL
+ WRITE(N6,2500) NEWN,SINCERR
+ 2500 FORMAT(1X,I5,' values obtained by sinc interp., error:',G15.5)
+ ENDIF ! IF ON POLY. OR SINC ..................
+C
+ WRITE(N6,3020) TL0(1),TL(1),FIRSTL
+ WRITE(N6,3010) TL0(NEWN),TL(N),ALASTL
+ WRITE(N6,3030) DELTAL
+ 3010 FORMAT(' Last lambda:',F15.4,' old :',F15.4,
+ 1 ' imposed :',F15.4)
+ 3020 FORMAT(' First lambda:',F15.4,' old :',F15.4,
+ 1 ' imposed :',F15.4)
+ 3030 FORMAT(' L2/L1:',G15.6)
+C
+ N=NEWN
+ RETURN
+ END
+C
+ SUBROUTINE MAXPRINT(C,CL,N,N6,CMAX,KCMAX)
+C --------------------------------------------
+C finds first 10 maximum values in C(n)
+C cmax is the max value, kcmax its index
+C --------------------------------------------
+ DIMENSION C(N),CL(N),NMAX(10)
+C
+ KMIN=1
+ DO 35 I=1,N
+ IF(C(I).LT.C(KMIN)) KMIN=I
+ 35 CONTINUE
+C Find the maximum value (on the first n values)
+ DO 40 I=1,10
+ K=KMIN
+ DO 45 J=1,N
+ IF(C(J).LE.C(K)) GO TO 45
+ DO 50 JJ=1,I-1
+ IF(NMAX(JJ).EQ.J) GO TO 45
+ 50 CONTINUE
+ K=J
+ 45 CONTINUE
+ NMAX(I)=K
+ 40 CONTINUE
+C
+ KCMAX=NMAX(1)
+ CMAX=C(KCMAX)
+C
+ DO 60 I=1,10
+ K=NMAX(I)
+ WRITE(N6,1000) K,K-1,CL(K),C(K)
+ 1000 FORMAT(' Point',I5,' z',I4,' Doppler shift (km/sec):',E12.5,
+ 1 ' Correlation:',E12.5)
+ 60 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE MAXPRINTC(C,CL,N,N3,N6,CMAX,KCMAX)
+C --------------------------------------------
+C finds first 10 maximum values in C(n)
+C cmax is the max value, kcmax its index
+C differs from maxprint in looking for in
+C the n3 central values,
+C --------------------------------------------
+ DIMENSION C(N),CL(N),NMAX(10)
+C
+C loocks for the min value
+ KMIN=N/2
+ DO 35 I=N/2-N3/2,N/2+N3/2
+ IF(C(I).LT.C(KMIN)) KMIN=I
+ 35 CONTINUE
+C Find the maximum value (on the first n values)
+ DO 40 I=1,10
+ K=KMIN
+ DO 45 J=N/2-N3/2,N/2+N3/2
+ IF(C(J).LE.C(K)) GO TO 45
+ DO 50 JJ=1,I-1
+ IF(NMAX(JJ).EQ.J) GO TO 45
+ 50 CONTINUE
+ K=J
+ 45 CONTINUE
+ NMAX(I)=K
+ 40 CONTINUE
+C
+ KCMAX=NMAX(1)
+ CMAX=C(KCMAX)
+C
+ DO 60 I=1,10
+ KK=NMAX(I)
+ WRITE(N6,1000) KK,KK-N/2-1,CL(KK),C(KK)
+ 1000 FORMAT(' Point',I5,' z',I4,' Doppler shift (km/sec):',E12.5,
+ 1 ' Correlation:',E12.5)
+ 60 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE MEANORM(A,N,K)
+C -----------------------------------------------------------
+C Normalizes to the medium value (if K<=0 ask for input)
+C -----------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION A(N)
+ CHARACTER*1 YN
+C
+ IF(N.LE.0) THEN
+ WRITE(N6,2888)
+ 2888 FORMAT(' ERROR! No values in spectrum')
+ RETURN
+ ENDIF
+ TOT=0.0
+ DO 10 I=1,N
+ 10 TOT=TOT+A(I)
+ TOT=TOT/N
+ IF(TOT.LT.0.0) THEN
+ WRITE(N6,2999)TOT
+ 2999 FORMAT(' MEDIUM VALUE < 0 :',E12.5,' sign changed!')
+ TOT=-TOT
+ ENDIF
+c KL<=0 ask for normalization; K>0 normalizes without asking
+ IF(K.GT.0) GOTO 100
+ WRITE(N6,3000) TOT
+ 3000 FORMAT(' The medium value is:',E12.5,' Must I normalize?'
+ 1 '(Y/N)')
+ READ(N5,3001) YN
+ 3001 FORMAT(A)
+ IF(YN.NE.'Y'.AND.YN.NE.'y') GOTO 200
+ IF(TOT.EQ.0.0) GOTO 200
+ 100 DO 20 I=1,N
+ 20 A(I)=A(I)/TOT
+ WRITE(N6,4000) TOT
+ 4000 FORMAT(' Normalized to the medium value:',E12.5)
+ RETURN
+ 200 WRITE(N6,4400)
+ 4400 FORMAT(' Data not normalized.')
+ RETURN
+ END
+C
+ SUBROUTINE MEANSUB(A,N)
+C -----------------------------------------------------------
+C Subtract the mean spectrum value
+C -----------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION A(N)
+ CHARACTER*1 YN
+C
+ TOT=0.0
+ DO 10 I=1,N
+ 10 TOT=TOT+A(I)
+ TOT=TOT/N
+ WRITE(N6,3000) TOT
+ 3000 FORMAT(' Subtracted medium value :',G15.5)
+C3000 FORMAT(' The medium value is:',E12.5,' Must I subtract ?'
+C 1 '(Y/N)')
+C READ(N5,3001) YN
+C 3001 FORMAT(A)
+C IF(YN.EQ.'Y'.OR.YN.EQ.'y') THEN
+ DO 20 I=1,N
+ 20 A(I)=A(I)-TOT
+C WRITE(N6,4000)
+C 4000 FORMAT(' Medium value subtracted.')
+ RETURN
+C ELSE
+C WRITE(N6,4400)
+C 4400 FORMAT(' Medium value not subtracted.')
+C RETURN
+C ENDIF
+ END
+C
+ FUNCTION NASKBUF(N5,N6,MAXBUF,NB,BUFTIT)
+C ----------------------------------------------
+C ASK the user a buffer number
+C ----------------------------------------------
+ CHARACTER*(*) BUFTIT(MAXBUF)
+C
+ NERR=0
+ 10 WRITE(N6,1000)MAXBUF,(J,BUFTIT(J),J=1,NB)
+ 1000 FORMAT(' Enter the complex buffer number, max:',I2
+ 1 /(1X,' buffer n.',I2,1X,A30) )
+ READ(N5,*,ERR=500) A
+ NA=A
+ IF(NA.LE.MAXBUF.AND.NA.GT.0) THEN
+ NASKBUF=NA
+ ELSE ! if error givess 2 other chances then quit
+ 500 NERR=NERR+1
+ IF(NERR.LE.3) THEN
+ WRITE(N6,2000) NERR,NA,MAXBUF
+ 2000 FORMAT(1X,I1,' INPUT ERROR ! ',I3,' is wrong !',
+ 1 ' give a number >0 and <= ',I3)
+ GOTO 10
+ ELSE
+ WRITE(N6,3000)
+ 3000 FORMAT(' ERROR AGAIN! Command aborted')
+ NASKBUF=0
+ ENDIF
+ ENDIF
+ RETURN
+ END
+C
+ SUBROUTINE PARAB(X,PK,Y,DYDA,N)
+C --------------------------------------------
+C Y=LN Y=LN D - 2(pi*enne*sigma/c)**2 *X**2
+C PK(1)= sigma/c , PK(2)= ln D
+C --------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ PARAMETER PI=3.141592653589793
+C
+ Y= PK(2) -2.*(PI*X/ENNE*PK(1))**2
+ DYDA(1)= -(PI*X/ENNE)**2 *4.*PK(1)
+ DYDA(2)= 1.0
+C
+ RETURN
+ END
+C
+ SUBROUTINE PARABG(X,PK,Y,DYDA,N)
+C --------------------------------------------
+C Y=LN Y=LN D - 2(pi*enne*sigma/c)**2 *X**2
+C PK(1)= sigma/c , PK(2)= ln D
+C W2: weights
+C --------------------------------------------
+ DIMENSION PK(N),DYDA(N)
+ REAL*8 DLL
+ COMMON /GUESSPK/ENNE,DLL
+ PARAMETER (NPTMX=10000)
+ COMPLEX W1
+ COMMON /WEIGHT/W(NPTMX),W1(NPTMX),W2(NPTMX)
+ PARAMETER PI=3.141592653589793
+C
+ K=X+ENNE/2+1
+ Y=W2(K)+ PK(2) -2.*(PI*X/ENNE*PK(1))**2
+ DYDA(1)= -(PI*X/ENNE)**2 *4.*PK(1)
+ DYDA(2)= 1.0
+C
+ RETURN
+ END
+C
+ SUBROUTINE PLOTTA(N,P,X,Y,YC,XMAX,XMIN,YMAX,YMIN,VARNAME,KF)
+C -----------------------------------------------------
+C This routine calls the old mongo subroutine
+C to plot y(x) or y(p) if x hasn't a good scale
+C x values must be in increasing order. (this is not tested here!)
+C KF is a format specifier
+C KF=0 Y(x) (if possible)
+C KF=1 Y(p) (p=1,2,.....n - P is integer)
+C KF=2 Y(P)(dots) superimposed to YC(P) (continuous line)
+C KF=3 Y(P)(dotted line) superimposed to YC(P) (continuous line)
+C KF=4 Y(P)(DOTS+dotted line) superimposed to YC(P) (continuous line)
+C VARNAME a y label for the plot
+C KFL=0 p on x axis
+C KFL>=1 x on x axis
+C -----------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION X(N),Y(N),P(N),YC(N)
+ CHARACTER*(*) VARNAME
+ CHARACTER*1 CHAR
+ CHARACTER*20 LABEL1
+ CHARACTER*22 OUTLABEL
+ CHARACTER*80 OUTVARNAME ! to store varname // ends
+ CHARACTER*2 ENDS ! mongo's string terminator
+ DATA ENDS/'\e'/
+C
+ LOGICAL XTERM/.FALSE./
+C mongo common
+ COMMON/LN03/NUMDEV1
+C
+C default pixel or x on x axis ( depending on KF )
+ IF(KF.LE.0) THEN
+ KFL=0
+ ELSE
+ KFL=1
+ ENDIF
+C
+ LVARNAME=LEN(VARNAME) ! length of varname
+ IF(LVARNAME.GT.78) LVARNAME=78 ! max 78 caratteri
+ OUTVARNAME=VARNAME(1:LVARNAME)//ENDS ! adding string terminator
+ LVARNAME=LVARNAME+2 ! Length of outvarname
+C
+ N1=1 ! first value to plot
+ N2=N ! last value to plot
+ N2N1=N2-N1+1 ! number of values to plot
+C
+C tests and sets x-y limits
+ CALL PLOTLIM(N,P,X,Y,YC,N1,N2,KFL,KF,XMAX,XMIN,YMAX,YMIN)
+C
+C ............................. interactive usage loop
+ 20 CONTINUE
+ WRITE(N6,2001)XMIN,XMAX,YMIN,YMAX,X(1),N,X(N),N1,N2,KF
+ 2001 FORMAT(' Xmin-max,ymin-max:',4G15.6/
+ 1 ' x(1)=',G15.6,' x(',I5,')=',G15.6,
+ 2 ' N1,N2,KF='3I5)
+ WRITE(N6,2000)
+ 2000 FORMAT(/' PLOTTING ROUTINE: Enter one of the following:'//
+ 1 ' Y : plotter on laser, V : on video,X:Xterm '/
+ 2 ' C : to change plot limits, E : end'/
+ 3 ' P : sets pixel on x axis L: lambda on axis'/
+ 4 ' F : change format')
+ READ(N5,3000,ERR=500) CHAR
+ 3000 FORMAT(A)
+C
+C ................................... If xterminal set special option
+ IF(CHAR.EQ.'X'.OR.CHAR.EQ.'x') THEN
+ XTERM=.TRUE.
+ CHAR='V'
+ ELSE
+ XTERM=.FALSE.
+ ENDIF
+C ............................... Change format for superimposed plots
+ IF(CHAR.EQ.'F'.OR.CHAR.EQ.'f') THEN
+ WRITE(N6,3100) KF
+ 3100 FORMAT(' Enter: 1: Y cont - 2: dots+cont - 3:dotted+cont -'
+ 1 ' 4: dot,dotted + cont. Now:',I5)
+ READ(N5,*,ERR=500) KKKFFF
+ IF(KKKFFF.GE.1.AND.KKKFFF.LE.4) KF=KKKFFF
+C however, if you are plotting only y(x), asking here for two
+C superimposed plots (KF>1) gives meaningless plot
+C ................................ changing x,y limits
+ ELSE IF(CHAR.EQ.'C'.OR.CHAR.EQ.'c') THEN
+ WRITE(N6,4000)
+ 4000 FORMAT(' PLOTTING ROUTINE: Enter XMIN,XMAX,YMIN,YMAX ')
+ READ(N5,*,ERR=500) XXMIN,XXMAX,YMIN,YMAX
+ IF(XXMAX.GT.XXMIN) THEN
+ XMAX=XXMAX ! else old values retained
+ XMIN=XXMIN
+ ENDIF
+C change n1 and n2 ( plot limits )
+C initial values
+ N1=1
+ N2=N
+ IF(KFL.LE. 0) THEN ! for y(x) plot : kfl =0
+ DO 40 I=1,N ! Looks for xmax,xmin
+ IF(X(I).GE.XMIN) THEN
+ N1=I
+ GOTO 400
+ ENDIF
+ 40 CONTINUE
+ 400 CONTINUE
+ DO 41 I=N1,N
+ IF(X(I).GE.XMAX) THEN
+ N2=I
+ GOTO 401
+ ENDIF
+ 41 CONTINUE
+ 401 CONTINUE
+ ELSE ! for y(p) plot : kf=1,2,3
+ DO 42 I=1,N ! Looks for first and last pixel
+ IF(P(I).GE.XMIN) THEN
+ N1=I
+ GOTO 402
+ ENDIF
+ 42 CONTINUE
+ 402 CONTINUE
+ DO 43 I=N1,N
+ IF(P(I).GE.XMAX) THEN
+ N2=I
+ GOTO 403
+ ENDIF
+ 43 CONTINUE
+ 403 CONTINUE
+ ENDIF
+C sets and tests x-y limits
+ CALL PLOTLIM(N,P,X,Y,YC,N1,N2,KFL,KF,XMAX,XMIN,YMAX,YMIN)
+C
+ ELSE IF (CHAR.EQ.'P'.OR.CHAR.EQ.'p') THEN ! pixel plot
+ KFL=1
+ XMIN=P(N1)
+ XMAX=P(N2)
+ ELSE IF (CHAR.EQ.'L'.OR.CHAR.EQ.'l') THEN ! x on x axis
+ KFL=0
+ XMIN=X(N1)
+ XMAX=X(N2)
+C sets and tests x-y limits
+ CALL PLOTLIM(N,P,X,Y,YC,N1,N2,KFL,KF,XMAX,XMIN,YMAX,YMIN)
+C
+ ELSE IF(CHAR.EQ.'E'.OR.CHAR.EQ.'e') THEN
+ RETURN
+C
+ ELSE IF(CHAR.EQ.'Y'.OR.CHAR.EQ.'y') THEN
+C ............................... laser plotting
+C This is a trick inserted in old Vista mongo by Giallongo
+C and Held; it simulates with unit 2 a terminal tektronik device
+C on which the plot is written, numdev1=13 is a flag to
+C distinguish from a true tektronik terminal
+C at the end fileplot prints plotln03.dat and resets numdev1
+C
+ WRITE(N6,5000)
+ 5000 FORMAT(' Enter a Label for the plot (max 20 char)')
+ READ(N5,3001,ERR=500) LABEL1
+ 3001 FORMAT(A20)
+ OUTLABEL=LABEL1//ENDS ! add terminator string
+C
+ OPEN(UNIT=2,NAME='PLOTLN03.DAT',STATUS='NEW',
+ 1 FORM='UNFORMATTED')
+C
+ NUMDEV1=13
+ CALL DEVICE(13)
+ CALL TSETUP
+C CALL ERASE
+ CALL SETLIM(XMIN,YMIN,XMAX,YMAX)
+ CALL BOX(1,2)
+C
+ N2N1=N2-N1+1
+ IF(KF.LE.1) THEN ! Y(X) or Y9p)
+ IF(KFL.LE.0) THEN
+ CALL CONNECT(X(N1),Y(N1),N2N1)
+ ELSE
+ CALL CONNECT(P(N1),Y(N1),N2N1)
+ ENDIF
+ ELSE IF (KF.EQ.2) THEN
+ STILE=61.5 ! 2 = punti , 61=asterischi a 6 punte
+ IF(KFL.GT.0) THEN
+ CALL POINTS(STILE,1,P(N1),Y(N1),N2N1)
+ CALL CONNECT(P(N1),YC(N1),N2N1)
+ ELSE
+ CALL POINTS(STILE,1,X(N1),Y(N1),N2N1)
+ CALL CONNECT(X(N1),YC(N1),N2N1)
+ ENDIF
+ ELSE IF (KF.EQ.3) THEN
+ CALL SETLTYPE(1)
+ IF(KFL.GT.0) THEN
+ CALL CONNECT(P(N1),Y(N1),N2N1)
+ CALL SETLTYPE(0)
+ CALL CONNECT(P(N1),YC(N1),N2N1)
+ ELSE
+ CALL CONNECT(X(N1),Y(N1),N2N1)
+ CALL SETLTYPE(0)
+ CALL CONNECT(X(N1),YC(N1),N2N1)
+ ENDIF
+ ELSE IF (KF.EQ.4) THEN
+ STILE=61.5 ! 2 = punti , 61=asterischi a 6 punte
+ IF(KFL.GT.0) THEN
+ CALL POINTS(STILE,1,P(N1),Y(N1),N2N1)
+ CALL SETLTYPE(1)
+ CALL CONNECT(P(N1),Y(N1),N2N1)
+ CALL SETLTYPE(0)
+ CALL SETLWEIGHT(2)
+ CALL CONNECT(P(N1),YC(N1),N2N1)
+ ELSE
+ CALL POINTS(STILE,1,X(N1),Y(N1),N2N1)
+ CALL SETLTYPE(1)
+ CALL CONNECT(X(N1),Y(N1),N2N1)
+ CALL SETLTYPE(0)
+ CALL SETLWEIGHT(2)
+ CALL CONNECT(X(N1),YC(N1),N2N1)
+ ENDIF
+ CALL SETLWEIGHT(1)
+ ENDIF
+ N22=22
+ CALL YLABEL(LVARNAME,OUTVARNAME)
+ CALL XLABEL(N22,OUTLABEL)
+ CALL GRELOCATE(0.,0.) ! cerco di evitae scarabbocchi
+ CALL LABEL(1,' \e')
+ CALL GRELOCATE(0.,0.)
+ CALL LABEL(1,'. \e ')
+
+ NVEC=FILEPLOT(0) ! this submits the plot to laser
+ WRITE(N6,8000)
+ 8000 FORMAT(' PLOT SUBMITTED, enter options for a new plot ..')
+C
+ ELSE IF(CHAR.EQ.'V'.OR.CHAR.EQ.'v') THEN
+C ............... plot on a vt220 type device
+ IF(XTERM) THEN
+ CALL DEVICE(12)
+ ELSE
+ CALL DEVICE(2)
+ ENDIF
+ CALL TSETUP
+ CALL ERASE
+ CALL SETLIM(XMIN,YMIN,XMAX,YMAX)
+ CALL BOX(1,2)
+ N2N1=N2-N1+1
+ IF(KF.LE.1) THEN
+ IF(KFL.LE.0) THEN
+ CALL CONNECT(X(N1),Y(N1),N2N1)
+ ELSE
+ CALL CONNECT(P(N1),Y(N1),N2N1)
+ ENDIF
+ ELSE IF (KF.EQ.2) THEN
+ STILE=2.
+ IF(KFL.GT.0) THEN
+ CALL POINTS(STILE,1,P(N1),Y(N1),N2N1)
+ CALL CONNECT(P(N1),YC(N1),N2N1)
+ ELSE
+ CALL POINTS(STILE,1,X(N1),Y(N1),N2N1)
+ CALL CONNECT(X(N1),YC(N1),N2N1)
+ ENDIF
+ ELSE IF (KF.EQ.3) THEN
+ IF(KFL.GT.0) THEN
+ CALL SETLTYPE(1)
+ CALL CONNECT(P(N1),Y(N1),N2N1)
+ CALL SETLTYPE(0)
+ CALL CONNECT(P(N1),YC(N1),N2N1)
+ ELSE
+ CALL SETLTYPE(1)
+ CALL CONNECT(X(N1),Y(N1),N2N1)
+ CALL SETLTYPE(0)
+ CALL CONNECT(X(N1),YC(N1),N2N1)
+ ENDIF
+ ELSE IF (KF.EQ.4) THEN
+ CALL SETLTYPE(1)
+ IF(KFL.GT.0) THEN
+ CALL CONNECT(P(N1),Y(N1),N2N1)
+ CALL SETLTYPE(0)
+ CALL SETLWEIGHT(2)
+ CALL CONNECT(P(N1),YC(N1),N2N1)
+ ELSE
+ CALL CONNECT(X(N1),Y(N1),N2N1)
+ CALL SETLTYPE(0)
+ CALL SETLWEIGHT(2)
+ CALL CONNECT(X(N1),YC(N1),N2N1)
+ ENDIF
+ CALL SETLWEIGHT(1)
+ ENDIF
+ CALL YLABEL(LVARNAME,OUTVARNAME)
+ CALL TIDLE
+ READ(N5,3000,ERR=500) CHAR
+C
+ ELSE
+ WRITE(N6,8800) CHAR
+ 8800 FORMAT(' Unrecognized command: ',A5,' reenter.')
+ ENDIF
+ GOTO 20
+C
+ 500 CONTINUE
+ WRITE(N6,9000)
+ 9000 FORMAT(' PLOTTING ROUTINE: ERROR DURING READ ! ')
+ GOTO 20
+ END
+C
+ SUBROUTINE PLOTLIM(N,P,X,Y,YC,N1,N2,KF,KF1,XMAX,XMIN,YMAX,YMIN)
+C ---------------------------------------------------------
+C used by subroutine plot to test and set x-y limits
+C KF=0 => Y(X) ; KF=1 => Y(P)
+C KF1 > 1 => Y(X) + YC(X)
+C ---------------------------------------------------------
+ COMMON/TAPE/N5,N6,N7
+ DIMENSION P(N),X(N),Y(N),YC(N)
+C
+C ............... Trying to set good x limits (fra N1,N2)
+ IF(XMAX.LE.XMIN.AND.KF.LE.0) THEN ! y(x) , per kf=0
+ WRITE(N6,900) XMAX,XMIN
+ 900 FORMAT(' Searching for good x limits, now:',2G15.4)
+ XMIN=X(N1)
+ XMAX=X(N2)
+ ENDIF
+C If x limits can't be set then use y(pixel number)
+ IF(XMAX.LE.XMIN) THEN ! y(p) , per kf=1,2 o bad x,y lim
+ IF(KF.LE.1) KF=1
+ XMIN=P(N1)
+ XMAX=P(N2)
+ ENDIF
+C ...................... y limits
+ IF(YMAX.LE.YMIN) THEN
+ WRITE(N6,910) YMAX,YMIN
+ 910 FORMAT(' Searching for good y limits, now:',2G15.4)
+ YMAX=Y(N1)
+ YMIN=Y(N1)
+ DO 20 I=N1+1,N2
+ IF(Y(I).LT.YMIN) YMIN=Y(I)
+ IF(Y(I).GT.YMAX) YMAX=Y(I)
+ IF(KF1.GT.1) THEN
+ IF(YC(I).LT.YMIN) YMIN=YC(I)
+ IF(YC(I).GT.YMAX) YMAX=YC(I)
+ ENDIF
+ 20 CONTINUE
+ IF(YMAX.LE.YMIN) THEN
+ YMAX=YMIN+1. ! for constant data stream
+ YMIN=YMIN-1.
+ ENDIF
+ ENDIF
+ RETURN
+ END
+C
+ SUBROUTINE POLY(X,A,MFIT)
+C ----------------------------
+C Polinomium terms
+C ----------------------------
+ DIMENSION A(MFIT)
+ A(1)=1.
+ DO 10 I=2,MFIT
+ 10 A(I)=A(I-1)*X
+ RETURN
+ END
+C
+ SUBROUTINE POWER(F,P,N)
+C --------------------------------------------------------
+C Power spectrum of a complex vector
+C --------------------------------------------------------
+ COMPLEX F(N)
+ DIMENSION P(N)
+C
+ DO 10 I=1,N
+ P(I)=F(I)*CONJG(F(I))
+ 10 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE PRINTA(AL,A,N)
+C -----------------------------------------------------
+C Writes a spectrum to a file to be read by a plotting routine
+C -----------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ DIMENSION AL(N),A(N)
+ CHARACTER*20 OUTFILE
+ CHARACTER*80 TITOLO
+C
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter output file name')
+ READ(N5,1100) OUTFILE
+ 1100 FORMAT(A20)
+ OPEN(UNIT=11,FILE=OUTFILE,STATUS='NEW',FORM='FORMATTED')
+C
+ DO 10 I=1,3
+ WRITE(N6,2200)
+ 2200 FORMAT(' Enter a title line')
+ READ(N5,1200) TITOLO
+ 1200 FORMAT(A80)
+ 10 WRITE(11,1200) TITOLO
+C
+ WRITE(11,3000) (I,AL(I),A(I),I=1,N)
+ 3000 FORMAT(1X,I6,1X,E20.13,1X,E20.13)
+C
+ WRITE(N6,3500) N,OUTFILE
+ 3500 FORMAT(1X,I5,'+3 lines written to file:',A20)
+ CLOSE(UNIT=11)
+ RETURN
+ END
+C
+ SUBROUTINE PRINTC(A,N)
+C -----------------------------------------------------
+C Writes a complex vector into a file for plotting
+C -----------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ COMPLEX A(N)
+ CHARACTER*20 OUTFILE
+ CHARACTER*80 TITOLO
+C
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter output file name')
+ READ(N5,1100) OUTFILE
+ 1100 FORMAT(A20)
+ OPEN(UNIT=11,FILE=OUTFILE,STATUS='NEW',FORM='FORMATTED')
+C
+ DO 10 I=1,3
+ WRITE(N6,2200)
+ 2200 FORMAT(' Enter a title line')
+ READ(N5,1200) TITOLO
+ 1200 FORMAT(A80)
+ 10 WRITE(11,1200) TITOLO
+C
+ WRITE(11,3000) (I,A(I),I=1,N)
+ 3000 FORMAT(1X,I6,1X,E20.13,1X,E20.13)
+C
+ WRITE(N6,3500) N,OUTFILE
+ 3500 FORMAT(1X,I5,'+3 lines written to file:',A20)
+ CLOSE(UNIT=11)
+ RETURN
+ END
+C
+ SUBROUTINE PRINTF(FT,FS,FG,N)
+C -----------------------------------------------------
+C Writes the transforms to a file to be read by a plotting routine
+C -----------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ COMPLEX FS(N),FT(N),FG(N)
+ CHARACTER*20 OUTFILE
+ CHARACTER*80 TITOLO
+C
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter output file name')
+ READ(N5,1100) OUTFILE
+ 1100 FORMAT(A20)
+ OPEN(UNIT=11,FILE=OUTFILE,STATUS='NEW',FORM='FORMATTED')
+C
+ DO 10 I=1,3
+ WRITE(N6,2200)
+ 2200 FORMAT(' Enter a title line')
+ READ(N5,1200) TITOLO
+ 1200 FORMAT(A80)
+ 10 WRITE(11,1200) TITOLO
+C
+ WRITE(11,3000) (I,FT(I),FS(I),FG(I),I=1,N)
+ 3000 FORMAT(1X,I5,1X,6E16.8)
+C
+ WRITE(N6,3500) N,OUTFILE
+ 3500 FORMAT(1X,I5,'+3 lines written to file:',A20)
+ CLOSE(UNIT=11)
+ RETURN
+ END
+C
+ SUBROUTINE PRINTP(AL,A,B,C,N)
+C -------------------------------------------------------------------
+C Writes four real vectors into a file for a plotting routine
+C Used to plot the power spectra.
+C -------------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ DIMENSION AL(N),A(N),B(N),C(N)
+ CHARACTER*20 OUTFILE
+ CHARACTER*80 TITOLO
+C
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter output file name')
+ READ(N5,1100) OUTFILE
+ 1100 FORMAT(A20)
+ OPEN(UNIT=11,FILE=OUTFILE,STATUS='NEW',FORM='FORMATTED')
+C
+ DO 10 I=1,3
+ WRITE(N6,2200)
+ 2200 FORMAT(' Enter a title line')
+ READ(N5,1200) TITOLO
+ 1200 FORMAT(A80)
+ 10 WRITE(11,1200) TITOLO
+C
+ WRITE(11,3000) (I,AL(I),A(I),B(I),C(I),I=1,N)
+ 3000 FORMAT(1X,I6,1X,E20.13,1X,E20.13,1X,E20.13,1X,E20.13)
+C
+ WRITE(N6,3500) N,OUTFILE
+ 3500 FORMAT(1X,I5,'+3 lines written to file:',A20)
+ CLOSE(UNIT=11)
+ RETURN
+ END
+C
+ SUBROUTINE RED(TL0,T0,TL,T,N)
+C ------------------------------------------------------------
+C RED shift the spectra by a given number of points
+C ------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL0(N),T0(N),TL(N),T(N)
+ CHARACTER*1 YN
+C
+ 10 CONTINUE
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter the number of poit (>0 redshift,0=quit)')
+ READ(N5,*) NZ
+ IF(NZ.EQ.0) RETURN
+ IF (NZ.GT.0) THEN
+ DO 20 I=N-NZ,1,-1
+ T(I+NZ)=T0(I)
+ 20 CONTINUE
+ DO 25 I=1,NZ
+ 25 T(I)=0.0
+ ELSE
+ DO 30 I=-NZ+1,N ! -nz being nz<0
+ 30 T(I+NZ)=T0(I) ! +nz being nz<0
+ DO 35 I=N+NZ+1,N
+ 35 T(I)=0.0
+ ENDIF
+C
+C WRITE(N6,2000)
+C 2000 FORMAT(' Do you want to print the shifted spectrum?'
+C 1 '(Y/N)')
+C READ(N5,2001) YN
+C 2001 FORMAT(A)
+C IF(YN.EQ.'Y'.OR.YN.EQ.'y') CALL PRINTA(TL,T,N)
+C WRITE(N6,3000)
+C 3000 FORMAT(' Are you satisfied with this shift?'
+C 1 '(Y/N)')
+C READ(N5,2001) YN
+C IF(YN.EQ.'Y'.OR.YN.EQ.'y') GOTO 500
+C
+C GOTO 10
+C
+ 500 CONTINUE
+ DO 50 I=1,N
+ T0(I)=T(I)
+ 50 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE REDSHIFT(TL0,T0,TL,T,N,K,ZETA,PXL)
+C -----------------------------------------------------------
+C Red shift (or blue shift) the spectrum by a non integer number
+C of points interpolating with a K-1 order pol. or Wittaker sinc.
+C TL0: lambda values, are unchanged and all the interpolation
+C is performed using the pixel number as independent variable
+C
+C The lambda scale is supposed to be a logaritmic one.
+C This is not circular: the point going over N are lost, new
+C ones are 0.0
+C ---------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ DIMENSION TL0(N),T0(N),TL(N),T(N),PXL(N)
+ CHARACTER*1 YN
+C
+ 10 IF(K.GT.N.OR.K.LT.0) THEN
+ WRITE(N6,1000) K-1
+ 1000 FORMAT(' Enter interp.pol.ord. now:',I5,
+ 1 ' (-1=sinc (doesn''t work)')
+ READ(N5,*,ERR=10) K
+ K=K+1
+ GOTO 10
+ ENDIF
+C
+ ERROR=0.0
+ TERROR=0.0
+C If this spectrum has't a lambda scale builds it
+ KSCAL=0
+ CALL LEGGESCAL(TL0,N,KSCAL)
+C
+ IF(ZETA.NE.0.) THEN
+ ZETAKM=299792.458*((TL0(2)/TL0(1))**ZETA-1.)
+ ELSE
+ 20 CONTINUE
+ WRITE(N6,1900)
+ 1900 FORMAT(' Enter v: km/sec ( 0 to give v in pixel)')
+ READ(N5,*,ERR=20) ZETAKM
+C
+ IF(ZETAKM.NE.0.0) THEN
+ ZETA=LOG(ZETAKM/299792.458+1.)/LOG(TL0(2)/TL0(1))
+ ELSE
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter the number of poit (>0 redshift,0=quit)')
+ READ(N5,*,ERR=20) ZETA
+ IF(ZETA.EQ.0.) RETURN
+ ZETAKM=299792.458*((TL0(2)/TL0(1))**ZETA-1.)
+ ENDIF
+ ENDIF
+ PIXKM=ZETAKM/ZETA
+ WRITE(N6,2100) ZETAKM,ZETA,PIXKM
+ 2100 FORMAT(' V(Km/sec):',G12.5,' pixel shift:',G12.5,
+ 1 ' Km/sec/pixel:',G12.5)
+C
+C integer shifting
+ NZ=INT(ZETA)
+ WRITE(N6,2110) NZ
+ 2110 FORMAT(' shifting by integre part, points:',I5)
+ IF (NZ.GT.0) THEN
+ DO 23 I=N-NZ,1,-1
+ T(I+NZ)=T0(I)
+ 23 CONTINUE
+ DO 25 I=1,NZ
+ 25 T(I)=0.0
+ ELSE ! Note: to fill T this holds also for nz=0
+ DO 30 I=-NZ+1,N ! -nz being nz<0
+ 30 T(I+NZ)=T0(I) ! +nz being nz<0
+ DO 35 I=N+NZ+1,N ! +nz being nz<0
+ 35 T(I)=0.0
+ ENDIF
+C
+C shift , interpolating, by the frac. part of zeta
+ ZFRAC=ZETA-NZ
+ IF(ZFRAC.EQ.0.) THEN ! set T0 and returns
+ DO 39 I=1,N
+ 39 T0(I)=T(I)
+ GOTO 500
+ ENDIF
+ WRITE(N6,2120) ZFRAC
+ 2120 FORMAT(' Shifting by the fractional part:',G12.4)
+C Pixel values in which Z must be computed
+ DO 40 I=1,N
+ TL(I)=PXL(I)-ZFRAC
+ 40 CONTINUE
+C
+ IF(K.GT.0) THEN ! POLINOMIAL INTERPOLATION ...................
+C
+C First,last and central point for interpolation
+ I1=1
+ I2=K
+ IC=K/2+1
+ IF(IC.LT.1) IC=1
+ DO 50 I=1,N
+C If passed over TL(ic) change point for interpolation
+ 55 IF(PXL(I).GT.TL(IC).AND.I2.LT.N) THEN
+ IC=IC+1
+ I1=I1+1
+ I2=I2+1
+ GOTO 55
+ ENDIF
+C Interpolated value at TL0(I)
+ CALL POLINT(PXL(I1),T(I1),K,TL(I),T0(I),ERR)
+C
+ IF(T0(I).NE.0.0) ERR=ERR/T0(I)*100.
+ IF(ERR.GT.ERROR) ERROR=ERR
+ TERROR=TERROR+ERR
+ 50 CONTINUE
+C
+ TERROR=TERROR/N
+ WRITE(N6,3000) N,K,ZETA,K-1,K-2,TERROR,ERROR
+ 3000 FORMAT(' Data :',I5,' int.pol.order:',I5,' zeta:',G12.5/
+ 1 ' Medium and maximum % interpolation error:'/
+ 2 ' ( % difference between polinomial of order ',
+ 3 I3,' and ',I3,' )'/
+ 4 G12.5,1x,G12.5)
+C
+ ELSE ! WITTAKER SINC INTERP ......
+C
+C IF(SINCERR.LE.0) THEN
+C WRITE(N6,2000)
+C 2000 FORMAT(' Enter 1/error in sinc interpolation')
+C READ(N5,*)SINCERR
+C IF(SINCERR.LE.0.0) SINCERR=1000000.
+C ENDIF
+C
+ DO 60 I=1,N
+ T0(I)=WITT(T,PXL,TL(I),N,TSCALE)
+C T0(I)=WITTC(T,PXL,TL(I),N,TSCALE,SINCERR)
+ 60 CONTINUE
+C
+ WRITE(N6,2500) N,SINCERR
+ 2500 FORMAT(1X,I5,' values obtained by sinc interp., error:',G15.5)
+ ENDIF ! IF ON POLY. OR SINC ..................
+C
+ 500 CONTINUE
+ WRITE(N6,5000) ZETA
+ 5000 FORMAT(' Spectrum shifted by',G15.5,' points')
+ RETURN
+ END
+C
+ SUBROUTINE RIGHT(TL,T,N)
+C -----------------------------------------------------------
+C The spectrum is right adjusted
+C -----------------------------------------------------------
+ DIMENSION TL(N),T(N)
+C
+C Find the last non zero point
+ DO 10 I=N,1,-1
+ IF(T(I).NE.0.0) GO TO 100
+ 10 CONTINUE
+ RETURN
+ 100 N=I
+ RETURN
+ END
+C
+ SUBROUTINE RUNMC(N,N1,N2,NK,SIG,MAXITER,A)
+C ----------------------------------------------------------
+C Cuts peaks in the fourier transform, between N1,n2
+C Peaks with abs over the mean value by more than sig*stand.dev
+C are substituted by the mean (the exceeding point excluded)
+C performed over Nk/2 point on the left and nk/2 on the right
+C of the point. The transform is supposed periodic.
+C The procedure is iterated maxiter times
+C -----------------------------------------------------------
+ COMMON /TAPE/ N5,N6,N7
+ COMPLEX A(N)
+ COMPLEX SUM,SUM2,SAI
+C
+ ITER=0
+C
+ 1 CONTINUE
+ NK2=NK/2
+ INF=N1-NK2
+ ISUP=N1+NK2
+ NUM=ISUP-INF
+ SUM=0.
+ SUM2=0.
+C
+C Initial value for the running mean (value for N1)
+ DO 10 I=INF,ISUP
+ II=I
+ IF(II.LT.1) II=I+N
+ IF(II.GT.N) II=I-N
+ SUM=SUM+A(II)
+ SUM2=SUM2+A(II)*CONJG(A(II))
+ 10 CONTINUE
+ SUM=SUM/NUM
+ SUM2=SUM2/NUM
+C
+ K=0 ! num of changed values
+C
+C running mean
+ K1=INF ! initial upper and lover bound for the running mean
+ K2=ISUP
+ IF(K1.GT.N) K1=K1-N ! adjusts boundary to simulate
+ IF(K1.LT.1) K1=K1+N ! periodic data stream
+ IF(K2.GT.N) K2=K1-N
+ IF(K2.LT.1) K2=K2+N
+C
+ DO 20 I=N1,N2
+C
+ SAI=SUM-A(I)/NUM ! average excluded current point a(i)
+ AMEDABS=ABS(SAI)
+ AQMED=REAL(SUM2-A(I)*CONJG(A(I))/NUM) ! media di a**2 escluso a(i)
+ AMEDQ=AMEDABS**2 ! ( a medio)**2
+ SIGMA=SQRT(ABS(AQMED-AMEDQ)) ! sigma**2=a**2medio-amedio**2
+C
+ IF(ABS( ABS(A(I))-AMEDABS ) .GT. SIG*SIGMA) THEN
+ K=K+1
+ A(I)=SAI
+ ENDIF
+C shift the running mean by one (for next point)
+ SUM=SUM+ ( A(K2)-A(K1) )/NUM
+ SUM2=SUM2+ ( A(K2)*CONJG(A(K2))-A(K1)*CONJG(A(K1)) )/NUM
+ K1=K1+1
+ IF(K1.GT.N) K1=K1-N
+ K2=K2+1
+ IF(K2.GT.N) K2=K2-N
+C
+ 20 CONTINUE
+C
+ ITER=ITER+1
+ WRITE(N6,1000) ITER,K
+ 1000 FORMAT(' Iteration:',I5,' substituded:',I5,' points')
+ IF(K.GT.0.AND.ITER.LT.MAXITER) GOTO 1
+C
+ RETURN
+ END
+C
+ SUBROUTINE RUNMC1(NSTEP,N,N1,N2,A,B)
+C ---------------------------------------------------------
+C B=running mean of A(N) from N1 to N2, window width: NSTEP
+C A is supposed circular: i.e.:A(N+1)=A(1);A(0)=A(N) etc.
+C nstep is forced to be odd
+C ---------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION A(N),B(N)
+C
+ IF(NSTEP.LE.0) NSTEP=1
+ IF(MOD(NSTEP,2).EQ.0) NSTEP=NSTEP+1
+ IF(N1.GT.N2.OR.N2.GT.N.OR.NSTEP.GT.N.OR.N1.LE.0) THEN
+ WRITE(N6,1000) N1,N2,N,NSTEP
+ 1000 FORMAT(' ERROR IN ROUTINE RUNMC1 !, mean skipped.'/
+ 1 ' parameters: n1,n2,n,nstep=',4I5)
+ RETURN
+ ENDIF
+C
+ B(N1)=0.0
+ DO 10 I=1,NSTEP
+ K=N1-(NSTEP/2)+I-1 ! remember:if nstep odd =>
+ IF(K.LE.0) K=K+N ! => -nstep/2+nstep=nstep/2+1
+ IF(K.GT.N) K=MOD(K,N) ! ( the division is truncated )
+ B(N1)=B(N1)+A(K)
+ 10 CONTINUE
+C
+ DO 20 I=N1+1,N2
+ K=I-1 - (NSTEP/2) ! element to subtract
+ IF(K.LE.0) K=K+N
+ KK=I + (NSTEP/2) ! element to add
+ IF(KK.GT.N) KK=MOD(KK,N)
+ B(I)=B(I-1)-A(K)+A(KK)
+ 20 CONTINUE
+C Normalizing
+ DO 30 I=N1,N2
+ 30 B(I)=B(I)/NSTEP
+C
+ WRITE(N6,2000) N1,N2,NSTEP,N
+ 2000 FORMAT(' Computed running mean between:',I5,' and ',I5,
+ 1 ' window:',I5,' tot. dimension:',I5)
+C
+ RETURN
+ END
+C
+ SUBROUTINE SEGMENT(TL0,T0,TL,T,NT,SL0,S0,SL,S,NS,
+ 1 FT,FS,FG,ANTI,NMAX,NEWN,PXL)
+C ---------------------------------------------------------
+C Divides galaxy and template in a given number of segments,
+C subtracts the continuum from each segment, trensform,
+C divide and averages the division. All to reduce the noise
+C ----------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL0(NT),T0(NT),TL(NT),T(NT),PXL(NT)
+ DIMENSION SL0(NS),S0(NS),SL(NS),S(NS)
+ COMPLEX FT(NMAX),FS(NMAX),FG(NMAX),ANTI(NMAX)
+ CHARACTER*1 YN
+C
+ 10 WRITE(N6,1000)NT,NS
+ 1000 FORMAT(' Template and galaxy are dimensioned:',I5,1X,I5/
+ 1 ' Enter the number of intervals (<=0 = Exit)')
+ READ(N5,*) NSEG
+ IF(NSEG.LE.0) RETURN
+C
+ WRITE(N6,1300)
+ 1300 FORMAT(' Enter the polinomium order for continuum subtraction')
+ READ(N5,*) NKPL
+C
+C If the template and the galaxy spectra are diffenent
+C in dimensions, the smaller is extended with zeroes
+C
+ IF(NT.LT.NS) THEN
+ WRITE(N6,1100) NT,NS
+ DO 11 I=NT+1,NS
+ 11 T(I)=0.0
+C
+ ELSE IF(NT.GT.NS) THEN
+ WRITE(N6,1100) NT,NS
+ DO 12 I=NS+1,NT
+ 12 S(I)=0.0
+ 1100 FORMAT(' !!!WARNING, Template and Galaxy have a different'
+ 1 ' number of points: ',I5,1X,I5/' The smaller has '
+ 2 ' been enlarged, filling with zeroes')
+ ENDIF
+C
+C The data below NSEG*NN are not used
+ NTS=MAX(NT,NS)
+ NEACH=NTS/NSEG
+ NN1=NEACH*NSEG
+ IF(NN1.NE.NTS) WRITE(N6,1200) NTS-NN1
+ 1200 FORMAT(' Last ',I5,' data will be ignored.')
+ NTS=NN1
+C
+ DO 20 I=1,NEACH
+ 20 FG(I)=CMPLX(0.,0.)
+C
+C The following loop is on segmants NSEG
+C
+ DO 30 NSTEP=1,NSEG
+ N1=(NSTEP-1)*NEACH+1
+C
+ DO 35 I=1,NEACH
+ T(I)=T0(N1+I-1)
+ TL(I)=TL0(N1+I-1)
+ 35 S(I)=S0(N1+I-1)
+C
+C subtract the continuum (SL is used as a working array)
+C with NKPL=-1 contin prompts for plot
+C with NKPL=0 contin uses the defaults
+C
+ NKPL1=0
+ CALL CONTIN(TL(N1),T(N1),SL,NEACH,NKPL,NKPL1,PXL(N1),T(N1))
+ CALL CONTIN(TL(N1),S(N1),SL,NEACH,NKPL,NKPL1,PXL(N1),S(N1))
+C
+ 30 CONTINUE
+C The following loop is on segmants NSEG
+C SL AND TL ARE USED AS WORKING ARRAY
+C
+ DO 31 NSTEP=1,NSEG
+ N1=(NSTEP-1)*NEACH+1
+
+C fourier transform
+ DO 36 I=1,NEACH
+ TL(I)=T(I+N1-1)
+ 36 SL(I)=S(I+N1-1)
+C
+ CALL TRASF(TL,NEACH,SL,NEACH,NMAX,FT,FS,NEWN)
+C
+C Divides
+C
+ DO 40 I=1,NEWN
+ FG(I)=FG(I)+FS(I)/FT(I)
+ 40 CONTINUE
+C
+C data saved for check
+C NANTI=(NSTEP-1)*NEWN
+C DO 44 I=1,NEWN
+C 44 ANTI(NANTI+I)=FS(I)/FT(I)
+C
+ 31 CONTINUE
+C
+C plot for check
+C WRITE(N6,4000)
+C4000 FORMAT(' Do you want to plot the ratio for each segment? '
+C 1 '(''Y''/''N'')')
+C READ(N5,*) YN
+C IF(YN.EQ.'Y'.OR.YN.EQ.'y') CALL PRINTC(ANTI,NEWN*NSEG)
+C
+C
+ END
+C
+ SUBROUTINE SEGMENT1(TL0,T0,TL,T,NT,SL0,S0,SL,S,NS,
+ 1 FT,FS,FG,ANTI,NMAX,NEWN,PXL)
+C ---------------------------------------------------------
+C Same as SEGMENT, but stores some data otherwise lost.
+C Divides galaxy and template in a given number of segments,
+C subtracts the continuum from each segment, trensform,
+C divide and averages the division. All to reduce the noise
+C ----------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL0(NT),T0(NT),TL(NT),T(NT),PXL(NT)
+ DIMENSION SL0(NS),S0(NS),SL(NS),S(NS)
+ COMPLEX FT(NMAX),FS(NMAX),FG(NMAX),ANTI(NMAX),FNORM
+ CHARACTER*1 YN
+C
+ 10 WRITE(N6,1000)NT,NS
+ 1000 FORMAT(' Template and galaxy are dimensioned:',I5,1X,I5/
+ 1 ' Enter the number of intervals (<=0 = Exit)')
+ READ(N5,*) NSEG
+ IF(NSEG.LE.0) RETURN
+C
+ WRITE(N6,1300)
+ 1300 FORMAT(' Enter the polinomium order for continuum subtraction')
+ READ(N5,*) NKPL
+C
+C If the template and the galaxy spectra are diffenent
+C in dimensions, the smaller is extended with zeroes
+C
+ IF(NT.LT.NS) THEN
+ WRITE(N6,1100) NT,NS
+ DO 11 I=NT+1,NS
+ 11 T(I)=0.0
+C
+ ELSE IF(NT.GT.NS) THEN
+ WRITE(N6,1100) NT,NS
+ DO 12 I=NS+1,NT
+ 12 S(I)=0.0
+ 1100 FORMAT(' !!!WARNING, Template and Galaxy have a different'
+ 1 ' number of points: ',I5,1X,I5/' The smaller has '
+ 2 ' been enlarged, filling with zeroes')
+ ENDIF
+C
+C The data below NSEG*NN are not used
+ NTS=MAX(NT,NS)
+ NEACH=NTS/NSEG
+ NN1=NEACH*NSEG
+ IF(NN1.NE.NTS) WRITE(N6,1200) NTS-NN1
+ 1200 FORMAT(' Last ',I5,' data will be ignored.')
+ NTS=NN1
+C
+C DO 20 I=1,NEACH
+C 20 FG(I)=CMPLX(0.,0.)
+C
+C Stores data into T,S,and TL, S0,T0,TL0 are not changed
+ DO 35 I=1,NTS
+ T(I)=T0(I)
+ TL(I)=TL0(I)
+ 35 S(I)=S0(I)
+C
+C
+C ..................... PIECEWISE CONTINUUM SUBTRACTION
+C The following loop is on segmants NSEG ........................
+C
+ DO 30 NSTEP=1,NSEG
+ N1=(NSTEP-1)*NEACH+1
+C
+C subtract the continuum (SL is used as a working array)
+C with NKPL=-1 contin prompts for plot
+C with NKPL=0 contin uses the defaults
+C
+ NKPL1=0
+ CALL CONTIN(TL(N1),T(N1),SL(N1),NEACH,NKPL,NKPL1,PXL(N1),T(N1))
+ CALL CONTIN(TL(N1),S(N1),SL(N1),NEACH,NKPL,NKPL1,PXL(N1),S(N1))
+C
+ 30 CONTINUE
+C ..................................................
+C
+C plot for check
+C WRITE(N6,4000)
+C 4000 FORMAT(' Do you want to print the piecewise continuum',
+C 1 ' subtracted spectra? (Y/N)')
+C READ(N5,4011) YN
+ 4011 FORMAT(A)
+C IF(YN.EQ.'Y'.OR.YN.EQ.'y') THEN
+C WRITE(N6,4001)
+C 4001 FORMAT(' Writing TEMPLATE..')
+C CALL PRINTA(TL,T,NTS)
+C WRITE(N6,4002)
+C 4002 FORMAT(' Writing GALAXY..')
+C CALL PRINTA(TL,S,NTS)
+C ENDIF
+C
+C NEWN1 is the first point of each segment in FT,FS
+ NEWN1=1
+C FOURIER TRANSFORM FOR EACH SEGMENT
+C The following loop is on segmants NSEG ........................
+C
+ DO 31 NSTEP=1,NSEG
+ N1=(NSTEP-1)*NEACH+1
+C
+C fourier transform
+C SL and TL are used by transf as working arrays
+ DO 36 I=1,NEACH
+ TL(I)=T(N1-1+I)
+ 36 SL(I)=S(N1-1+I)
+C
+ CALL TRASF(TL,NEACH,SL,NEACH,NMAX,FT(NEWN1),FS(NEWN1),NEWN)
+C
+ NEWN1=NEWN1+NEWN
+ IF(NEWN1.GT.NMAX) WRITE(N6,1250) NEWN1
+ 1250 FORMAT(' ERROR! NMAX must be greater than',I10)
+ IF(MOD(NEWN1-1,NEWN).NE.0.AND.NSTEP.GT.1) WRITE(N6,1255)
+ 1255 FORMAT(' ERROR! Not the same fourier dimension in each step!')
+C
+ 31 CONTINUE
+C ..........................................
+C
+ NEWN1=NEWN*NSEG
+C
+C For each value of each segment divides
+ DO 50 I=1,NEWN1
+ 50 FG(I)=FS(I)/FT(I)
+C
+ WRITE(N6,4005)
+ 4005 FORMAT(' Do you want to average the transforms of the',
+ 1 ' different segments? (Y/N)')
+ READ(N5,4011) YN
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') THEN
+ ANORM=1./NSEG
+ FNORM=CMPLX(ANORM)
+ DO 60 I=1,NEWN
+ DO 60 J=2,NSEG
+ FT(I)=FT(I)+FT((J-1)*NEWN+I)*ANORM
+ FS(I)=FS(I)+FS((J-1)*NEWN+I)*ANORM
+ 60 CONTINUE
+C recomputes: FG here the division of the mean not mean of division
+ DO 65 I=1,NEWN
+ 65 FG(I)=FS(I)/FT(I)
+ ELSE
+C here each segment contain its transf. and division
+ NEWN=NEWN1
+ ENDIF
+C
+ RETURN
+C
+ END
+C
+ SUBROUTINE SET(AL0,A0,A,NI,NP1,NP2,VALUE,PXL)
+C ------------------------------------------------------
+C This routine applies set a range of the spectrum to a given
+C value. If 0<NP1<=NP2<=NI then the use isn't interactive
+C ------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ DIMENSION AL0(NI),A0(NI),A(NI),PXL(NI)
+ CHARACTER*1 YN
+ LOGICAL NUMBFLAG /.TRUE./
+ CHARACTER*20 NOME/' '/
+C Non interactive usage:
+ IF(NP1.GT.0.AND.NP1.LE.NP2.AND.NP2.LE.NI) THEN
+ DO 5 I=NP1,NP2
+ A0(I)=VALUE
+ 5 CONTINUE
+ RETURN
+ ENDIF
+C
+C Interactive usage:
+ 90 DO 9 I=1,NI ! ==========> RESET
+ 9 A(I)=A0(I)
+C
+ 10 WRITE(N6,1000)
+ WRITE(N6,5000)
+ 1000 FORMAT(' N:set by number,L: by lambda,Q :quit ,E: OK exit')
+ 5000 FORMAT(' P: plot , S: print, R:reset, T:type, D:define npt',
+ 1 ' A: def.lam.scale')
+ READ(N5,5001,ERR=500) YN
+ 5001 FORMAT(A)
+ IF ( YN.EQ.'Q'.OR.YN.EQ.'q') THEN ! =======> RETURN
+ RETURN
+ ELSE IF( YN.EQ.'R'.OR.YN.EQ.'r') THEN ! =======> RESET
+ GOTO 90
+ ELSE IF( YN.EQ.'E'.OR.YN.EQ.'e') THEN ! =======> QUIT
+ DO 20 I=1,NI
+ 20 A0(I)=A(I)
+ RETURN
+ ELSE IF( YN.EQ.'D'.OR.YN.EQ.'d') THEN ! =======> SET N
+ WRITE(N6,2001) NI
+ 2001 FORMAT(' Enter the number of data, now:',I6)
+ READ(N5,*,ERR=500) NI
+ ELSE IF( YN.EQ.'A'.OR.YN.EQ.'a') THEN ! =======> LAM SCALE
+ KSCAL=1
+ CALL LEGGESCAL(AL0,NI,KSCAL)
+ ELSE IF( YN.EQ.'T'.OR.YN.EQ.'t') THEN ! =======> TYPE
+ WRITE(N6,2005)NI
+ 2005 FORMAT(' Enter first, last point NUM. to type',
+ 1 ' (MAX:',I6,' ) ' )
+ READ(N5,*,ERR=500) NP1,NP2
+ IF(NP1.LE.0.OR.NP2.GT.NI.OR.NP1.GT.NP2) GOTO 500
+ WRITE(N6,2010) (J,AL0(J),A0(J),A(J),J=NP1,NP2)
+ 2010 FORMAT(1X,I6,2G20.10,' ==> ',G20.10)
+ ELSE IF( YN.EQ.'N'.OR.YN.EQ.'n') THEN ! =======> SET BY NUMBER
+ WRITE(N6,2000)NI
+ 2000 FORMAT(' Enter first, last point NUM. to be set',
+ 1 ' (MAX:',I6,' ) and value')
+ READ(N5,*,ERR=500) NP1,NP2,VALUE
+ IF(NP1.LE.0.OR.NP2.GT.NI.OR.NP1.GT.NP2) GOTO 500
+ DO 30 I=NP1,NP2
+ 30 A(I)=VALUE
+ NUMBFLAG=.TRUE.
+ ELSE IF( YN.EQ.'L'.OR.YN.EQ.'l') THEN ! =======> SET BY LAMBDA
+ WRITE(N6,3000) AL0(1),AL0(NI)
+ 3000 FORMAT(' Enter first, last LAMB. to be set',
+ 1 ' (MAX range:',2G12.4,' ) and value')
+ READ(N5,*,ERR=500) LP1,LP2,VALUE
+ IF(LP1.LT.AL0(I).OR.LP2.GT.AL0(I).OR.LP1.GT.LP2) GOTO 500
+ DO 40 I=1,NI
+ IF(AL0(I).GE.LP1.AND.AL0(I).LE.LP2) A(I)=VALUE
+ 40 CONTINUE
+ NUMBFLAG=.FALSE.
+ ELSE IF(YN.EQ.'S'.OR.YN.EQ.'s') THEN ! =======> PRINT
+ CALL PRINTA(AL0,A,NI)
+ ELSE IF(YN.EQ.'P'.OR.YN.EQ.'p') THEN ! =======> PLOT
+ XMAX=0.0
+ YMAX=0.0
+ XMIN=0.0
+ YMIN=0.0
+C IF(NUMBFLAG) THEN
+C KPLOT=1 ! pixel plot
+C ELSE
+C KPLOT=0 ! lambda plot
+C ENDIF
+ KPLOT=2 ! superimposed plot
+ CALL PLOTTA(NI,PXL,AL0,A0,A,XMAX,XMIN,YMAX,YMIN,NOME,KPLOT)
+ ELSE
+ GOTO 500
+ ENDIF
+C
+ GOTO 10
+ 500 WRITE(N6,9000)
+ 9000 FORMAT(' ERROR: WRONG VALUE OR COMMAND! REENTER')
+ GOTO 10
+ END
+C
+ SUBROUTINE SETCUT(AL0,A0,A,N,PXL,SIGMAX,NDEL,VALUE)
+C ------------------------------------------------------
+C routine to eliminate too big emission lines.
+C This routine sets to a given value (now the medium
+C value of the spectrum) the spectrum zone exceeding sigmax*stand.dev
+C stand.dev is the mean square deviation of the spectrum
+C value from the means.
+C After and before each zone exceeding sigmax*std,
+C extending for k points, a zone of widht k*NDEL is set = value,
+C ------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ DIMENSION AL0(N),A0(N),A(N),PXL(N)
+ CHARACTER*1 YN
+ LOGICAL NUMBFLAG /.TRUE./
+ LOGICAL INTERACTIVE/.TRUE./
+ CHARACTER*20 NOME/' '/
+C
+C defaults
+ IF(NSIG.LE.0) NSIG=1
+ IF(SIGMAX.LE.0.0) THEN ! Interactive usage flag set
+ INTERACTIVE=.TRUE.
+ ELSE
+ INTERACTIVE=.FALSE.
+ ENDIF
+C
+ 90 DO 9 I=1,N ! ==========> RESET
+ 9 A(I)=A0(I)
+C medium value and std
+ AMED=0.0
+ DO 80 I=1,N
+ 80 AMED=AMED+A(I)
+ AMED=TOT/N
+ VALUE=AMED ! NOW THE SPECTRUM IS SET TO AMED
+ STD=0.0
+ DO 81 I=1,N
+ 81 STD=STD+(AMED-A(I))**2
+ STD=SQRT(STD/N)
+ WRITE(N6,8000) AMED,STD
+ 8000 FORMAT(' medium spectrum value:',G15.5,' std: ',G15.5)
+C to interactive usage if
+ IF(INTERACTIVE) GOTO 10
+C ! ======> CUTTING peakS
+ 82 CONTINUE
+ IF(SIGMAX.LE.0.0) SIGMAX=3. ! DEFAULT sigmax
+ I=0
+ 83 I=I+1
+ IF(A(I).GT.STD*SIGMAX+AMED.AND.I.LE.N) THEN
+ J=I
+ DO WHILE(A(J).GT.STD*SIGMAX+AMED.AND.J.LE.N)
+ J=J+1
+ ENDDO
+ K=J-I
+ J1=MAX(1,I-K*NSIG)
+ J2=MIN(N,J+K*NSIG)
+ DO 85 JK=J1,J2
+ 85 A(JK)=VALUE
+ WRITE(N6,8100) J1,J2,VALUE
+ 8100 FORMAT(' Values from:',I6,' to ',I6,' set to ',G15.5)
+ I=J2
+ GOTO 83 ! END OF LOOP
+ ENDIF
+ IF(.NOT.INTERACTIVE) THEN
+ YN='E'
+ GOTO 11
+ ENDIF
+C
+ 10 WRITE(N6,1000)
+ WRITE(N6,5000)
+ 1000 FORMAT(' N:set by number,L: by lambda,Q :quit ,E: OK exit'/)
+ 5000 FORMAT(' P: plot , S: print, R:reset, T:type, C:cut peaks,',
+ 1 ' G:change pars.')
+ READ(N5,5001,ERR=500) YN
+ 5001 FORMAT(A)
+ 11 IF ( YN.EQ.'Q'.OR.YN.EQ.'q') THEN ! =======> QUIT
+ RETURN
+ ELSE IF( YN.EQ.'R'.OR.YN.EQ.'r') THEN ! =======> RESET
+ GOTO 90
+ ELSE IF( YN.EQ.'C'.OR.YN.EQ.'c') THEN ! =======> CUT PEAKS
+ GOTO 82
+ ELSE IF( YN.EQ.'G'.OR.YN.EQ.'g') THEN ! =======> PARAMETERS
+ WRITE(N6,8500) SIGMAX,NSIG,VALUE
+ 8500 FORMAT(' Enter: threshold (std units), range to set '
+ 1 '(line width units) and value . Now:'/1X,G15.5,I6,G15.5)
+ READ(N5,*,ERR=500) SIGMAX,NSIG,VALUE
+ ELSE IF( YN.EQ.'E'.OR.YN.EQ.'e') THEN ! =======> OK RETURN
+ DO 20 I=1,N
+ 20 A0(I)=A(I)
+ RETURN
+ ELSE IF( YN.EQ.'T'.OR.YN.EQ.'t') THEN ! =======> TYPE
+ WRITE(N6,2005)N
+ 2005 FORMAT(' Enter first, last point NUM. to type',
+ 1 ' (MAX:',I6,' ) ' )
+ READ(N5,*,ERR=500) NP1,NP2
+ IF(NP1.LE.0.OR.NP2.GT.N.OR.NP1.GT.NP2) GOTO 500
+ WRITE(N6,2010) (J,AL0(J),A0(J),A(J),J=NP1,NP2)
+ 2010 FORMAT(1X,I6,2G15.5,' ==> ',G15.5)
+ ELSE IF( YN.EQ.'N'.OR.YN.EQ.'n') THEN ! =======> SET BY NUMBER
+ WRITE(N6,2000)N
+ 2000 FORMAT(' Enter first, last point NUM. to be set',
+ 1 ' (MAX:',I6,' ) and value')
+ READ(N5,*,ERR=500) NP1,NP2,VALUE
+ IF(NP1.LE.0.OR.NP2.GT.N.OR.NP1.GT.NP2) GOTO 500
+ DO 30 I=NP1,NP2
+ 30 A(I)=VALUE
+ NUMBFLAG=.TRUE.
+ ELSE IF( YN.EQ.'L'.OR.YN.EQ.'l') THEN ! =======> SET BY LAMBDA
+ WRITE(N6,3000) AL0(1),AL0(N)
+ 3000 FORMAT(' Enter first, last LAMB. to be set',
+ 1 ' (MAX range:',2G12.4,' ) and value')
+ READ(N5,*,ERR=500) LP1,LP2,VALUE
+ IF(LP1.LT.AL0(I).OR.LP2.GT.AL0(I).OR.LP1.GT.LP2) GOTO 500
+ DO 40 I=1,N
+ IF(AL0(I).GE.LP1.AND.AL0(I).LE.LP2) A(I)=VALUE
+ 40 CONTINUE
+ NUMBFLAG=.FALSE.
+ ELSE IF(YN.EQ.'S'.OR.YN.EQ.'s') THEN ! =======> PRINT
+ CALL PRINTA(AL0,A,N)
+ ELSE IF(YN.EQ.'P'.OR.YN.EQ.'p') THEN ! =======> PLOT
+ XMAX=0.0
+ YMAX=0.0
+ XMIN=0.0
+ YMIN=0.0
+C IF(NUMBFLAG) THEN
+C KPLOT=1 ! pixel plot
+C ELSE
+C KPLOT=0 ! lambda plot
+C ENDIF
+ KPLOT=2 ! superimposed plot
+ CALL PLOTTA(N,PXL,AL0,A0,A,XMAX,XMIN,YMAX,YMIN,NOME,KPLOT)
+ ELSE
+ GOTO 500
+ ENDIF
+C
+ GOTO 10
+ 500 WRITE(N6,9000)
+ 9000 FORMAT(' ERROR: WRONG VALUE OR COMMAND! REENTER')
+ GOTO 10
+ END
+C
+ SUBROUTINE SETDEF
+C ------------------------------------------------------------
+C Set defaults options on user choiche
+C ------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ CHARACTER*80 NAM
+ PARAMETER (NDEFMAX=10)
+ CHARACTER*80 NAMVAL
+ CHARACTER*30 NOMEDEF
+ LOGICAL FLAGDEF
+ COMMON /DEFAULTS/ NOMEDEF(NDEFMAX),
+ 1 NAMVAL(NDEFMAX),
+ 2 VALDEF(NDEFMAX),NVALDEF(NDEFMAX),
+ 3 FLAGDEF(NDEFMAX)
+C NOMEDEF : description of default value
+C NAMVAL : character value for character type default s
+C VALDEF : numeric value for the default
+C NVALDEF : integer numeric value for the default
+C FLAGDEF : if true the default is active
+C
+C ......................................
+ 10 WRITE(N6,1000) (J,NOMEDEF(J),NAMVAL(J),
+ 1 VALDEF(J),NVALDEF(J),FLAGDEF(J),J=1,NDEFMAX)
+ 1000 FORMAT(1X,I2,1X,A30,' =>',A15,G15.4,I5,L2)
+ 11 WRITE(N6,2000)
+ 2000 FORMAT(' -1 : exit, 0:see , j: default number to enter')
+ READ(N5,*,ERR=500) K
+ IF(K.EQ.-1) THEN
+ RETURN
+ ELSE IF(K.EQ.0) THEN
+ GOTO 10
+ ELSE IF(K.LE.NDEFMAX.AND.K.GT.0) THEN
+ WRITE(N6,3000)
+ 3000 FORMAT(' Enter 0/1, OLD/alpha , real and integer value')
+ READ(N5,*) IACTIVE
+ IF(IACTIVE.LE.0) THEN
+ FLAGDEF(K)=.FALSE.
+ ELSE
+ FLAGDEF(K)=.TRUE.
+ READ(N5,4000,ERR=500) NAM
+ 4000 FORMAT(A)
+ CALL UPCASE(NAM)
+ IF(NAM.EQ.'OLD') GOTO 10
+ READ(N5,*,ERR=500) VAL,NVAL
+ NAMVAL(K)=NAM
+ VALDEF(K)=VAL
+ NVALDEF(K)=NVAL
+ WRITE(N6,1000) (K,NOMEDEF(K),NAMVAL(K),VALDEF(K),
+ 1 NVALDEF(K),FLAGDEF(K))
+ ENDIF
+ ELSE
+ GOTO 500
+ ENDIF
+ GOTO 11
+ 500 CONTINUE
+ WRITE(N6,5000) K
+ 5000 FORMAT(' INPUT ERROR: REENTER !',I10)
+ GOTO 11
+ END
+C
+ SUBROUTINE SHIFT(TL0,T0,TL,T,N)
+C ------------------------------------------------------------
+C Doppler shift the spectra by a given number of points
+C ------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL0(N),T0(N),TL(N),T(N)
+ CHARACTER*1 YN
+C
+C Logaritmic scale is assumed
+ DELTAL=TL0(2)/TL0(1)
+ 10 CONTINUE
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter the number of poit (>0 redshift,0=quit)')
+ READ(N5,*) NZ
+ IF(NZ.EQ.0) RETURN
+ IF (NZ.GT.0) THEN
+ DO 20 I=N-NZ,1,-1
+ TL(I+NZ)=TL0(I)
+ 20 T(I+NZ)=T0(I)
+ DO 25 I=NZ,1,-1
+ TL(I)=TL(I+1)/DELTAL
+ 25 T(I)=0.0
+ ELSE
+ DO 30 I=-NZ+1,N
+ TL(I+NZ)=TL0(I)
+ 30 T(I+NZ)=T0(I)
+ DO 35 I=N+NZ+1,N
+ TL(I)=TL(I-1)*DELTAL
+ 35 T(I)=0.0
+ ENDIF
+C
+C WRITE(N6,2000)
+C 2000 FORMAT(' Do you want to print the shifted spectrum?'
+C 1 '(Y/N)')
+C READ(N5,*) YN
+C 2001 FORMAT(A)
+C IF(YN.EQ.'Y'.OR.YN.EQ.'y') CALL PRINTA(TL,T,N)
+C WRITE(N6,3000)
+C 3000 FORMAT(' Are you satisfied with this shift?'
+C 1 '(Y/N)')
+C READ(N5,2001) YN
+C IF(YN.EQ.'Y'.OR.YN.EQ.'y') GOTO 500
+C
+C GOTO 10
+C
+ 500 CONTINUE
+ DO 50 I=1,N
+ TL0(I)=TL(I)
+ T0(I)=T(I)
+ 50 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE SHRINK(TL,T,N,K1,K2)
+C -----------------------------------------------------------
+C The spectrum is SHRINKED between points K1 and K2
+C -----------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL(*),T(*)
+C
+ WRITE(N6,2000) N,K1,K2,K2-K1+1
+ 2000 FORMAT(' Old points:',I6,' saved from:',I5,' to:',I5,
+ 1 ' remaining:',I6)
+ IF(K2.GT.N) K2=N
+ IF(K1.GT.K2.OR.K2.LE.0.OR.K1.LE.0) THEN
+ WRITE(N6,1000) K1,K2,N
+ 1000 FORMAT(1X,3I4,' ERROR!! Inconsistent data.')
+ ELSE IF(K1.EQ.1) THEN
+ N=K2
+ RETURN
+ ELSE IF(K1.GT.1) THEN
+C
+ DO 10 I=1,K2
+ TL(I)=TL(I+K1-1)
+ T(I)=T(I+K1-1)
+ 10 CONTINUE
+ N=K2-K1+1
+ ENDIF
+ RETURN
+ END
+C
+C
+ SUBROUTINE SUBLIN(SL,S,N)
+C -----------------------------------------------
+C Subtract from the spectrum its linear fit
+C -----------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION S(N),SL(N)
+ CHARACTER*1 YN
+C
+ CALL FIT(SL,S,N,DUM,A,B,SIGA,SIGB,CHI2,Q)
+C
+ WRITE(N6,1000) B,SIGB,A,SIGA,CHI2,Q
+ 1000 FORMAT(' Linear fit Ax+B gives: A=',E12.5,'+-',E12.5,
+ 1 ' B=',E12.5,'+-',E12.5,' Chi2=',E12.5,' Chi2 Prob.='E12.5)
+ WRITE(N6,2000)
+ 2000 FORMAT(' Must I subtract the linear behaviour (''Y''/''N'') ?')
+ READ(N5,*) YN
+ IF(YN.EQ.'N'.OR.YN.EQ.'n') RETURN
+ DO 10 I=1,N
+ 10 S(I)=S(I)-A-B*SL(I)
+ RETURN
+ END
+C
+ SUBROUTINE TRASF(T,NT,S,NS,NMAX,FT,FS,NEWN)
+C ---------------------------------------------
+C Fourier Transform of S and T
+C The FFT routines used assume SL and ST =0,1,..N-1
+C S(1) and T(1) contain the value for the zero point.
+C ---------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION T(NMAX),S(NMAX)
+ COMPLEX FT(NMAX),FS(NMAX)
+C
+C If the template and the galaxy spectra are diffenent
+C in dimensions, the smaller is extended with zeroes
+C
+ IF(NT.LT.NS) THEN
+C AMED=0.0
+C DO 12 I=1,NT
+C 12 AMED=AMED+T(I)
+C AMED=AMED/NT
+C WRITE(N6,1000) NT,NS,AMED
+ WRITE(N6,1100) NT,NS
+ DO 10 I=NT+1,NS
+ 10 T(I)=0.0
+C
+ ELSE IF(NT.GT.NS) THEN
+C AMED=0.0
+C DO 22 I=1,NS
+C 22 AMED=AMED+S(I)
+C AMED=AMED/NS
+C WRITE(N6,1000) NT,NS,AMED
+ WRITE(N6,1100) NT,NS
+ DO 20 I=NS+1,NT
+C 20 S(I)=AMED
+ 20 S(I)=0.0
+C 1000 FORMAT(' !!!WARNING, Template and Galaxy have a different'
+C 1 ' number of points: ',I5,1X,I5/' The smaller has '
+C 2 ' been enlarged, filling with the mean value: ',1PE12.5)
+ 1100 FORMAT(' !!!WARNING, Template and Galaxy have a different'
+ 1 ' number of points: ',I5,1X,I5/' The smaller has '
+ 2 ' been enlarged, filling with zeroes')
+ ENDIF
+ NN=MAX(NT,NS)
+C
+C The number of points must be a power of two,
+C otherwise the arrays are extended with zeroes
+C
+ K=2
+ 30 CONTINUE
+ IF(NN.EQ.K) GOTO 400
+ IF(NN.LT.K) GOTO 300
+ K=K*2
+ GO TO 30
+ 300 CONTINUE
+C
+ WRITE(N6,2000)NN,K
+ 2000 FORMAT(' The original dimension of ',I4,
+ 1 ' has been extended to ',I4)
+ IF(K.GT.NMAX) WRITE(N6,3000) NMAX
+ 3000 FORMAT(' ERROR! Increase the maximum dimension, which is:',I5)
+C
+ DO 40 I=NN+1,K
+ S(I)=0.0
+ T(I)=0.0
+ 40 CONTINUE
+C
+C Fourier Transform Routine (which uses FS,FT(NEWN+1))
+C
+ 400 NEWN=K
+ CALL TWOFFT(T,S,FT,FS,NEWN)
+C
+ RETURN
+ END
+C
+ SUBROUTINE TRASF1(TL,T,NT,NMAX,FT,NEWN)
+C ---------------------------------------------
+C Fourier Transform of T (real)
+C The FFT routines used assume ST =0,1,..N-1
+C T(1) contains the value for the zero point.
+C ---------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL(NMAX),T(NMAX)
+ COMPLEX FT(NMAX)
+C
+ NN=NT
+C
+C The number of points must be a power of two,
+C otherwise the arrays are extended with zeroes
+C
+ K=2
+ 30 CONTINUE
+ IF(NN.EQ.K) GOTO 400
+ IF(NN.LT.K) GOTO 300
+ K=K*2
+ GO TO 30
+ 300 CONTINUE
+C
+ WRITE(N6,2000)NN,K
+ 2000 FORMAT(' The original dimension of ',I4,
+ 1 ' has been extended to ',I4)
+ IF(K.GT.NMAX) WRITE(N6,3000) NMAX
+ 3000 FORMAT(' ERROR! Increase the maximum dimension, which is:',I5)
+C
+C DELTL=SL(NN)-SL(NN-1)
+ DO 40 I=NN+1,K
+ T(I)=0.0
+C TL(I)=TL(I-1)+DELTL
+ 40 CONTINUE
+C
+C Fourier Transform Routine
+C
+ 400 NEWN=K
+ DO 50 I=2,NEWN,2
+ 50 FT(I/2)=CMPLX(T(I-1),T(I))
+ NEWN2=NEWN/2
+ CALL REALFT(FT,NEWN2,1)
+C Half of the transform is computed, the remaining half is given
+C by simmetry (T is a real vector) (see also how REALFT stores data)
+ FT(NEWN2+1)=CMPLX(AIMAG(FT(1)),0.0)
+ FT(1)=CMPLX(REAL(FT(1)),0.0)
+ DO 51 I=NEWN2+2,NEWN
+ 51 FT(I)=CONJG(FT(NEWN-I+2))
+C
+ RETURN
+ END
+C
+ SUBROUTINE UPCASE(C)
+C -----------------------------------------------------
+C Change string C to upcase letters
+C ---------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ CHARACTER*(*) C
+C
+C Transform lowercase to upcase ASCII characters by adding
+C the constant value 32 to the ASCII value. 32 il the
+C distance between upcase and lowercase in the ASCII
+C collating sequence
+ DO 10 I=1,LEN(C)
+ IF(C(I:I).GE.'a'.AND.C(I:I).LE.'z') THEN
+ IC=ICHAR(C(I:I))
+ IC=IC-32
+ C(I:I)=CHAR(IC)
+ ENDIF
+ 10 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE UPPERC(C)
+C -----------------------------------------------------
+C Reads an input command and transform it to upcase letters
+C ---------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ CHARACTER*(*) C
+C
+ WRITE(N6,1000)
+C note:"$"; this way to insert a prompt is VAX FORTRAN extension
+ 1000 FORMAT(' > ',$)
+ READ(N5,1100,ERR=550,END=500)C
+ 1100 FORMAT(A80)
+C
+C Transform lowercase to upcase ASCII characters by adding
+C the constant value 32 to the ASCII value. 32 il the
+C distance between upcase and lowercase in the ASCII
+C collating sequence
+ DO 10 I=1,LEN(C)
+ IF(C(I:I).GE.'a'.AND.C(I:I).LE.'z') THEN
+ IC=ICHAR(C(I:I))
+ IC=IC-32
+ C(I:I)=CHAR(IC)
+ ENDIF
+C
+C 1 C(I:I)=CHAR(ICHAR(C(I:I))+32)
+ 10 CONTINUE
+C
+ RETURN
+ 500 CONTINUE ! Eof encoutered, reset to input from video
+ C='VIDEO'
+ RETURN
+ 550 CONTINUE
+ C=' READ ERROR!'
+ RETURN
+ END
+C
+ SUBROUTINE VERIFY(TL,T,NT,SL,S,NS)
+C ------------------------------------------------------------
+C check if the frequency values for spectra and template match
+C ------------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+ DIMENSION TL(NT),T(NT),SL(NS),S(NS)
+C
+ IF(NT.NE.NS) WRITE(N6,1000)NT,NS
+ 1000 FORMAT(' !!! WARNING: Tempate has ',I4,' lambda values,',
+ 1 ' Galaxy, instead:',I4)
+C
+ N=MIN(NT,NS)
+C
+ DO 20 I=1,N
+ IF(TL(I).NE.SL(I)) WRITE(N6,2000) I,TL(I),SL(I)
+ 2000 FORMAT(' !!! WARNING: INCONSISTENT LAMBDA VALUE:',
+ 1 I4,' Template:',1PE12.6,' Galaxy:',1PE12.6)
+ 20 CONTINUE
+C
+ TA0=TL(2)/TL(1)
+ SA0=SL(2)/SL(1)
+C
+ DO 30 I=3,N
+ TA=TL(I)/TL(I-1)
+ SA=SL(I)/SL(I-1)
+ IF(SA.NE.SA0) WRITE(N6,3000) I,SA,SA0
+ 3000 FORMAT(' !!! WARNING: GALAXY step changed, value:',I4,
+ 1 ' old value:',1PE12.6,' new:',1PE12.6)
+ IF(TA.NE.TA0) WRITE(N6,3300) I,TA,TA0
+ 3300 FORMAT(' !!! WARNING: TEMPLATE step changed, value:',I4,
+ 1 ' old value:',1PE12.6,' new:',1PE12.6)
+ TA0=TA
+ SA0=SA
+ 30 CONTINUE
+C
+ WRITE(N6,4000) N,TA,SA
+ 4000 FORMAT(' CHECKED:',I4,' VALUES. Lambda steps for ',
+ 1 'Template and galaxy are:',2(1X,1PE12.6))
+ RETURN
+ END
+C
+ SUBROUTINE WIENER(TL,T,SL,S,PFS,FG,ANTI,N)
+C ------------------------------------------------------
+C This routine applies to FG; the noisy smearing function
+C a Wiener filtering, hoping to see some signal in this way.
+C A polynomial fit in used to represent the signal and the
+C noise in two different, user chosen regions of the galaxy
+C power spectrum.
+C The maximum order for the polinomium is 20
+C Warning! you should always look at the produced filter, improper
+C extrapolation of the power spectrum fits has been detected.
+C
+C ------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ EXTERNAL POLY
+ PARAMETER (NMAX=20)
+ DIMENSION TL(N),T(N),SL(N),S(N),PFS(N)
+ COMPLEX FG(N),ANTI(N)
+ DIMENSION DUM(NMAX,NMAX),DUM1(NMAX),DUM2(NMAX)
+ DIMENSION COEFF(NMAX)
+ CHARACTER*1 YN
+C
+ NMAX1=NMAX-1
+C
+C Finctious lambda values for PSF function
+ DO 10 I=1,N
+ 10 TL(I)=I
+C
+ GOTO 20
+ 200 WRITE(N6,5000)
+5000 FORMAT(' ERROR! Given data are not consistent.')
+ WRITE(N6,5050)
+5050 FORMAT(' Do you want to quit?(Y/N)')
+ READ(N5,5051) YN
+5051 FORMAT(A)
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') RETURN
+ 20 CONTINUE
+C
+C fit for the noise
+C
+ WRITE(N6,1000)
+ 1000 FORMAT(' Enter the first and last point for noise computation,',
+ 1 ' 0=quit')
+ READ(N5,*) N1,N2
+ IF(N1.LE.0.OR.N2.GT.N.OR.N2.LT.N1) GOTO 200
+ NN=N2-N1+1
+C
+ WRITE(N6,1100)NMAX1
+ 1100 FORMAT(' Enter the polinomium order (<=',I5,')')
+ READ(N5,*) MFIT
+C MFIT is the number of pol. coefficients=1+ pol. order
+ MFIT=MFIT+1
+C
+ IF (MFIT.GT.NMAX.OR.MFIT.LE.0) THEN
+ WRITE (N6,5500) NMAX1
+ 5500 FORMAT(' ERROR !',I5,' Is the maximun value')
+ GOTO 200
+ ENDIF
+C
+ CALL FITTA(TL(N1),PFS(N1),NN,COEFF,MFIT,
+ 1 DUM,DUM1,DUM2,CHISQ,POLY)
+ WRITE(N6,2000) CHISQ,(COEFF(J),J=1,MFIT)
+ 2000 FORMAT(' Chisquare=',E12.5,' Coefficients: C0+C1*x+C2*x**2+..'/
+ 1 5(1X,E12.5))
+C
+C Computes the noise power spectrum (only half for simmetry)
+ DO 41 I=1,N/2+1
+ T(I)=COEFF(1)
+ DO 40 J=2,MFIT
+ T(I)=T(I)+COEFF(J)*TL(I)**(J-1)
+ 40 CONTINUE
+ IF(T(I).LT.0.)T(I)=0.0
+ 41 CONTINUE
+C
+C fit for the signal power spectrum
+C
+ WRITE(N6,1110)
+ 1110 FORMAT(' Enter the first and last point for signal computation')
+ READ(N5,*) N1,N2
+ IF(N1.LE.0.OR.N2.GT.N.OR.N2.LT.N1) GOTO 200
+ NN=N2-N1+1
+C
+ WRITE(N6,1100)NMAX1
+ READ(N5,*) MFIT
+C MFIT is the number of pol. coefficients=1+ pol. order
+ MFIT=MFIT+1
+C
+ IF (MFIT.GT.NMAX.OR.MFIT.LE.0) THEN
+ WRITE (N6,5500) NMAX1
+ GOTO 200
+ ENDIF
+C
+ CALL FITTA(TL(N1),PFS(N1),NN,COEFF,MFIT,
+ 1 DUM,DUM1,DUM2,CHISQ,POLY)
+ WRITE(N6,2000) CHISQ,(COEFF(J),J=1,MFIT)
+C
+C Computes the signal (only half for simmetry)
+ DO 45 I=1,N/2+1
+ S(I)=COEFF(1)
+ DO 44 J=2,MFIT
+ S(I)=S(I)+COEFF(J)*TL(I)**(J-1)
+ 44 CONTINUE
+ IF(S(I).LT.0.) S(I)=0.0
+ 45 CONTINUE
+C
+C Computes the wiener filter
+ WRITE(N6,1200)
+ 1200 FORMAT(' Enter the range where the signal is zero ',
+ 1 ' (this points included) ')
+ READ(N5,*) N1,N2
+ IF(N1.LE.0.OR.N1.GT.N2.OR.N2.LE.0) THEN
+ WRITE(N6,1220)
+ 1220 FORMAT(' Warning the signal is always present, you can have'
+ 1 ,' no filtering if fitted noise is near zero'/
+ 2 ' Warning! cheeck the filter for improper extrapolations')
+ N2=-1
+ ENDIF
+C (half filter for simmetry)
+ DO 60 I=1,N/2+1
+ IF(I.GE.N1.AND.I.LE.N2) THEN
+ SL(I)=0.0
+ ELSE IF((S(I)+T(I)).NE.0.0) THEN
+ SL(I)=S(I)/(S(I)+T(I))
+ ELSE
+ SL(I)=0.0
+ ENDIF
+ ANTI(I)=FG(I)*SL(I)
+ 60 CONTINUE
+C remaining data are obtained by simmetry
+ DO 62 I=2,N/2
+ SL(N-I+2)=SL(I)
+ 62 ANTI(N-I+2)=FG(N-I+2)*SL(N-I+2)
+C
+ WRITE(N6,3000)
+ 3000 FORMAT(' Do you want a print for the filter?'
+ 1 '(Y/N)')
+ READ(N5,3001) YN
+ 3001 FORMAT(A)
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') CALL PRINTP(TL,SL,T,S,N)
+C
+ WRITE(N6,3100)
+ 3100 FORMAT(' Do you want a print for the filtered function?'
+ 1 '(Y/N)')
+ READ(N5,3001) YN
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') CALL PRINTC(ANTI,N)
+C
+ WRITE(N6,3200)
+ 3200 FORMAT(' Do you want to change the filter ?'
+ 1 '(Y/N)')
+ READ(N5,3001) YN
+ IF(YN.EQ.'Y'.OR.YN.EQ.'y') GOTO 20
+C
+ DO 70 I=1,N
+ 70 FG(I)=ANTI(I)
+C
+ RETURN
+ END
+C
+ SUBROUTINE WINDOW(AL0,A0,A,NI,NP1,NP2,PXL)
+C ------------------------------------------------------
+C This routine applies to the spectrum a rectangular window.
+C If 0<NP1<=NP2<=NI then the use isn't interactive
+C ------------------------------------------------------
+ COMMON/TAPE/ N5,N6,N7
+C
+ DIMENSION AL0(NI),A0(NI),A(NI),PXL(NI)
+ CHARACTER*1 YN
+ CHARACTER*20 COMMAND
+ CHARACTER*20 NOME/' '/
+C
+ IF(NP1.GT.0.AND.NP1.LE.NP2.AND.NP2.LE.NI) THEN
+ DO 5 I=1,NI
+ IF(I.LT.NP1.OR.I.GT.NP2) A0(I)=0.0
+ 5 CONTINUE
+ RETURN
+ ENDIF
+C
+ 10 WRITE(N6,1000)
+ 1000 FORMAT(' Window by NUMBER, LAMBDA, QUIT or EXIT ?')
+ CALL UPPERC(COMMAND)
+ IF ( COMMAND.EQ.'QUIT') THEN
+ RETURN
+C
+ ELSE IF( COMMAND.EQ.'EXIT') THEN
+ DO 20 I=1,NI
+ 20 A0(I)=A(I)
+ RETURN
+C
+ ELSE IF ( COMMAND.EQ.'NUMBER') THEN
+ WRITE(N6,2000)
+ 2000 FORMAT(' Enter the first and last point number to be conserved')
+ READ(N5,*) NP1,NP2
+ DO 30 I=1,NI
+ IF(I.LT.NP1.OR.I.GT.NP2) THEN
+ A(I)=0.0
+ ELSE
+ A(I)=A0(I)
+ ENDIF
+ 30 CONTINUE
+ GOTO 100
+C
+ ELSE IF ( COMMAND.EQ.'LAMBDA') THEN
+ WRITE(N6,3000)
+ 3000 FORMAT(' Enter the first and last lambda value to be conserved')
+ READ(N5,*) LP1,LP2
+ DO 40 I=1,NI
+ IF(AL0(I).LT.LP1.OR.AL0(I).GT.LP2) THEN
+ A(I)=0.0
+ ELSE
+ A(I)=A0(I)
+ ENDIF
+ 40 CONTINUE
+ GOTO 100
+C
+ ELSE
+ WRITE(N6,4000)
+ 4000 FORMAT(' Command not recognized ! REENTER.')
+ GOTO 10
+ ENDIF
+C
+ 100 CONTINUE
+ WRITE(N6,5000)
+ 5000 FORMAT(' P: plot the masked spectrum, S: print, Q:quit,',
+ 1 ' E:exit, W:window')
+ READ(N5,5001,ERR=100) YN
+ 5001 FORMAT(A)
+ IF(YN.EQ.'S'.OR.YN.EQ.'s') THEN
+ CALL PRINTA(AL0,A,NI)
+ ELSE IF(YN.EQ.'P'.OR.YN.EQ.'p') THEN
+ XMAX=0.0
+ YMAX=0.0
+ XMIN=0.0
+ YMIN=0.0
+ IF(COMMAND.EQ.'NUMBER') THEN
+ KPLOT=1
+ ELSE
+ KPLOT=0
+ ENDIF
+ CALL PLOTTA(NI,PXL,AL0,A,A,XMAX,XMIN,YMAX,YMIN,NOME,KPLOT)
+ ELSE IF(YN.EQ.'Q'.OR.YN.EQ.'q') THEN
+ RETURN
+ ELSE IF(YN.EQ.'E'.OR.YN.EQ.'e') THEN
+ DO 50 I=1,NI
+ 50 A0(I)=A(I)
+ RETURN
+ ENDIF
+C
+ GOTO 10
+ END
+C
+ FUNCTION WITT(T,P,AL,N,TSAMPLE)
+C ------------------------------------------
+C Wittaker sinc interpolation function
+C from t(p) data stream
+C (you must have here equilog t(i))
+C ------------------------------------------
+ DIMENSION T(N),P(N)
+ REAL*8 A,B,W,PI,ARG,C
+ DATA PI/3.14159265358979323846/
+ W=0.0D0
+ C=-SIN(PI*DBLE(AL)/TSAMPLE)*TSAMPLE/PI
+ DO 10 I=1,N
+C ARG=AL-P(I)*TSAMPLE
+ ARG=AL-P(I)
+ IF(ARG.EQ.0.0D0) THEN
+ WITT=T(I)
+ RETURN
+ ELSE
+ W=W+T(I)*(-1)**I/ARG
+ ENDIF
+ 10 CONTINUE
+C DO 11 I=N+1,N+3*N ! correction from upper circularity
+C K=MOD(I,N)
+C ARG=AL-P(I)
+C IF(ARG.EQ.0.0D0) THEN
+C W=W+T(K)
+C ELSE
+C W=W+T(K)*(-1)**I/ARG
+C ENDIF
+C 11 CONTINUE
+ WITT=W*C
+ RETURN
+ END
+C
+ FUNCTION WITTC(T,P,AL,N,TSAMPLE,ERR)
+C ------------------------------------------
+C Wittaker sinc interpolation function
+C from t(p) data stream
+C (you must have here equilog t(i))
+C Here the data stream is considered periodic
+C and so long that error is< 1/ERR
+C ------------------------------------------
+ DIMENSION T(N),P(N)
+ REAL*8 A,B,W,PI,ARG,C
+ DATA PI/3.14159265358979323846/
+C
+ W=0.0D0
+ C=-SIN(PI*DBLE(AL)/TSAMPLE)*TSAMPLE/PI
+C
+ DO 10 I=1,N
+ ARG=AL-P(I)
+ IF(ARG.EQ.0.0D0) THEN
+ WITTC=T(I)
+ RETURN
+ ELSE
+ TERM=(-1)**I/ARG
+ SOGLIA=ABS(TERM)
+ W=W+T(I)*TERM
+ ENDIF
+C Sum extension to all circular term
+ ARGTOT=0.0
+ DO 20 K=1,N
+C
+ ARG1=ARG+K*N*TSAMPLE
+ IF(ARG1.EQ.0.0) THEN
+ WITTC=T(I)
+ RETURN
+ ELSE
+ ARG1=(-1)**(I+K*N)/ARG1
+ ENDIF
+C
+ ARG2=ARG-K*N*TSAMPLE
+ IF(ARG2.EQ.0) THEN
+ WITTC=T(I)
+ RETURN
+ ELSE
+ ARG2=(-1)**(I-K*N)/ARG2
+ ENDIF
+C
+ TERM =ARG1 + ARG2
+ ARGTOT=ARGTOT+TERM
+ IF(SOGLIA/ABS(TERM).GT.ERR) GOTO 200
+ 20 CONTINUE
+C
+ 200 W=W+T(I)*ARGTOT
+C
+ 10 CONTINUE
+C
+ WITTC=W*C
+ RETURN
+ END
+C
+ SUBROUTINE ZERO(N,N1,N2,A,VALUE)
+C -----------------------------------
+C Sets a(n1-n2) =value
+C -----------------------------------
+ DIMENSION A(N)
+ COMMON/TAPE/N5,N6,N7
+ IF(N.LE.0.OR.N1.GT.N2.OR.N2.GT.N.OR.N1.LT.1) THEN
+ WRITE(N6,1000) N,N1,N2
+ 1000 FORMAT(' ERROR ! inconsistent parameters in subr.zero:',
+ 1 3I5)
+ RETURN
+ ENDIF
+ DO 10 I=N1,N2
+ A(I)=VALUE
+ 10 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE ZSHIFT(AL,N,Z)
+C ------------------------------------------
+C never used nor tested
+C Doppler shifts a logaritmic spectrum :
+C log(lambda) into log(lambda)+z
+C ------------------------------------------
+ DIMENSION AL(N)
+ DO 10 I=1,N
+ AL(I)=AL(I)+Z
+ 10 CONTINUE
+ RETURN
+ END
+C
+C =======================================================
+C -------------------------------------------------------
+C The Following routines are from:
+C Press,Flannery,Teukolsky and Vetterling -
+C " Numerical Recipes" - Cambridge Univ. Press 1985
+C -------------------------------------------------------
+C
+ SUBROUTINE CORREL(DATA1,DATA2,N,ANS,FFT,NMAX)
+C -----------------------------------------------
+C Cross correlation by FFT
+C --------------------------------------------
+ DIMENSION DATA1(N),DATA2(N)
+ COMPLEX FFT(NMAX),ANS(N)
+ CALL TWOFFT(DATA1,DATA2,FFT,ANS,N)
+ NO2=FLOAT(N)/2.0
+ DO 11 I=1,N/2+1
+ ANS(I)=FFT(I)*CONJG(ANS(I))/NO2
+11 CONTINUE
+ ANS(1)=CMPLX(REAL(ANS(1)),REAL(ANS(N/2+1)))
+ CALL REALFT(ANS,N/2,-1)
+ RETURN
+ END
+C
+ SUBROUTINE FIT(X,Y,NDATA,SIG,MWT,A,B,SIGA,SIGB,CHI2,Q)
+C ------------------------------------------------------
+C Linear fit
+C -----------------------------------------------------
+ DIMENSION X(NDATA),Y(NDATA),SIG(NDATA)
+ SX=0.
+ SY=0.
+ ST2=0.
+ B=0.
+ IF(MWT.NE.0) THEN
+ SS=0.
+ DO 11 I=1,NDATA
+ WT=1./(SIG(I)**2)
+ SS=SS+WT
+ SX=SX+X(I)*WT
+ SY=SY+Y(I)*WT
+11 CONTINUE
+ ELSE
+ DO 12 I=1,NDATA
+ SX=SX+X(I)
+ SY=SY+Y(I)
+12 CONTINUE
+ SS=FLOAT(NDATA)
+ ENDIF
+ SXOSS=SX/SS
+ IF(MWT.NE.0) THEN
+ DO 13 I=1,NDATA
+ T=(X(I)-SXOSS)/SIG(I)
+ ST2=ST2+T*T
+ B=B+T*Y(I)/SIG(I)
+13 CONTINUE
+ ELSE
+ DO 14 I=1,NDATA
+ T=X(I)-SXOSS
+ ST2=ST2+T*T
+ B=B+T*Y(I)
+14 CONTINUE
+ ENDIF
+ B=B/ST2
+ A=(SY-SX*B)/SS
+ SIGA=SQRT((1.+SX*SX/(SS*ST2))/SS)
+ SIGB=SQRT(1./ST2)
+ CHI2=0.
+ IF(MWT.EQ.0) THEN
+ DO 15 I=1,NDATA
+ CHI2=CHI2+(Y(I)-A-B*X(I))**2
+15 CONTINUE
+ Q=1.
+ SIGDAT=SQRT(CHI2/(NDATA-2))
+ SIGA=SIGA*SIGDAT
+ SIGB=SIGB*SIGDAT
+ ELSE
+ DO 16 I=1,NDATA
+ CHI2=CHI2+((Y(I)-A-B*X(I))/SIG(I))**2
+16 CONTINUE
+C Q NOT COMPUTED in this version
+C Q=GAMMQ(0.5*(NDATA-2),0.5*CHI2)
+ ENDIF
+ RETURN
+ END
+C FUNCTION GAMMQ(A,X)
+C IF(X.LT.0..OR.A.LE.0.)PAUSE
+C IF(X.LT.A+1.)THEN
+C CALL GSER(GAMSER,A,X,GLN)
+C GAMMQ=1.-GAMSER
+C ELSE
+C CALL GCF(GAMMQ,A,X,GLN)
+C ENDIF
+C RETURN
+C END
+ SUBROUTINE CONVLV(DATA,N,RESPNS,ISIGN,ANS,FFT,NMAX)
+C -------------------------------------------
+C Convolution or deconvolution
+C From numerical recipes, modified.
+C Here respns and data have the same dimension
+C respns is arranged in wrap around order
+C -------------------------------------------
+ DIMENSION DATA(N),RESPNS(N)
+ COMPLEX FFT(NMAX),ANS(*)
+C DO 11 I=1,(M-1)/2
+C RESPNS(N+1-I)=RESPNS(M+1-I)
+C11 CONTINUE
+C DO 12 I=(M+3)/2,N-(M-1)/2
+C RESPNS(I)=0.0
+C12 CONTINUE
+ CALL TWOFFT(DATA,RESPNS,FFT,ANS,N)
+ NO2=N/2
+ DO 13 I=1,NO2+1
+ IF (ISIGN.EQ.1) THEN
+ ANS(I)=FFT(I)*ANS(I)/NO2
+ ELSE IF (ISIGN.EQ.-1) THEN
+ IF (CABS(ANS(I)).EQ.0.0) THEN
+ ANS(I)=CMPLX(0.0,0.0)
+ ELSE
+ ANS(I)=FFT(I)/ANS(I)/NO2
+ ENDIF
+ ELSE
+ PAUSE 'no meaning for ISIGN'
+ ENDIF
+13 CONTINUE
+ ANS(1)=CMPLX(REAL(ANS(1)),REAL(ANS(NO2+1)))
+ CALL REALFT(ANS,NO2,-1)
+ RETURN
+ END
+ SUBROUTINE FOUR1(DATA,NN,ISIGN)
+C -----------------------------------------------------
+C Fourier Transform ; if isign=-1 The inverse transform.
+C Note that there is no normalization in this routine:
+C you should divide the obtained antitransform by NN
+C ( or the transform, if you chose the other normalization)
+C -----------------------------------------------------
+ REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
+ DIMENSION DATA(*)
+ N=2*NN
+ J=1
+ DO 11 I=1,N,2
+ IF(J.GT.I)THEN
+ TEMPR=DATA(J)
+ TEMPI=DATA(J+1)
+ DATA(J)=DATA(I)
+ DATA(J+1)=DATA(I+1)
+ DATA(I)=TEMPR
+ DATA(I+1)=TEMPI
+ ENDIF
+ M=N/2
+1 IF ((M.GE.2).AND.(J.GT.M)) THEN
+ J=J-M
+ M=M/2
+ GO TO 1
+ ENDIF
+ J=J+M
+11 CONTINUE
+ MMAX=2
+2 IF (N.GT.MMAX) THEN
+ ISTEP=2*MMAX
+ THETA=6.28318530717959D0/(ISIGN*MMAX)
+ WPR=-2.D0*DSIN(0.5D0*THETA)**2
+ WPI=DSIN(THETA)
+ WR=1.D0
+ WI=0.D0
+ DO 13 M=1,MMAX,2
+ DO 12 I=M,N,ISTEP
+ J=I+MMAX
+ TEMPR=SNGL(WR)*DATA(J)-SNGL(WI)*DATA(J+1)
+ TEMPI=SNGL(WR)*DATA(J+1)+SNGL(WI)*DATA(J)
+ DATA(J)=DATA(I)-TEMPR
+ DATA(J+1)=DATA(I+1)-TEMPI
+ DATA(I)=DATA(I)+TEMPR
+ DATA(I+1)=DATA(I+1)+TEMPI
+12 CONTINUE
+ WTEMP=WR
+ WR=WR*WPR-WI*WPI+WR
+ WI=WI*WPR+WTEMP*WPI+WI
+13 CONTINUE
+ MMAX=ISTEP
+ GO TO 2
+ ENDIF
+ RETURN
+ END
+ SUBROUTINE TWOFFT(DATA1,DATA2,FFT1,FFT2,N)
+C ----------------------------------------------------
+C Fourier transform for two real vectors
+C ----------------------------------------------------
+ DIMENSION DATA1(N),DATA2(N)
+ COMPLEX FFT1(*),FFT2(*),H1,H2,C1,C2
+ C1=CMPLX(0.5,0.0)
+ C2=CMPLX(0.0,-0.5)
+ DO 11 J=1,N
+ FFT1(J)=CMPLX(DATA1(J),DATA2(J))
+11 CONTINUE
+ CALL FOUR1(FFT1,N,1)
+ FFT1(N+1)=FFT1(1)
+ N2=N+2
+ DO 12 J=1,N/2+1
+ H1=C1*(FFT1(J)+CONJG(FFT1(N2-J)))
+ H2=C2*(FFT1(J)-CONJG(FFT1(N2-J)))
+ FFT1(J)=H1
+ FFT1(N2-J)=CONJG(H1)
+ FFT2(J)=H2
+ FFT2(N2-J)=CONJG(H2)
+12 CONTINUE
+ RETURN
+ END
+ SUBROUTINE REALFT(DATA,N,ISIGN)
+C --------------------------------------------
+C Fourier transform for a real function
+C --------------------------------------------
+ REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
+ DIMENSION DATA(*)
+ THETA=6.28318530717959D0/2.0D0/DBLE(N)
+ WR=1.0D0
+ WI=0.0D0
+ C1=0.5
+ IF (ISIGN.EQ.1) THEN
+ C2=-0.5
+ CALL FOUR1(DATA,N,+1)
+ DATA(2*N+1)=DATA(1)
+ DATA(2*N+2)=DATA(2)
+ ELSE
+ C2=0.5
+ THETA=-THETA
+ DATA(2*N+1)=DATA(2)
+ DATA(2*N+2)=0.0
+ DATA(2)=0.0
+ ENDIF
+ WPR=-2.0D0*DSIN(0.5D0*THETA)**2
+ WPI=DSIN(THETA)
+ N2P3=2*N+3
+ DO 11 I=1,N/2+1
+ I1=2*I-1
+ I2=I1+1
+ I3=N2P3-I2
+ I4=I3+1
+ WRS=SNGL(WR)
+ WIS=SNGL(WI)
+ H1R=C1*(DATA(I1)+DATA(I3))
+ H1I=C1*(DATA(I2)-DATA(I4))
+ H2R=-C2*(DATA(I2)+DATA(I4))
+ H2I=C2*(DATA(I1)-DATA(I3))
+ DATA(I1)=H1R+WRS*H2R-WIS*H2I
+ DATA(I2)=H1I+WRS*H2I+WIS*H2R
+ DATA(I3)=H1R-WRS*H2R+WIS*H2I
+ DATA(I4)=-H1I+WRS*H2I+WIS*H2R
+ WTEMP=WR
+ WR=WR*WPR-WI*WPI+WR
+ WI=WI*WPR+WTEMP*WPI+WI
+11 CONTINUE
+ IF (ISIGN.EQ.1) THEN
+ DATA(2)=DATA(2*N+1)
+ ELSE
+ CALL FOUR1(DATA,N,-1)
+ ENDIF
+ RETURN
+ END
+C
+ SUBROUTINE FITTA(X,Y,NDATA,A,MFIT,COVAR,BETA,AFUNC,CHISQ,FUNCS)
+C -------------------------------------------------------------------
+C Linear fit (subroutine LFIT from "Recipes", but simplified)
+C sotto ho fatto fitta1, questa si potrebbe sostituire (usata in wiener)
+C -------------------------------------------------------------------
+ DIMENSION X(NDATA),Y(NDATA),A(MFIT),COVAR(MFIT,MFIT),BETA(MFIT)
+ DIMENSION AFUNC(MFIT)
+C
+C Here Sigma=1
+C
+ DO 14 J=1,MFIT
+ DO 13 K=1,MFIT
+ COVAR(J,K)=0.
+13 CONTINUE
+ BETA(J)=0.
+14 CONTINUE
+C
+C Computes the coefficients for the normal equations
+C
+ DO 18 I=1,NDATA
+ CALL FUNCS(X(I),AFUNC,MFIT)
+ YM=Y(I)
+ DO 17 J=1,MFIT
+ WT=AFUNC(J)
+ DO 16 K=1,J
+ COVAR(J,K)=COVAR(J,K)+WT*AFUNC(K)
+16 CONTINUE
+ BETA(J)=BETA(J)+YM*WT
+17 CONTINUE
+18 CONTINUE
+C
+ IF (MFIT.GT.1) THEN
+ DO 21 J=2,MFIT
+ DO 19 K=1,J-1
+ COVAR(K,J)=COVAR(J,K)
+19 CONTINUE
+21 CONTINUE
+ ENDIF
+C Solves the normal equations
+ CALL GAUSSJ(COVAR,MFIT,MFIT,BETA,1,1)
+ DO 22 J=1,MFIT
+ A(J)=BETA(J)
+22 CONTINUE
+C Chi square computation
+ CHISQ=0.
+ DO 24 I=1,NDATA
+ CALL FUNCS(X(I),AFUNC,MFIT)
+ SUM=0.
+ DO 23 J=1,MA
+ SUM=SUM+A(J)*AFUNC(J)
+23 CONTINUE
+ CHISQ=CHISQ+(Y(I)-SUM)**2
+24 CONTINUE
+C
+ RETURN
+ END
+C
+ SUBROUTINE FITTA1(X,Y,PESI,NDATA,
+ 1 A,MFIT,COVAR,BETA,AFUNC,CHISQ,FUNCS)
+C -------------------------------------------------------------------
+C Linear fit (subroutine LFIT from "Recipes", but simplified)
+C It is the same as fitta routine, but PESI are added again
+C -------------------------------------------------------------------
+ DIMENSION X(NDATA),Y(NDATA),A(MFIT),COVAR(MFIT,MFIT),BETA(MFIT)
+ DIMENSION AFUNC(MFIT),PESI(NDATA)
+C
+C Here pesi are weights, not errors as in the original routine
+C
+ DO 14 J=1,MFIT
+ DO 13 K=1,MFIT
+ COVAR(J,K)=0.
+13 CONTINUE
+ BETA(J)=0.
+14 CONTINUE
+C
+C Computes the coefficients for the normal equations
+C
+ DO 18 I=1,NDATA
+ CALL FUNCS(X(I),AFUNC,MFIT)
+ YM=Y(I)
+ DO 17 J=1,MFIT
+ WT=AFUNC(J)*PESI(I)
+ DO 16 K=1,J
+ COVAR(J,K)=COVAR(J,K)+WT*AFUNC(K)
+16 CONTINUE
+ BETA(J)=BETA(J)+YM*WT
+17 CONTINUE
+18 CONTINUE
+C
+ IF (MFIT.GT.1) THEN
+ DO 21 J=2,MFIT
+ DO 19 K=1,J-1
+ COVAR(K,J)=COVAR(J,K)
+19 CONTINUE
+21 CONTINUE
+ ENDIF
+C Solves the normal equations
+ CALL GAUSSJ(COVAR,MFIT,MFIT,BETA,1,1)
+ DO 22 J=1,MFIT
+ A(J)=BETA(J)
+22 CONTINUE
+C Chi square computation
+ CHISQ=0.
+ DO 24 I=1,NDATA
+ CALL FUNCS(X(I),AFUNC,MFIT)
+ SUM=0.
+ DO 23 J=1,MA
+ SUM=SUM+A(J)*AFUNC(J)
+23 CONTINUE
+ CHISQ=CHISQ+((Y(I)-SUM)*PESI(I))**2
+24 CONTINUE
+C
+ RETURN
+ END
+C
+ SUBROUTINE GAUSSJ(A,N,NP,B,M,MP)
+C --------------------------------------------
+C Gauss Jordan to solve a linear sistem
+C --------------------------------------------
+ PARAMETER (NMAX=50)
+ DIMENSION A(NP,NP),B(NP,MP),IPIV(NMAX),INDXR(NMAX),INDXC(NMAX)
+ DO 11 J=1,N
+ IPIV(J)=0
+11 CONTINUE
+ DO 22 I=1,N
+ BIG=0.
+ DO 13 J=1,N
+ IF(IPIV(J).NE.1)THEN
+ DO 12 K=1,N
+ IF (IPIV(K).EQ.0) THEN
+ IF (ABS(A(J,K)).GE.BIG)THEN
+ BIG=ABS(A(J,K))
+ IROW=J
+ ICOL=K
+ ENDIF
+ ELSE IF (IPIV(K).GT.1) THEN
+ PAUSE 'Singular matrix'
+ RETURN
+ ENDIF
+12 CONTINUE
+ ENDIF
+13 CONTINUE
+ IPIV(ICOL)=IPIV(ICOL)+1
+ IF (IROW.NE.ICOL) THEN
+ DO 14 L=1,N
+ DUM=A(IROW,L)
+ A(IROW,L)=A(ICOL,L)
+ A(ICOL,L)=DUM
+14 CONTINUE
+ DO 15 L=1,M
+ DUM=B(IROW,L)
+ B(IROW,L)=B(ICOL,L)
+ B(ICOL,L)=DUM
+15 CONTINUE
+ ENDIF
+ INDXR(I)=IROW
+ INDXC(I)=ICOL
+ IF (A(ICOL,ICOL).EQ.0.) THEN
+ PAUSE 'Singular matrix.'
+ RETURN
+ ENDIF
+ PIVINV=1./A(ICOL,ICOL)
+ A(ICOL,ICOL)=1.
+ DO 16 L=1,N
+ A(ICOL,L)=A(ICOL,L)*PIVINV
+16 CONTINUE
+ DO 17 L=1,M
+ B(ICOL,L)=B(ICOL,L)*PIVINV
+17 CONTINUE
+ DO 21 LL=1,N
+ IF(LL.NE.ICOL)THEN
+ DUM=A(LL,ICOL)
+ A(LL,ICOL)=0.
+ DO 18 L=1,N
+ A(LL,L)=A(LL,L)-A(ICOL,L)*DUM
+18 CONTINUE
+ DO 19 L=1,M
+ B(LL,L)=B(LL,L)-B(ICOL,L)*DUM
+19 CONTINUE
+ ENDIF
+21 CONTINUE
+22 CONTINUE
+ DO 24 L=N,1,-1
+ IF(INDXR(L).NE.INDXC(L))THEN
+ DO 23 K=1,N
+ DUM=A(K,INDXR(L))
+ A(K,INDXR(L))=A(K,INDXC(L))
+ A(K,INDXC(L))=DUM
+23 CONTINUE
+ ENDIF
+24 CONTINUE
+ RETURN
+ END
+ SUBROUTINE POLINT(XA,YA,N,X,Y,DY)
+C --------------------------------------------
+C Polynomial interpolation
+C --------------------------------------------
+ PARAMETER (NMAX=20)
+ DIMENSION XA(N),YA(N),C(NMAX),D(NMAX)
+ NS=1
+ DIF=ABS(X-XA(1))
+ DO 11 I=1,N
+ DIFT=ABS(X-XA(I))
+ IF (DIFT.LT.DIF) THEN
+ NS=I
+ DIF=DIFT
+ ENDIF
+ C(I)=YA(I)
+ D(I)=YA(I)
+11 CONTINUE
+ Y=YA(NS)
+ NS=NS-1
+ DO 13 M=1,N-1
+ DO 12 I=1,N-M
+ HO=XA(I)-X
+ HP=XA(I+M)-X
+ W=C(I+1)-D(I)
+ DEN=HO-HP
+ IF(DEN.EQ.0.) THEN
+ PAUSE ' Too near points to interpolate'
+ DEN=1.E-6
+ ENDIF
+ DEN=W/DEN
+ D(I)=HP*DEN
+ C(I)=HO*DEN
+12 CONTINUE
+ IF (2*NS.LT.N-M)THEN
+ DY=C(NS+1)
+ ELSE
+ DY=D(NS)
+ NS=NS-1
+ ENDIF
+ Y=Y+DY
+13 CONTINUE
+ RETURN
+ END
+ SUBROUTINE MRQMIN(X,Y,SIG,NDATA,A,DA,MA,LISTA,MFIT,
+ * COVAR,ALPHA,BETA,NCA,CHISQ,FUNCS,ALAMDA)
+C -----------------------------------------------------------
+C non linear fit to funcs (from recipes, with minor changes)
+C -----------------------------------------------------------
+ PARAMETER (MMAX=20)
+ DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),A(MA),LISTA(MFIT),
+ * COVAR(NCA,NCA),ALPHA(NCA,NCA),ATRY(MMAX),BETA(MA),DA(MA)
+ IF(ALAMDA.LT.0.)THEN
+ KK=MFIT+1
+ DO 12 J=1,MA
+ IHIT=0
+ DO 11 K=1,MFIT
+ IF(LISTA(K).EQ.J)IHIT=IHIT+1
+11 CONTINUE
+ IF (IHIT.EQ.0) THEN
+ LISTA(KK)=J
+ KK=KK+1
+ ELSE IF (IHIT.GT.1) THEN
+ PAUSE 'Improper permutation in LISTA'
+ RETURN
+ ENDIF
+12 CONTINUE
+ IF (KK.NE.(MA+1)) PAUSE 'Improper permutation in LISTA'
+ ALAMDA=0.001
+ CALL MRQCOF(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,ALPHA,BETA,NCA,CHISQ,F
+ *UNCS)
+ OCHISQ=CHISQ
+ DO 13 J=1,MA
+ ATRY(J)=A(J)
+13 CONTINUE
+ ENDIF
+ DO 15 J=1,MFIT
+ DO 14 K=1,MFIT
+ COVAR(J,K)=ALPHA(J,K)
+14 CONTINUE
+ COVAR(J,J)=ALPHA(J,J)*(1.+ALAMDA)
+ DA(J)=BETA(J)
+15 CONTINUE
+ CALL GAUSSJ(COVAR,MFIT,NCA,DA,1,1)
+ IF(ALAMDA.EQ.0.)THEN
+ CALL COVSRT(COVAR,NCA,MA,LISTA,MFIT)
+ RETURN
+ ENDIF
+ DO 16 J=1,MFIT
+ ATRY(LISTA(J))=ATRY(LISTA(J))+DA(J)
+16 CONTINUE
+ CALL MRQCOF(X,Y,SIG,NDATA,ATRY,MA,LISTA,MFIT,COVAR,DA,NCA,CHISQ,FU
+ *NCS)
+ IF(CHISQ.LT.OCHISQ)THEN
+ ALAMDA=0.1*ALAMDA
+ OCHISQ=CHISQ
+ DO 18 J=1,MFIT
+ DO 17 K=1,MFIT
+ ALPHA(J,K)=COVAR(J,K)
+17 CONTINUE
+ BETA(J)=DA(J)
+ A(LISTA(J))=ATRY(LISTA(J))
+18 CONTINUE
+ ELSE
+ ALAMDA=10.*ALAMDA
+ CHISQ=OCHISQ
+ ENDIF
+ RETURN
+ END
+ SUBROUTINE MRQCOF(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,ALPHA,BETA,NALP,CH
+ *ISQ,FUNCS)
+C ----------------------------------------------------------------
+C used by mrqmin to compute beta etc.
+C ---------------------------------------------------------------
+ PARAMETER (MMAX=20)
+ DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),ALPHA(NALP,NALP),BETA(MA),
+ * DYDA(MMAX),LISTA(MFIT)
+ DO 12 J=1,MFIT
+ DO 11 K=1,J
+ ALPHA(J,K)=0.
+11 CONTINUE
+ BETA(J)=0.
+12 CONTINUE
+ CHISQ=0.
+ DO 15 I=1,NDATA
+ CALL FUNCS(X(I),A,YMOD,DYDA,MA)
+C SIG2I=1./(SIG(I)*SIG(I))
+ SIG2I=SIG(I) ! now sig must be given as (1/sigma)**2
+ DY=Y(I)-YMOD
+ DO 14 J=1,MFIT
+ WT=DYDA(LISTA(J))*SIG2I
+ DO 13 K=1,J
+ ALPHA(J,K)=ALPHA(J,K)+WT*DYDA(LISTA(K))
+13 CONTINUE
+ BETA(J)=BETA(J)+DY*WT
+14 CONTINUE
+ CHISQ=CHISQ+DY*DY*SIG2I
+15 CONTINUE
+ DO 17 J=2,MFIT
+ DO 16 K=1,J-1
+ ALPHA(K,J)=ALPHA(J,K)
+16 CONTINUE
+17 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE COVSRT(COVAR,NCVM,MA,LISTA,MFIT)
+C ------------------------------------------------
+C covariance matrix manipulation, called by mrqmin
+C ------------------------------------------------
+ DIMENSION COVAR(NCVM,NCVM),LISTA(MFIT)
+ DO 12 J=1,MA-1
+ DO 11 I=J+1,MA
+ COVAR(I,J)=0.
+11 CONTINUE
+12 CONTINUE
+ DO 14 I=1,MFIT-1
+ DO 13 J=I+1,MFIT
+ IF(LISTA(J).GT.LISTA(I)) THEN
+ COVAR(LISTA(J),LISTA(I))=COVAR(I,J)
+ ELSE
+ COVAR(LISTA(I),LISTA(J))=COVAR(I,J)
+ ENDIF
+13 CONTINUE
+14 CONTINUE
+ SWAP=COVAR(1,1)
+ DO 15 J=1,MA
+ COVAR(1,J)=COVAR(J,J)
+ COVAR(J,J)=0.
+15 CONTINUE
+ COVAR(LISTA(1),LISTA(1))=SWAP
+ DO 16 J=2,MFIT
+ COVAR(LISTA(J),LISTA(J))=COVAR(1,J)
+16 CONTINUE
+ DO 18 J=2,MA
+ DO 17 I=1,J-1
+ COVAR(I,J)=COVAR(J,I)
+17 CONTINUE
+18 CONTINUE
+ RETURN
+ END
+C
+ FUNCTION GAMMQ(A,X)
+C ---------------------------------
+C from num. recipes. gamma function
+C ---------------------------------
+ IF(X.LT.0..OR.A.LE.0.)PAUSE
+ IF(X.LT.A+1.)THEN
+ CALL GSER(GAMSER,A,X,GLN)
+ GAMMQ=1.-GAMSER
+ ELSE
+ CALL GCF(GAMMQ,A,X,GLN)
+ ENDIF
+ RETURN
+ END
+C
+ SUBROUTINE GSER(GAMSER,A,X,GLN)
+C ----------------------------------
+ PARAMETER (ITMAX=100,EPS=3.E-7)
+ GLN=GAMMLN(A)
+ IF(X.LE.0.)THEN
+ IF(X.LT.0.)PAUSE
+ GAMSER=0.
+ RETURN
+ ENDIF
+ AP=A
+ SUM=1./A
+ DEL=SUM
+ DO 11 N=1,ITMAX
+ AP=AP+1.
+ DEL=DEL*X/AP
+ SUM=SUM+DEL
+ IF(ABS(DEL).LT.ABS(SUM)*EPS)GO TO 1
+11 CONTINUE
+ PAUSE 'A too large, ITMAX too small'
+1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN)
+ RETURN
+ END
+C
+ SUBROUTINE GCF(GAMMCF,A,X,GLN)
+C ------------------------------
+ PARAMETER (ITMAX=100,EPS=3.E-7)
+ GLN=GAMMLN(A)
+ GOLD=0.
+ A0=1.
+ A1=X
+ B0=0.
+ B1=1.
+ FAC=1.
+ DO 11 N=1,ITMAX
+ AN=FLOAT(N)
+ ANA=AN-A
+ A0=(A1+A0*ANA)*FAC
+ B0=(B1+B0*ANA)*FAC
+ ANF=AN*FAC
+ A1=X*A0+ANF*A1
+ B1=X*B0+ANF*B1
+ IF(A1.NE.0.)THEN
+ FAC=1./A1
+ G=B1*FAC
+ IF(ABS((G-GOLD)/G).LT.EPS)GO TO 1
+ GOLD=G
+ ENDIF
+11 CONTINUE
+ PAUSE 'A too large, ITMAX too small'
+1 GAMMCF=EXP(-X+A*ALOG(X)-GLN)*G
+ RETURN
+ END
+ FUNCTION GAMMLN(XX)
+C ------------------------------------------------
+ REAL*8 COF(6),STP,HALF,ONE,FPF,X,TMP,SER
+ DATA COF,STP/76.18009173D0,-86.50532033D0,24.01409822D0,
+ * -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/
+ DATA HALF,ONE,FPF/0.5D0,1.0D0,5.5D0/
+ X=XX-ONE
+ TMP=X+FPF
+ TMP=(X+HALF)*LOG(TMP)-TMP
+ SER=ONE
+ DO 11 J=1,6
+ X=X+ONE
+ SER=SER+COF(J)/X
+11 CONTINUE
+ GAMMLN=TMP+LOG(STP*SER)
+ RETURN
+ END
+C --------------------------------------------------
+C DUMMY ROUTINES TO AVOID UNSATISFIED EXTERNAL WHEN
+C CALLING AED ROUTINES FROM MONGO ROUTINES
+C --------------------------------------------------
+ SUBROUTINE DUMMY(A)
+ COMMON/TAPE/ N5,N6,N7
+ ENTRY AE1BYTE
+ ENTRY AECOLOR
+ ENTRY AEDRAW
+ ENTRY AEERASE
+ ENTRY AEFLUSH
+ ENTRY AEMASK
+ ENTRY AEMOVE
+ ENTRY AESTART
+ ENTRY STUFF
+ WRITE(N6,1000)
+ 1000 FORMAT(' ERROR: NOT INCLUDED ROUTINE CALLED ! ')
+ RETURN
+ END
projects / xsig.git / commitdiff