      SUBROUTINE FB01QD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B,
     $                   LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL,
     $                   IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To calculate a combined measurement and time update of one
C     iteration of the time-varying Kalman filter. This update is given
C     for the square root covariance filter, using dense matrices.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBK    CHARACTER*1
C             Indicates whether the user wishes to compute the Kalman
C             filter gain matrix K  as follows:
C                                 i
C             = 'K':  K  is computed and stored in array K;
C                      i
C             = 'N':  K  is not required.
C                      i
C
C     MULTBQ  CHARACTER*1                    1/2
C             Indicates how matrices B  and Q    are to be passed to
C                                     i      i
C             the routine as follows:
C             = 'P':  Array Q is not used and the array B must contain
C                                    1/2
C                     the product B Q   ;
C                                  i i
C             = 'N':  Arrays B and Q must contain the matrices as
C                     described below.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The actual state dimension, i.e., the order of the
C             matrices S    and A .  N >= 0.
C                       i-1      i
C
C     M       (input) INTEGER
C             The actual input dimension, i.e., the order of the matrix
C              1/2
C             Q   .  M >= 0.
C              i
C
C     P       (input) INTEGER
C             The actual output dimension, i.e., the order of the matrix
C              1/2
C             R   .  P >= 0.
C              i
C
C     S       (input/output) DOUBLE PRECISION array, dimension (LDS,N)
C             On entry, the leading N-by-N lower triangular part of this
C             array must contain S   , the square root (left Cholesky
C                                 i-1
C             factor) of the state covariance matrix at instant (i-1).
C             On exit, the leading N-by-N lower triangular part of this
C             array contains S , the square root (left Cholesky factor)
C                             i
C             of the state covariance matrix at instant i.
C             The strict upper triangular part of this array is not
C             referenced.
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,N).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain A ,
C                                                                 i
C             the state transition matrix of the discrete system at
C             instant i.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain B ,
C                                                        1/2      i
C             the input weight matrix (or the product B Q    if
C                                                      i i
C             MULTBQ = 'P') of the discrete system at instant i.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     Q       (input) DOUBLE PRECISION array, dimension (LDQ,*)
C             If MULTBQ = 'N', then the leading M-by-M lower triangular
C                                              1/2
C             part of this array must contain Q   , the square root
C                                              i
C             (left Cholesky factor) of the input (process) noise
C             covariance matrix at instant i.
C             The strict upper triangular part of this array is not
C             referenced.
C             If MULTBQ = 'P', Q is not referenced and can be supplied
C             as a dummy array (i.e., set parameter LDQ = 1 and declare
C             this array to be Q(1,1) in the calling program).
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= MAX(1,M) if MULTBQ = 'N';
C             LDQ >= 1        if MULTBQ = 'P'.
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain C , the
C                                                                 i
C             output weight matrix of the discrete system at instant i.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,P)
C             On entry, the leading P-by-P lower triangular part of this
C                                 1/2
C             array must contain R   , the square root (left Cholesky
C                                 i
C             factor) of the output (measurement) noise covariance
C             matrix at instant i.
C             On exit, the leading P-by-P lower triangular part of this
C                                    1/2
C             array contains (RINOV )   , the square root (left Cholesky
C                                  i
C             factor) of the covariance matrix of the innovations at
C             instant i.
C             The strict upper triangular part of this array is not
C             referenced.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,P).
C
C     K       (output) DOUBLE PRECISION array, dimension (LDK,P)
C             If JOBK = 'K', and INFO = 0, then the leading N-by-P part
C             of this array contains K , the Kalman filter gain matrix
C                                     i
C             at instant i.
C             If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the
C             leading N-by-P part of this array contains AK , a matrix
C                                                          i
C             related to the Kalman filter gain matrix at instant i (see
C                                                            -1/2
C             METHOD). Specifically, AK  = A P     C'(RINOV')    .
C                                      i    i i|i-1 i      i
C
C     LDK     INTEGER
C             The leading dimension of array K.   LDK >= MAX(1,N).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If JOBK = 'K', then TOL is used to test for near
C                                               1/2
C             singularity of the matrix (RINOV )   . If the user sets
C                                             i
C             TOL > 0, then the given value of TOL is used as a
C             lower bound for the reciprocal condition number of that
C             matrix; a matrix whose estimated condition number is less
C             than 1/TOL is considered to be nonsingular. If the user
C             sets TOL <= 0, then an implicitly computed, default
C             tolerance, defined by TOLDEF = P*P*EPS, is used instead,
C             where EPS is the machine precision (see LAPACK Library
C             routine DLAMCH).
C             Otherwise, TOL is not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK),
C             where LIWORK = P if JOBK = 'K',
C             and   LIWORK = 1 otherwise.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.  If INFO = 0 and JOBK = 'K', DWORK(2) returns
C             an estimate of the reciprocal of the condition number
C                                        1/2
C             (in the 1-norm) of (RINOV )   .
C                                      i
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= MAX(1,N*(P+N)+2*P,N*(N+M+2)),     if JOBK = 'N';
C             LDWORK >= MAX(2,N*(P+N)+2*P,N*(N+M+2),3*P), if JOBK = 'K'.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C                                                        1/2
C             = 1:  if JOBK = 'K' and the matrix (RINOV )   is singular,
C                                                      i           1/2
C                   i.e., the condition number estimate of (RINOV )
C                                                                i
C                   (in the 1-norm) exceeds 1/TOL.  The matrices S, AK ,
C                               1/2                                   i
C                   and (RINOV )    have been computed.
C                             i
C
C     METHOD
C
C     The routine performs one recursion of the square root covariance
C     filter algorithm, summarized as follows:
C
C      |  1/2                      |     |         1/2          |
C      | R      C x S      0       |     | (RINOV )     0     0 |
C      |  i      i   i-1           |     |       i              |
C      |                      1/2  | T = |                      |
C      | 0      A x S    B x Q     |     |     AK       S     0 |
C      |         i   i-1  i   i    |     |       i       i      |
C
C          (Pre-array)                      (Post-array)
C
C     where T is an orthogonal transformation triangularizing the
C     pre-array.
C
C     The state covariance matrix P    is factorized as
C                                  i|i-1
C        P     = S  S'
C         i|i-1   i  i
C
C     and one combined time and measurement update for the state X
C                                                                 i|i-1
C     is given by
C
C        X     = A X      + K (Y - C X     ),
C         i+1|i   i i|i-1    i  i   i i|i-1
C
C                          -1/2
C     where K = AK (RINOV )     is the Kalman filter gain matrix and Y
C            i    i      i                                            i
C     is the observed output of the system.
C
C     The triangularization is done entirely via Householder
C     transformations exploiting the zero pattern of the pre-array.
C
C     REFERENCES
C
C     [1] Anderson, B.D.O. and Moore, J.B.
C         Optimal Filtering.
C         Prentice Hall, Englewood Cliffs, New Jersey, 1979.
C
C     [2] Verhaegen, M.H.G. and Van Dooren, P.
C         Numerical Aspects of Different Kalman Filter Implementations.
C         IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986.
C
C     [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G.
C         Algorithm 675: FORTRAN Subroutines for Computing the Square
C         Root Covariance Filter and Square Root Information Filter in
C         Dense or Hessenberg Forms.
C         ACM Trans. Math. Software, 15, pp. 243-256, 1989.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires
C
C           3    2                               2   2
C     (7/6)N  + N  x (5/2 x P + M) + N x (1/2 x M + P )
C
C     operations and is backward stable (see [2]).
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine FB01ED by M. Vanbegin,
C     P. Van Dooren, and M.H.G. Verhaegen.
C
C     REVISIONS
C
C     February 20, 1998, November 20, 2003.
C
C     KEYWORDS
C
C     Kalman filtering, optimal filtering, orthogonal transformation,
C     recursive estimation, square-root covariance filtering,
C     square-root filtering.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, TWO
      PARAMETER         ( ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBK, MULTBQ
      INTEGER           INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK,
     $                  M, N, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*),
     $                  K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*)
C     .. Local Scalars ..
      LOGICAL           LJOBK, LMULTB
      INTEGER           I12, ITAU, JWORK, N1, PN, WRKOPT
      DOUBLE PRECISION  RCOND
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DGELQF, DLACPY, DTRMM, MB02OD, MB04LD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      PN = P + N
      N1 = MAX( 1, N )
      INFO = 0
      LJOBK  = LSAME( JOBK, 'K' )
      LMULTB = LSAME( MULTBQ, 'P' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDS.LT.N1 ) THEN
         INFO = -7
      ELSE IF( LDA.LT.N1 ) THEN
         INFO = -9
      ELSE IF( LDB.LT.N1 ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDR.LT.MAX( 1, P ) ) THEN
         INFO = -17
      ELSE IF( LDK.LT.N1 ) THEN
         INFO = -19
      ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + 2*P,
     $                                      N*(N + M + 2), 3*P ) ) .OR.
     $    ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + 2*P,
     $                                      N*(N + M + 2) ) ) ) THEN
         INFO = -23
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'FB01QD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         IF ( LJOBK ) THEN
            DWORK(1) = TWO
            DWORK(2) = ONE
         ELSE
            DWORK(1) = ONE
         END IF
         RETURN
      END IF
C
C     Construction of the needed part of the pre-array in DWORK.
C     To save workspace, only the blocks (1,2), (2,2), and (2,3) will be
C     constructed as shown below.
C
C     Storing A x S and C x S in the (1,1) and (2,1) blocks of DWORK,
C     respectively.
C     Workspace: need (N+P)*N.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK, PN )
      CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), PN )
      CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', PN, N,
     $            ONE, S, LDS, DWORK, PN )
C
C     Triangularization (2 steps).
C
C     Step 1: annihilate the matrix C x S.
C     Workspace: need (N+P)*N + 2*P.
C
      ITAU  = PN*N + 1
      JWORK = ITAU + P
C
      CALL MB04LD( 'Full', P, N, N, R, LDR, DWORK(N+1), PN, DWORK, PN,
     $             K, LDK, DWORK(ITAU), DWORK(JWORK) )
      WRKOPT = PN*N + 2*P
C
C     Now, the workspace for C x S is no longer needed.
C     Adjust the leading dimension of DWORK, to save space for the
C     following computations.
C
      CALL DLACPY( 'Full', N, N, DWORK, PN, DWORK, N )
      I12 = N*N + 1
C
C     Storing B x Q in the (1,2) block of DWORK.
C     Workspace: need N*(N+M).
C
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I12), N )
      IF ( .NOT.LMULTB )
     $   CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M,
     $               ONE, Q, LDQ, DWORK(I12), N )
      WRKOPT = MAX( WRKOPT, N*( N + M ) )
C
C     Step 2: LQ triangularization of the matrix [ A x S  B x Q ], where
C     A x S was modified at Step 1.
C     Workspace: need N*(N+M+2);  prefer N*(N+M+1)+N*NB.
C
      ITAU  = N*( N + M ) + 1
      JWORK = ITAU + N
C
      CALL DGELQF( N, N+M, DWORK, N, DWORK(ITAU), DWORK(JWORK),
     $             LDWORK-JWORK+1, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     Output S and K (if needed) and set the optimal workspace
C     dimension (and the reciprocal of the condition number estimate).
C
      CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS )
C
      IF ( LJOBK ) THEN
C
C        Compute K.
C        Workspace: need 3*P.
C
         CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit',
     $                '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL,
     $                IWORK, DWORK, INFO )
         IF ( INFO.EQ.0 ) THEN
            WRKOPT = MAX( WRKOPT, 3*P )
            DWORK(2) = RCOND
         END IF
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of FB01QD ***
      END


      double precision function rotwig (beta, jj, m1, m2, ient)
c     uses Wigner formula (Messiah eq.C.72) to calculate rotation matrix
c     for integers  (ient=1)  or semiintegers (ient=2)
c     other arguments (except beta) should be multiplied by ient

      implicit double precision (a-h,o-z)
      parameter (idim = 58)
c     dimensions  modified for larger arguments by ala 12.12.94
      dimension al(idim+1),m(12)
      save ini, al
      data ini/1/
c     idim-1 is the largest argument of factorial to calculate

      if (((ient-1)*(ient-2)).ne.0) stop ' Illegal ient in rotwig.'

      if (ini.eq.1) then
c       initialisation of the log's of the factorials
        ini=0
        al(1)=0.0d 00
        do 11 i=1,idim
           b=i
 11        al(i+1)=al(i)+ log(b)
      endif
      rotwig = 0.d0

      if ( m1.ge.0 .and. abs(m1).ge.abs(m2)) then
         m1p = m1
         m2p = m2
         betap = beta
         isign = 1
      elseif (m2.ge.0 .and. abs(m2).ge.abs(m1)) then
         m1p = m2
         m2p = m1
         betap = - beta
         isign = 1
      elseif (m1.le.0 .and. abs(m1).ge.abs(m2)) then
         m1p = - m1
         m2p = - m2
         betap = beta
         isign = (-1)**( (m1-m2)/ient )
      else
         m1p = - m2
         m2p = - m1
         betap = - beta
         isign = (-1)**( (m2-m1)/ient )
      endif

      temp = 0.d0
      zeta = cos ( betap / 2.d0 )
      eta  = sin ( betap / 2.d0 )
      do 100 it = m1p - m2p, jj - m2p, ient
        m(1) = 1 + (jj+m1p) / ient
        m(2) = 1 + (jj-m1p) / ient
        m(3) = 1 + (jj+m2p) / ient
        m(4) = 1 + (jj-m2p) / ient
        m(5) = 1 + (jj+m1p-it) / ient
        m(6) = 1 + (jj-m2p-it) / ient
        m(7) = 1 + it / ient
        m(8) = 1 + (m2p-m1p+it) / ient
        m(9)  = (2*jj+m1p-m2p-2*it) / ient
        m(10) = (2*it-m1p+m2p) / ient
        factor = 0.d0
        do 110 i = 1,4
  110     factor = factor + al(m(i))/2.d0 - al(m(i+4))
c       special cases to resolve 0.d0**0 problem (a.ankudinov, may 2001)
        if (m(10).eq.0 .and. m(9).eq.0) then
          temp = temp + (-1)**(it/ient)*exp(factor)
        elseif (m(10).eq.0) then
          temp = temp + (-1)**(it/ient)*zeta**m(9)*exp(factor)
        elseif (m(9).eq.0) then
          temp = temp + (-1)**(it/ient)*eta**m(10)*exp(factor)
        else
c         general expression
          temp = temp+ (-1)**(it/ient)*zeta**m(9)*eta**m(10)*exp(factor)
        endif
  100 continue

      rotwig = isign * temp

      return
      end


      SUBROUTINE CALP(CMN,DMN,EMN,EPSIL,LROW,LDIAG,ALP,DALP)
C
C CALCULATES THE ASSOCIATED LEGENDRE POLYNOMIALS USING A HIGHLY
C STABLE FOUR TERM RECURRENCE RELATION GIVEN BY BELOUSOV (1962).
C THE SPECTRAL TRUNCATION PARAMETERS ARE DEFINED BY 3 PARAMETERS:
C MM, THE LARGEST FOURIER WAVENUMBER; KK, THE HIGHEST DEGREE OF THE
C ASSOCIATED LEGENDRE POLYNOMIALS, AND NN THE HIGHEST DEGREE OF THE
C ASSOCIATED LEGENDRE POLYNOMIALS FOR M=0.  THE LENGTH OF THE
C ASSOCIATED LEGENDRE POLYNOMIAL ARRAY ALP IS GIVEN BY THE RELATION
C LEN = ((MM+1)*(NN+1) - (LMN**2 + LMN)/2)  WHERE LMN = MM + NN - KK
C VARIABLES ARE STORED ALONG DIAGONALS STARTING WITH DIAGONAL M=N.
C THE LENGTH OF EACH ROW IS STORED IN THE ARRAY LROW(0:KK,2).
C THE LENGTH OF EACH DIAGONAL IS STORED IN THE ARRAY LDIAG(0:NN,1)
C AND IS EVALUATED IN SUBROUTINE CEPS AS (MM+1)-AMAX(MM+N-KK,0)
C WHERE 0>N>NN.  CUMULATIVE DIAGONAL LENGTHS (CUMULATIVE
C DISPLACEMENTS) ARE ALSO STORED IN LDIAG(0:NN,2) SO THAT THE
C ASSOCIATED LEGENDRE POLYNOMIAL OF ORDER M, DEGREE N, AND ARGUMENT
C SNJ(NL) IS ADDRESSED AS ALP(1 + LDIAG(N-M,2)+M),NL), OR USING THE
C STATEMENT FUNCTION IDSP AS ALP(IDSP(M,N),NL).  THE SAME FORM
C APPLIES FOR ADDRESSING THE DERIVATIVES (DALP) AND RECURRENCE
C COEFFICIENTS DEFINED IN THE EPSIL MATRIX.
C
C CALLED BY: INPUT
C CALLS: GLAT
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C RECURRENCE COEFFICIENTS FOR ALP
      REAL CMN(LRM+1)
C RECURRENCE COEFFICIENTS FOR ALP
      REAL DMN(LRM+1)
C RECURRENCE COEFFICIENTS FOR ALP
      REAL EMN(LRM+1)
C RECURRENCE COEFFICIENTS FOR DALP
      REAL EPSIL(NALP)
C ROW LENGTH AND INDEX
      INTEGER LROW(0:KK,2)
C DIAGONAL LENGTH AND INDEX
      INTEGER LDIAG(0:NN,2)
C
C     Output
C
C ASSOC. LEGENDRE POLYNOMIALS
      REAL ALP(NALP,NLAT/2)
C DERIV. ASSOC. LEGENDRE POLYNOMIALS
      REAL DALP(NALP,NLAT/2)
C
C------ Local Parameters -----------------------------------------------
C
      REAL PI
      PARAMETER (PI=3.141592653589793)
C
C------ Local Variables ------------------------------------------------
C
      REAL CN2N1N(KK+1,3)
      REAL COL1(KK), COL2(KK), SNPSUM(KK), CSPSUM(KK), SQNP(KK),
     $     AN(KK), CSFAC(KK), SNFAC(KK), COSTBL(KK), SINTBL(KK)
C
C     TEMPORARIES
C
      REAL RNORM,COS2P,RLAT,SNJ,THTA
      INTEGER N,M,JK,JM,JN,MSTART,NSTART
      INTEGER MLIM,IS,ISM1,NL,LAT
C
C----- External Functions ----------------------------------------------
C
C     GAUSSIAN LATITUDES
C
      EXTERNAL GLAT
      REAL GLAT
C
C----- Statement Functions ---------------------------------------------
C
C     ADDRESS COMPUTATION OF ALP, DALP, EPSIL
C     E.G., EPSIL(M,N) = EPSIL(IDSP(M,N))
C
      INTEGER MDUM, NDUM, IDSP, IDSPR
      IDSP(MDUM,NDUM) = 1 + LDIAG(NDUM-MDUM,2)+MDUM
C
C     ADDRESS COMPUTATION OF BELOUSOV RECURRENCE
C     COEFFICIENT MATRICES.  E.G., CMN(M,N) = CMN(IDSPR(M,N))
C
      IDSPR(MDUM,NDUM) = 1 + LROW(NDUM,2)+MDUM
C
C----- Executable Statements -------------------------------------------
C
C     COMPUTE ASSOCIATED LEGENDRE POLYNOMIALS AND THEIR DERIVATIVES FOR
C     THE TRUNCATED WAVENUMBER SPACE DEFINED IN LDIAG(0:NN,1:2) WITH
C     ARGUMENTS GIVEN BY GRID FUNCTION GLAT USING BELOUSOV'S ALGORITHM.
C     THE PROCEDURE INVOLVES EXTRA WORK FOR ANY TRUNCATION OTHER THAN
C     TRIANGULAR BECAUSE BELOUSOV'S RECURRENCE REQUIRES POLYNOMIAL
C     INFORMATION IN PART OF THE REGION BETWEEN KK AND NN.  MORE
C     ELABORATE BOOKKEEPING COULD REDUCE THIS EXTRA COMPUTATION, BUT BY
C     LESS THAN A FACTOR OF TWO (PROBABLY LESS THAN 10% OF TOTAL WORK).
C
C     PRECOMPUTE SOME FACTORS
C
      AN(1) = SQRT(0.75)
      DO 190 N=2,KK
         AN(N) = AN(N-1)*SQRT(1.0-(1.0/REAL(4*N*N)))
  190 CONTINUE
C
C     BEGIN PROCEDURE ... OUTER LOOP OVER LATITUDE (ARGUMENT)
C
      DO 290 NL=1,NLAT/2
C
C     DETERMINE PROPER INDEX FOR LATITUDE DEPENDENT QUANTITIES
C     (PROVISION FOR DOING THIS COMPUTATION ON THE FLY, NOT IN USE)
C
         LAT = NL
         RLAT = GLAT(LAT)
C
C        LATITUDE = RLAT
C
C        BEGIN BY COMPUTING 1ST TWO ELEMENTS IN EACH ROW (M=0:1;N=0:KK)
C        EVALUATE THE SERIES EXPANSIONS (19) AND (21) IN BELOUSOV (1962)
C        FINAL RESULTS ARE STORED IN WORK ARRAYS COL1 AND COL2
C
C        COS2P = SQRT(CSJ(LAT))
         COS2P = COS(RLAT)
         SNJ   = SIN(RLAT)
         THTA  = PI/2.0 - RLAT
         CN2N1N(1,1)  = SQRT(0.50)
         ALP(1,NL)  = CN2N1N(1,1)
         DALP(1,NL) = 0.0
C
C        INITIALIZE WORKING SPACE
C
         DO 205 N=1,KK
            SNPSUM(N) = 0.0
            CSPSUM(N) = 0.0
            SQNP(N)   = 1.0/SQRT(REAL(N*N + N))
            CSFAC(N)  = 1.0
            SNFAC(N)  = REAL(N)*SQNP(N)
            COSTBL(N) = COS(REAL(N)*THTA)
            SINTBL(N) = SIN(REAL(N)*THTA)
  205    CONTINUE
C
C        EACH INCREMENT IN JK EVALUATES AN ADDITIONAL TERM IN EXPANSIONS
C
         JK=1
         DO 215 N=1,KK
            CSPSUM(N) = CSPSUM(N)+COSTBL(N-JK+1)*CSFAC(N)
            SNPSUM(N) = SNPSUM(N)+SINTBL(N-JK+1)*SNFAC(N)
  215    CONTINUE
C
         DO 225 JK=3,KK+1,2
C
            NSTART = MAX0(JK-1,1)
            N = NSTART
            CSFAC(N)  = REAL(JK-2)/REAL(JK-1)*REAL(2*N-JK+3)
     $                  /REAL(2*N-JK+2)*CSFAC(N)
            CSPSUM(N) = CSPSUM(N) + CSFAC(N)*0.50
C
            DO 220 N=NSTART+1,KK
               CSFAC(N)  = REAL(JK-2)/REAL(JK-1)*REAL(2*N-JK+3)
     $                     /REAL(2*N-JK+2)*CSFAC(N)
               SNFAC(N)  = CSFAC(N)*REAL(N-JK+1)*SQNP(N)
               CSPSUM(N) = CSPSUM(N)+COSTBL(N-JK+1)*CSFAC(N)
               SNPSUM(N) = SNPSUM(N)+SINTBL(N-JK+1)*SNFAC(N)
  220       CONTINUE
  225    CONTINUE
C
         RNORM = 1.0/ALP(1,NL)
         DO 230 N=1,KK
            COL1(N) = AN(N)*CSPSUM(N)*RNORM
            COL2(N) = AN(N)*SNPSUM(N)*RNORM
  230    CONTINUE
C
         DO 260 N=1,KK
C
C        EVALUATE REMAINING POLYNOMIALS BY SWEEPING THROUGH ROWS N=1:KK
C        FIRST TWO ELEMENTS OBTAINED FROM THE ABOVE SERIES EXPANSIONS
C
            CN2N1N(1,3) = COL1(N)
            CN2N1N(2,3) = COL2(N)
C
C           NECESSARY DETOUR TO "PRIME THE PIPELINE" (FIRST PASS)
C
            IF (N .EQ. 1) THEN
               CN2N1N(1,2)   = CN2N1N(1,3)
               CN2N1N(2,2)   = CN2N1N(2,3)
               ALP(MM+2,NL)  = CN2N1N(1,2)
               DALP(MM+2,NL) = SQRT(3.0)*CN2N1N(1,1)
     $                           - SNJ*CN2N1N(1,2)
               ALP(2,NL)     = CN2N1N(2,2)
               DALP(2,NL)    = -SNJ*CN2N1N(2,2)
            ELSE
C
C           EVALUATE THE REMAINDER OF THIS ROW (M = 2, 3, 4, ...)
C           USING BELOUSOV'S RECURRENCE RELATION
C
            MLIM = MIN0(MM,N-1)
            DO 235 M=2,MLIM
               JM = M+1
               CN2N1N(JM,3) = CMN(IDSPR(M,N))*CN2N1N(JM-2,1)
     $                        -SNJ*(DMN(IDSPR(M,N))
     $                        *CN2N1N(JM-2,2) - EMN(IDSPR(M,N))
     $                        *CN2N1N(JM,2))
  235       CONTINUE
C
C           PUT VALUES OF THE POLYNOMIALS CONTAINED IN CN2N1N(0:MLIM,3)
C           INTO THE ASSOCIATED LEGENDRE POLYNOMIAL ARRAY ALP
C
            MSTART = MAX0(N-NN,0)
            DO 240 M=MSTART,MLIM
               JM = M+1
               ALP(IDSP(M,N),NL) = CN2N1N(JM,3)
  240       CONTINUE
C
C           SPECIAL EVALUATION REQUIRED FOR DIAGONAL ELEMENT M=N
C
            IF (N .LE. MM) THEN
               CN2N1N(N+1,3)      = SQRT(1.0 + (1.0/REAL(2*N)))*COS2P
     $                                *CN2N1N(N,2)
               ALP(IDSP(N,N),NL)  = CN2N1N(N+1,3)
               DALP(IDSP(N,N),NL) = -REAL(N)*SNJ*CN2N1N(N+1,3)
            ENDIF
C
C           MAKE ROOM FOR NEW POLYNOMIAL EVALUATION IN CN2N1N(0:MLIM,3)
C
            DO 250 JM=1,N+1
               CN2N1N(JM,1) = CN2N1N(JM,2)
               CN2N1N(JM,2) = CN2N1N(JM,3)
  250       CONTINUE
C
            ENDIF
C
  260    CONTINUE
C
C        EFFICIENTLY EVALUATE DERIVATIVES SEPARATELY (ALONG DIAGONALS)
C
         DO 280 JN = 1,NN
            IS   = LDIAG(JN,2)
            ISM1 = LDIAG(JN-1,2)
            DO 270 M=0,LDIAG(JN,1)-1
               JM = M+1
               N  = JN+M
               DALP(IS+JM,NL) = REAL(2*N+1)*EPSIL(IS+JM)*
     $                     ALP(ISM1+JM,NL)-REAL(N)*SNJ*ALP(IS+JM,NL)
  270       CONTINUE
  280    CONTINUE
C
  290 CONTINUE
C
      RETURN
      END


      FUNCTION rc(x,y)
      REAL rc,x,y,ERRTOL,TINY,SQRTNY,BIG,TNBG,COMP1,COMP2,THIRD,C1,C2,
     *C3,C4
      PARAMETER (ERRTOL=.04,TINY=1.69e-38,SQRTNY=1.3e-19,BIG=3.E37,
     *TNBG=TINY*BIG,COMP1=2.236/SQRTNY,COMP2=TNBG*TNBG/25.,THIRD=1./3.,
     *C1=.3,C2=1./7.,C3=.375,C4=9./22.)
      REAL alamb,ave,s,w,xt,yt
      if(x.lt.0..or.y.eq.0..or.(x+abs(y)).lt.TINY.or.(x+
     *abs(y)).gt.BIG.or.(y.lt.-COMP1.and.x.gt.0..and.x.lt.COMP2))pause
     *'invalid arguments in rc'
      if(y.gt.0.)then
        xt=x
        yt=y
        w=1.
      else
        xt=x-y
        yt=-y
        w=sqrt(x)/sqrt(xt)
      endif
1     continue
        alamb=2.*sqrt(xt)*sqrt(yt)+yt
        xt=.25*(xt+alamb)
        yt=.25*(yt+alamb)
        ave=THIRD*(xt+yt+yt)
        s=(yt-ave)/ave
      if(abs(s).gt.ERRTOL)goto 1
      rc=w*(1.+s*s*(C1+s*(C2+s*(C3+s*C4))))/sqrt(ave)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rc.for


      SUBROUTINE PELGEV(XMOM,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  PARAMETER ESTIMATION VIA L-MOMENTS FOR THE GENERALIZED EXTREME-VALUE
C  DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2, TAU-3.
C  PARA   *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER XI, ALPHA, K (LOCATION, SCALE, SHAPE).
C
C  OTHER ROUTINES USED: DLGAMA
C
C  METHOD: FOR  -0.8 LE TAU3 LT 1,  K IS APPROXIMATED BY RATIONAL
C  FUNCTIONS AS IN DONALDSON (1996, COMMUN. STATIST. SIMUL. COMPUT.).
C  IF TAU3 IS OUTSIDE THIS RANGE, NEWTON-RAPHSON ITERATION IS USED.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(3),PARA(3)
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/
      DATA P8/0.8D0/,P97/0.97D0/
C
C         SMALL IS USED TO TEST WHETHER K IS EFFECTIVELY ZERO
C         EPS,MAXIT CONTROL THE TEST FOR CONVERGENCE OF N-R ITERATION
C
      DATA SMALL/1D-5/,EPS/1D-6/,MAXIT/20/
C
C         EU IS EULER'S CONSTANT
C         DL2 IS LOG(2), DL3 IS LOG(3)
C
      DATA EU/0.57721566D0/,DL2/0.69314718D0/,DL3/1.0986123D0/
C
C         COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATIONS FOR K
C
      DATA A0,A1,A2/ 0.28377530D0,-1.21096399D0,-2.50728214D0/
      DATA A3,A4   /-1.13455566D0,-0.07138022D0/
      DATA B1,B2,B3/ 2.06189696D0, 1.31912239D0, 0.25077104D0/
      DATA C1,C2,C3/ 1.59921491D0,-0.48832213D0, 0.01573152D0/
      DATA D1,D2   /-0.64363929D0, 0.08985247D0/
C
      T3=XMOM(3)
      IF(XMOM(2).LE.ZERO)GOTO 1000
      IF(DABS(T3).GE.ONE)GOTO 1000
      IF(T3.LE.ZERO)GOTO 10
C
C         RATIONAL-FUNCTION APPROXIMATION FOR TAU3 BETWEEN 0 AND 1
C
      Z=ONE-T3
      G=(-ONE+Z*(C1+Z*(C2+Z*C3)))/(ONE+Z*(D1+Z*D2))
      IF(DABS(G).LT.SMALL)GOTO 50
      GOTO 40
C
C         RATIONAL-FUNCTION APPROXIMATION FOR TAU3 BETWEEN -0.8 AND 0
C
   10 G=(A0+T3*(A1+T3*(A2+T3*(A3+T3*A4))))/(ONE+T3*(B1+T3*(B2+T3*B3)))
      IF(T3.GE.-P8)GOTO 40
C
C         NEWTON-RAPHSON ITERATION FOR TAU3 LESS THAN -0.8
C
      IF(T3.LE.-P97)G=ONE-DLOG(ONE+T3)/DL2
      T0=(T3+THREE)*HALF
      DO 20 IT=1,MAXIT
      X2=TWO**(-G)
      X3=THREE**(-G)
      XX2=ONE-X2
      XX3=ONE-X3
      T=XX3/XX2
      DERIV=(XX2*X3*DL3-XX3*X2*DL2)/(XX2*XX2)
      GOLD=G
      G=G-(T-T0)/DERIV
      IF(DABS(G-GOLD).LE.EPS*G)GOTO 30
   20 CONTINUE
      WRITE(6,7010)
   30 CONTINUE
C
C         ESTIMATE ALPHA,XI
C
   40 PARA(3)=G
      GAM=DEXP(DLGAMA(ONE+G))
      PARA(2)=XMOM(2)*G/(GAM*(ONE-TWO**(-G)))
      PARA(1)=XMOM(1)-PARA(2)*(ONE-GAM)/G
      RETURN
C
C         ESTIMATED K EFFECTIVELY ZERO
C
   50 PARA(3)=ZERO
      PARA(2)=XMOM(2)/DL2
      PARA(1)=XMOM(1)-EU*PARA(2)
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE PELGEV : L-MOMENTS INVALID')
 7010 FORMAT(' ** WARNING ** ROUTINE PELGEV :',
     *  ' ITERATION HAS NOT CONVERGED. RESULTS MAY BE UNRELIABLE.')
      END


program ho_wf
        use numerical_integration
        implicit none
        integer, parameter :: nmax = 10, num_pts = 101 ! Number of H.O. basis functions
        integer :: m, n, i, j
        real(kind=dp), parameter :: pi_4_root = sqrt(sqrt(pi))
        real(kind=dp) :: x_min, x_max, dx, x_pts(num_pts)
        real(kind=dp), dimension(0:nmax-1, 0:nmax-1) :: inner_prod, pot_e, kin_e, ham
        real(kind=dp), dimension(num_pts, 0:nmax-1) :: wf, wf_deriv2

        x_min = -10.0d0; x_max = 10.0d0
        dx = (x_max-x_min)/(num_pts-1)
        x_pts = [ (x_min+i*dx, i=0, num_pts-1) ]

        call gen_wf(x_pts, num_pts, nmax, wf, wf_deriv2)

        ! Calculate second derivative

        ! Print Wavefunctions upto order N
        open(unit=50, file='howf_data.txt')
        do i=1,num_pts
           write(50, *) x_pts(i), wf(i, :)
        end do
        close(50)

        ! Calculate orthogonality
        do i=0,nmax-1
           do j=0,nmax-1
                inner_prod(i,j) = simpson(x_pts, wf(:,i)*wf(:,j), num_pts)
                pot_e(i, j) = simpson(x_pts, wf(:,i)*wf(:,j)*pot_func(x_pts,num_pts), num_pts)
                kin_e(i,j) = simpson(x_pts, -wf(:,i)*wf_deriv2(:,j), num_pts)
           end do
        end do

        ham = kin_e + pot_e

        open(unit=50, file='ortho_data.txt')
        open(unit=51, file='pot_e_data.txt')
        open(unit=52, file='kin_e_data.txt')
        open(unit=53, file='ham_data.txt')
        do i=0,nmax-1
                write(50,*) inner_prod(i,:)
                write(51,*) pot_e(i,:)
                write(52,*) kin_e(i,:)
                write(53,*) ham(i,:)
        end do
        close(50)
        close(51)
        close(52)
        close(53)
contains
        function pot_func(x, n)
                integer, intent(in) :: n
                real(kind=dp) :: pot_func(n)
                real(kind=dp), intent(in) :: x(n)

                pot_func = x**2
        end function pot_func

        subroutine gen_wf(x_pts, num_pts, max_order, wf, wf_deriv2)
          ! Generates harmonic oscillator wavefunctions upto order max_order
          ! Wavefunction order starts from 0
                implicit none
                integer, intent(in) :: max_order, num_pts
                real(kind=dp), intent(in) :: x_pts(num_pts)
                real(kind=dp), intent(inout), dimension(num_pts, 0:max_order-1) :: wf, wf_deriv2
                integer :: i, j, k

                wf(:,0) = exp(-0.5d0*x_pts**2)/pi_4_root
                wf_deriv2(:,0) = (x_pts**2 - 1)*wf(:,0)
                if (nmax > 1) then
                        wf(:,1) = sqrt(2.0d0)*x_pts*wf(:,0)
                        wf_deriv2(:,1) = (x_pts**2 - 1)*wf(:,1) - sqrt(8.0d0)*x_pts*wf(:,0)
                        do i=2, max_order-1
                           wf(:,i) = sqrt(2.0d0/i)*x_pts*wf(:,i-1) - sqrt(float(i-1)/i)*wf(:,i-2)
                           wf_deriv2(:,i) = 2*sqrt(float(i*(i-1)))*wf(:,i-2) - sqrt(8.0d0*i)*x_pts*wf(:,i-1) &
                                + (x_pts**2 - 1)*wf(:,i)
                        end do
                end if

        end subroutine gen_wf

end program ho_wf


!##############################################################################
! MODULE Globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module Globals

    implicit none

    ! time preference
    real*8 :: beta

    ! risk aversion
    real*8 :: eta

end module

!##############################################################################
! MODULE UtilFunc
!##############################################################################
module UtilFunc

    implicit none

contains

    ! a utility function
    function utility(c1, c2)

        use Globals

        implicit none
        real*8, intent(in) :: c1, c2
        real*8 :: utility

        utility = 1d0/(1d0-eta)*c1**(1d0-eta) + beta/(1d0-eta)*c2**(1d0-eta)

    end function

end module


       SUBROUTINE LPMNS(M,N,X,PM,PD)
c**************************************************************
C
C       ========================================================
C       Purpose: Compute associated Legendre functions Pmn(x)
C                and Pmn'(x) for a given order
C       Input :  x --- Argument of Pmn(x)
C                m --- Order of Pmn(x),  m = 0,1,2,...,n
C                n --- Degree of Pmn(x), n = 0,1,2,...,N
C       Output:  PM(n) --- Pmn(x)
C                PD(n) --- Pmn'(x)
C       ========================================================
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION PM(0:N),PD(0:N)
        DO 10 K=0,N
           PM(K)=0.0D0
10         PD(K)=0.0D0
        IF (DABS(X).EQ.1.0D0) THEN
           DO 15 K=0,N
              IF (M.EQ.0) THEN
                 PM(K)=1.0D0
                 PD(K)=0.5D0*K*(K+1.0)
                 IF (X.LT.0.0) THEN
                    PM(K)=(-1)**K*PM(K)
                    PD(K)=(-1)**(K+1)*PD(K)
                 ENDIF
              ELSE IF (M.EQ.1) THEN
                 PD(K)=1.0D+300
              ELSE IF (M.EQ.2) THEN
                 PD(K)=-0.25D0*(K+2.0)*(K+1.0)*K*(K-1.0)
                 IF (X.LT.0.0) PD(K)=(-1)**(K+1)*PD(K)
              ENDIF
15         CONTINUE
           RETURN
        ENDIF
        X0=DABS(1.0D0-X*X)
        PM0=1.0D0
        PMK=PM0
        DO 20 K=1,M
           PMK=(2.0D0*K-1.0D0)*DSQRT(X0)*PM0
20         PM0=PMK
        PM1=(2.0D0*M+1.0D0)*X*PM0
        PM(M)=PMK
        PM(M+1)=PM1
        DO 25 K=M+2,N
           PM2=((2.0D0*K-1.0D0)*X*PM1-(K+M-1.0D0)*PMK)/(K-M)
           PM(K)=PM2
           PMK=PM1
25         PM1=PM2
        PD(0)=((1.0D0-M)*PM(1)-X*PM(0))/(X*X-1.0)
        DO 30 K=1,N
30          PD(K)=(K*X*PM(K)-(K+M)*PM(K-1))/(X*X-1.0D0)
        RETURN
        END


c
c-----------------------------------------------------------------------
c main program: test program to exercise the wfta subroutine
c   the test waveform is a complex exponential a**i whose
c   transform is known analytically to be (1 - a**n)/(1 - a*w**k).
c
c authors:
c   james h. mcclellan     and     hamid nawab
c   department of electrical engineering and computer science
c   massachusetts of technology
c   cambridge, mass.  02139
c
c inputs:
c   n-- transform length. it must be formed as the product of
c       relatively prime integers from the set:
c           2,3,4,5,7,8,9,16
c   invrs is the flag for forward or inverse transform.
c           invrs = 1 yields inverse transform
c           invrs .ne. 1 gives forward transform
c   rad and phi are the magnitude and angle (as a fraction of
c       2*pi/n) of the complex exponential test signal.
c          suggestion: rad = 0.98, phi = 0.5.
c-----------------------------------------------------------------------
c
      double precision pi2,pin,xn,xj,xt
      dimension xr(1260),xi(1260)
      complex cone,ca,can,cnum,cden
c
c   output will be punched
c
      iout=i1mach(3)
      input=i1mach(1)
      cone=cmplx(1.0,0.0)
      pi2=8.0d0*datan(1.0d0)
50    continue
      read(input,130)n
130   format(i5)
      write(iout,150) n
150   format(10h length = ,i5)
      if(n.le.0 .or. n.gt.1260) stop
c
c   enter a 1 to perform the inverse
c
c     read(input,130) invrs
      invrs = 0
c
c   enter magnitude and angle (in fraction of 2*pi/n)
c   avoid multiples of n for the angle if the radius is
c   close to one.  suggestion: rad = 0.98, phi = 0.5.
c
c     read(input,160) rad,phi
      rad = 0.98
      phi = 0.5
160   format(2f15.10)
      xn=float(n)
      pin=phi
      pin=pin*pi2/xn
c
c   generate z**j
c
      init=0
      do 200 j=1,n
      an=rad**(j-1)
      xj=j-1
      xj=xj*pin
      xt=dcos(xj)
      xr(j)=xt
      xr(j)=xr(j)*an
      xt=dsin(xj)
      xi(j)=xt
      xi(j)=xi(j)*an
200   continue
      can=cmplx(xr(n),xi(n))
      ca=cmplx(xr(2),xi(2))
      can=can*ca
c
c   print first 50 values of input sequence
c
      max=50
      if(n.lt.50)max=n
      write(iout,300)(j,xr(j),xi(j),j=1,max)
c
c   call the winograd fourier transform algorithm
c
      call wfta(xr,xi,n,invrs,init,ierr)
c
c   check for error return
c
      if(ierr.lt.0) write(iout,250) ierr
250   format(1x,5herror,i5)
      if(ierr.lt.0) go to 50
c
c   print first 50 values of the transformed sequence
c
      write(iout,300)(j,xr(j),xi(j),j=1,max)
300   format(1x,3hj =,i3,6hreal =,e20.12,6himag =,e20.12)
c
c   calculate absolute and relative deviations
c
      devabs=0.0
      devrel=0.0
      cnum=cone-can
      pin=pi2/xn
      do 350 j=1,n
      xj=j-1
      xj=-xj*pin
      if(invrs.eq.1) xj=-xj
      tr=dcos(xj)
      ti=dsin(xj)
      can=cmplx(tr,ti)
      cden=cone-ca*can
      cden=cnum/cden
c
c   true value of the transform (1. - a**n)/(1. - a*w**k),
c   where a = rad*exp(j*phi*(2*pi/n)), w = exp(-j*2*pi/n).
c   for the inverse transform the complex exponential w
c   is conjugated.
c
      tr=real(cden)
      ti=aimag(cden)
      if(invrs.ne.1) go to 330
c
c   scale inverse transform by 1/n
c
      tr=tr/float(n)
      ti=ti/float(n)
330   tr=xr(j)-tr
      ti=xi(j)-ti
      devabs=sqrt(tr*tr+ti*ti)
      xmag=sqrt(xr(j)*xr(j)+xi(j)*xi(j))
      devrel=100.0*devabs/xmag
      if(devabs.le.devmx1)go to 340
      devmx1=devabs
      labs=j-1
340   if(devrel.le.devmx2)go to 350
      devmx2=devrel
      lrel=j-1
350   continue
c
c   print the absolute and relative deviations together
c   with their locations.
c
      write(iout,380) devabs,labs,devrel,lrel
380   format(1x,21habsolute deviation = ,e20.12,9h at index,i5/
     1 1x,21hrelative deviation = ,f11.7,8h percent,1x,9h at index,i5)
      go to 50
      end


program test_program
   implicit none

   integer :: i, j
   integer, dimension(5,3) :: M
   integer, dimension(3,3) :: A, B

   do i = 1, 5
      do j = 1, 3
         M(i,j) = i+j
      end do
   end do
   write(*,*) "nrows", size(M,1)
   write(*,*) "ncols", size(M,2)
   do i = 1, size(M,1)
      write(*,*) (M(i,j), j = 1, size(M,2))
   end do
   write(*,*)

   A = (reshape((/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), shape(A)))
   do i = 1,size(A,1)
      write(*,*) (A(i,j), j = 1, size(A,2))
   end do
   write(*,*)

   B = transpose(reshape((/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /), shape(B)))
   do i = 1, size(B,1)
      write(*,*) (B(i,j), j = 1, size(B,2))
   end do
end program test_program


c     program DRSBLAS1
c>> 1996-06-18 DRSBLAS1 Krogh  Minor format change for C conversion.
c>> 1996-05-28 DRSBLAS1 Krogh Added external statement.
c>> 1994-10-19 DRSBLAS1 Krogh  Changes to use M77CON
c>> 1992-03-24 DRSBLAS1 CLL Removed reference to REAL() function.
c>> 1991-12-02 DRSBLAS1 CLL
c>> 1991-07-25 DRSBLAS1 CLL
c>> 1987-12-09 DRBLAS1  Lawson  Initial Code.
c
c     Demonstrate usage of SAXPY, SCOPY, and SDOT from the BLAS
c     by computing
c     (1) p = A * b              using SDOT
c     (2) q = A * b              using SCOPY & SAXPY
c     (3) r = (A Transposed) * p using SDOT
c     (4) S = A * E              using SDOT
c     ------------------------------------------------------------------
c--S replaces "?": DR?BLAS1, ?AXPY, ?COPY, ?DOT
c     ------------------------------------------------------------------
      external SDOT
      real             SDOT
      integer M2, M3, M4, N2, N3, N4
      parameter ( M2=5, M3=10, M4=12 )
      parameter ( N2=2, N3=3, N4=4 )
      integer I, J
      real             A(M2,M3), E(M3,M4), S(M2,M4)
      real             B(M3), P(M2), Q(M2), R(M3)
      real             ZERO(1)
c
      data ZERO(1) / 0.0e0 /
      data (A(1,J),J=1,N3) /  2.0e0, -4.0e0, 3.0e0 /
      data (A(2,J),J=1,N3) / -5.0e0, -2.0e0, 6.0e0 /
      data (B(J),J=1,N3)   /  7.0e0, -3.0e0, 5.0e0 /
      data (E(1,J),J=1,N4) / -4.0e0, 2.0e0,  3.0e0, -6.0e0 /
      data (E(2,J),J=1,N4) /  7.0e0, 5.0e0, -6.0e0, -3.0e0 /
      data (E(3,J),J=1,N4) /  3.0e0, 4.0e0, -2.0e0,  5.0e0 /
c     ---------------------------------------------------------------
c
c                                  1. p = A * b using SDOT
c
      do 10 I = 1, N2
        P(I) = SDOT(N3,A(I,1),M2,B,1)
   10 continue
c
c                                  2. q = A * b using SCOPY and SAXPY
c
      call SCOPY(N2,ZERO,0,Q,1)
      do 20 J = 1, N3
        call SAXPY(N2,B(J),A(1,J),1,Q,1)
   20 continue
c
c                                  3. r = (A Transposed) * p using SDOT
c
      do 30 J = 1, N3
        R(J) = SDOT(N2,A(1,J),1,P,1)
   30 continue
c
c                                  4. S = A * E using SDOT
c
      do 50 I = 1, N2
        do 40 J = 1, N4
          S(I,J) = SDOT(N3,A(I,1),M2,E(1,J),1)
   40   continue
   50 continue
c
      print*,'DRSBLAS1..  Demo driver for SAXPY, SCOPY, and SDOT'
      print'(/'' P() = '', 7x,4f8.1)', (P(J),J=1,N2)
      print'(/'' Q() = '',7x,4f8.1)', (Q(J),J=1,N2)
      print'(/'' R() = '',7x,4f8.1)', (R(J),J=1,N3)
      print'(/'' S(,) = '')'
      do 60 I = 1,N2
         print'(''   Row '',i2,5x,4f8.1)', I,(S(I,J),J=1,N4)
   60 continue
      stop
      end


c FILE: fplfit.f
      subroutine plfit(x,nosmall,ksa,av,lx)
c     internal section of plfit
c      requires that x be sorted!
      integer lx,nosmall
      real*8 x(lx)
      real*8 ksa(lx)
      real*8 av(lx)
cf2py intent(in) :: x, nosmall
cf2py intent(hide) :: lx
cf2py intent(out) :: av,ksa
      integer j,n,k,nk
      real*8 lzs,cx,cf,ks,ksp,xmin
      xmin = 0.0
c     write(*,*) "Starting length ",lx," run"
c     equivalent to python loop: i in arange(1,lx)
      do 100 i=1,lx
            if ( x(i) .lt. xmin ) write(*,*) "WARNING X WAS NOT SORTED!"
c           skip repeat values (only compute unique values of xmin)
            if ( x(i) .eq. xmin ) then
                ksa(i)=0
                av(i)=0
                goto 100
            endif
            xmin = x(i)

c           a = 1 + float(n) / sum(log(x/xmin))
c           lzs = sum(log(x/xmin))
            lzs = 0.0
            do 200 j=i,lx
                lzs = lzs + log(x(j)/xmin)
200         continue
            n = j - i
            av(i) = 1.0 + float(n) / (lzs)

            if (nosmall.gt.0) then
                if ((av(i)-1.0)/sqrt(float(n+1)) .ge. 0.1) then
c                   write(*,*) "Exiting nosmall - n=",n
c           write(*,*) "Debug: lx=",lx,"n=",n,"ijk=",i,j,k,av(i),ksa(i)
                  return
                endif
            endif

c           ks = max(abs(cf-cx))
            ksp = 0
c           if (mod(i,100).eq.0) write(*,*) "i=",i," a=",a,"n=",
c    &       n,"lzs=",lzs
            nk = lx - i
c           nk = number of points between xmin and the largest value
c           k = the index of xmin + k
            do 300 k=0,nk
                cx = float(k) / float(nk+1)
                cf = 1.0 - ( (xmin/x(k+i))**(av(i)-1) )
                ks = abs(cf-cx)
                if (ks.gt.ksp)  ksp = ks
300         continue
c           write(*,*) "k=",k,"n=",n,"i=",i,"nk=",nk,"j=",j,"cx=",cx
            ksa(i) = ksp
100   continue
c     write(*,*) "Debug: lx=",lx,"n=",n,"ijk=",i,j,k,av(i),ksa(i)
      return
      END
c END FILE fplfit.f


program random_integers
    implicit none
    integer :: nr_values, lower, upper, i

    call get_values(nr_values, lower, upper)
    do i = 1, nr_values
        print '(I0)', random_integer(lower, upper)
    end do

contains

    !> @brief copmute a random number in a given range
    !>
    !> The function returns a random integer value between a given lower and
    !> upper limits, inclusively.
    !>
    !> @param[in] lower lower value for the random value
    !> @param[in] upper upper value for the random value
    !> @returns integer value
    function random_integer(lower, upper) result(rand_int)
        implicit none
        integer, value :: lower, upper
        integer :: rand_int
        real :: rand_real

        call random_number(rand_real)
        rand_int = lower + floor(rand_real*(upper - lower + 1))
    end function random_integer

    subroutine get_values(nr_values, lower, upper)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer, intent(out) :: nr_values, lower, upper

        if (command_argument_count() /= 3) then
            write (unit=error_unit, fmt='(A)') &
                'error: argument nr_values lower upper expected'
            stop 1
        end if
        nr_values = get_integer(1)
        lower = get_integer(2)
        upper = get_integer(3)
        if (lower > upper) then
            write (unit=error_unit, fmt='(A)') &
                'error: upper should be larger or equal to lower'
            stop 3
        end if
    end subroutine get_values

    function get_integer(i) result(value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer, value :: i
        integer :: value
        character(len=32) :: buffer
        integer :: istat
        character(len=1024) :: msg

        call get_command_argument(i, buffer)
        read (buffer, fmt=*, iostat=istat, iomsg=msg) value
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'error: ', msg
            stop 2
        end if
    end function get_integer

end program random_integers


      PROGRAM vec2los
C----
C Take three-dimensional N-E-Z displacements and compute line-of-sight
C displacements given the azimuth (from north) and inclination (from
C horizontal) of the view
C----
      IMPLICIT NONE
      REAL*8 pi,d2r
      PARAMETER (pi=4.0d0*atan(1.0d0),d2r=pi/180.0d0)
      REAL*8 uLOS,stlo,stla,stdp,uN,uE,uZ
      REAL*8 az,incl,cosaz,cosinc,sinaz,sininc
      CHARACTER*40 ifile,ofile
      LOGICAL ex

C----
C Parse command line
C----
      call gcmdln(az,incl,ifile,ofile)
      if (az.lt.-1000.0d0.or.incl.lt.-1000.0d0) then
          write(*,*) '!! Error: azimuth or inclination are undefined'
          call usage('!! Use -a AZ or -i INCL')
      endif
      if (ifile.eq.'none') then
          write(*,*) '!! Error: Input displacement vector file ',
     1               'unspecified'
          call usage('!! Use -f IFILE to specify input file')
      else
          inquire(file=ifile,EXIST=ex)
          if (.not.ex) call usage('!! Error: no input file: '//ifile)
      endif
      if (ofile.eq.'none') then
          write(*,*) '!! Error: No output file specified'
          call usage('!! Use -o OFILE to specify LOS output file')
      endif
      cosaz = dcos(az*d2r)
      sinaz = dsin(az*d2r)
      cosinc = dcos(incl*d2r)
      sininc = dsin(incl*d2r)
      !print *,'AZ',az
      !print *,'INCL',incl
      !print *,'IFILE ',ifile
      !print *,'OFILE ',ofile

C----
C Control files
C----
      open (unit=11,file=ifile,status='old')
      open (unit=12,file=ofile,status='unknown')

C----
C Convert NEZ to LOS
C----
   11 read (11,*,end=12) stlo,stla,stdp,uE,uN,uZ
          uLOS = uN*cosaz*cosinc
     1             + uE*sinaz*cosinc
     2                 - uZ*sininc
          write (12,9991) stlo,stla,stdp,uLOS
          goto 11
   12 continue

 9991 format(3F12.4,X,3E12.4)

      END

C======================================================================C

      SUBROUTINE gcmdln(az,incl,ifile,ofile)
      IMPLICIT none
      REAL*8 az,incl
      CHARACTER*40 tag,ifile,ofile
      INTEGER i,narg
      az = -99999.0d0
      incl = -99999.0d0
      ifile = 'none'
      ofile = 'none'
      narg = iargc()
      if (narg.eq.0) then
          call usage('!! Error: no command line arguments specified')
      endif
      i = 0
   11 i = i + 1
      if (i.gt.narg) goto 12
          call getarg(i,tag)
          if (tag(1:2).eq.'-a') then
              i = i + 1
              call getarg(i,tag)
              read (tag,'(BN,F12.0)') az
          elseif (tag(1:2).eq.'-i') then
              i = i + 1
              call getarg(i,tag)
              read (tag,'(BN,F12.0)') incl
          elseif (tag(1:2).eq.'-f') then
              i = i + 1
              call getarg(i,ifile)
          elseif (tag(1:2).eq.'-o') then
              i = i + 1
              call getarg(i,ofile)
          elseif (tag(1:2).eq.'-h') then
              call usage(' ')
          endif
          goto 11
   12 continue
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE usage(str)
      IMPLICIT none
      INTEGER lstr
      CHARACTER str*(*)
      if (str.ne.' ') then
          lstr = len(str)
          write(*,*) str(1:lstr)
          write(*,*)
      endif
      write(*,*)
     1 'Usage: vec2los -a AZ -i INC -f IFILE -o OFILE [-h]'
      write(*,*)
      write(*,*)
     1 '-a AZ     Look azimuth (CW from N)'
      write(*,*)
     1 '-i INC    Look inclination (from horizontal)'
      write(*,*)
     1 '-f IFILE  Input vector displacement file (stlo stla stdp uE ',
     2                                                'uN uZ)'
      write(*,*)
     1 '-o OFILE  Output LOS displacement file (stlo stla stdp uLOS)'
      write (*,*)
     1 '-h        Online help (this message)'
      write (*,*)
      STOP
      END


      real function backtr(vrgs,nt,vr,vrg,zmin,zmax,ltail,ltpar,
     +                     utail,utpar)
c-----------------------------------------------------------------------
c
c           Back Transform Univariate Data from Normal Scores
c           *************************************************
c
c This subroutine backtransforms a standard normal deviate from a
c specified back transform table and option for the tails of the
c distribution.  Call once with "first" set to true then set to false
c unless one of the options for the tail changes.
c
c
c
c INPUT VARIABLES:
c
c   vrgs             normal score value to be back transformed
c   nt               number of values in the back transform tbale
c   vr(nt)           original data values that were transformed
c   vrg(nt)          the corresponding transformed values
c   zmin,zmax        limits possibly used for linear or power model
c   ltail            option to handle values less than vrg(1):
c   ltpar            parameter required for option ltail
c   utail            option to handle values greater than vrg(nt):
c   utpar            parameter required for option utail
c
c
c
c-----------------------------------------------------------------------

      implicit integer (i-n)
      implicit double precision (a-h,o-z)

      parameter(EPSLON=1.0e-20)
      dimension vr(nt),vrg(nt)
      real*8      ltpar,utpar,lambda
      integer   ltail,utail
c
c Value in the lower tail?    1=linear, 2=power, (3 and 4 are invalid):
c
      if(vrgs.le.vrg(1)) then
            backtr = vr(1)
            cdflo  = gcum(vrg(1))
            cdfbt  = gcum(vrgs)
            if(ltail.eq.1) then
                  backtr = powint(0.d0,cdflo,zmin,vr(1),cdfbt,1.0)
            else if(ltail.eq.2) then
                  cpow   = 1.0 / ltpar
                  backtr = powint(0.d0,cdflo,zmin,vr(1),cdfbt,cpow)
            endif
c
c Value in the upper tail?     1=linear, 2=power, 4=hyperbolic:
c
      else if(vrgs.ge.vrg(nt)) then
            backtr = vr(nt)
            cdfhi  = gcum(vrg(nt))
            cdfbt  = gcum(vrgs)
            if(utail.eq.1) then
                  backtr = powint(cdfhi,1.0,vr(nt),zmax,cdfbt,1.0)
            else if(utail.eq.2) then
                  cpow   = 1.0 / utpar
                  backtr = powint(cdfhi,1.0,vr(nt),zmax,cdfbt,cpow)
            else if(utail.eq.4) then
                  lambda = (vr(nt)**utpar)*(1.0-gcum(vrg(nt)))
                  backtr = (lambda/(1.0-gcum(vrgs)))**(1.0/utpar)
            endif
      else
c
c Value within the transformation table:
c
            call locate(vrg,nt,1,nt,vrgs,j)
            j = max(min((nt-1),j),1)
            backtr = powint(vrg(j),vrg(j+1),vr(j),vr(j+1),vrgs,1.0)
      endif
      return
      end


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

MODULE NUCLEAR

    USE FACT
    USE CONSTANTS
    USE GAUSSIAN

    IMPLICIT NONE

    !REAL*8 :: xx
    !INTEGER :: nunu

    CONTAINS
        FUNCTION f(j,l,m,a,b)
            !----------------------------------------
            ! Expansion coefficient.
            !----------------------------------------
            !
            ! Source:
            !     Handbook of Computational Chemistry
            !     David Cook
            !     Oxford University Press
            !     1998
            !
            !----------------------------------------

            ! INPUT
            INTEGER, intent(in) :: j, l, m
            REAL*8, intent(in) :: a, b

            ! INTERMEDIATE VARIABLES
            INTEGER :: k    ! Loop index
            REAl*8 :: tmp   ! Temporary product

            ! OUTPUT
            REAL*8 :: f

            f = 0.0D0

            DO k = MAX(0,j-m), MIN(j,l)
                tmp = 1.0D0
                tmp = tmp * binom(l,k) * binom(m,j-k)
                tmp = tmp * a**(l-k) * b**(m+k-j)

                f = f + tmp
            END DO

        END FUNCTION f

        ! -------------
        ! BOYS FUNCTION
        ! -------------
        FUNCTION boys(nu,x)
            ! ------------------------------------------------------------------------
            ! Compute boys function (different strategies for different x)
            ! ------------------------------------------------------------------------
            !
            ! Source:
            !   On the evaluation of Boys functions using downward  recursion relation
            !   B. A. Mamedov
            !   Journal of Mathematical Chemistry
            !   2004
            !
            ! ------------------------------------------------------------------------

            IMPLICIT NONE

            REAL*8, EXTERNAL :: DGAMIT

            ! INPUT
            INTEGER, intent(in) :: nu   ! Boys' index
            REAL*8, intent(in) :: x

            ! INTERMEDIATE VARIABLES
            !REAL*8 :: prod
            !REAL*8 :: sum
            !REAL*8 :: sumold
            !INTEGER :: idx

            ! OUTPUT
            REAL*8 :: boys

            boys = 0.0D0

            IF (x .LE. 1e-6) THEN   ! First order Taylor expansion of the integrand

                boys = 1.0D0 / (2.0D0 * nu + 1.0D0) - x / (2.0D0 * nu + 3.0D0)

            ELSE

                boys = 0.5D0 * DGAMIT(nu + 0.5D0, x) * GAMMA(nu + 0.5D0)

            END IF

        END FUNCTION boys

        FUNCTION A(l,r,i,l1,l2,Ra,Rb,Rc,Rp,eps)
            ! -------------------------------------
            ! Factor A
            ! -------------------------------------
            !
            ! Source:
            !   Handbook of Computational Chemistry
            !   David Cook
            !   Oxford University Press
            !   1998
            !
            !--------------------------------------

            ! INPUT
            INTEGER, intent(in) :: l, r, i , l1, l2
            REAL*8, intent(in) :: Ra, Rb, Rc, Rp, eps

            ! OUTPUT
            REAL*8 :: A

            A = 1.0D0
            A = A * (-1)**(l)
            A = A * f(l,l1,l2,Rp-Ra,Rp-Rb)
            A = A * (-1)**i
            A = A * factorial(l)
            A = A * (Rp-Rc)**(l - 2*r - 2*i)
            A = A * eps**(r+i)
            A = A / factorial(r)
            A = A / factorial(i)
            A = A / factorial(l - 2*r - 2*i)

        END FUNCTION A

        FUNCTION nuclear_coeff(ax,ay,az,bx,by,bz,aa,bb,Ra,Rb,Rn,Zn) result(Vnn)
            ! -------------------------------------------------------------------------
            ! Compute electon-nucleus integral between two Cartesian Gaussian functions
            ! -------------------------------------------------------------------------
            !
            ! Source:
            !   Handbook of Computational Chemistry
            !   David Cook
            !   Oxford University Press
            !   1998
            !
            !--------------------------------------------------------------------------

            ! INPUT
            INTEGER, intent(in) :: ax, ay, az, bx, by, bz   ! Angular momentum coefficients
            REAL*8, intent(in) :: aa, bb                    ! Exponential Gaussian coefficients
            REAL*8, dimension(3), intent(in) :: Ra, Rb      ! Gaussian centers
            REAL*8, dimension(3), intent(in) :: Rn          ! Nuclear position
            INTEGER, intent(in) :: Zn                       ! Nuclear charge

            ! INTERMEDIATE VARIABLES
            REAL*8 :: eps
            REAL*8 :: g                             ! Gaussian produc exponential coefficient
            REAL*8, dimension(3) :: Rp              ! Gaussian produc center
            REAL*8 :: cp                            ! Gaussian product multiplicative constant
            INTEGER :: l, r, i, m, s, j, n, t, k    ! Loop indices
            REAL*8 :: AAx, AAy, AAz                 ! Temporary calls to FUNCTION A
            INTEGER :: nu                           ! Boys function index

            ! OUTPUT
            REAL*8 :: Vnn ! Nuclear matrix element

            CALL gaussian_product(aa,bb,Ra,Rb,g,Rp,cp)

            eps = 1.0D0 / (4.0D0 * g)

            Vnn = 0.0D0

            DO l = 0, ax+bx
                DO r = 0, FLOOR(l / 2.0)
                    DO i = 0, FLOOR((l - 2*r)/2.0)
                        AAx = A(l,r,i,ax,bx,Ra(1),Rb(1),Rn(1),Rp(1),eps)

                        DO m = 0, ay+by
                            DO s = 0, FLOOR(m / 2.0)
                                DO j = 0, FLOOR((m - 2*s)/2.0)
                                    AAy = A(m,s,j,ay,by,Ra(2),Rb(2),Rn(2),Rp(2),eps)

                                    DO n = 0, az+bz
                                        DO t = 0, FLOOR(n / 2.0)
                                            DO k = 0, FLOOR((n - 2*t)/2.0)
                                                AAz =  A(n,t,k,az,bz,Ra(3),Rb(3),Rn(3),Rp(3),eps)

                                                nu = l + m + n - 2 * (r + s + t) - (i + j + k)

                                                Vnn = Vnn + AAx * AAy * AAz * boys(nu,g*DOT_PRODUCT(Rp-Rn,Rp-Rn))

                                            END DO ! k
                                        END DO ! t
                                    END DO ! n
                                END DO ! j
                            END DO ! s
                        END DO ! m
                    END DO ! i
                END DO ! r
            END DO ! l

            Vnn = Vnn * (-Zn) * norm(ax,ay,az,aa) * norm(bx,by,bz,bb) * cp * 2.0D0 * PI / g

        END FUNCTION nuclear_coeff

        ! --------------------------------
        ! NUCLEUS-ELECRON POTENTIAL MATRIX
        ! --------------------------------
        SUBROUTINE V_nuclear(Kf,c,basis_D,basis_A,basis_L,basis_R,Vn,Rnn,Znn)
            ! ------------------------------------------
            ! Compute nucleus-electrona potential matrix
            ! ------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: Kf                       ! Number of basis functions
            INTEGER, intent(in) :: c                        ! Number of contractions (TODO)
            REAL*8, dimension(Kf,3), intent(in) :: basis_R  ! Basis set niclear positions
            INTEGER, dimension(Kf,3), intent(in) :: basis_L ! Basis set angular momenta
            REAL*8, dimension(Kf,c), intent(in) :: basis_D  ! Basis set contraction coefficients
            REAL*8, dimension(Kf,c), intent(in) :: basis_A  ! Basis set exponential contraction coefficients
            REAL*8, dimension(3), intent(in) :: Rnn         ! Nuclear position
            INTEGER, intent(in) :: Znn                      ! Nuclear charge (> 0)

            ! INTERMEDIATE VARIABLES
            INTEGER :: i,j,k,l
            REAL*8 :: tmp

            ! OUTPUT
            REAL*8, dimension(Kf,Kf), intent(out) :: Vn     ! Nucleus-electron potential matrix

            Vn(:,:) = 0.0D0

            DO i = 1,Kf
                DO j = 1,Kf
                    DO k = 1,c
                        DO l = 1,c
                            tmp = basis_D(i,k) * basis_D(j,l)
                            tmp = tmp * nuclear_coeff(  basis_L(i,1),&      ! lx for basis function i
                                                        basis_L(i,2),&      ! ly for basis function i
                                                        basis_L(i,3),&      ! lz for basis function i
                                                        basis_L(j,1),&      ! lx for basis function j
                                                        basis_L(j,2),&      ! ly for basis function j
                                                        basis_L(j,3),&      ! lz for basis function j
                                                        basis_A(i,k),&      ! Exponential coefficient for basis function i, contraction k
                                                        basis_A(j,l),&      ! Exponential coefficient for basis function j, contraction l
                                                        basis_R(i,:),&      ! Center of basis function i
                                                        basis_R(j,:),&      ! Center of basis function j
                                                        Rnn,Znn)            ! Nuclear position and nuclear charge

                            Vn(i,j) = Vn(i,j) + tmp
                        END DO ! l
                    END DO ! k
                END DO ! j
            END DO ! i

        END SUBROUTINE V_nuclear

END MODULE NUCLEAR


      PROGRAM xmrqcof
C     driver for routine mrqcof
      INTEGER NPT,MA
      REAL SPREAD
      PARAMETER(NPT=100,MA=6,SPREAD=0.1)
      INTEGER i,idum,j,ia(MA),mfit
      REAL chisq,gasdev,x(NPT),y(NPT),sig(NPT),a(MA),
     *     alpha(MA,MA),beta(MA),gues(MA)
      EXTERNAL fgauss
      DATA a/5.0,2.0,3.0,2.0,5.0,3.0/
      DATA gues/4.9,2.1,2.9,2.1,4.9,3.1/
      idum=-911
C     first try sum of two gaussians
      do 12 i=1,NPT
        x(i)=0.1*i
        y(i)=0.0
        do 11 j=1,4,3
          y(i)=y(i)+a(j)*exp(-((x(i)-a(j+1))/a(j+2))**2)
11      continue
        y(i)=y(i)*(1.0+SPREAD*gasdev(idum))
        sig(i)=SPREAD*y(i)
12    continue
      mfit=MA
      do 13 i=1,mfit
        ia(i)=1
13    continue
      do 14 i=1,mfit
        a(i)=gues(i)
14    continue
      call mrqcof(x,y,sig,NPT,a,ia,MA,alpha,beta,MA,chisq,fgauss)
      write(*,'(/1x,a)') 'matrix alpha'
      do 15 i=1,MA
        write(*,'(1x,6f12.4)') (alpha(i,j),j=1,MA)
15    continue
      write(*,'(1x,a)') 'vector beta'
      write(*,'(1x,6f12.4)') (beta(i),i=1,MA)
      write(*,'(1x,a,f12.4/)') 'Chi-squared:',chisq
C     next fix one line and improve the other
      mfit=3
      do 16 i=1,mfit
        ia(i)=0
16    continue
      do 17 i=1,MA
        a(i)=gues(i)
17    continue
      call mrqcof(x,y,sig,NPT,a,ia,MA,alpha,beta,MA,chisq,fgauss)
      write(*,'(1x,a)') 'matrix alpha'
      do 18 i=1,mfit
        write(*,'(1x,6f12.4)') (alpha(i,j),j=1,mfit)
18    continue
      write(*,'(1x,a)') 'vector beta'
      write(*,'(1x,6f12.4)') (beta(i),i=1,mfit)
      write(*,'(1x,a,f12.4/)') 'Chi-squared:',chisq
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xmrqcof.for


Program testKinds

Use Kinds

Implicit None

Write(*,*)
Write(*,'(A,I2,A,F10.6,A)') 'SINGLE precision (',sp,' bytes) gives ',-Log10(2._sp*Spacing(1._sp)),' digits of precision near 1'
Write(*,'(A,I2,A,F10.6,A)') 'DOUBLE precision (',dp,' bytes) gives ',-Log10(2._dp*Spacing(1._dp)),' digits of precision near 1'
# if EXTP
    Write(*,'(A,I2,A,F10.6,A)') 'QUAD precision   (',qp,' bytes) gives ',-Log10(2._qp*Spacing(1._qp)),' digits of precision near 1'
# endif
Write(*,*)
Write(*,'(A,I2,A,ES11.3E4,A,ES11.3E4)') 'SINGLE precision (',sp,' bytes) gives HUGE = ',HUGE(1._sp),' and TINY = ',TINY(1._sp)
Write(*,'(A,I2,A,ES11.3E4,A,ES11.3E4)') 'DOUBLE precision (',dp,' bytes) gives HUGE = ',HUGE(1._dp),' and TINY = ',TINY(1._dp)
# if EXTP
    Write(*,'(A,I2,A,ES11.3E4,A,ES11.3E4)') 'QUAD precision   (',qp,' bytes) gives HUGE = ',HUGE(1._qp),' and TINY = ',TINY(1._qp)
# endif
Write(*,*)
Write(*,'(A,I2,A,I0)') 'SHORT integer  (',is,' bytes) gives range +/- ',HUGE(1_is)
Write(*,'(A,I2,A,I0)') 'LONG integer   (',il,' bytes) gives range +/- ',HUGE(1_il)
Write(*,'(A,I2,A,I0)') 'DOUBLE integer (',id,' bytes) gives range +/- ',HUGE(1_id)

End Program testKinds


! $UWHPSC/codes/fortran/array1

program array1

    ! demonstrate declaring and using arrays

    implicit none
    integer, parameter :: m = 5, n=6

    real (kind=8), dimension(m,n) :: A
    real (kind=8), dimension(m) :: b
    real (kind=8), dimension(n) :: x

    real (kind=8), dimension(m,n) :: At
    real (kind=8), dimension(m) :: bt
    real (kind=8), dimension(n) :: xt
    integer :: i,j

    ! initialize matrix A and vector x:
    do i=1,m
        do j=1,n
            A(i,j) = i+j
            At(i,j)=i+j
            enddo
        enddo

    xt = 1.
    x  = 1.

    ! multiply A*x to get b:
    do i=1,m
        b(i) = 0.
        do j=1,n
            b(i) = b(i) + A(i,j)*x(j)
            enddo
        enddo
    bt=matmul(At,xt)
    print *, "A = "
    do i=1,m
        print *, A(i,:)   ! i'th row of A
        enddo
    print "(2d16.6)", ((A(i,j), j=1,2), i=1,3)
    print *, "x = "
    print "(d16.6)", x
    print *, "b and bt should be equal "
    print *, "b="
    print "(d16.6)", b
    print *, "bt="
    print "(d16.6)",bt

end program array1


!!$subroutine varimax(X,Y,M,K,N)
!!$
!!$  !  THIS SUBROUTINE ROTATES THE VECTORS X USING THE VARIMAX CRITERION.
!!$  !  ON INPUT,  X CONTAINS THE N EIGENVECTORS, EACH OF LENGTH M, TO BE ROTATED.
!!$  !  ON OUTPUT, X CONTAINS THE ROTATED SYSTEM.
!!$
!!$  implicit none
!!$
!!$  integer, intent(IN) :: M, K, N
!!$  real, intent(INOUT) :: X(M,N),Y(K,N)
!!$
!!$  real, dimension(M) :: H,U,V
!!$  real, dimension(K) :: T
!!$  real    :: A, B, C, D, VVOLD, VVNEW
!!$  real    :: PHI, COSPHI, SINPHI
!!$  integer :: P, Q, L, MAXITER
!!$
!!$  !f2py intent(in) :: M, K, N
!!$  !f2py intent(in,out) :: X, Y
!!$  !f2py intent(hide)  :: M, K, N
!!$
!!$  ! NORMALIZE COMPONENTS
!!$
!!$  do P=1,M
!!$     H(P) =sqrt(sum(X(P,:)**2))
!!$  enddo
!!$
!!$  do Q=1,N
!!$     where(H/=0.) X(:,Q) = X(:,Q)/H(:)
!!$  enddo
!!$
!!$  ! VARIMAX ITERATION FOR ALL PAIRS OF VECTORS
!!$
!!$  maxiter = 40
!!$  vvold =  M*sum(X(:,:)**4) - sum(sum(X**2,1)**2)
!!$
!!$  do L=1,MAXITER
!!$     do P=1,N-1
!!$        do Q=P+1,N
!!$           U = X(:,P)**2 - X(:,Q)**2
!!$           V = 2.*X(:,P)*X(:,Q)
!!$           A = sum(U)
!!$           B = sum(V)
!!$           C = sum(U*U-V*V) - (A*A-B*B)/FLOAT(M)
!!$           D = 2.*(sum(U*V) - A*B/FLOAT(M))
!!$           PHI    = .25*atan2(D,C)
!!$           COSPHI = cos(PHI)
!!$           SINPHI = sin(PHI)
!!$           U      =  X(:,P)*COSPHI+X(:,Q)*SINPHI
!!$           X(:,Q) = -X(:,P)*SINPHI+X(:,Q)*COSPHI
!!$           X(:,P) = U
!!$           T      =  Y(:,P)*COSPHI+Y(:,Q)*SINPHI
!!$           Y(:,Q) = -Y(:,P)*SINPHI+Y(:,Q)*COSPHI
!!$           Y(:,P) = T
!!$        end do
!!$     enddo
!!$
!!$     VVNEW =  M*sum(X(:,:)**4) - sum(sum(X**2,1)**2)
!!$     print *, vvold, vvnew, (VVNEW-VVOLD)/VVNEW
!!$     if((VVNEW-VVOLD)/VVNEW < .0001) exit
!!$
!!$     if(L==MAXITER) then
!!$        print *, 'eofs: VARIMAX rotation iteration did not converge'
!!$        call exit(10)
!!$     endif
!!$
!!$     VVOLD = VVNEW
!!$
!!$  enddo
!!$
!!$  do Q=1,N
!!$     X(:,Q) = X(:,Q)*H(:)
!!$  end do
!!$
!!$  return
!!$end subroutine VARIMAX

subroutine varimax(X,Y,M,K,N,NM)

  !  THIS SUBROUTINE ROTATES THE VECTORS X USING THE VARIMAX CRITERION.
  !  ON INPUT,  X CONTAINS THE N EIGENVECTORS, EACH OF LENGTH M, TO BE ROTATED.
  !  ON OUTPUT, X CONTAINS THE ROTATED SYSTEM.

  implicit none

  integer, intent(IN) :: M, K, N, NM
  real*8, intent(INOUT) :: X(M,N),Y(K,N)

  real*8, dimension(M) :: H,U,V
  real*8, dimension(K) :: T
  real*8    :: A, B, C, D, VVOLD, VVNEW
  real*8    :: PHI, COSPHI, SINPHI
  integer :: P, Q, L, MAXITER

  !f2py intent(in) :: M, K, N, NM
  !f2py intent(in,out) :: X, Y
  !f2py intent(hide)  :: M, K, N

  ! NORMALIZE COMPONENTS

  do P=1,M
     H(P) =sqrt(sum(X(P,:)**2))
  enddo

  do Q=1,N
     where(H/=0.) X(:,Q) = X(:,Q)/H(:)
  enddo

  ! VARIMAX ITERATION FOR ALL PAIRS OF VECTORS

  maxiter = 40
  vvold =  M*sum(X(:,:)**4) - sum(sum(X**2,1)**2)

  do L=1,MAXITER

     do P=1,NM-1 !N,N-NM+2,-1
        do Q=P+1,NM !P-1,N-NM+1,-1
           U = X(:,P)**2 - X(:,Q)**2
           V = 2.*X(:,P)*X(:,Q)
           A = sum(U)
           B = sum(V)
           C = sum(U*U-V*V) - (A*A-B*B)/FLOAT(M)
           D = 2.*(sum(U*V) - A*B/FLOAT(M))
           PHI    = .25*atan2(D,C)
           COSPHI = cos(PHI)
           SINPHI = sin(PHI)
           U      =  X(:,P)*COSPHI+X(:,Q)*SINPHI
           X(:,Q) = -X(:,P)*SINPHI+X(:,Q)*COSPHI
           X(:,P) = U
           T      =  Y(:,P)*COSPHI+Y(:,Q)*SINPHI
           Y(:,Q) = -Y(:,P)*SINPHI+Y(:,Q)*COSPHI
           Y(:,P) = T
        end do
     enddo

     VVNEW =  M*sum(X(:,:)**4) - sum(sum(X**2,1)**2)
     print *, vvold, vvnew, (VVNEW-VVOLD)/VVNEW
     if((VVNEW-VVOLD)/VVNEW < .0001) exit

     if(L==MAXITER) then
        print *, 'eofs: VARIMAX rotation iteration did not converge'
        call exit(10)
     endif

     VVOLD = VVNEW

  enddo

  do Q=1,N
     X(:,Q) = X(:,Q)*H(:)
  end do

  return
end subroutine VARIMAX


!--------------------------------------------------
!PHY1038 Assignment 2 Series Computation
!URN: 6408056
!February 2017
!--------------------------------------------------
PROGRAM Taylorseriesexpansion
IMPLICIT NONE

CHARACTER::figrunone, fig, figninput, fignoption, intchoice, figintervaltwo, figinter, figninputtwo
INTEGER:: n, i, p
DOUBLE PRECISION :: factorial
REAL:: interval, taylorvalueatx, valueofderivative, yexact, x, pi
REAL, DIMENSION(:), ALLOCATABLE::a
figrunone='e' !setting this so introduction to program is only printed on the first run
fig='y'!set to y so do loop allowing users to run the program again runs first time
figninput='n'
fignoption='n'
intchoice='N' !this allows (on the intial run) for the user to be given a choice as to what the interval increases in x will be
!this is because on further runs of the main do while loop, they are given a choice as to wether they want to use the same value
!so the interval choice part of the program needs to be in an if loop to stop it playing after the user has chosen to use the
!same interval value
pi=4*atan(1.0)!setting pi for later use
DO WHILE(fig=='y' .or. fig=='Y')!This do while loop allows the user to run the program again at the end, or exit it
 figninputtwo='l' !so on reruns, the user is not told the introduction to the program again
 figintervaltwo='n'
 figninput='n'
 IF (figrunone=='e') THEN !only plays intro on first do loop
   WRITE(6,*) 'This program calculates the Taylor Expansion around zero for f(x)=sin(x)*exp(-x/2), it then'
   WRITE(6,*) 'calulates the values of both the exact function and the Taylor expansion between x=-2pi, and'
   WRITE(6,*) 'x=2pi, and writes the values to a file called taylor.dat. The Taylor function is plotted in'
   WRITE(6,*) 'columns one and two, and the exact function is plotted in columns one and three.'
   WRITE(6,*) 'Thus using: plot "taylor.dat" u 1:2 w l, "taylor.dat" u 1:3 w l'
   WRITE(6,*) 'in gnuplot will allow you to compare the Taylor expansion, of your chosen order, and'
   WRITE(6,*) 'the exact funtion.'
 END IF

 IF(fignoption=='n' .or. fignoption=='N') THEN!Later users are given a choice if they want to use the same order of the
   !polynomial, this if loop allows for this, if N is selected, saying they don't want to use the same order
   !they are given the following option, thus fignoption is set to N at the beginning, outside the do loop
   !so this plays on the first run
   WRITE(6,*)'Please input the order you would like the program to calculate the polynomial for?'
   DO WHILE (figninput=='n' .or. figninput=='N' )  !if they say the order they entered isn't correct, this allows them to
     !enter it again
     DO
       READ(5,*) n
       IF(n<=0)THEN!prevents negative orders being chosen
         WRITE(6,*) 'The order of a polynomial should be positive, please try again.'
         CYCLE
       ELSE
           EXIT
       END IF
     END DO
     WRITE(6,*)'You inputed',n,' Is the correct? Type N for no, or Y for yes.'
     READ(5,*) figninput
     figninputtwo='q'
     IF (figninput=='n' .or. figninput =='N') THEN
       WRITE(6,*)'Please try again.'
     END IF
   END DO
 ELSE IF(fignoption=='y' .or. fignoption=='Y') THEN
   WRITE(6,*)'Using same value for order of Taylor expansion.'!here so that if user chooses to use same value of n
 END IF!they know it has worked
 IF (figrunone=='e') THEN !if loop so intro only plays on first run
   WRITE(6,*) 'This program compares the taylor series to the nth degree between -2pi, and 2pi.'
   WRITE(6,*) 'By default the program increase the value of x in steps of 0.01, until 2pi is reached'
 END IF

 IF(intchoice=='y' .or. intchoice=='Y')THEN
   figinter='p' !later users are given the choice if they want to use the same interval increases in x when they run
   !the program again, if they say yes, figinter is set to p, this later lets them know that the program is using
   !the same value, if they say no, then  the choice is selected that they

 ELSE IF(intchoice=='N'.or. intchoice=='n') THEN
   figinter='y' !if they pick no, figinter is set to Y, meaning they want to change the value of the interval
   IF(figrunone=='e') THEN !this is so they are not asked twice about changing the interval, this is only played
     !on the first run
     DO
       WRITE(6,*) 'If you would like to change the intervals that X increases in from 0.01, type Y, if not type N.'
       READ(5,*) figinter
       IF (figinter /= 'n' .and. figinter /='N' .and. figinter /='Y' .and. figinter /='y') THEN
         WRITE (6,*) 'Invalid option.' !If prevents wrong figures being picked
         CYCLE
       ELSE
         EXIT
       END IF
     END DO
   END IF
 END IF

 IF(figinter=='y' .or. figinter=='Y')THEN !if they don't want to keep the same interval value, this runs
   DO WHILE(figintervaltwo=='n' .or. figintervaltwo=='N')!ensures they pick the interval they want
     WRITE(6,*)'Please type in the interval you want to use.'
     READ(5,*) interval
     WRITE(6,*)'You entered',interval,' Is this correct, type Y for yes, or N for no.'
     READ(5,*) figintervaltwo
     interval=abs(interval)
   END DO
 ELSE IF (figinter=='n' .or. figinter=='N') THEN
   WRITE(6,*)'Using 0.01 as interval'
   interval=0.01
 ELSE IF (figinter=='p') THEN
   WRITE(6,*)'Using same interval value.'
 END IF

 ALLOCATE(a(0:n))!allocates an array to be the same length as the desired polynomial

 factorial=1
 x=-2.0*pi

 OPEN(unit=20,file='taylor.dat')
!(main part of program)
 DO i=1,n
   factorial=factorial*i!calculating factorial
   valueofderivative = ((-SQRT(5.0)/2.0)**(i)*(sin(-(i)*Atan(2.0))))
   a(i) = valueofderivative/factorial!This calculates the taylor expansion, and storing it in to the array
 END DO

 DO WHILE(x<=2.0*pi)!do while loop to set the interval between -2pi and 2pi
   taylorvalueatx=0.0 !makes sure taylor value is set to 0 inbetween do loops, as otherwise the taylor values are too big

   DO i=1,n !multiples each part of the taylor expansion by X to the desired order, for each x
     taylorvalueatx=(x**(i))*a(i)+taylorvalueatx !calculating the actual value of the taylor expansion, by multiplying
   END DO !x to the order and summing all values

   yexact=sin(x)*exp(-x/2.0) !calculates what the exact value is so the user can compare
   WRITE(20,*) x, taylorvalueatx, yexact !writes the values in a file
   x=x+interval
 END DO

 CLOSE(20)

 WRITE(6,*)'Would you like to run the program again? '
 DO
   WRITE(6,*) 'Type Y for yes, or N for no.' !this correlates to main do loop
   READ(5,*)fig
   IF (fig /= 'n' .and. fig /='N' .and. fig /='Y' .and. fig/='y') THEN !ensures valid options are entered
     WRITE (6,*) 'Invalid option.'
     CYCLE
   ELSE
     EXIT
   END IF
 END DO
 IF (fig=='Y' .or. fig=='y') THEN
   WRITE(6,*) 'Would you like to use the same value for the order of the polynomial?'
   DO !allowing user to keep data for last run of program to make running the program multiple times more user friendly
     WRITE(6,*) 'Type Y for yes, or N for no.'
     READ(5,*) fignoption
     IF (fignoption /= 'n' .and. fignoption /='N' .and. fignoption /='Y' .and. fignoption /='y') THEN
       WRITE (6,*) 'Invalid option.'
       CYCLE
     ELSE
       EXIT
     END IF
   END DO
   WRITE(6,*)'Would you like to use the same value for the interval? ie the how much x increases inbetween steps.'
   DO
     WRITE(6,*) 'Type Y for yes, or N for no.'
     READ(5,*) intchoice
     IF (intchoice /= 'n' .and. intchoice /='N' .and. intchoice /='Y' .and. intchoice /='y') THEN
       WRITE (6,*) 'Invalid option.'
       CYCLE
     ELSE
       EXIT
     END IF
   END DO
 END IF
 figrunone='p'!setting this to stop introduction elements playing again
 DEALLOCATE(a) !deallocating a so that new n values can be entered

 END DO
WRITE(6,*)'Thank you for using the program.'
END PROGRAM Taylorseriesexpansion


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.01/06                           *
C  *    TEST TITLE : Building transformations              *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      REAL      ACT4X4(4,4), ACT3X3(3,3), EXP4X4(4,4), EXP3X3(3,3)
      REAL      X0,Y0,Z0, DX,DY,DZ, PHIX,PHIY,PHIZ, FX,FY,FZ
      LOGICAL   TRNSEQ

      CALL INITGL ('06.01.01/06')

C open PHIGS
      CALL XPOPPH  (ERRFIL, MEMUN)

      CALL SETMSG ('1 2 15', '<Build transformation matrix 3> ' //
     1             'should generate a matrix to perform the '   //
     2             'specified 3D transformation.')

C Set up parameters:
C   set fixed point
      X0 = -1.12
      Y0 = 2.23
      Z0 = 3.34
C   set shift vector
      DX = 6.7
      DY = 8.9
      DZ = 10.11
C   set rotation angle
      PHIX = 7.6
      PHIY = -5.4
      PHIZ = 3.2
C   set scale factors
      FX = 0.0023
      FY = -636.34
      FZ = 2.2

C <Build transformation matrix 3> returns act4x4 = actual array
      CALL PBLTM3 (X0,Y0,Z0, DX,DY,DZ, PHIX,PHIY,PHIZ, FX,FY,FZ,
     1             ERRIND, ACT4X4)
      CALL CHKINQ ('pbltm3', ERRIND)

C Compute exp4x4 = expected array
      CALL EBLTM3 (X0,Y0,Z0, DX,DY,DZ, PHIX,PHIY,PHIZ, FX,FY,FZ,
     1             EXP4X4)
      CALL IFPF ( TRNSEQ (4, ACT4X4, EXP4X4))

      CALL SETMSG ('1 2 16', '<Build transformation matrix> ' //
     1             'should generate a matrix to perform the ' //
     2             'specified 2D transformation.')

C Set up parameters:
C   set fixed point
      X0 = -1.12
      Y0 = 2.23
C   set shift vector
      DX = 6.7
      DY = 10.11
C   set rotation angle
      PHIZ = -5.4
C   set scale factors
      FX = 0.0023
      FY = -636.34

C <Build transformation matrix> returns act3x3 = actual array
      CALL PBLTM (X0,Y0, DX,DY, PHIZ, FX,FY, ERRIND, ACT3X3)
      CALL CHKINQ ('pbltm', ERRIND)

C Compute exp3x3 = expected array
      CALL EBLTM (X0,Y0, DX,DY, PHIZ, FX,FY, EXP3X3)
      CALL IFPF ( TRNSEQ (3, ACT3X3, EXP3X3))

      CALL ENDIT
      END


include 'OUCS.f90'
include 'fftlib.for'
module Wave
       integer, parameter :: N = 2048
       double precision,parameter ::  x0=50d0, xmax = 100d0
       double precision :: t, told,x, dx = xmax / (N), dx3,  k, c,amp, Cconv ,Cdisp, L2norm
       double precision,dimension(0:N) :: u, usq, uold, unew, UUx, Uxxx, Lu , uexact, error
endmodule Wave

module RK
      double precision :: dt=1d-5, tmax
      integer :: stage, Niter, Ncycle=5 ,writeafter
      integer :: spatial_conv = 5 ,spatial_disp = 2 ! 1-CD2, 2-UD3,  3-CD4, 4-CD4 non conserv, 5-OUCS3; 1-CD2, 2-CD4, 3-O3CS
      double precision,dimension(1:4) :: fac_dt, fac_rk
endmodule RK

subroutine Initialize
        use Wave
        use RK
        implicit none
        integer :: i
       ! k   = 1d0
        amp = 2d0*k**2*0.999d0
        c   = 4d0*k**2

        tmax    = xmax/c*Ncycle
        Niter   = tmax/dt
        writeafter = 1/dt/10

        Cconv=6d0
        Cdisp=1d0
        x=0d0
        dx3 = dx**3

!       u=0        ! Delta function
!       u(N/2)=-1d0

        do i = 0,N ! Soliton wave solution
             u(i) = amp* (1d0- dtanh(k*(x-x0))**2d0)
             x=x+dx
        enddo

        t = 0d0
        fac_dt(1) = 0.5d0
        fac_dt(2) = 0.5d0
        fac_dt(3) = 1d0
        fac_dt(4) = 1d0

        fac_rk(1) = 1d0/6d0
        fac_rk(2) = 1d0/3d0
        fac_rk(3) = 1d0/3d0
        fac_rk(4) = 1d0/6d0
endsubroutine Initialize

subroutine Backup
        use Wave
        implicit none
        uold = u
        unew = u
endsubroutine Backup

subroutine Restore
        use Wave
        implicit none
        u = unew
endsubroutine Restore

subroutine SpatialDerivative
        use Wave
        use RK
        implicit none
        integer :: i

        !*** Convection term****!
        select case(spatial_conv)
           case(1)
           !CD2
               do i = 1,N-1
                 UUx(i) = (u(i+1)**2 - u(i-1)**2)/2d0/dx/2d0
               enddo
               UUx(N) = (u(1)**2 - u(N-1)**2)/2d0/dx/2d0
               UUx(0) = UUx(N)

           case(2)
           !UD3
              UUx(1) = (3d0*u(1)**2 - 4d0*u(0)**2 + u(N-1)**2)/2d0/dx/2d0
              do i = 2,N
                UUx(i) = (3d0*u(i)**2 - 4d0*u(i-1)**2 + u(i-2)**2)/2d0/dx/2d0
              enddo
              UUx(0) = UUx(N)

           case(3)
           !CD4
               do i = 2,N-2
                 UUx(i) = -(u(i+2)**2 - 8d0*u(i+1)**2 + 8d0*u(i-1)**2 - u(i-2)**2)/12d0/dx/2d0
               enddo
               UUx(1)   = -(u(3)**2 - 8d0*u(2)**2 + 8d0*u(N)**2   - u(N-1)**2)/12d0/dx/2d0
               UUx(N)   = -(u(2)**2 - 8d0*u(1)**2 + 8d0*u(N-1)**2 - u(N-2)**2)/12d0/dx/2d0
               UUx(N-1) = -(u(1)**2 - 8d0*u(0)**2 + 8d0*u(N-2)**2 - u(N-3)**2)/12d0/dx/2d0
               UUx(0) = UUx(N)
           case(4)
           !CD4 - Non_conservation form
               do i = 2,N-2
                 UUx(i) = -u(i)*(u(i+2) - 8d0*u(i+1) + 8d0*u(i-1) - u(i-2))/12d0/dx
               enddo
               UUx(1)   = -u(1)*(u(3) - 8d0*u(2)+ 8d0*u(N)   - u(N-1))/12d0/dx
               UUx(N)   = -u(N)*(u(2) - 8d0*u(1)+ 8d0*u(N-1) - u(N-2))/12d0/dx
               UUx(N-1) = -u(N-1)*(u(1) - 8d0*u(0)+ 8d0*u(N-2) - u(N-3))/12d0/dx
               UUx(0) = UUx(N)
           case(5)
              ! call Dealias1d(u, usq,N)
              ! call ShiftAlign(u,usq,N)
               call Periodic_OUCS3(u*u,UUx,N,dx)
               UUx= UUx/2d0
        end select

        ! Dispersion term
        select case(spatial_disp)
        !CD2
            case(1)
               do i = 2,N-2
                 Uxxx(i) = (u(i+2) - 2d0*u(i+1) + 2d0*u(i-1) - u(i-2))/2d0/dx3
               enddo
               Uxxx(1) = (u(3) - 2d0*u(2) + 2d0*u(N) - u(N-1))/2d0/dx3
               Uxxx(N) = (u(2) - 2d0*u(1) + 2d0*u(N-1) - u(N-2))/2d0/dx3
               Uxxx(N-1) = (u(1) - 2d0*u(N) + 2d0*u(N-2) - u(N-3))/2d0/dx3
               Uxxx(0) = Uxxx(N)
        !CD4
            case(2)
               do i = 3,N-3
                 Uxxx(i) = (-u(i+3) +8d0*u(i+2) - 13d0*u(i+1) + 13d0*u(i-1) - 8d0*u(i-2) + u(i-3))/8d0/dx3
               enddo
               Uxxx(2)   = (-u(5) +8d0*u(4) - 13d0*u(3) + 13d0*u(1) - 8d0*u(N)   + u(N-1))/8d0/dx3
               Uxxx(1)   = (-u(4) +8d0*u(3) - 13d0*u(2) + 13d0*u(N) - 8d0*u(N-1) + u(N-2))/8d0/dx3
               Uxxx(N)   = (-u(3) +8d0*u(2) - 13d0*u(1) + 13d0*u(N-1) - 8d0*u(N-2) + u(N-3))/8d0/dx3
               Uxxx(N-1) = (-u(2) +8d0*u(1) - 13d0*u(0) + 13d0*u(N-2) - 8d0*u(N-3) + u(N-4))/8d0/dx3
               Uxxx(N-2) = (-u(1) +8d0*u(0) - 13d0*u(N-1) + 13d0*u(N-3) - 8d0*u(N-4) + u(N-5))/8d0/dx3
               Uxxx(0)   = Uxxx(N)
        !O3CS
             case(3)
               call Periodic_O3CS(u,Uxxx,N,dx3)
       end select
endsubroutine SpatialDerivative

subroutine RKstage
        use Wave
        use RK
        implicit none

        call SpatialDerivative
        Lu = -dt *(Cconv*UUx + Cdisp*Uxxx)

        unew = unew + fac_rk(stage)*Lu

        u = uold + fac_dt(stage)*Lu
endsubroutine RKstage

subroutine CalcError
        use Wave
        use RK, only: Ncycle
        implicit none
        integer :: i, ii

        x  = 0d0
        ii = 0
        uexact = 0d0

        do i=0,N*(Ncycle+1)
         uexact(ii) = uexact(ii)+amp*(1d0 - dtanh(k*(x-x0 - c*t))**2 )
         if(i/=0 .and. mod(i,N)==0) then
            ii = 0
            uexact(ii) = uexact(N)
         endif
         x  = x+dx
         ii = ii+1
        enddo

        error = dabs(u-uexact)
        L2norm = dsqrt(dot_product(error,error)/N)
endsubroutine CalcError

subroutine March
       use Wave
       use RK
       implicit none
       integer :: i

       call Initialize

       call CalcError
       call SolnWrite
       open(1,file='L2norm.dat',status='replace')
       write(1,*) 'Variables= t, L2norm'

       do i=0,Niter!while(t < tmax)
               call Backup
               do stage=1,4
                 call RKstage
               enddo
               call Restore

               t = t + dt

               if(mod(i,writeafter)==0) then
                call CalcError
                call SolnWrite
                write(*,*) 't=',t, L2norm !'umax=', maxval(u), 'logerrormax=', log10(maxval(error)), 'L2norm=',L2norm
                write(1,*) t, L2norm
               endif
       enddo
       close(3)

endsubroutine March

subroutine SolnWrite
        use Wave
        use RK
       implicit none
       integer :: i
       character(40) :: fname

       if(int(t)<10) then
        write(fname,11) 'sol_000',t,'.dat'
        11 format(A7,F6.4,A4)
       elseif(int(t)<100) then
        write(fname,12) 'sol_00',t,'.dat'
        12 format(A6,F7.4,A4)
       elseif(int(t)<1000) then
        write(fname,13) 'sol_0',t,'.dat'
        13 format(A5,F8.4,A4)
       else
        write(fname,14) 'sol_',t,'.dat'
        14 format(A4,F9.4,A4)
       endif

       open(101, file=trim(fname),status='replace')

       write(101,*) 'Variables = x, u'!, u_exact, error'
       write(101,*) 'Zone i=',N+1
       write(101,*) 'Auxdata time="',real(t),'"'

       111 format(4ES15.3)
       x=0d0
       do i=0,N
        write(101,111) x,u(i)!, uexact(i), error(i)!, (i), error(i)
        x=x+dx
       enddo

       close(101)
endsubroutine SolnWrite

program KdV
        use Wave
        use RK
        implicit none
        print*, "k, (2/3) CD4/O3CS"
        read*, k, spatial_disp
        call Initialize
        call March

endprogram KdV