C @(#)tsaort.for	19.1 (ESO-DMD) 02/25/03 13:33:26
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT (c) 1992 European Southern Observatory & Copernicus Astron. Center
C.IDENT     tsaort.for
C.AUTHOR    Alex Schwarzenberg-Czerny, Copernicus Astron. Center, Warsaw
C.KEYWORD   MIDAS, time series, ORT/TSA
C.LANGUAGE  FORTRAN 77
C.PURPOSE   Compute multiharmonic Fourier spectrum by orthogonal projections
C.VERSION   0.0               June 1996
C.RETURNS   None
C.ENVIRON   TIME/ANAL context
C 
C 020507	last modif
C 02/10/11	new meaning of ORDERTSA/order parameter
C 02/10/11	algorithm uses new formulae for better rounding
C 
C-----------------------------------------------------------------------------
C
      IMPLICIT NONE
      INTEGER      NAXIS
      PARAMETER    (NAXIS=2)
      INTEGER      LENGTH(NAXIS)        !  NUMBER OF FREQUENCIES
      INTEGER      ORDER                !  NUMBER OF BINS
      INTEGER      MODE                
      INTEGER      IACTS,KUN,KNUL
      INTEGER      TID,ITIME,IVAL
      INTEGER      NCOL,ICOL,NROW,IROW,ISOR
      INTEGER      LFIELD,TTYP,VTYP
      INTEGER      ICZ,ICZN,ICCF,ICP
      INTEGER      NOBS2,ASIZE
      INTEGER*8    PTIME,PVAL,PPER,IDPER
      INTEGER*8    CZ,CZN,CCF,CP
C 
      CHARACTER*10 FORM
      CHARACTER*80 TEXT
      CHARACTER*60 INAME                !  NAME OF INPUT TABLE
      CHARACTER*60 ONAME                !  NAME OF OUTPUT IMAGE
C
      DOUBLE PRECISION  START(NAXIS)         !  START FREQUENCY
      DOUBLE PRECISION  STEP(NAXIS)          !  STEP IN FREQUENCY
      DOUBLE PRECISION  OM
C
      INCLUDE 'MID_REL_INCL:TSA_DEF.INC'
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C
      INCLUDE 'MID_REL_INCL:TSA_DAT.INC'
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
C   Get parameters
C
      CALL STSPRO ('tsaort')
      CALL STKRDC ('IN_A'  ,1,1,60,IACTS,INAME    ,KUN,KNUL,ISTAT)
      CALL STKRDC ('OUT_A', 1,1,60,IACTS,ONAME    ,KUN,KNUL,ISTAT)
      CALL STKRDD ('STARTTSA',
     $     1, 1,IACTS,START(1) ,KUN,KNUL,ISTAT)
      CALL STKRDD ('STEPTSA',
     $     1, 1,IACTS,STEP(1)  ,KUN,KNUL,ISTAT)
      CALL STKRDI ('NSTEPS',  1, 1,IACTS,LENGTH(1),KUN,KNUL,ISTAT)
      CALL STKRDI ('ORDERTSA',
     $     1, 1,IACTS,ORDER, KUN,KNUL,ISTAT)
      MODE=1
      START(NAXIS)=  ZERO
      STEP(NAXIS)=   ONE
      LENGTH(NAXIS)= 2
C
C   Map input data
C
      CALL TBTOPN (INAME,F_I_MODE,TID,ISTAT)
      CALL TBIGET (TID,NCOL,NROW,ISOR,ICOL,IROW,ISTAT)
      CALL TBLSER (TID,'TIME',ITIME,ISTAT)
      IF (ITIME.LT.0) THEN
        CALL STETER(3,'Column :TIME not found')
      ENDIF
      CALL TBLSER (TID,'VALUE',IVAL,ISTAT)
      IF (IVAL.LT.0) THEN
        CALL STETER(3,'Column :VALUE not found')
      ENDIF
      CALL TBFGET (TID,ITIME,FORM,LFIELD,TTYP,ISTAT)
      CALL TBFGET (TID,IVAL, FORM,LFIELD,VTYP,ISTAT)
      CALL TBDGET (TID,ISTORE,ISTAT)
      IF (ISTORE.NE.F_TRANS) THEN
        TEXT='Input table '//INAME//' stored not transposed'
        CALL STETER(2,TEXT)
      ENDIF
      IF (TTYP.NE.D_R8_FORMAT.OR.VTYP.NE.D_R8_FORMAT) THEN
        CALL STETER(1,'Column(s) must be of DOUBLE PRECISION type')
      ENDIF
      CALL TBCMAP (TID,ITIME,PTIME,ISTAT)
      CALL TBCMAP (TID,IVAL, PVAL, ISTAT)
C
C   Create and map work tables  Z,ZN,CF,P,DZ,DCF
C
      NOBS2=NROW+NROW
      CALL STFCRE('ZZMIDAWORK',D_R8_FORMAT,F_X_MODE,F_IMA_TYPE,
     $   NOBS2,ICZ,  ISTAT)
      CALL STFMAP(ICZ,  F_X_MODE,1,NOBS2,ASIZE,CZ,  ISTAT)
C
      CALL STFCRE('ZZMIDDWORK',D_R8_FORMAT,F_X_MODE,F_IMA_TYPE,
     $   NOBS2,ICZN, ISTAT)
      CALL STFMAP(ICZN, F_X_MODE,1,NOBS2,ASIZE,CZN, ISTAT)
C
      CALL STFCRE('ZZMIDEWORK',D_R8_FORMAT,F_X_MODE,F_IMA_TYPE,
     $   NOBS2,ICCF, ISTAT)
      CALL STFMAP(ICCF, F_X_MODE,1,NOBS2,ASIZE,CCF, ISTAT)
C
      CALL STFCRE('ZZMIDFWORK',D_R8_FORMAT,F_X_MODE,F_IMA_TYPE,
     $   NOBS2,ICP,  ISTAT)
      CALL STFMAP(ICP,  F_X_MODE,1,NOBS2,ASIZE,CP,  ISTAT)
C
C   Map output data
C
      CALL STIPUT (ONAME,D_R8_FORMAT,F_IO_MODE,
     $   F_IMA_TYPE,NAXIS,LENGTH,
     $   START,STEP,ONAME,'AXIS: 1/TIME DATA: UNITLESS',
     $   PPER,IDPER,ISTAT)
C
C   Compute multiharmonic Fourier periodogramme
C
      CALL TIMORT(NROW,MADRID(PTIME),MADRID(PVAL),LENGTH(1),START(1),
     $   STEP(1),ORDER,MODE,MADRID(PPER),OM,MADRID(CZ),MADRID(CZN),
     $   MADRID(CCF),MADRID(CP))
C
C   Wind-up
C
      CALL DSCUPT(IDPER,IDPER,' ',ISTAT)
      CALL STSEPI
C
      END
C
C
C
      subroutine TIMORT(no,t,f,nf,fr0,frs,norder,mode,th,om,
     $    z,zn,cf,p)
c
c   Fast Fit Periodogramme
c
c   Method: A. Schwarzenberg-Czerny, 
c       Ap.J. 460, L107, 1996 April 1
c
c   Input:
c     no - number of observations
c     t(no),f(no) - times and values of observations
c     nf - number of frequencies
c     fr0 - first frequency
c     frs - frequency step
c     n2 - number of fitted harmonics
c     mode - mode of operation
c       1 - AOV periodogramme
c       2 - Chi2 periodogramme
c       3 - values in f(no) replaced by residua, AOV periodogramme
c       4 - harmonics amplitudes and AOV periodogramme
c
c   Output
c     th(nf) - Periodogramme (type depends on 'mode')
c     om - frequency of maximum power
c
C
      IMPLICIT NONE
      INCLUDE  'MID_REL_INCL:TSA_DEF.INC'
C
      INTEGER  norder                   ! NORDER (2*NUMBER OF HARMONICS)
      INTEGER  no                       ! NUMBER OF OBSERVATIONS
      INTEGER  nf                       ! NUMBER OF FREQUENCIES
      INTEGER  mode                     ! MODE OF OPERATION

      integer k,n,n2,nn,l,lmax,mtrig,ksign
C
      INTEGER  MN
      PARAMETER(MN=100)
      DOUBLE PRECISION tol,tiny
      parameter (tol=1d-6,tiny=1d-99)
C 
      DOUBLE PRECISION   T(no),F(no)    ! TIMES AND VALUES OF OBSERVATIONS
      DOUBLE PRECISION   TH(nf,2)       ! PERIODOGRAMME
      DOUBLE PRECISION   FR0,FRS,OM     ! FREQUENCY START AND INCREMENT
      DOUBLE PRECISION   pi2,sav,df1,df2,df3,avf,vrf,t0,thmax,sn,ph
C 
      COMPLEX*16 Z(no),ZN(no),CF(no),P(no) ! WORK TABLES
      complex*16 a,c,al,sc,pc,amx,cmx,zz
      dimension a(0:mn),c(0:mn),amx(0:mn),cmx(0:mn)
C
      CHARACTER*80 TEXT
C 
      logical test
c
      REAL   PROB
      REAL riembi
      EXTERNAL RIEMBI
C 
C
      INCLUDE 'MID_REL_INCL:TSA_CONST.INC'
C
      CALL STTPUT('Mapped arrays',ISTAT)
      nn=min(max(NORDER/2*2,2),MN)
      n2=nn/2
      write(text,'(a24,i5,i5)') 'TIMORT: No_harm, order: ',n2,nn
      CALL STTPUT(TEXT,ISTAT)

      pi2=two*atan2(zero,-one)
      df3=no-1
      df1=nn
      df2=no-nn-1

C mean and variance
      avf=zero
      do k=1,no
        avf=avf+f(k)
      enddo
      avf=avf/no
      t0=(t(1)+t(no))*half
      vrf=zero
      do k=1,no
        sav=f(k)-avf
        vrf=vrf+sav*sav
      enddo

      thmax=zero
      do l=1,nf 
        om=(fr0+(l-1)*frs)
        do k=1,no
          ph=om*(t(k)-t0)
          ph=pi2*(ph-nint(ph))
          z(k)=cmplx(cos(ph),sin(ph))
          ph=n2*ph
          cf(k)=(f(k)-avf)*cmplx(cos(ph),sin(ph))
          zn(k)=one
          p(k)=one
        enddo

        th(l,1)=zero
        do n=0,nn
          sn=zero
          al=zero
          sc=zero
          do k=1,no
            pc=conjg(p(k))
            sn=p(k)*pc+sn
            al=p(k)*z(k)+al
            sc=cf(k)*pc+sc
          enddo
          sn=max(sn,10.*tiny)
          al=al/sn
          a(n)=al
          c(n)=sc/sn
          th(l,1)=abs(sc)**2/sn+th(l,1)
          do k=1,no
            p(k)=p(k)*z(k)-al*zn(k)*conjg(p(k))
            zn(k)=zn(k)*z(k)
          enddo
        enddo

        if (abs(al).le.tiny) then
          write(text,9099) om/pi2
9099  FORMAT('TIMORT: Singular at frequency',G15.7)
          CALL STTPUT(TEXT,ISTAT)
        endif
        if (th(l,1).ge.thmax) then
          thmax=th(l,1)
          lmax=l
          do n=0,nn
            amx(n)=a(n)
            cmx(n)=c(n)
          enddo
        endif
        if (mode.eq.2) then
          th(l,1)=th(l,1)*df3/(df1*vrf)
        else
          sav=max((vrf-th(l,1))/df2,tiny)
          th(l,1)=th(l,1)/(df1*sav)
          th(l,2)=sav
        endif
      enddo
      
      if (mode.eq.2) then
        prob=exp(-th(lmax,l))
      else 
        prob=riembi(REAL(half*df2),REAL(half*df1),
     $          REAL(df2/(df2+df1*th(lmax,1))))
      endif
      om=pi2*(fr0+(lmax-1)*frs)
 
      if (mode.eq.3) then
        ksign=0
C sn->vrf, al->z,zz->zn,pc->p,sc
        sn=zero
        do k=1,no
          ph=om*t(k)
          al=cmplx(cos(ph),sin(ph))
          zz=one
          pc=one
          sc=zero
          do n=0,nn
            sc=cmx(n)*pc+sc
            pc=pc*al-amx(n)*zz*conjg(pc)
            zz=zz*al
          enddo
          ph=-n2*ph
          sav=f(k)-sc*cmplx(cos(ph),sin(ph))
          sn=sn+sav*sav
        enddo
        vrf=abs(vrf-sn-thmax)/vrf
        if (vrf.gt.tol) then
          write(text,9098) vrf
9098  FORMAT('TIMORT: Rounding error',G15.7)
          CALL STTPUT(TEXT,ISTAT)
        endif
      endif

      if (mode.eq.4) then
       
        CALL STTPUT('TIMORT: Power step expansion unimplemented yet '
     $     ,ISTAT)
      endif

      write(text,'(a,1pe15.6,2e12.3,0p)') 
     $   'TIMORT:max: f, th, prob=',om/pi2,th(lmax,1),prob
        CALL STTPUT(TEXT,ISTAT)

      end 



