CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C  Subroutine package RITA        (Francesc Salvat. 22 January, 2011)  C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     This package contains subroutines for random sampling from single-
C  variate discrete and continuous probability distributions. Discrete
C  distributions are sampled by using the aliasing method of Walker. The
C  sampling from continuous distributions is performed by means of the
C  RITA (Rational Inverse Transform with Aliasing) algorithm. These
C  methods are described in Chapter 1 of the PENELOPE manual; they are
C  among the fastest sampling techniques available for arbitrary
C  numerical distributions.
C
C  *********************************************************************
C                       FUNCTION IRND
C  *********************************************************************
      FUNCTION IRND(F,IA,N)
C
C  Random sampling from a discrete probability distribution using
C  Walker's aliasing algorithm.
C
C  The arrays F and IA are determined by the initialisation routine
C  IRND0, which must be invoked before using function IRND.
C
C  Input arguments:
C    F(1:N) .... cutoff values.
C    IA(1:N) ... alias values.
C    N ......... number of different values of the random variable.
C
C  Output argument:
C    IRND ...... sampled value.
C
C  Other subprograms needed: function RAND and subroutine IRND0.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
      DIMENSION F(N),IA(N)
      EXTERNAL RAND
C
      RN=RAND(1.0D0)*N+1.0D0
      IRND=INT(RN)
      TST=RN-IRND
      IF(TST.GT.F(IRND)) IRND=IA(IRND)
C
      RETURN
      END
C  *********************************************************************
C                       FUNCTION RITA
C  *********************************************************************
      FUNCTION RITA()
C
C  Random sampling of a continuous variable using the RITA (Rational
C  Inverse Transform with Aliasing) method.
C
C  The needed numerical parameters are determined by the initialisa-
C  tion subroutine RITA0, which must be invoked before using function
C  RITA; these parameters are stored in common block /CRITAA/.
C
C  Other subprograms needed: EXTERNAL functions PDF and RAND,
C                            subroutines RITA0, IRND0 and RITAI0.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
      PARAMETER (NM=512)
      COMMON/CRITAA/X(NM),A(NM),B(NM),F(NM),IA(NM),NPM1
      EXTERNAL RAND
C  ****  Selection of the interval (Walker's aliasing).
      RN=RAND(1.0D0)*NPM1+1.0D0
      K=INT(RN)
      TST=RN-K
      IF(TST.LT.F(K)) THEN
        I=K
        RR=TST
        D=F(K)
      ELSE
        I=IA(K)
        RR=TST-F(K)
        D=1.0D0-F(K)
      ENDIF
C  ****  Sampling from the rational inverse cumulative distribution.
      IF(RR.GT.1.0D-12) THEN
        RITA=X(I)+((1.0D0+A(I)+B(I))*D*RR/(D*D+(A(I)*D+B(I)*RR)*RR))
     1      *(X(I+1)-X(I))
      ELSE
        RITA=X(I)+RAND(2.0D0)*(X(I+1)-X(I))
      ENDIF
C
      RETURN
      END
C  *********************************************************************
C                       FUNCTION RITAI
C  *********************************************************************
      FUNCTION RITAI()
C
C  Random sampling of a continuous variable using the RITA (Rational
C  Inverse Transform with Aliasing) method, with binary search within
C  pre-calculated index intervals.
C
C  The needed numerical parameters are determined by the initialisation
C  subroutine RITAI0, which must be invoked before using function RITAY;
C  these parameters are stored in common block /CRITA/.
C
C  Other subprograms needed: EXTERNAL functions PDF and RAND,
C                            subroutine RITAI0.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
      PARAMETER (NM=512)
      COMMON/CRITA/X(NM),PAC(NM),DPAC(NM),A(NM),B(NM),IL(NM),IU(NM),
     1  NPM1
      EXTERNAL RAND
C
C  ****  Selection of the interval
C        (binary search within pre-calculated limits).
C
      RU=RAND(1.0D0)
      ITN=RU*NPM1+1
      I=IL(ITN)
      J=IU(ITN)
      IF(J-I.LT.2) GO TO 2
    1 K=(I+J)/2
      IF(RU.GT.PAC(K)) THEN
        I=K
      ELSE
        J=K
      ENDIF
      IF(J-I.GT.1) GO TO 1
C
C  ****  Sampling from the rational inverse cumulative distribution.
C
    2 CONTINUE
      RR=RU-PAC(I)
      D=DPAC(I)  ! DPAC(I)=PAC(I+1)-PAC(I)
      IF(D.GT.1.0D-12) THEN
        RITAI=X(I)+((1.0D0+A(I)+B(I))*D*RR/(D*D+(A(I)*D+B(I)*RR)*RR))
     1       *(X(I+1)-X(I))
      ELSE
        RITAI=X(I)+RAND(2.0D0)*(X(I+1)-X(I))
      ENDIF
C
      RETURN
      END
C  *********************************************************************
C                       SUBROUTINE IRND0
C  *********************************************************************
      SUBROUTINE IRND0(W,F,K,N)
C
C  Initialisation of Walker's aliasing algorithm for random sampling
C  from discrete probability distributions.
C
C  Input arguments:
C    N ........ number of different values of the random variable.
C    W(1:N) ... corresponding point probabilities (not necessarily
C               normalised to unity).
C  Output arguments:
C    F(1:N) ... cutoff values.
C    K(1:N) ... alias values.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
      DIMENSION W(N),F(N),K(N)
C  ****  Renormalisation.
      WS=0.0D0
      DO I=1,N
        IF(W(I).LT.0.0D0) STOP 'IRND0. Negative point probability.'
        WS=WS+W(I)
      ENDDO
      WS=DBLE(N)/WS
      DO I=1,N
        K(I)=I
        F(I)=W(I)*WS
      ENDDO
      IF(N.EQ.1) RETURN
C  ****  Cutoff and alias values.
      DO I=1,N-1
        HLOW=1.0D0
        HIGH=1.0D0
        ILOW=0
        IHIGH=0
        DO J=1,N
          IF(K(J).EQ.J) THEN
            IF(F(J).LT.HLOW) THEN
              HLOW=F(J)
              ILOW=J
            ELSE IF(F(J).GT.HIGH) THEN
              HIGH=F(J)
              IHIGH=J
            ENDIF
          ENDIF
        ENDDO
        IF(ILOW.EQ.0.OR.IHIGH.EQ.0) RETURN
        K(ILOW)=IHIGH
        F(IHIGH)=HIGH+HLOW-1.0D0
      ENDDO
      RETURN
      END
C  *********************************************************************
C                       SUBROUTINE RITA0
C  *********************************************************************
      SUBROUTINE RITA0(PDF,XLOW,XHIG,N,NU,ERRM,IWR)
C
C  Initialisation of the RITA algorithm for random sampling of a
C  continuous random variable X from a probability distribution function
C  PDF(X) defined in the interval (XLOW,XHIG). The external function
C  PDF(X) must be provided by the user. N is the number of points in the
C  sampling grid. These points are determined by means of an adaptive
C  strategy that minimises local interpolation errors. The first NU grid
C  points are uniformly spaced in (XLOW,XHIG); when NU is negative, the
C  initial grid consists of -NU points logarithmically spaced (in this
C  case, XLOW must be nonnegative).
C
C  ERRM is a measure of the interpolation error (the largest value of
C  the absolute error of the rational interpolation integrated over each
C  grid interval).
C
C  ****  Interpolation coefficients and PDF tables are printed on
C        separate files (UNIT=IWR) if IWR is greater than zero.
C
C  Other subprograms needed: EXTERNAL function PDF,
C                            subroutines RITAI0 and IRND0.
C

      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
      PARAMETER (NM=512)
      COMMON/CRITA/XA(NM),PAC(NM),DPAC(NM),AA(NM),BA(NM),IL(NM),IU(NM),
     1  NPM1A
      COMMON/CRITAA/X(NM),A(NM),B(NM),F(NM),IA(NM),NPM1
      EXTERNAL PDF
C  ****  Initialisation of the RITA algorithm.
      CALL RITAI0(PDF,XLOW,XHIG,N,NU,ERRM,IWR)
C  ****  Walker's aliasing; cutoff and alias values.
      NPM1=NPM1A
      DO I=1,NPM1
        X(I)=XA(I)
        A(I)=AA(I)
        B(I)=BA(I)
      ENDDO
      X(NPM1+1)=XA(NPM1+1)
      CALL IRND0(DPAC,F,IA,NPM1)
      F(NPM1+1)=1.0D0
      IA(NPM1+1)=NPM1
      RETURN
      END
C  *********************************************************************
C                       SUBROUTINE RITAI0
C  *********************************************************************
      SUBROUTINE RITAI0(PDF,XLOW,XHIG,N,NU,ERRM,IWR)
C
C  Initialisation of the RITA algorithm for random sampling of a
C  continuous random variable X from a probability distribution function
C  PDF(X) defined in the interval (XLOW,XHIG). The external function
C  PDF(X) must be provided by the user. N is the number of points in the
C  sampling grid. These points are determined by means of an adaptive
C  strategy that minimises local interpolation errors. The first NU grid
C  points are uniformly spaced in (XLOW,XHIG); when NU is negative, the
C  initial grid consists of -NU points logarithmically spaced (in this
C  case, XLOW must be nonnegative).
C
C  ERRM is a measure of the interpolation error (the largest value of
C  the absolute error of the rational interpolation integrated over each
C  grid interval).
C
C  ****  Interpolation coefficients and PDF tables are printed on
C        separate files (UNIT=IWR) if IWR is greater than zero.
C
C  Other subprograms needed: EXTERNAL function PDF.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
      PARAMETER (EPS=1.0D-10, ZERO=1.0D-45, ZEROT=0.1D0*ZERO)
      PARAMETER (NM=512)
C
C  The information used by the sampling function RITAI is exported
C  through the following common block,
      COMMON/CRITA/X(NM),PAC(NM),DPAC(NM),A(NM),B(NM),IL(NM),IU(NM),
     1  NPM1
C  where
C    X(I) ...... grid points, in increasing order.
C    PAC(I) .... value of the cumulative pdf at X(I).
C    DPAC(I) ... probability of the I-th interval.
C    A(I), B(I) ... rational inverse cumulative distribution parameters.
C    IL(I) .... largest J for which PAC(J) < (I-1)/(NP-1).
C    IU(I) .... smallest J for which PAC(J) > I/(NP-1).
C    NPM1 ..... numner of grid points minus one, NP-1 (8.LE.NP.LE.NM).
C
      COMMON/CRITA0/ERR(NM),C(NM)
      PARAMETER (NIP=51)
      DIMENSION PDFI(NIP),PDFIH(NIP),SUMI(NIP)
      EXTERNAL PDF
C
      IF(N.LE.16) THEN
        WRITE(6,'('' Error in RITAI0: N must be larger than 16.'',
     1    /,'' N='',I11)') N
        STOP 'RITAI0: N must be larger than 16.'
      ENDIF
      IF(N.GT.NM) THEN
        WRITE(6,'('' Error in RITAI0: N must be less than NM=512.'',
     1    /,'' N='',I11)') N
        STOP 'RITAI0: N must be less than NM=512.'
      ENDIF
      IF(XLOW.GT.XHIG-EPS) THEN
        WRITE(6,'('' Error in RITAI0: XLOW must be larger than XHIG.'',
     1    /,'' XLOW='',1P,E13.6,'', XHIG ='',E13.6)') XLOW,XHIG
        STOP 'RITAI0: XLOW must be larger than XHIG.'
      ENDIF
C
C  ****  We start with a grid of NUNIF points uniformly spaced in the
C        interval (XLOW,XHIG).
C
      IF(NU.GE.0) THEN
        NUNIF=MIN(MAX(8,NU),N/2)
        NP=NUNIF
        DX=(XHIG-XLOW)/DBLE(NP-1)
        X(1)=XLOW
        DO I=1,NP-1
          X(I+1)=XLOW+I*DX
        ENDDO
        X(NP)=XHIG
      ELSE
C  ****  If NU.LT.0,the NUNIF points are logarithmically spaced.
C        XLOW must be greater than or equal to zero.
        NUNIF=MIN(MAX(8,-NU),N/2)
        NP=NUNIF
        IF(XLOW.LT.0.0D0) THEN
          WRITE(6,'('' Error in RITAI0: XLOW and NU are negative.'',
     1    /,'' XLOW='',1P,E14.7, '',  NU='',I11)') XLOW,NU
          STOP 'RITAI0: XLOW and NU are negative.'
        ENDIF
        X(1)=XLOW
        IF(XLOW.LT.1.0D-16) THEN
          X(2)=XLOW+1.0D-6*(XHIG-XLOW)
          I1=2
        ELSE
          I1=1
        ENDIF
        FX=EXP(LOG(XHIG/X(I1))/DBLE(NP-I1))
        DO I=I1,NP-1
          X(I+1)=X(I)*FX
        ENDDO
        X(NP)=XHIG
      ENDIF
C
      DO I=1,NP-1
        DX=X(I+1)-X(I)
        DXI=(X(I+1)-X(I))/DBLE(NIP-1)
        PDFMAX=0.0D0
        DO K=1,NIP
          XIK=X(I)+DBLE(K-1)*DXI
          PDFI(K)=MAX(PDF(XIK),ZEROT)
          PDFMAX=MAX(PDFMAX,PDFI(K))
          IF(K.LT.NIP) THEN
            XIH=XIK+0.5D0*DXI
            PDFIH(K)=MAX(PDF(XIH),ZEROT)
            PDFMAX=MAX(PDFMAX,PDFIH(K))
          ENDIF
        ENDDO
C  ****  Simpson's integration.
        CONS=DXI*3.3333333333333333D-1*0.5D0
        SUMI(1)=0.0D0
        DO L=2,NIP
          SUMI(L)=SUMI(L-1)+CONS*(PDFI(L-1)+4.0D0*PDFIH(L-1)+PDFI(L))
        ENDDO
C
        DPAC(I)=SUMI(NIP)
        FACT=1.0D0/DPAC(I)
        DO K=1,NIP
          SUMI(K)=FACT*SUMI(K)
        ENDDO
C  ****  When the PDF vanishes at one of the interval end points, its
C        value is modified.
        IF(PDFI(1).LT.ZERO) PDFI(1)=1.0D-5*PDFMAX
        IF(PDFI(NIP).LT.ZERO) PDFI(NIP)=1.0D-5*PDFMAX
C
        PLI=PDFI(1)*FACT
        PUI=PDFI(NIP)*FACT
        B(I)=1.0D0-1.0D0/(PLI*PUI*DX*DX)
        A(I)=(1.0D0/(PLI*DX))-1.0D0-B(I)
        C(I)=1.0D0+A(I)+B(I)
        IF(C(I).LT.ZERO) THEN
          A(I)=0.0D0
          B(I)=0.0D0
          C(I)=1.0D0
        ENDIF
C
C  ****  ERR(I) is the integral of the absolute difference between the
C        rational interpolation and the true PDF, extended over the
C        interval (X(I),X(I+1)). Calculated using the trapezoidal rule.
C
        ICASE=1
  100   CONTINUE
        ERR(I)=0.0D0
        DO K=1,NIP
          RR=SUMI(K)
          PAP=DPAC(I)*(1.0D0+(A(I)+B(I)*RR)*RR)**2/
     1       ((1.0D0-B(I)*RR*RR)*C(I)*(X(I+1)-X(I)))
          IF(K.EQ.1.OR.K.EQ.NIP) THEN
            ERR(I)=ERR(I)+0.5D0*ABS(PAP-PDFI(K))
          ELSE
            ERR(I)=ERR(I)+ABS(PAP-PDFI(K))
          ENDIF
        ENDDO
        ERR(I)=ERR(I)*DXI
C  ****  If ERR(I) is too large, the PDF is approximated by a uniform
C        distribution.
        IF(ERR(I).GT.0.10D0*DPAC(I).AND.ICASE.EQ.1) THEN
          B(I)=0.0D0
          A(I)=0.0D0
          C(I)=1.0D0
          ICASE=2
          GO TO 100
        ENDIF
      ENDDO
      X(NP)=XHIG
      A(NP)=0.0D0
      B(NP)=0.0D0
      C(NP)=0.0D0
      ERR(NP)=0.0D0
      DPAC(NP)=0.0D0
C
C  ****  New grid points are added by halving the subinterval with the
C        largest absolute error.
C
  200 CONTINUE
      ERRM=0.0D0
      LMAX=1
      DO I=1,NP-1
C  ****  ERRM is the largest of the interval errors ERR(I).
        IF(ERR(I).GT.ERRM) THEN
          ERRM=ERR(I)
          LMAX=I
        ENDIF
      ENDDO
C
      NP=NP+1
      DO I=NP,LMAX+1,-1
        X(I)=X(I-1)
        A(I)=A(I-1)
        B(I)=B(I-1)
        C(I)=C(I-1)
        ERR(I)=ERR(I-1)
        DPAC(I)=DPAC(I-1)
      ENDDO
      X(LMAX+1)=0.5D0*(X(LMAX)+X(LMAX+2))
      DO I=LMAX,LMAX+1
        DX=X(I+1)-X(I)
        DXI=(X(I+1)-X(I))/DBLE(NIP-1)
        PDFMAX=0.0D0
        DO K=1,NIP
          XIK=X(I)+DBLE(K-1)*DXI
          PDFI(K)=MAX(PDF(XIK),ZEROT)
          PDFMAX=MAX(PDFMAX,PDFI(K))
          IF(K.LT.NIP) THEN
            XIH=XIK+0.5D0*DXI
            PDFIH(K)=MAX(PDF(XIH),ZEROT)
            PDFMAX=MAX(PDFMAX,PDFIH(K))
          ENDIF
        ENDDO
C  ****  Simpson's integration.
        CONS=DXI*3.3333333333333333D-1*0.5D0
        SUMI(1)=0.0D0
        DO L=2,NIP
          SUMI(L)=SUMI(L-1)+CONS*(PDFI(L-1)+4.0D0*PDFIH(L-1)+PDFI(L))
        ENDDO
C
        DPAC(I)=SUMI(NIP)
        FACT=1.0D0/DPAC(I)
        DO K=1,NIP
          SUMI(K)=FACT*SUMI(K)
        ENDDO
C
        IF(PDFI(1).LT.ZERO) PDFI(1)=1.0D-5*PDFMAX
        IF(PDFI(NIP).LT.ZERO) PDFI(NIP)=1.0D-5*PDFMAX
        PLI=PDFI(1)*FACT
        PUI=PDFI(NIP)*FACT
        B(I)=1.0D0-1.0D0/(PLI*PUI*DX*DX)
        A(I)=(1.0D0/(PLI*DX))-1.0D0-B(I)
        C(I)=1.0D0+A(I)+B(I)
        IF(C(I).LT.ZERO) THEN
          A(I)=0.0D0
          B(I)=0.0D0
          C(I)=1.0D0
        ENDIF
C
        ICASE=1
  300   CONTINUE
        ERR(I)=0.0D0
        DO K=1,NIP
          RR=SUMI(K)
          PAP=DPAC(I)*(1.0D0+(A(I)+B(I)*RR)*RR)**2/
     1       ((1.0D0-B(I)*RR*RR)*C(I)*(X(I+1)-X(I)))
          IF(K.EQ.1.OR.K.EQ.NIP) THEN
            ERR(I)=ERR(I)+0.5D0*ABS(PAP-PDFI(K))
          ELSE
            ERR(I)=ERR(I)+ABS(PAP-PDFI(K))
          ENDIF
        ENDDO
        ERR(I)=ERR(I)*DXI
C
        IF(ERR(I).GT.0.10D0*DPAC(I).AND.ICASE.EQ.1) THEN
          B(I)=0.0D0
          A(I)=0.0D0
          C(I)=1.0D0
          ICASE=2
          GO TO 300
        ENDIF
      ENDDO
C
      IF(NP.LT.N) GO TO 200
      NPM1=NP-1
C
C  ****  Renormalisation.
C
      WS=0.0D0
      DO I=1,NPM1
        WS=WS+DPAC(I)
      ENDDO
      WS=1.0D0/WS
      ERRM=0.0D0
      DO I=1,NPM1
        DPAC(I)=DPAC(I)*WS
        ERR(I)=ERR(I)*WS
        ERRM=MAX(ERRM,ERR(I))
      ENDDO
C
      PAC(1)=0.0D0
      DO I=1,NPM1
        PAC(I+1)=PAC(I)+DPAC(I)
      ENDDO
      PAC(NP)=1.0D0
C
C  ****  Pre-calculated limits for the initial binary search in
C        subroutine RITAI.
C
      BIN=1.0D0/DBLE(NPM1)
      IL(1)=1
      DO I=2,NPM1
        PTST=(I-1)*BIN
        DO J=IL(I-1),NP
          IF(PAC(J).GT.PTST) THEN
            IL(I)=J-1
            IU(I-1)=J
            GO TO 400
          ENDIF
        ENDDO
  400   CONTINUE
      ENDDO
      IU(NPM1)=NP
      IL(NP)=NP-1
      IU(NP)=NP
C
C  ****  Print interpolation tables (done only when IWR.GT.0).
C
      IF(IWR.GT.0) THEN
        OPEN(IWR,FILE='param.dat')
        WRITE(IWR,1000)
 1000   FORMAT(1X,'#',5X,'X',11X,'PDF(X)',10X,'A',13X,'B',13X,'C',
     1    11X,'error')
        DO I=1,NPM1
          PDFE=MAX(PDF(X(I)),ZEROT)*WS
          WRITE(IWR,'(1P,7E14.6)') X(I),PDFE,A(I),B(I),C(I),ERR(I)
        ENDDO
        CLOSE(IWR)
C
        OPEN(IWR,FILE='table.dat')
        WRITE(IWR,2000)
 2000   FORMAT(1X,'#',6X,'X',13X,'PDF_ex',10X,'PDF_ap',11X,'err')
        DO I=1,NPM1
          DX=(X(I+1)-X(I))/DBLE(NIP-1)
          DO K=1,NIP,5
            XT=X(I)+(K-1)*DX
            P1=MAX(PDF(XT),ZEROT)*WS
C  ****  Rational interpolation.
            TAU=(XT-X(I))/(X(I+1)-X(I))
            CON1=2.0D0*B(I)*TAU
            CON2=C(I)-A(I)*TAU
            IF(ABS(CON1).GT.1.0D-10*ABS(CON2)) THEN
              ETA=CON2*(1.0D0-SQRT(1.0D0-2.0D0*TAU*CON1/CON2**2))/CON1
            ELSE
              ETA=TAU/CON2
            ENDIF
            P2=DPAC(I)*(1.0D0+(A(I)+B(I)*ETA)*ETA)**2
     1        /((1.0D0-B(I)*ETA*ETA)*C(I)*(X(I+1)-X(I)))
            WRITE(IWR,'(1P,5E16.8)') XT,P1,P2,(P1-P2)/P1
          ENDDO
        ENDDO
        CLOSE(IWR)
C
        OPEN(IWR,FILE='limits.dat')
        WRITE(IWR,3000)
 3000   FORMAT(1X,'#  I',6X,'PAC(ITL)',9X,'(I-1)/NPM1',11X,'I/NPM1',
     1    12X,'PAC(ITU)',12X,'PAC(I)')
        DO I=1,NPM1
          WRITE(IWR,'(I5,1P,5E19.11)') I,PAC(IL(I)),(I-1)*BIN,I*BIN,
     1      PAC(IU(I)),PAC(I)
          IF(PAC(IL(I)).GT.(I-1)*BIN+EPS.OR.
     1      PAC(IU(I)).LT.I*BIN-EPS) THEN
            WRITE(IWR,3001)
 3001       FORMAT(' #  WARNING: The first four values should be in in',
     1        'creasing order.')
          ENDIF
        ENDDO
        CLOSE(IWR)
      ENDIF
C
      RETURN
      END
C  *********************************************************************
C                       SUBROUTINE RITAV
C  *********************************************************************
      SUBROUTINE RITAV(X,PDF,CDF)
C
C  This subroutine gives the values of the (normalized) pdf, PDF, and of
C  its cumulative distribution function, CDF, at the point X. These
C  values are calculated from the RITA approximation.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
C
      PARAMETER (NM=512)
      COMMON/CRITA/XT(NM),PAC(NM),DPAC(NM),A(NM),B(NM),IL(NM),IU(NM),
     1  NPM1
      COMMON/CRITA0/ERR(NM),C(NM)
C
      IF(X.GT.XT(NPM1+1)) THEN
        PDF=0.0D0
        CDF=1.0D0
      ELSE IF(X.LT.XT(1)) THEN
        PDF=0.0D0
        CDF=0.0D0
      ELSE
        I=1
        I1=NPM1+1
    1   IT=(I+I1)/2
        IF(X.GT.XT(IT)) THEN
          I=IT
        ELSE
          I1=IT
        ENDIF
        IF(I1-I.GT.1) GO TO 1
        TAU=(X-XT(I))/(XT(I+1)-XT(I))
        CON1=2.0D0*B(I)*TAU
        CON2=C(I)-A(I)*TAU
        IF(ABS(CON1).GT.1.0D-10*ABS(CON2)) THEN
          ETA=CON2*(1.0D0-SQRT(1.0D0-2.0D0*TAU*CON1/CON2**2))/CON1
        ELSE
          ETA=TAU/CON2
        ENDIF
        PDF=DPAC(I)*(1.0D0+(A(I)+B(I)*ETA)*ETA)**2
     1    /((1.0D0-B(I)*ETA*ETA)*C(I)*(XT(I+1)-XT(I)))
        CDF=PAC(I)+ETA*DPAC(I)
      ENDIF
      RETURN
      END
C  *********************************************************************
C                       SUBROUTINE RITAM
C  *********************************************************************
      SUBROUTINE RITAM(XD,XU,XM0,XM1,XM2)
C
C  Calculation of (restricted) momenta of a pdf, PDF(X), obtained from
C  its RITA approximation.
C
C     XD, XU ... limits of the integration interval.
C     XM0 ...... 0th order moment.
C     XM1 ...... 1st order moment.
C     XM2 ...... 2nd order moment.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
C
      PARAMETER (NM=512)
      COMMON/CRITA/XT(NM),PAC(NM),DPAC(NM),A(NM),B(NM),IL(NM),IU(NM),
     1  NPM1
      COMMON/CRITA0/ERR(NM),C(NM)
      PARAMETER (NIP=51)
      DIMENSION XI(NIP),FUN(NIP)
C
      XM0=0.0D0
      XM1=0.0D0
      XM2=0.0D0
      DO I=1,NPM1
        IF(XT(I+1).GE.XD.AND.XT(I).LE.XU) THEN
          X1=MAX(XT(I),XD)
          X2=MIN(XT(I+1),XU)
          DX=(X2-X1)/DBLE(NIP-1)
C
          DO K=1,NIP
            XI(K)=X1+DBLE(K-1)*DX
C  ****  Value of the RITA rational pdf at the point XI(K).
            TAU=(XI(K)-XT(I))/(XT(I+1)-XT(I))
            CON1=2.0D0*B(I)*TAU
            CON2=C(I)-A(I)*TAU
            IF(ABS(CON1).GT.1.0D-10*ABS(CON2)) THEN
              ETA=CON2*(1.0D0-SQRT(1.0D0-2.0D0*TAU*CON1/CON2**2))/CON1
            ELSE
              ETA=TAU/CON2
            ENDIF
            FUN(K)=DPAC(I)*(1.0D0+(A(I)+B(I)*ETA)*ETA)**2
     1        /((1.0D0-B(I)*ETA*ETA)*C(I)*(XT(I+1)-XT(I)))
          ENDDO
C  ****  Simpson's integration.
          CONS=DX*3.3333333333333333D-1
          SUM=0.0D0
          DO L=3,NIP,2
            SUM=SUM+FUN(L-2)+4.0D0*FUN(L-1)+FUN(L)
          ENDDO
          XM0=XM0+SUM*CONS
C
          DO K=1,NIP
            FUN(K)=FUN(K)*XI(K)
          ENDDO
          SUM=0.0D0
          DO L=3,NIP,2
            SUM=SUM+FUN(L-2)+4.0D0*FUN(L-1)+FUN(L)
          ENDDO
          XM1=XM1+SUM*CONS
C
          DO K=1,NIP
            FUN(K)=FUN(K)*XI(K)
          ENDDO
          SUM=0.0D0
          DO L=3,NIP,2
            SUM=SUM+FUN(L-2)+4.0D0*FUN(L-1)+FUN(L)
          ENDDO
          XM2=XM2+SUM*CONS
        ENDIF
      ENDDO
      RETURN
      END
C  *********************************************************************
C                         FUNCTION RAND (Random number generator)
C  *********************************************************************
      FUNCTION RAND(DUMMY)
C
C  This is an adapted version of subroutine RANECU written by F. James
C  (Comput. Phys. Commun. 60 (1990) 329-344), which has been modified to
C  give a single random number at each call.
C
C  The 'seeds' ISEED1 and ISEED2 must be initialised in the main program
C  and transferred through the named common block /RSEED/.
C
C  Some compilers incorporate an intrinsic random number generator with
C  the same name (but with different argument lists). To avoid conflict,
C  it is advisable to declare RAND as an external function in all sub-
C  programs that call it.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER*4 (I-N)
      PARAMETER (USCALE=1.0D0/2.147483563D9)
      COMMON/RSEED/ISEED1,ISEED2
C
      I1=ISEED1/53668
      ISEED1=40014*(ISEED1-I1*53668)-I1*12211
      IF(ISEED1.LT.0) ISEED1=ISEED1+2147483563
C
      I2=ISEED2/52774
      ISEED2=40692*(ISEED2-I2*52774)-I2*3791
      IF(ISEED2.LT.0) ISEED2=ISEED2+2147483399
C
      IZ=ISEED1-ISEED2
      IF(IZ.LT.1) IZ=IZ+2147483562
      RAND=IZ*USCALE
C
      RETURN
      END


      subroutine gensingle(sh,school,nparam,
     $     curpars,ndata, tps, rtn, ndays, epi_model)

      implicit none

      integer iday_per_week
      parameter(iday_per_week=7)
      integer nstep
      parameter (nstep = 6)
      integer ndata, nparam, ndays
      integer epi_model
      real*8 sh(ndata), school(ndata)
      real*8 curpars(nparam)
      real*8 pC, e_bckgrnd
      real*8 tps(ndata)
      real*8 rtn(ndata)
      real*8 dsdt((ndays)*nstep)
      integer imid((ndata+1))

!
! Need to find the mid-point
! This will need to be further cleaned - the CDC data is absolute day numbers..
!

      if (tps(1) > (iday_per_week * 10)) Then
         call BuildIMIDforCDC(ndata, nstep, tps, imid)
      else
         call BuildIMID(ndata, nstep, tps, imid)
      endif

      pC = curpars(5)
      e_bckgrnd = curpars(8)

      rtn = 0.0d0
      dsdt = 0.0d0

      select case (epi_model)
         case (1)
            call RK4SIROneD(sh,school,ndata,ndays,nstep,tps,
     $           nparam,curpars,dsdt)
         case (2)
            call RK4SEIROneD(sh,school,ndata,ndays,nstep,tps,
     $           nparam,curpars,dsdt)
        case (3)
           call RK4VecSIROneD(ndata,ndays,nstep,tps,
     $          nparam,curpars,dsdt)
        case (4)
           call RK4VecSEIROneD(ndata,ndays,nstep,tps,
     $          nparam,curpars,dsdt)
        case default
           call RK4SIROneD(sh,school,ndata,ndays,nstep,tps,
     $            nparam,curpars,dsdt)
      end select

      call weekly1D(ndata, ndays, nstep, imid, dsdt, pC,e_bckgrnd,
     $     rtn)

      return
      end subroutine gensingle


      REAL FUNCTION gengam(a,r)
C**********************************************************************
C
C     REAL FUNCTION GENGAM( A, R )
C           GENerates random deviates from GAMma distribution
C
C
C                              Function
C
C
C     Generates random deviates from the gamma distribution whose
C     density is
C          (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X)
C
C
C                              Arguments
C
C
C     A --> Location parameter of Gamma distribution
C                              REAL A
C
C     R --> Shape parameter of Gamma distribution
C                              REAL R
C
C
C                              Method
C
C
C     Renames SGAMMA from TOMS as slightly modified by BWB to use RANF
C     instead of SUNIF.
C
C     For details see:
C               (Case R >= 1.0)
C               Ahrens, J.H. and Dieter, U.
C               Generating Gamma Variates by a
C               Modified Rejection Technique.
C               Comm. ACM, 25,1 (Jan. 1982), 47 - 54.
C     Algorithm GD
C
C               (Case 0.0 <= R <= 1.0)
C               Ahrens, J.H. and Dieter, U.
C               Computer Methods for Sampling from Gamma,
C               Beta, Poisson and Binomial Distributions.
C               Computing, 12 (1974), 223-246/
C     Adapted algorithm GS.
C
C**********************************************************************
C     .. Scalar Arguments ..
      REAL a,r
C     ..
C     .. External Functions ..
      REAL sgamma
      EXTERNAL sgamma
C     ..
C     .. Executable Statements ..
      gengam = sgamma(r)
      gengam = gengam/a
      RETURN

      END


      Subroutine TX2FED
C
C-------------------------------------------------------------------------------
C                              Process TX2FK
C                              ------- -----
C
C  Document date: 28th October 1991    version 2.1    a.j. harding
C
C     Process TX2FK transforms data from the TX (time-space) domain into the
C  FK (frequency-wavenumber) domain.  The input is a set of normal (t-x)
C  seismic traces and the output is a transformed set of FK traces. The
C  transformed output traces are in rectangular form unless polar form
C  (amplitude and phase) are requested.
C
C     The frequencies within each output trace are ordered from -Nyq to 0 to
C  Nyq.  Each output trace contains a power of 2 number of samples. The traces
C  are ordered in wavenumber from 0 to k (Nyquist). Data in polar
C  form are ordered with the modulus followed by the argument.
C
C     Any SIOSEIS process may follow TX2FK, but care should be taken that it
C  makes sense!  The imaginary part of data in rectangular coordinates may be
C  omitted from plot by decimating by a factor of 2.
C
C     The steps used in the FK transformation are:
C       1.)  Each trace is windowed temporally in order to minimize edge
C            effects along the time trace.
C       2.)  The data is transposed so that all the data of constant times are
C            adjacent. This sorts the data by x rather than t (or f).
C       3.)  The 'range' traces are zero padded. Effectively adding dummy traces
C            to the end of the dataset. The data must be padded to a power of 2.
C            but additional padding may be desirable for migration etc. A user
C            minimum number of dead traces is specified by nxpad. The
C            data is also windowed in x if desired.
C       4.)  The complex fft is performed, transforming x to k, or from
C            space to wavenumber.
C       5.)  The data is transposed back to ordering by time.
C       6.)  The forward fft is performed, converting time to frequency.
C       7.)  The data is converted to polar coordinates if requested.
C       Data in the fk domain may be processed by any other seismic process in
C  sioseis.
C
C     The run time of TX2FK is governed by the number of traces, including pads,
C  and the trace length, including pads.  Both dimensions are a power of 2, so
C  transforming 1500 points takes as long as 2000 points (2048 being the
C  closest larger power of 2).
C
C    The frequency-wavenumber domain is discussed in a paper "a review of the
C  two-dimensional transform and its use in seismic processing" by D.W. March
C  and A.D.Bailey in the "First Break", January 1983.
C
C     Each parameter list must be terminated with the word end.  The entire set
C  of TX2FK parameters must be terminated by the word end.
C
C  The Parameter Dictionary
C  --- --------- ----------
C
C  STIME  - The start time of the data for the entire data set.  Any trace
C           that has an initial time (delay) greater than stime will be zero
C           padded so that the data starts at stime.  Any trace that has a
C           delay greater than stime will be truncated.
C           preset = the delay of the first trace.
C
C  ETIME  - The end time of the data for the entire data set. Data in excess
C           of etime will be omitted from the transformation.
C           preset = the last time of the first trace.
C
C  NXPAD  - the number of dummy traces to insert at both ends of the seismic
C           line.  Process fkmigr needs dummy traces in order to prevent
C           "wrap around".
C           preset = 10
C
C  TWINDOW - The type of window to apply before computing the temporal fft.
C          = HAMM, hamming
C          = HANN, hanning
C          = GAUS, gaussian
C          = BART, bartlett (triangular)
C          = RECT, rectangular (box car - no window)
C          = BLAC, blackman
C          = EBLA, exact blackman
C          = BLHA, blackman harris
C            preset=HANN  e.g. window RECT
C
C  TWINLEN - The window length, in seconds.  a window length of zero causes
C           the entire time domain trace to be windowed.  A non zero length
C           indicates that winlen data will be modified at both ends of each
C           trace.
C           preset=.1  e.g. winlen .2
C
c  XWINDOW - Same as Twindow only it windows the data by range.
C            preset = RECT ( No windowing of ranges )
C
C  XWINLEN - The window length in number of traces. A window length of zero
C            causes the entire set of ranges to be windowed. A non zero length
C            causes that number of traces to be windowed at each end.
C            preset = 10
C
C  COORDS - The coordinates of the output trace.
C
C         =RECT, Rectangular coordinates.  The output trace will be complex.
C                The trace values will consist of real and imaginary pairs.
C                The frequency dimension runs from 0 to nyquist (pi) then the
C                negative frequencies back to 0, as output from the fft.  The
C                output frequency trace is a poiwer of two.  The k dimension
C                is also ordered as it comes directly out of the fft, 0 to
C                nyquist followed by the most negative k.
C
C         =POLAR,Polar coordinates.  The first half of the output trace will be
C                the amplitude spectrum and the second half of the trace will
C                be the phase spectrum, each ordered 0 to nyquist back to 0.
C                The k dimension is reordered so that the first trace is the
C                negative nyquist, then increasing to 0, then increasing to
C                the positive nyquist.  The total number of traces output
C                is a power of two plus 1.
C
C        = POLARU, "user friendly" polar coordinates. This produces output data
C                as a series of wavenumber traces running from -Nyq -> +Nyq
C                and only positive frequencies in polar form. This format is
C                useful if it is desired to look at the FK data using for example
C                a contouring program. The data is not used internally in this
C                form but is converted on input/output from SIOSEIS.
C
C           preset = RECT   e.g.  coords POLAR
C
C  OHDRPATH - If processes TX2FK and FK2TX are called in the same job then the
C             original TX headers will be used as the trace headers of the
C             the processed TX data. This will preserve all RP/Shot numbering
C             as well as GMT information. However, if these two processes are
C             done in separate jobs then the user may specify a permanent disk
C             file to hold the original TX headers. This filename can then
C             be given to FK2TX when the inverse transform is done.
C
C  PATH1 & PATH2 - Before TX2FK transforms the input traces it accumulates them
C                them in a scratch datafile. The size of this file is the number
C                of input traces prior to padding in range * The sample length
C                of each trace (etime - stime) prior to padding in time.
C
C                  The size of the data after transformation is equal to the
C                number of traces * trace length after padding of each to the
C                nearest power of 2. This is stored in a second scratch dataset
C                after which the first scratch file is deleted. If there is a
C                FK2TX in the procs list then it will use this second scratch
C                file as its 1st scratch file.
C
C                   The default location of these files is implementation
C                dependent and may be of insufficient size. The PATH parameters
C                allow the user to specify the location of the two scratch files
C
C  PATH1    The location of the 1st scratch file.
C
C  PATH2    The location of the 2nd scratch file. Since this is the same as the
C            first scratch file used by FK2TX (if present) it should be
C            given only here or in FK2TX. If contradictory definitions are
C            given the first on processed will be used.
c  PRESTK - When set nonzero, the FK transformation is done whenever the
c           PRESTK number of "gathers" have been collected.  A "gather" is
c           whenever the "end-of-sort" flag (SEGY header word 51) is -1.
c           Processes SORT and GATHER set the "end-of-sort" flag.  Even
c           shot data must have gone through SORT in order to have word
c           51 set.
C
C  END    - terminates each parameter list.
C
C Last Modified
C    10/20/88 ajh. ( Corrected window errors)
c    10/28/91 pch  add prestk
c    4/5/96 pch.  change prestk from switch to a counter.
c    8 Nov 06 pch - Change time window length from time to samples.
c    21 Apr 09 - Make prestk > 1 an error
C-------------------------------------------------------------------------------
C INCLUDE FILES
c INCLUDE seisio.inc
c This include file include all (?) of the parameters needed to define SIOSEIS
c I/O routines. In particular it defines positions of objects in the SEGY
c headers & constants for these values
c
c EBCDIC HEADER
c Declare Header lengths. These are the length of the EXTERNAL disk image in
c host words.
      integer     CRAYEBC, NORMEBC
      parameter ( CRAYEBC  = 400)
      parameter ( NORMEBC  = 2*CRAYEBC)
c
c BINARY HEADER
      integer     CRAYBIN, NORMBIN
      parameter ( CRAYBIN  =  50)                                       ! length of external disk image
      parameter ( NORMBIN  = 2*CRAYBIN)
c
c  The position of objects in the Binary header
      integer    NTRCPTR,IFMTPTR, IDTYPPTR, INKPTR, ITSIPTR
      integer    ITDELPTR, IVERSPTR
      parameter (NTRCPTR  =  7)                                         ! No of traces / gather
      parameter (IFMTPTR  = 13)                                         ! The SEGY Format of the data
      parameter (IDTYPPTR = 31)                                         ! The Domain/ID of the data e.q. T-X data
      parameter (INKPTR   = 32)                                         ! The No. of wavenumbers in an f-k dataset
      parameter (ITSIPTR  = 33)                                         ! Record of tx sample interval in us
      parameter (ITDELPTR = 34)                                         ! Record of tx time delay in ms.
      parameter (IVERSPTR = 35)                                         ! The SIOSEIS version number
c
c..Constants for SEGY Format (IFMTPTR)
      integer IBMFP, INT16, INT32, HOSTFP
      parameter (IBMFP  = 1)                                            ! IBM floating point
      parameter (INT32  = 2)
      parameter (INT16  = 3)
      parameter (HOSTFP = 5)                                            ! Host FP. In actuality Host FP >= 5
c
c.. Data Domains/Types (IDTYPPTR)
      integer    IDTX, IDFKRCT, IDFKPLR, IDFKPLRU
      parameter (IDTX     = 1)
      parameter (IDFKRCT  = 2)
      parameter (IDFKPLR  = 3)
      parameter (IDFKPLRU = 8)
c
c.. Version Number
      integer  CURVERS
      parameter( CURVERS = 210)
c
c TRACE HEADER
c.. Declare header length on external disk files. Internal length is given by
c Numhdr in common block READT.
      integer  CRAYTHDR, NORMTHDR
      parameter ( CRAYTHDR =  30)                                       ! Length of external disk image
      parameter ( NORMTHDR = 2*CRAYTHDR)
c
c    The positions of elements of the trace header are defined by elements of
c the common block SEGYPTR. This block is initialized in routine SETPTR. The
c position of elements differs on the CRAY since it does not allow mixing of
c Integer*16 & Integer*32 words but only has Integer*64.
c
      integer LLSEQPTR                                                  ! Trace Sequence No. within line
      integer LRSEQPTR                                                  ! Trace Sequence No. within reel
      integer LSHOTPTR                                                  ! Shot number or Stacked Number
      integer LSHTRPTR                                                  ! Trace number within Shot
      integer LRPNPTR                                                   ! RP or CDP number
      integer LRPTRPTR                                                  ! Trace No. within CDP
      integer ITRIDPTR                                                  ! Trace ID Live(1)/Dead(2)
      integer LDISTPTR                                                  ! Source to Receiver Distance
      integer LWBDPTR                                                   ! Water Bottom depth at source
      integer LSXCOPTR                                                  ! Source X co-ordinate
      integer LRXCOPTR                                                  ! Receiver X co-ordingate
      integer IDELMPTR                                                  ! Deep water delay in ms.
      integer ISTMPTR                                                   ! Start Mute time in ms.
      integer IENDMPTR                                                  !   End Mute time in ms
      integer ISAMPPTR                                                  ! Number of data samples in trace
      integer ISIPTR                                                    ! Sample interval of trace in us
      integer IYRPTR                                                    ! Year data was recorded
      integer IDAYPTR                                                   ! Day of year
      integer IHRPTR                                                    ! Hour of day
      integer IMINPTR                                                   ! Minute of hour
      integer ISECPTR                                                   ! Second of Minute
      integer IGMTPTR                                                   ! Time zone of header Local(1)/GMT(2)
      integer LDELSPTR                                                  ! Deep water delay in secs.
      integer LSMUSPTR                                                  ! Start of mute in seconds
      integer LEMUSPTR                                                  ! End of mute in seconds
      integer LSISPTR                                                   ! Sample interval in seconds
      integer LWBTSPTR                                                  ! Water bottom time in seconds
      integer LGATPTR                                                   ! No. of traces in stacked data(>0) or End of Gather(<0)
      integer LSSMSPTR                                                  ! Start of surgical mute in secs.
      integer LESMSPTR                                                  ! End of surgical mute in secs
      integer LSBPTR                                                    ! SeaBeam slant range
c
      common /SEGYPTR/ LLSEQPTR, LRSEQPTR, LSHOTPTR, LSHTRPTR, LRPNPTR,
     *                 LRPTRPTR, ITRIDPTR, LDISTPTR, LWBDPTR,  LSXCOPTR,
     *                 LRXCOPTR, IDELMPTR, ISTMPTR,  IENDMPTR, ISAMPPTR,
     *                 ISIPTR,   IYRPTR,   IDAYPTR,  IHRPTR,   IMINPTR,
     *                 ISECPTR,  IGMTPTR,  LDELSPTR, LSMUSPTR, LEMUSPTR,
     *                 LSISPTR,  LWBTSPTR, LGATPTR,  LSSMSPTR, LESMSPTR,
     *                 LSBPTR
C
c.. Define Constants for Trace Header
c
c.. Constants for Trace ID (ITRIDPTR)
      integer    LIVETR, DEADTR                                         ! Parameters for trace Type
      parameter (LIVETR  = 1)
      parameter (DEADTR  = 2)
C
c.. Define constants for use with the DISKIO subroutines getfil, frefil,
c podisc
c GETFIL constants
      integer    CREATTMP, CREATNEW, OPENOLD
      parameter (CREATTMP   = 1)                                        ! Create a temporary file
      parameter (CREATNEW   = 3)                                        ! Create a new named file
      parameter (OPENOLD    = 4)                                        ! Open an existing file
c FREFIL constants
      integer    RLDLCLS, RLCLS
      parameter (RLCLS   = 2)                                           ! Release and Close the file
      parameter (RLDLCLS = 3)                                           ! Release, delete and close
c PODISC constants
      integer    POSABS, POSREL, DSKSTRT
      parameter (POSABS     = 1)
      parameter (POSREL     = 2)
      parameter (DSKSTRT    = 0)                                        ! The starting position on the disk
c INCLUDE txfk.inc
C Include file TXFK.INC
C include file for the sioseis 2D FFT and fk migration routines
C
c
c Parameters for coord type
      integer CDRECT, CDPOLAR, CDPOLARU
      parameter ( CDRECT   = 1)
      parameter ( CDPOLAR  = 2)
      parameter ( CDPOLARU = 3)
C
C parameters for Windows
      integer BoxCar
      parameter (BoxCar = 5)
c INCLUDE txfkgbl.inc
c.. This is the global common block for the FK routines. At present it is used
c.. by TX2FEX, FK2TEX & their associated edit routines to indicate whether they
c.. have been called & to pass file unit numbers.
c
c  Last Modified 10/18/88
c
      logical txinit, fkinit                                            ! Execution initialization ?
      logical txed, fked                                                ! Edit initialization ?
      integer ltxunt1, ltxunt2                                          ! File Stream ID for tx2fex scratch file
      integer lfkunt1, lfkunt2                                          ! File Stream ID for fk2tex scratch file
      integer txunit                                                    ! Used Stream ID for tx2fex scratch file
      integer ohdrtxfk                                                  ! File unit holding tx headers
      logical tmptxhdr                                                  ! Indicates if tx header file is temporary
      integer prestk                                                    ! Indicates if data is prestack or not
      common /TXFKE/ txinit, fkinit, txed, fked, txunit,
     $               ltxunt1, ltxunt2, lfkunt1, lfkunt2,
     $               ohdrtxfk, tmptxhdr, prestk, ntx2fk, nfk2tx, range
C PROGRAM
      parameter (NPARS  = 15)                                           ! the number of user parameters
      PARAMETER (multiv = 15)
      parameter (MAXWEI = 20)                                           ! the maximum number of weights that may be given
C
C..                Parameters for TX2FK are transferred via common block TX2FKC
      integer twindo, xwindo, xwinle, Twinlen, twinle
      common /TX2FKC/ stim,etim,nxpa,twindo,twinle,xwindo,xwinle,lprin,
     *     nweigs, lcoord, weigs(maxwei)
      common /EDITS/ ierror,iwarn,irun,now,icompt
c
      character*4 lwinds(8)
      character*4 Twindow, Xwindow
      integer     Xwinlen
      character*8 names(NPARS)
      character*1 types(NPARS)
      integer     length(NPARS)
      character*80 token
      dimension vals(NPARS),lvals(NPARS)
      logical flag
      integer status
c
      save /TX2FKC/
C
      equivalence (stime,    vals(1)),
     2            (etime,    vals(2)),
     3            (nxpad,   lvals(3)),
     4            (lprint,  lvals(4)),
     5            (Twinlen,  lvals(5)),
     7            (coords,  lvals(7)),
     8            (Xwinlen, lvals(8)),
     4            (nprestk, lvals(13)),
     *            (weight,   vals(15))
c
      data names/'STIME ','ETIME ','NXPAD ','LPRINT', 'TWINLEN',
     *           'TWINDOW','COORDS','XWINLEN','XWINDOW', 'PATH1',
     *           'PATH2','PRESTK','NPRESTK','OHDRPATH',
     &           'WEIGHT'/
      data types/2*'F', 2*'L','F', 2*'A','L', 4*'A','L','A','L'/
      data length/5,5,5,6,7,7,6,7,7,2*5,6,7,8,6/
      data lwinds/'HAMM','HANN','GAUS','BART','RECT','BLAC','EBLA',
     *            'BLHA'/
C****
C****      set the presets
C****
      stime   = -1.
      etime   = -1.
      nxpad   = 10
      Twinlen = 25
      Twindow = 'HANN'
      Xwinlen = 10
      Xwindow = 'RECT'
      lcoord  = CDRECT
      weight  = -1.
      lprint  = 0
      ns      = 0
      nweigs  = 0
c..                     Set values in FK global common
      call txfkinit
      txed     = .TRUE.
      ltxunt1  = 0
      ltxunt2  = 0
      ohdrtxfk = 0
      nprestk = 0
C****
C****   the current command line in the system buffer may have the parameters.
C****   get a parameter list from the user.
C****
  100 continue
      call getoke(token,nchars)                                         ! get a token from the user parameter line
      call upcase(token,nchars)                                         ! convert the token to uppercase
C
      if(nchars.le.0) then                                              ! get another user parameter line
        if(now.eq.1) print 140
  140   format(' <  Enter Parameters  >')
        call rdline
        go to 100
      endif
C
      do 190 i = 1, npars                                               ! see if it is a parameter name
        len    = length(i)                                              ! get the legal parameter name length
        iparam = i                                                      ! save the index
        if(token(1:nchars).eq.names(i)(1:len).and.nchars.eq.len)
     *  go to 200
  190   continue
C                                                                       ! still looking for the name
      if(token(1:nchars).eq.'END'.and.nchars.eq.3) go to 1000           ! end of list?
      if (ns.ne.0) go to 230                                            ! Multivalued parameter
      print 191, token(1:nchars)
  191 format(' ***  Error  *** TX2FK does not have a parameter ',
     *  'named ',A10)
      ierror = ierror + 1
      go to 100
C****
C****    found the parameter name, now find the value
C****
  200 continue
      ns      = 0
      nparam  = iparam
  210   continue                                                        !  now find the value
        call getoke(token,nchars)
        if(nchars.le.0) then                                            ! end of line?
          if(now.eq.1) print 140                                        ! Allow parameters on a different line
          call rdline                                                   ! get another line
          go to 210
        endif
C
  230 continue
      if( types(nparam).eq.'A') then                                    ! An alpha Parameter
c
        if ( names(nparam).eq.'PATH1') then                             ! Open first Scratch file
          call getfil(CREATNEW,ltxunt1,token,status)
          if (status.ne.0) then
            print *,'***ERROR*** Error opening PATH1: ',token
            ierror = ierror + 1
          endif
c
        else if ( names(nparam).eq.'PATH2') then
          if ( fked.and.(lfkunt1.ne.0) ) then
            ltxunt2 = lfkunt1
            print *,'*** Warning TX2FK **** Second scratch file already'
     $             ,' specified by FK2TX. Using that file'
          else
            call getfil(CREATNEW,ltxunt2,token,status)
            if (status.ne.0) then
              print *,'***ERROR*** Error opening PATH2: ',token
              ierror = ierror + 1
            endif
          endif
c
        else if (names(nparam).eq.'OHDRPATH') then
          call getfil(CREATNEW, ohdrtxfk, token, status)
          if (status.ne.0) then
              print *,'***ERROR*** Error opening OHDRPATH: ',token
              ierror = ierror + 1
          endif
c
        else if( names(nparam) .eq. 'COORDS' ) then
          call upcase(token,nchars)
          if( token(1:nchars) .eq. 'RECT' ) then
             lcoord = CDRECT
          else if( token(1:nchars) .eq. 'POLAR' ) then
             lcoord = CDPOLAR
          else if( token(1:nchars) .eq. 'POLARU' ) then
             lcoord = CDPOLARU
          else
             print *,'*** ERROR *** Illegal COORDS Option'
             ierror = ierror + 1
          endif
        else if ( names(nparam) .eq. 'TWINDOW' ) then
          call upcase(token,nchars)
          Twindow = token(1:4)
        else if ( names(nparam) .eq. 'XWINDOW' ) then
          call upcase(token,nchars)
          Xwindow = token(1:4)
        else if ( names(nparam) .eq. 'PRESTK' ) then
          call upcase(token,nchars)
          if( token(1:1) .eq. 'Y' ) nprestk = 1
          if( token(1:1) .eq. '1' ) nprestk = 1
          IF( token(1:1) .NE. 'Y' .AND. token(1:1) .NE. 'N' .AND.
     &        token(1:1) .NE. '1' .AND. token(1:1) .NE. '0' ) THEN
              PRINT *,' ***  ERROR  ***  Illegal PRESTK.'
              PRINT *,'                  Did you mean NPRESTK?'
              ierror = ierror + 1
          ENDIF
        endif
      else
        call dcode(token,nchars,areal,istat)                            ! try and decode it
        if(istat.ne.2) then                                             ! =2 means it is a numeric
          ierror = ierror + 1                                           ! dcode printed an error
          go to 100
        endif
        if(types(nparam).eq.'F') then                                   ! floating point values
          if(nparam.eq.multiv) then                                     ! Multivalued parameter
            ns        = ns + 1
            nweigs    = ns
            if(ns.le.maxwei) weigs(ns) = areal
          else
            vals(nparam) = areal
          endif
        else                                                            ! 32 bit integer values
          lvals(nparam) = areal
        endif
      endif
      go to 100
C****
C****   finished a list, now do the error and validity checks
C****
 1000 continue
      flag = .true.                                                     ! Convert Time window to integer code
      i    = 0
 1010 if (flag.and.(i.lt.8)) then
        i = i + 1
        if(Twindow.eq.lwinds(i)) flag = .false.
        go to 1010
      endif
      if (flag) then
        print 1020, Twindow
        ierror = ierror + 1
 1020   format(' ***  ERROR  *** Illegal Time window type : ',A4)
      else
        Twindo = i
      endif
C
      flag = .true.                                                     ! Convert Range window to integer code
      i    = 0
 1015 if (flag.and.(i.lt.8)) then
        i = i + 1
        if(Xwindow.eq.lwinds(i)) flag = .false.
        go to 1015
      endif
      if (flag) then
        print 1025, Xwindow
        ierror = ierror + 1
 1025   format(' ***  ERROR  *** Illegal Range window type : ',A4)
      else
        Xwindo = i
      endif
C
      if(nweigs.gt.maxwei) then                                         ! Number of input weights exceeded
        itemp = maxwei
        print 1040, itemp
 1040   format(' ***  ERROR  ***  Too many taper weights. ',I2,
     *       ' is the maximum.')
        ierror = ierror + 1
      endif
C                                                                       ! Transfer values into common block variables
      stim   = stime
      etim   = etime
      nxpa   = nxpad
      Twinle = Twinlen
      Xwinle = Xwinlen
      lprin  = lprint
      prestk = nprestk
      if(nweigs.eq.0) then
        do 1110 i = 1, 9
 1110   weigs(i) = float(i)/10.
        nweigs   = 9
      endif
C
      if(IAND(lprint,1).eq.1) print *, stim,etim,nxpa,twindo,twinle,
     *   xwindo,xwinle, nweigs,lcoord,prestk,(weigs(i),i=1,nweigs)
C
C                                                                       ! Look for the end of the parameter list
 2020 call getoke(token,nchars)
      call upcase(token,nchars)
      if(nchars.eq.0) then                                              ! End of a line?. Then get another
        if (now.eq.1) print 140
        call rdline
        go to 2020
      endif
      if(token(1:nchars).ne.'END'.or.nchars.ne.3) then
        print *,' ***  ERROR  ***  TX2FK only permits one list to be ',
     *    ' given.'
        ierror = ierror + 1
      endif
      return
      end


  subroutine init(magnetic_field_direction, magnetic_field, &
    & is_magnet_on)
    implicit none
    real(dp), dimension(3), intent(in) :: magnetic_field_direction
    real(dp), intent(in) :: magnetic_field
    logical, intent(in) :: is_magnet_on
    magnetic_field_ = magnetic_field
    magnetic_field_direction_ = magnetic_field_direction
    is_magnet_on_ = is_magnet_on
  end subroutine init

function diamagnetic(particlei)
  use particle
  use num_kind
  implicit none
  intrinsic dot_product
  type(particledat), intent(in) :: particlei
  real(dp) :: diamagnetic
  real(dp), dimension(3) :: B0,u,Bmol
  real(dp), dimension(3,3) :: sus
  real(dp) :: susiso,anisosus,antipar,par
  real(sp), parameter :: kB=1.38065e-23
  real(sp), parameter :: temp=107.0
  B0=(/0.0_dp,0.0_dp,11.47_dp/)
  susiso=-3290e-30
  anisosus=1750e-30
  antipar=susiso-anisosus/3.0_dp
  par=susiso+2.0_dp*anisosus/3.0_dp
  sus(1:3,1:3)=0
  sus(1,1)=antipar
  sus(2,2)=antipar
  sus(3,3)=par
  u=(/particlei%ux,particlei%uy,particlei%uz/)
  Bmol(3)=dot_product(B0,u)
  Bmol(1)=sqrt(0.5_dp*(dot_product(B0,B0)-Bmol(3)**2))
  Bmol(2)=Bmol(1)
  write (*,*) 'Bmol:',Bmol
  diamagnetic=-dot_product(Bmol,matmul(sus,Bmol))
  diamagnetic=diamagnetic/(kB*temp)
end function


      SUBROUTINE LOPAS(M,F2,X,NL,IBACK)
C
C
C
C Subroutine LOPAS.
C
C    LOPAS is a Butterworth low pass reCursive filter written by
C Keith McCamy at Lamont-Doherty Geological Observatory, N.Y.  It is
C used in place of the Ormsby filter.
C
C    Call LOPAS (m, f2, x, nl, iback)
C
C        m = a flag;
C            if > 0, a filter is designed and new data used
C            if = 0, the last designed filter is used
C            if < 0, the last filter is used with new data
C        f2 = corner frequency in Nyquist units (fny=2*dt*fcps)
C        x = source data array
C        nl = the number of points in x
C        iback = a flag that indicates direction; 0 = forward,
C            1 = backward
C
C-
C
      DIMENSION  ALR(5), ALI(5), AO(5), A1(5), B1(5), B2(5), X(*)
      DIMENSION  Z(5), Z1(5), Z2(5)
C
      IF (M) 10, 2, 1
   10 N = -M
      GOTO 20
    1 N = M
      FN = N * 2
      RT = 3.1415926 / FN
      FI = -RT / 2.
      WW = X(1)
      DO 12 I = 1,N
         Z1(I) = 0.
         Z2(I) = 0.
         FI = FI + RT
         ALR(I) = -COS(FI)
   12    ALI(I) = SIN(FI)
      DO 122 K = 1,N
         PR = 0.
         PI = 2. * ALI(K)
         PRK = ALR(K)**2 - ALI(K)**2
         DO 1221 I = 1,N
            IF (I .EQ. K) GOTO 1221
            DR = PRK - ALR(K)*ALR(I)*2. + 1.
            DI = 2.*ALR(K)*ALI(K) - 2.*ALI(K)*ALR(I)
            TPR = PR*DR - PI*DI
            PI = PR*DI + PI*DR
            PR = TPR
 1221       CONTINUE
         DR = PR*PR + PI*PI
         AR = PR / DR
         AI = -PI / DR
         A1(K) = 2. * AR
         AO(K) = 2. * (ALR(K)*AR+ALI(K)*AI)
  122    B1(K) = -2. * ALR(K)
C...  HERE ENDS ALL GENERALIZED FORMS
      POO = F2 * 3.1415926/2.
      WU = 2. * SIN(POO)/COS(POO)
      DO 13 K = 1,N
         DR = 4./WU/WU + B1(K)*2./WU + 1.
         TA = (A1(K)*2./WU-AO(K)) / DR
         A1(K) = -(A1(K)*2./WU+AO(K)) / DR
         AO(K) = TA
         B2(K) = (4./WU/WU-B1(K)*2./WU+1.) / DR
   13    B1(K) = (2.-8./WU/WU) / DR
   20 CONTINUE
      WW = X(1)
      IF (IBACK .EQ. 1) WW = X(NL)
      DO 201 I = 1,N
         Z1(I) = 0.
  201    Z2(I) = 0.
    2 DO 22 II = 1,NL
         I = II
         IF (IBACK .EQ. 1) I = NL - II + 1
         ZZ = X(I) + WW
         XX = 0.
         WW = X(I)
         DO 21 J = 1,N
            Z(J) = ZZ - B1(J)*Z1(J) - B2(J)*Z2(J)
            XX = XX + AO(J)*Z(J) + A1(J)*Z1(J)
            Z2(J) = Z1(J)
   21       Z1(J) = Z(J)
   22    X(I) = XX
      PN = N
      FP = F2
      RETURN
      END
      SUBROUTINE HIPAS (M, F2, X, NL, IBACK)
C
C+
C
C Subroutine HIPAS.
C
C    HIPAS uses MCCamy's Butterworth high-pass recursive
C filter.
C
C    Call HIPAS (m, f2, x, nl, iback)
C
C        m = filter flag; if it = 0 then the last
C            designed filter is used; if it > 0 then
C            it designs a filter and starts with new data;
C            if it < 0 then it uses the last filter, but
C            starts on new data
C        f2 = the corner frequency in Nyquist units (fny =
C             2*dt*fcps)
C        x = the source array
C        nl = the number of points in x
C        iback = a flag that indicates direction; 0 = forward,
C            1 = backward
C
C-
C
      DIMENSION  ALR(5), ALI(5), AO(5), A1(5), B1(5), B2(5), X(*)
      DIMENSION  Z(5), Z1(5), Z2(5)
C
      IF(M) 10, 2, 1
C...  N = filter order (roll-off=N*12db/octave)
   10 N = -M
      GOTO 20
    1 N = M
      FN = N * 2
      RT = 3.1415926 / FN
      FI = -RT / 2.
      WW = X(1)
      DO 12 I = 1,N
         Z1(I) = 0.
         Z2(I) = 0.
         FI = FI + RT
         ALR(I) = -COS(FI)
   12    ALI(I) = SIN(FI)
      DO 122 K = 1,N
         PR = 0.
         PI = 2. * ALI(K)
         PRK = ALR(K)**2 - ALI(K)**2
         DO 1221 I = 1,N
            IF(I .EQ. K) GOTO 1221
            DR = PRK - 2.*ALR(K)*ALR(I) + 1.
            DI = 2.*ALR(K)*ALI(K) - 2.*ALI(K)*ALR(I)
            TPR = PR*DR - PI*DI
            PI = PR*DI + PI*DR
            PR = TPR
 1221       CONTINUE
         DR = PR*PR + PI*PI
         AR = PR / DR
         AI = -PI / DR
         A1(K) = 2. * AR
         AO(K) = 2. * (ALR(K)*AR+ALI(K)*AI)
  122    B1(K) = -2. * ALR(K)
C
C   HERE ENDS ALL GENERALIZED FORMS
C   BUILD HIGH PASS
      POO = F2 * 3.1415926 / 2.
      WU = 2. * SIN(POO) / COS(POO)
      DO 13 K = 1,N
         DR = WU*WU/4. + B1(K)*WU/2. + 1.
         TA = (A1(K)*WU/2.-AO(K)) / DR
         A1(K) = (A1(K)*WU/2.+AO(K)) / DR
         AO(K) = TA
         B2(K) = (WU*WU/4.-B1(K)*WU/2.+1.) / DR
   13    B1(K) = (WU*WU/2.-2.) / DR
   20 CONTINUE
      WW = X(1)
      IF (IBACK .EQ. 1) WW = X(NL)
      DO 201 I = 1,N
         Z1(I) = 0.
  201    Z2(I) = 0.
    2 DO 22 II = 1,NL
         I = II
         IF (IBACK .EQ. 1) I = NL - II + 1
         ZZ = X(I) - WW
         XX = 0.
         WW = X(I)
         DO 21 J = 1,N
            Z(J) = ZZ - B1(J)*Z1(J) - B2(J)*Z2(J)
            XX = XX + AO(J)*Z(J) + A1(J)*Z1(J)
            Z2(J) = Z1(J)
   21       Z1(J) = Z(J)
   22    X(I) = XX
      PN = N
      FP = F2
      RETURN
      END
      SUBROUTINE ZPLOP (M, FR2, X, NL)
C
C+
C
C Subroutine ZPLOP.
C
C    ZPLOP Calls McCamys low pass Butterworth routine 2 times,
C once forward and once with the time sequence reversed.
C
C    call ZPLOP (m, fr2, x, nl)
C
C        m  - integer roll-off width for high pass
C        fr2- corner frequency
C        x  - array that will be filtered, equally spaced in time
C        nl - the number of elements in x
C
C
C-
C
      DIMENSION  X(NL)
C
      IBACK=0
      CALL LOPAS(M,FR2,X,NL,IBACK)
      IBACK=1
      CALL LOPAS(M,FR2,X,NL,IBACK)
      RETURN
      END
      SUBROUTINE ZPHIP (M, FR2, X, NL)
C
C+
C
C Subroutine ZPHIP.
C
C    ZPHIP Calls McCamys high pass Butterworth routine 2 times,
C once forward and once with the time sequence reversed.
C
C    call ZPHIP (m, fr2, x, nl)
C
C        m  - integer roll-off width for high pass
C        fr2- corner frequency
C        x  - array that will be filtered, equally spaced in time
C        nl - the number of elements in x
C
C-
C
      DIMENSION  X(NL)
C
      IBACK = 0
      CALL HIPAS(M,FR2,X,NL,IBACK)
      IBACK = 1
      CALL HIPAS(M,FR2,X,NL,IBACK)
      RETURN
      END


!
!     READ IN ONE LAYER CONVECTION MODEL (CODE COMPARISON PROJECT)
!

subroutine read_ccp_one_layer(nzones,rrl,rr,rrr,ddi,ppi,tti,mui,xyzi)
!
  implicit none
  include 'dimen.inc'
  include 'bdimen.inc'
  include 'intgrs.inc'
  include 'float.inc'
  include 'files.inc'
  include 'burnf.inc'
  include 'comp.inc'
  include 'heos.inc'
  include 'constants.inc'
  include 'mpif.h'
  include 'mpicom.inc'
!
  integer*4 i, ii, j, jj, nlines, nzones

  real*8 rri(nzones),yi(nzones),tti(nzones)
  real*8 ppi(nzones), ddi(nzones)
  real*8 ggi(nzones), mui(nzones)
  real*8 xyzi(nzones,qn)

  real*8 ggic(nzones),ppic(nzones)

  real*8 rrp(nzones), rrl(nzones)
  real*8 rrr(nzones), rr(nzones)

  integer stat(MPI_STATUS_SIZE)
  real*8 fv, yyy, rtop, rbot, ccpy, width, deltay, y1, y3, ynlines
  real*8 gzero,deltar,dppdr,py1
  real*8 g0,five_fourth,y,fgy

  character*50 fn_name
  logical fkeyerr
!
  pi = 4.d0*datan(1.d0)
!
  fn_name = "data/setup_one_layer.in"

  call open_check(fn_name,ntlocal,fkeyerr)

  read(ntlocal,*) nlines

  if(ilog.eq.1) then
     write(6,*) 'MSG(read_ccp_one_layer): nlines=',nlines
  endif

  if(ilog.eq.1) print*,'MSG(read_ccp_one_layer): begin loop over model: nlines =', nlines

  ! init output arrays
  do i=1,nzones
     rri(i) = 0.d0
     ggi(i) = 0.d0
     ddi(i) = 0.d0
     ppi(i) = 0.d0
     ggic(i) = 0.d0
     ppic(i) = 0.d0
  enddo

  !pi=4.d0*datan(1.d0) ! calculate pi

  ncomp = qn

  ! read model lines
  do i=1,nlines
     read(ntlocal,*) yi(i), ggi(i), ddi(i), ppi(i), tti(i)
  enddo

  ! according to code comparison project specs > moved to constants.inc

  !onelu = 4.e8             ! length unit 4 Mm
  !onepu = 4.607893d23      ! pressure unit dyne
  !onedu = 1.82094d6        ! density unit g/cm3
  !onetu = 0.7951638        ! time unit in seconds
  !onemu = 1.165402d32      ! mass unit in grams
  !onettu = 3.401423e9      ! temperature unit in Kelvins
  !onegu = onelu/(onetu**2) ! gravitational acceleration unit
  !mu0 = 1.848              ! mean molecular weight of fluid_1
  !mu1 = 1.802              ! mean molecular weight of fluid_2
  !oneluu =  3.708735d49    ! luminosity unit erg/s
  !oneeu  = 2.949052d49     ! energy unit erg

  ! convert to physical units
  do i=1,nlines
     rri(i) = onelu*yi(i)
     ggi(i) = onegu*ggi(i)
     ddi(i) = onedu*ddi(i)
     ppi(i) = onepu*ppi(i)
     tti(i) = onettu*tti(i)
  enddo

  do i=1,nlines
     xyzi(i,1) = 1.d0
     mui(i) = 1.d0/((xyzi(i,1)/mu0))
  enddo

!     MANAGE ZONES: shift index:
!     rrl: left interface of zone i
!     rrr: right interface of zone i
!     rr : center of zone i
      do i=1,nlines-1
         rrl(i) = rri(i)
         rrr(i) = rri(i+1)
         rr(i)  = (rrr(i)+rrl(i))/2.d0
         ppi(i) = ppi(i+1)
         ddi(i) = ddi(i+1)
         tti(i) = tti(i+1)
         mui(i) = mui(i+1)
         do ii=1,qn
            xyzi(i,ii) = xyzi(i+1,ii)
         enddo
      enddo

!     COPY LAST ZONE (nzones-nlines) TIMES TO FILL ARRAY
      do i=nlines,nzones
         rrl(i) = rrl(i-1)
         rr(i)  = rr(i-1)
         rrr(i) = rrr(i-1)
         ppi(i) = ppi(i-1)
         ddi(i) = ddi(i-1)
         tti(i) = tti(i-1)
         mui(i) = mui(i-1)
         do ii=1,qn
            xyzi(i,ii) = xyzi(i-1,ii)
         enddo
      enddo

  !do i=1,nlines
  !   print*,i,rri(i),mui(i),xyzi(i,1),xyzi(i,2),ggi(i)
  !enddo

  !stop

  print*,'MSG(read_ccp_one_layer): pp, rho:  =', ppi(1),ppi(nlines),ddi(1),ddi(nlines)

  if(ilog.eq.1) print*,'END(read_ccp_one_layer):'

  return

end subroutine read_ccp_one_layer


! inprod_analytic.f90
!
!> Inner products between the truncated set of basis functions for the
!> ocean and atmosphere streamfunction fields.
!
!> @remark
!> These are partly calculated using the analytical expressions from
!> Cehelsky, P., & Tung, K. K. : Theories of multiple equilibria and
!> weather regimes-A critical reexamination. Part II: Baroclinic two-layer
!> models. Journal of the atmospheric sciences, 44(21), 3282-3303, 1987.
!
!
!> @copyright
!> 2015-2020 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!
!
!
!---------------------------------------------------------------------------!

MODULE inprod_analytic

  !-----------------------------------------------------!
  !                                                     !
  ! Preamble and variables declaration                  !
  !                                                     !
  !-----------------------------------------------------!

  USE params
  USE util, only: isin,piksrt
  IMPLICIT NONE

  PRIVATE

  !> Atmospheric bloc specification object
  TYPE :: AtmosphericWavenumber
    CHARACTER :: typ=" "
    INTEGER :: M=0,P=0,H=0
    REAL(KIND=8) :: Nx=0.,Ny=0.
  END TYPE AtmosphericWavenumber

  !> Oceanic bloc specification object
  TYPE :: OceanicWavenumber
    INTEGER :: P=0,H=0
    REAL(KIND=8) :: Nx=0.,Ny=0.
  END TYPE OceanicWavenumber

  !> Class holding the atmospheric inner products functions
  TYPE :: AtmosphereInnerProducts
    TYPE(InnerProducts), POINTER :: inner_products   !< Pointer to a global inner products object
  CONTAINS
    PROCEDURE :: a => calculate_a         !< Eigenvalues of the Laplacian (atmospheric)
    PROCEDURE :: b => calculate_b         !< Streamfunction advection terms (atmospheric)
    PROCEDURE :: c => calculate_c_atm     !< Beta term for the atmosphere
    PROCEDURE :: d => calculate_d         !< Forcing of the ocean on the atmosphere
    PROCEDURE :: g => calculate_g         !< Temperature advection terms (atmospheric)
    PROCEDURE :: s => calculate_s         !< Forcing (thermal) of the ocean on the atmosphere
  END TYPE AtmosphereInnerProducts

  !> Class holding the oceanic inner products functions
  TYPE :: OceanInnerProducts
    TYPE(InnerProducts), POINTER :: inner_products   !< Pointer to a global inner products object
  CONTAINS
    PROCEDURE :: K => calculate_K         !< Forcing of the atmosphere on the ocean.
    PROCEDURE :: M => calculate_M         !< Forcing of the ocean fields on the ocean.
    PROCEDURE :: C => calculate_C_oc      !< Streamfunction advection terms (oceanic)
    PROCEDURE :: N => calculate_N         !< Beta term for the ocean
    PROCEDURE :: O => calculate_O         !< Temperature advection term (passive scalar)
    PROCEDURE :: W => calculate_W         !< Short-wave radiative forcing of the ocean
  END TYPE OceanInnerProducts

  !> Global class for the inner products. Contains also the modes informations.
  TYPE, PUBLIC :: InnerProducts

    TYPE(ModelConfiguration), POINTER :: model_config   !< Pointer to a model configuration object.

    !> Atmospheric blocs specification
    TYPE(AtmosphericWavenumber), DIMENSION(:), ALLOCATABLE, PUBLIC :: awavenum
    !> Oceanic blocs specification
    TYPE(OceanicWavenumber), DIMENSION(:), ALLOCATABLE, PUBLIC :: owavenum

    !> Atmospheric tensors
    TYPE(AtmosphereInnerProducts), PUBLIC :: atmos
    !> Oceanic tensors
    TYPE(OceanInnerProducts), PUBLIC :: ocean
    LOGICAL :: initialized = .FALSE.

  CONTAINS
    PROCEDURE :: init => init_inner_products        !< Procedure to initialize the inner products functions based on the modes configuration.
    PROCEDURE :: clean => delete_inner_products     !< Procedure to clean the inner products object.

  END TYPE InnerProducts

  !-----------------------------------------------------!
  !                                                     !
  ! End of preamble                                     !
  !                                                     !
  !-----------------------------------------------------!

CONTAINS

  !-----------------------------------------------------!
  !                                                     !
  ! Definition of the Helper functions from Cehelsky    !
  ! & Tung                                              !
  !                                                     !
  !-----------------------------------------------------!

  ! Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION B1(Pi, Pj, Pk)
    INTEGER :: Pi,Pj,Pk
    B1 = (Pk + Pj) / REAL(Pi)
  END FUNCTION B1

  !  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION B2(Pi, Pj, Pk)
    INTEGER :: Pi,Pj,Pk
    B2 = (Pk - Pj) / REAL(Pi)
  END FUNCTION B2

  !  Integer Dirac delta function
  REAL(KIND=8) FUNCTION delta(r)
    INTEGER :: r
    IF (r==0) THEN
      delta = 1.D0
    ELSE
      delta = 0.D0
    ENDIF
  END FUNCTION delta

  !  "Odd or even" function
  REAL(KIND=8) FUNCTION flambda(r)
    INTEGER :: r
    IF (mod(r,2)==0) THEN
      flambda = 0.D0
    ELSE
      flambda = 1.D0
    ENDIF
  END FUNCTION flambda

  !  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION S1(Pj, Pk, Mj, Hk)
    INTEGER :: Pk,Pj,Mj,Hk
    S1 = -((Pk * Mj + Pj * Hk)) / 2.D0
  END FUNCTION S1

  !  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION S2(Pj, Pk, Mj, Hk)
    INTEGER :: Pk,Pj,Mj,Hk
    S2 = (Pk * Mj - Pj * Hk) / 2.D0
  END FUNCTION S2

  !  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION S3(Pj, Pk, Hj, Hk)
    INTEGER :: Pj,Pk,Hj,Hk
    S3 = (Pk * Hj + Pj * Hk) / 2.D0
  END FUNCTION S3

  !  Cehelsky & Tung Helper functions
  REAL(KIND=8) FUNCTION S4(Pj, Pk, Hj, Hk)
    INTEGER :: Pj,Pk,Hj,Hk
    S4 = (Pk * Hj - Pj * Hk) / 2.D0
  END FUNCTION S4

  !-----------------------------------------------------!
  ! Inner products definition routines                  !
  !--------------------------------------------------------!
  ! 1. Inner products in the equations for the atmosphere  !
  !--------------------------------------------------------!

  !> Eigenvalues of the Laplacian (atmospheric)
  !>
  !> \f$ a_{i,j} = (F_i, \nabla^2 F_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_a(self, i,j)
    CLASS(AtmosphereInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j
    TYPE(AtmosphericWavenumber) :: Ti

    calculate_a = 0.D0
    IF (i==j) THEN
      Ti = self%inner_products%awavenum(i)
      calculate_a = -(self%inner_products%model_config%physics%n**2) * Ti%Nx**2 - Ti%Ny**2
    END IF
  END FUNCTION calculate_a

  !> Streamfunction advection terms (atmospheric)
  !>
  !> \f$ b_{i,j,k} = (F_i, J(F_j, \nabla^2 F_k))\f$ .
  REAL(KIND=8) FUNCTION calculate_b(self,i,j,k)
    CLASS(AtmosphereInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j,k

    calculate_b = self%a(k,k) * self%g(i,j,k)

  END FUNCTION calculate_b

  !> Beta term for the atmosphere
  !>
  !> \f$ c_{i,j} = (F_i, \partial_x F_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_c_atm(self,i,j)
    CLASS(AtmosphereInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j
    TYPE(AtmosphericWavenumber) :: Ti, Tj

    Ti = self%inner_products%awavenum(i)
    Tj = self%inner_products%awavenum(j)
    calculate_c_atm = 0.D0
    IF ((Ti%typ == "K") .AND. (Tj%typ == "L")) THEN
      calculate_c_atm = Ti%M * delta(Ti%M - Tj%H) * delta(Ti%P - Tj%P)
    ELSE IF ((Ti%typ == "L") .AND. (Tj%typ == "K")) THEN
      Ti = self%inner_products%awavenum(j)
      Tj = self%inner_products%awavenum(i)
      calculate_c_atm = - Ti%M * delta(Ti%M - Tj%H) * delta(Ti%P - Tj%P)
    END IF
    calculate_c_atm = self%inner_products%model_config%physics%n * calculate_c_atm
  END FUNCTION calculate_c_atm

  !> Forcing of the ocean on the atmosphere.
  !>
  !> \f$ d_{i,j} = (F_i, \nabla^2 \eta_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_d(self,i,j)
    CLASS(AtmosphereInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j

    calculate_d=self%s(i,j) * self%inner_products%ocean%M(j,j)

  END FUNCTION calculate_d

  !> Temperature advection terms (atmospheric)
  !>
  !> \f$ g_{i,j,k} = (F_i, J(F_j, F_k))\f$ .
  REAL(KIND=8) FUNCTION calculate_g(self,i,j,k)
    CLASS(AtmosphereInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j,k
    TYPE(AtmosphericWavenumber) :: Ti,Tj,Tk
    REAL(KIND=8) :: val,vb1, vb2, vs1, vs2, vs3, vs4
    INTEGER, DIMENSION(3) :: a,b
    INTEGER, DIMENSION(3,3) :: w
    CHARACTER, DIMENSION(3) :: s
    INTEGER :: par

    Ti = self%inner_products%awavenum(i)
    Tj = self%inner_products%awavenum(j)
    Tk = self%inner_products%awavenum(k)

    a(1)=i
    a(2)=j
    a(3)=k

    val=0.D0

    IF ((Ti%typ == "L") .AND. (Tj%typ == "L") .AND. (Tk%typ == "L")) THEN

      CALL piksrt(3,a,par)

      Ti = self%inner_products%awavenum(a(1))
      Tj = self%inner_products%awavenum(a(2))
      Tk = self%inner_products%awavenum(a(3))

      vs3 = S3(Tj%P,Tk%P,Tj%H,Tk%H)
      vs4 = S4(Tj%P,Tk%P,Tj%H,Tk%H)
      val = vs3 * ((delta(Tk%H - Tj%H - Ti%H) - delta(Tk%H &
        &- Tj%H + Ti%H)) * delta(Tk%P + Tj%P - Ti%P) +&
        & delta(Tk%H + Tj%H - Ti%H) * (delta(Tk%P - Tj%P&
        & + Ti%P) - delta(Tk%P - Tj%P - Ti%P))) + vs4 *&
        & ((delta(Tk%H + Tj%H - Ti%H) * delta(Tk%P - Tj&
        &%P - Ti%P)) + (delta(Tk%H - Tj%H + Ti%H) -&
        & delta(Tk%H - Tj%H - Ti%H)) * (delta(Tk%P - Tj&
        &%P - Ti%P) - delta(Tk%P - Tj%P + Ti%P)))
    ELSE

      s(1)=Ti%typ
      s(2)=Tj%typ
      s(3)=Tk%typ

      w(1,:)=isin("A",s)
      w(2,:)=isin("K",s)
      w(3,:)=isin("L",s)

      IF (ANY(w(1,:)/=0) .AND. ANY(w(2,:)/=0) .AND. ANY(w(3,:)/=0)) THEN
        b=w(:,1)
        Ti = self%inner_products%awavenum(a(b(1)))
        Tj = self%inner_products%awavenum(a(b(2)))
        Tk = self%inner_products%awavenum(a(b(3)))
        call piksrt(3,b,par)
        vb1 = B1(Ti%P,Tj%P,Tk%P)
        vb2 = B2(Ti%P,Tj%P,Tk%P)
        val = -2 * sqrt(2.) / self%inner_products%model_config%physics%pi * Tj%M * delta(Tj%M - Tk%H) * flambda(Ti%P + Tj%P + Tk%P)
        IF (val /= 0.D0) val = val * (vb1**2 / (vb1**2 - 1) - vb2**2 / (vb2**2 - 1))
      ELSEIF ((w(2,2)/=0) .AND. (w(2,3)==0) .AND. ANY(w(3,:)/=0)) THEN
        Ti = self%inner_products%awavenum(a(w(2,1)))
        Tj = self%inner_products%awavenum(a(w(2,2)))
        Tk = self%inner_products%awavenum(a(w(3,1)))
        b(1)=w(2,1)
        b(2)=w(2,2)
        b(3)=w(3,1)
        call piksrt(3,b,par)
        vs1 = S1(Tj%P,Tk%P,Tj%M,Tk%H)
        vs2 = S2(Tj%P,Tk%P,Tj%M,Tk%H)
        val = vs1 * (delta(Ti%M - Tk%H - Tj%M) * delta(Ti%P -&
          & Tk%P + Tj%P) - delta(Ti%M- Tk%H - Tj%M) *&
          & delta(Ti%P + Tk%P - Tj%P) + (delta(Tk%H - Tj%M&
          & + Ti%M) + delta(Tk%H - Tj%M - Ti%M)) *&
          & delta(Tk%P + Tj%P - Ti%P)) + vs2 * (delta(Ti%M&
          & - Tk%H - Tj%M) * delta(Ti%P - Tk%P - Tj%P) +&
          & (delta(Tk%H - Tj%M - Ti%M) + delta(Ti%M + Tk%H&
          & - Tj%M)) * (delta(Ti%P - Tk%P + Tj%P) -&
          & delta(Tk%P - Tj%P + Ti%P)))
      ENDIF
    ENDIF
    calculate_g=par*val*self%inner_products%model_config%physics%n

  END FUNCTION calculate_g

  !> Forcing (thermal) of the ocean on the atmosphere.
  !>
  !> \f$ s_{i,j} = (F_i, \eta_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_s(self,i,j)
    CLASS(AtmosphereInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j
    TYPE(AtmosphericWavenumber) :: Ti
    TYPE(OceanicWavenumber) :: Dj
    REAL(KIND=8) :: val

    Ti = self%inner_products%awavenum(i)
    Dj = self%inner_products%owavenum(j)
    val=0.D0
    IF (Ti%typ == "A") THEN
      val = flambda(Dj%H) * flambda(Dj%P + Ti%P)
      IF (val /= 0.D0) THEN
        val = val*8*sqrt(2.)*Dj%P/(self%inner_products%model_config%physics%pi**2 * (Dj%P**2 - Ti%P**2) * Dj%H)
      END IF
    ELSEIF (Ti%typ == "K") THEN
      val = flambda(2 * Ti%M + Dj%H) * delta(Dj%P - Ti%P)
      IF (val /= 0.D0) THEN
        val = val*4*Dj%H/(self%inner_products%model_config%physics%pi * (-4 * Ti%M**2 + Dj%H**2))
      END IF
    ELSEIF (Ti%typ == "L") THEN
      val = delta(Dj%P - Ti%P) * delta(2 * Ti%H - Dj%H)
    END IF
    calculate_s=val

  END FUNCTION calculate_s

  !--------------------------------------------------------!
  ! 2. Inner products in the equations for the ocean       !
  !--------------------------------------------------------!

  !> Forcing of the atmosphere on the ocean.
  !>
  !> \f$ K_{i,j} = (\eta_i, \nabla^2 F_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_K(self,i,j)
    CLASS(OceanInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j

    calculate_K = self%inner_products%atmos%s(j,i) * self%inner_products%atmos%a(j,j)
  END FUNCTION calculate_K

  !> Forcing of the ocean fields on the ocean.
  !>
  !> \f$ M_{i,j} = (eta_i, \nabla^2 \eta_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_M(self,i,j)
    CLASS(OceanInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j
    TYPE(OceanicWavenumber) :: Di

    calculate_M=0.D0
    IF (i==j) THEN
      Di = self%inner_products%owavenum(i)
      calculate_M = -(self%inner_products%model_config%physics%n**2) * Di%Nx**2 - Di%Ny**2
    END IF
  END FUNCTION calculate_M

  !> Beta term for the ocean
  !>
  !> \f$ N_{i,j} = (\eta_i, \partial_x \eta_j) \f$.
  REAL(KIND=8) FUNCTION calculate_N(self,i,j)
    CLASS(OceanInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j
    TYPE(OceanicWavenumber) :: Di,Dj
    REAL(KIND=8) :: val

    Di = self%inner_products%owavenum(i)
    Dj = self%inner_products%owavenum(j)
    calculate_N = 0.D0
    IF (Dj%H/=Di%H) THEN
      val = delta(Di%P - Dj%P) * flambda(Di%H + Dj%H)
      calculate_N = val * (-2) * Dj%H * Di%H * self%inner_products%model_config%physics%n
      calculate_N = calculate_N / ((Dj%H**2 - Di%H**2) * self%inner_products%model_config%physics%pi)
    ENDIF

  END FUNCTION calculate_N

  !> Temperature advection term (passive scalar)
  !>
  !> \f$ O_{i,j,k} = (\eta_i, J(\eta_j, \eta_k))\f$ .
  REAL(KIND=8) FUNCTION calculate_O(self,i,j,k)
    CLASS(OceanInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j,k
    TYPE(OceanicWavenumber) :: Di,Dj,Dk
    REAL(KIND=8) :: vs3,vs4,val
    INTEGER, DIMENSION(3) :: a
    INTEGER :: par

    val=0.D0

    a(1)=i
    a(2)=j
    a(3)=k

    CALL piksrt(3,a,par)

    Di = self%inner_products%owavenum(a(1))
    Dj = self%inner_products%owavenum(a(2))
    Dk = self%inner_products%owavenum(a(3))

    vs3 = S3(Dj%P,Dk%P,Dj%H,Dk%H)
    vs4 = S4(Dj%P,Dk%P,Dj%H,Dk%H)
    val = vs3*((delta(Dk%H - Dj%H - Di%H) - delta(Dk%H - Dj&
      &%H + Di%H)) * delta(Dk%P + Dj%P - Di%P) + delta(Dk&
      &%H + Dj%H - Di%H) * (delta(Dk%P - Dj%P + Di%P) -&
      & delta(Dk%P - Dj%P - Di%P))) + vs4 * ((delta(Dk%H &
      &+ Dj%H - Di%H) * delta(Dk%P - Dj%P - Di%P)) +&
      & (delta(Dk%H - Dj%H + Di%H) - delta(Dk%H - Dj%H -&
      & Di%H)) * (delta(Dk%P - Dj%P - Di%P) - delta(Dk%P &
      &- Dj%P + Di%P)))
    calculate_O = par * val * self%inner_products%model_config%physics%n / 2
  END FUNCTION calculate_O

  !> Streamfunction advection terms (oceanic)
  !>
  !> \f$ C_{i,j,k} = (\eta_i, J(\eta_j,\nabla^2 \eta_k))\f$ .
  REAL(KIND=8) FUNCTION calculate_C_oc(self,i,j,k)
    CLASS(OceanInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j,k

    calculate_C_oc = self%M(k,k) * self%O(i,j,k)

  END FUNCTION calculate_C_oc

  !> Short-wave radiative forcing of the ocean
  !>
  !> \f$ W_{i,j} = (\eta_i, F_j)\f$ .
  REAL(KIND=8) FUNCTION calculate_W(self,i,j)
    CLASS(OceanInnerProducts), INTENT(IN) :: self
    INTEGER, INTENT(IN) :: i,j

    calculate_W = self%inner_products%atmos%s(j,i)

  END FUNCTION calculate_W

  !-----------------------------------------------------!
  !                                                     !
  ! Initialisation routine                              !
  !                                                     !
  !-----------------------------------------------------!

  !> Initialization routine for the inner products functions.
  !> @param[in,out] inner_products Inner products global object to initialize
  !> @param[in] model_config Global model configuration object to initialize the inner products with
  SUBROUTINE init_inner_products(inner_products, model_config)
    CLASS(InnerProducts), INTENT(INOUT), TARGET :: inner_products
    CLASS(ModelConfiguration), INTENT(IN), TARGET :: model_config

    TYPE(InnerProducts), POINTER :: ips

    INTEGER :: i,j
    INTEGER :: AllocStat

    ips => inner_products

    IF (.NOT.model_config%initialized) THEN
      PRINT*, "Warning: Model configuration not initialized."
      PRINT*, "Aborting inner products initialization."
      RETURN
    END IF

    ! Definition of the types and wave numbers tables

    IF (allocated(ips%owavenum)) DEALLOCATE(ips%owavenum)
    ALLOCATE(ips%owavenum(model_config%modes%noc), STAT=AllocStat)
    IF (AllocStat /= 0) THEN
      PRINT*, "*** init_inner_products: Problem with allocation! ***"
      STOP "Exiting ..."
    END IF

    IF (allocated(ips%awavenum)) DEALLOCATE(ips%awavenum)
    ALLOCATE(ips%awavenum(model_config%modes%natm), STAT=AllocStat)
    IF (AllocStat /= 0) THEN
      PRINT*, "*** init_inner_products: Problem with allocation! ***"
      STOP "Exiting ..."
    END IF

    j=0
    DO i=1,model_config%modes%nbatm
      IF (model_config%modes%ams(i,1)==1) THEN
        ips%awavenum(j+1)%typ='A'
        ips%awavenum(j+2)%typ='K'
        ips%awavenum(j+3)%typ='L'

        ips%awavenum(j+1)%P=model_config%modes%ams(i,2)
        ips%awavenum(j+2)%M=model_config%modes%ams(i,1)
        ips%awavenum(j+2)%P=model_config%modes%ams(i,2)
        ips%awavenum(j+3)%H=model_config%modes%ams(i,1)
        ips%awavenum(j+3)%P=model_config%modes%ams(i,2)

        ips%awavenum(j+1)%Ny=REAL(model_config%modes%ams(i,2))
        ips%awavenum(j+2)%Nx=REAL(model_config%modes%ams(i,1))
        ips%awavenum(j+2)%Ny=REAL(model_config%modes%ams(i,2))
        ips%awavenum(j+3)%Nx=REAL(model_config%modes%ams(i,1))
        ips%awavenum(j+3)%Ny=REAL(model_config%modes%ams(i,2))

        j=j+3
      ELSE
        ips%awavenum(j+1)%typ='K'
        ips%awavenum(j+2)%typ='L'

        ips%awavenum(j+1)%M=model_config%modes%ams(i,1)
        ips%awavenum(j+1)%P=model_config%modes%ams(i,2)
        ips%awavenum(j+2)%H=model_config%modes%ams(i,1)
        ips%awavenum(j+2)%P=model_config%modes%ams(i,2)

        ips%awavenum(j+1)%Nx=REAL(model_config%modes%ams(i,1))
        ips%awavenum(j+1)%Ny=REAL(model_config%modes%ams(i,2))
        ips%awavenum(j+2)%Nx=REAL(model_config%modes%ams(i,1))
        ips%awavenum(j+2)%Ny=REAL(model_config%modes%ams(i,2))

        j=j+2

      ENDIF
    ENDDO

    DO i=1,model_config%modes%noc
      ips%owavenum(i)%H=model_config%modes%oms(i,1)
      ips%owavenum(i)%P=model_config%modes%oms(i,2)

      ips%owavenum(i)%Nx=model_config%modes%oms(i,1)/2.D0
      ips%owavenum(i)%Ny=model_config%modes%oms(i,2)

    ENDDO

    inner_products%model_config => model_config
    inner_products%atmos%inner_products => inner_products
    inner_products%ocean%inner_products => inner_products

    inner_products%initialized = .TRUE.

  END SUBROUTINE init_inner_products

  !> Routine to clean a inner products global object
  !> @param[in,out] inner_products Inner products global object to initialize
  SUBROUTINE delete_inner_products(inner_products)
    CLASS(InnerProducts), INTENT(INOUT), TARGET :: inner_products

    IF (allocated(inner_products%owavenum)) DEALLOCATE(inner_products%owavenum)
    IF (allocated(inner_products%awavenum)) DEALLOCATE(inner_products%awavenum)

    inner_products%initialized = .FALSE.

  END SUBROUTINE delete_inner_products

END MODULE inprod_analytic