subroutine tzt(z1,z2,nz,z,t)
   implicit none;
 integer*4::s,nz,Lz;
 integer*4,parameter :: nz1=50001
 real*8,dimension(nz)::z,t;
 real*8,dimension(nz1)::zn,tz;
 real*8::z0,z1,z2,zz,omegam,omegal;
omegam=0.266
omegal=0.734
z0=1000.0
z=(/((z1+(z2-z1)/(nz-1)*Lz),Lz=0,nz-1)/);
!t=-1.240191545d10*z+4.703083872d7+68927.1838&
!&*sqrt(3.240302366d10*z**2-1.868729701d9*z+3.940756737d10);
do s=1,nz
	zz=z(s)
	zn=(/((zz+(z0-zz)/(nz1-1)*Lz),Lz=0,nz1-1)/);
	tz=9.78d9/0.71/(1+zn)/sqrt(omegal+omegam*(1+zn)**3)
	call trapz(zn,tz,nz1,t(s))
enddo
   return;
end subroutine


module common_mtx
!=======================================================================
!
! [PURPOSE:] Matrix Functions
!
! [CREATED:] 07/20/2004 Takemasa Miyoshi
! [UPDATED:] 10/16/2004 Takemasa Miyoshi
!            06/03/2011 Yoichiro Ota - Adapted for EnKF/GFS to meet with coding standards
!
! [PUBLIC:]
!   mtx_eigen  : eigenvalue decomposition
!   mtx_inv    : real symmetric matrix inverse
!   mtx_sqrt   : real symmetric matrix square root
!
! [REFERENCES:]
!    Core subroutines are adapted from netlib.org
!
! [HISTORY:]
!  07/20/2003 Takemasa Miyoshi  Created at University of Maryland, College Park
!
!=======================================================================
  use kinds,only: i_kind,r_kind,r_double
  use netlib,only: rs

  implicit none

  private
  public :: mtx_eigen

contains
!=======================================================================
!  Eigenvalue decomposition using subroutine rs
!    INPUT
!      integer :: imode           : mode switch (0: only eiven values)
!      integer :: n               : dimension of matrix
!      real(r_kind) :: a(n,n)     : input matrix
!    OUTPUT
!      real(r_kind) :: eival(n)   : eiven values in decending order
!                                   i.e. eival(1) is the largest
!      real(r_kind) :: eivec(n,n) : eiven vectors
!      integer :: nrank_eff       : number of positive eivenvalues
!=======================================================================
subroutine mtx_eigen(imode,n,a,eival,eivec,nrank_eff)
  implicit none

  integer(i_kind),intent(in) :: imode ! 0: calculate only eigen values
  integer(i_kind),intent(in) :: n
  real(r_kind),intent(in) :: a(1:n,1:n)
  real(r_kind),intent(out) :: eival(1:n)
  real(r_kind),intent(out) :: eivec(1:n,1:n)
  integer(i_kind),intent(out) :: nrank_eff

  real(r_double) :: a8(n,n)
  real(r_double) :: eival8(n)
  real(r_double) :: eivec8(n,n)
  real(r_double) :: wrk1(n)
  real(r_double) :: wrk2(n)
  integer(i_kind) :: ierr,i,j

  a8 = a
  eivec8 = 0._r_double
  call rs(n,n,a8,eival8,imode,eivec8,wrk1,wrk2,ierr)
  if( ierr/=0 ) then
    print *,'!!! ERROR (mtx_eigen): rs error code is ',ierr
    call stop2(2)
  end if

  nrank_eff = n
  if( eival8(n) > 0 ) then
    do i=1,n
      if( eival8(i) < abs(eival8(n))*sqrt(epsilon(eival8)) ) then
        nrank_eff = nrank_eff - 1
        eival8(i) = 0._r_double
        eivec8(:,i) = 0._r_double
      end if
    end do
  else
    print *,'!!! ERROR (mtx_eigen): All Eigenvalues are below 0'
    call stop2(2)
  end if

  if( nrank_eff<n .and. eival8(1)/=0 ) then
    j = 0
    do i=n,1,-1
      if( eival8(i) == 0 ) then
        eival8(i) = eival8(n-nrank_eff-j)
        eivec(:,i) = eivec8(:,n-nrank_eff-j)
        eival8(n-nrank_eff-j) = 0._r_double
        eivec8(:,n-nrank_eff-j) = 0._r_double
        j = j+1
      end if
    end do
  end if

  do i=1,n
    eival(i) = eival8(n+1-i)
    eivec(:,i) = eivec8(:,n+1-i)
  end do

  return
end subroutine mtx_eigen
end module common_mtx


      SUBROUTINE perturbation_gaussian
      USE global
      IMPLICIT NONE
      REAL*8  ::X1(1,NXP4), XC
      INTEGER :: IC
!
!---------------------------------------------------------------------
!
      XC = aint(0.5*NX)+1      ! Center of the system lenght
!--------- HOT Electron density perturbation ------------------------------
      DO IC = 1, NXP4
         X1(1,IC)=(IC -XC)*DX/L0;  ! Argument of gaussion purturbation
      END DO
!
         DO 121 IC = 1, NXP4
         NI(1,IC)  = NI0 + DN*NI0*exp(0-X1(1,IC)**2)
         NE(1,IC) = NE0 + DN*NE0*exp(0-X1(1,IC)**2)

         VXI(1,IC)  = VXI0
         VXE(1,IC) = VXE0

         PI(1,IC)   = NI(1,IC)*TI
         PE(1,IC)  = NE(1,IC)*TE
  121    CONTINUE
! ---- Boundary condition -------

!
      NI(2,:)  = NI(1,:)
      NE(2,:) = NE(1,:)

      PI(2,:)  = PI(1,:)
      PE(2,:)  = PE(1,:)

      VXI(2,:)  = VXI(1,:)
      VXE(2,:) = VXE(1,:)

      CALL poisson_sol_E2(NI(2,:), NE(2,:), EX(2,:))
      CALL poisson_sol_E2(NI(1,:), NE(1,:), EX(1,:))
!
      END SUBROUTINE perturbation_gaussian


      SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute N Markov parameters M(1), M(2),..., M(N) from a
C     multivariable system whose transfer function matrix G(z) is given.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NC      (input) INTEGER
C             The number of system outputs, i.e. the number of rows in
C             the transfer function matrix G(z).  NC >= 0.
C
C     NB      (input) INTEGER
C             The number of system inputs, i.e. the number of columns in
C             the transfer function matrix G(z).  NB >= 0.
C
C     N       (input) INTEGER
C             The number of Markov parameters M(k) to be computed.
C             N >= 0.
C
C     IORD    (input) INTEGER array, dimension (NC*NB)
C             This array must contain the order r of the elements of the
C             transfer function matrix G(z), stored row by row.
C             For example, the order of the (i,j)-th element of G(z) is
C             given by IORD((i-1)xNB+j).
C
C     AR      (input) DOUBLE PRECISION array, dimension (NA), where
C             NA = IORD(1) + IORD(2) + ... + IORD(NC*NB).
C             The leading NA elements of this array must contain the
C             denominator coefficients AR(1),...,AR(r) in equation (1)
C             of the (i,j)-th element of the transfer function matrix
C             G(z), stored row by row, i.e. in the order
C             (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ...,
C             (NC,1),(NC,2),...,(NC,NB). The coefficients must be given
C             in decreasing order of powers of z; the coefficient of the
C             highest order term is assumed to be equal to 1.
C
C     MA      (input) DOUBLE PRECISION array, dimension (NA)
C             The leading NA elements of this array must contain the
C             numerator coefficients MA(1),...,MA(r) in equation (1)
C             of the (i,j)-th element of the transfer function matrix
C             G(z), stored row by row, i.e. in the order
C             (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ...,
C             (NC,1),(NC,2),...,(NC,NB). The coefficients must be given
C             in decreasing order of powers of z.
C
C     H       (output) DOUBLE PRECISION array, dimension (LDH,N*NB)
C             The leading NC-by-N*NB part of this array contains the
C             multivariable Markov parameter sequence M(k), where each
C             parameter M(k) is an NC-by-NB matrix and k = 1,2,...,N.
C             The Markov parameters are stored such that H(i,(k-1)xNB+j)
C             contains the (i,j)-th element of M(k) for i = 1,2,...,NC
C             and j = 1,2,...,NB.
C
C     LDH     INTEGER
C             The leading dimension of array H.  LDH >= MAX(1,NC).
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
C     METHOD
C
C     The (i,j)-th element of G(z), defining the particular I/O transfer
C     between output i and input j, has the following form:
C
C                          -1         -2               -r
C                    MA(1)z   + MA(2)z   + ... + MA(r)z
C         G  (z) = ----------------------------------------.         (1)
C          ij                -1         -2               -r
C                  1 + AR(1)z   + AR(2)z   + ... + AR(r)z
C
C     The (i,j)-th element of G(z) is defined by its order r, its r
C     moving average coefficients (= numerator) MA(1),...,MA(r) and its
C     r autoregressive coefficients (= denominator) AR(1),...,AR(r). The
C     coefficient of the constant term in the denominator is assumed to
C     be equal to 1.
C
C     The relationship between the (i,j)-th element of the Markov
C     parameters M(1),M(2),...,M(N) and the corresponding element of the
C     transfer function matrix G(z) is given by:
C
C                               -1          -2                -k
C      G  (z) = M  (0) + M  (1)z   + M  (2)z   + ... + M  (k)z  + ...(2)
C       ij       ij       ij          ij                ij
C
C     Equating (1) and (2), we find that the relationship between the
C     (i,j)-th element of the Markov parameters M(k) and the ARMA
C     parameters AR(1),...,AR(r) and MA(1),...,MA(r) of the (i,j)-th
C     element of the transfer function matrix G(z) is as follows:
C
C        M  (1)   = MA(1),
C         ij
C                           k-1
C        M  (k)   = MA(k) - SUM AR(p) x M  (k-p) for 1 < k <= r and
C         ij                p=1          ij
C                      r
C        M  (k+r) = - SUM AR(p) x M  (k+r-p) for k > 0.
C         ij          p=1          ij
C
C     From these expressions the Markov parameters M(k) are computed
C     element by element.
C
C     REFERENCES
C
C     [1] Luenberger, D.G.
C         Introduction to Dynamic Systems: Theory, Models and
C         Applications.
C         John Wiley & Sons, New York, 1979.
C
C     NUMERICAL ASPECTS
C
C     The computation of the (i,j)-th element of M(k) requires:
C        (k-1) multiplications and k additions if k <= r;
C          r   multiplications and r additions if k > r.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TF01ED by S. Van Huffel, Katholieke
C     Univ. Leuven, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Markov parameters, multivariable system, transfer function,
C     transfer matrix.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, N, NB, NC
C     .. Array Arguments ..
      INTEGER           IORD(*)
      DOUBLE PRECISION  AR(*), H(LDH,*), MA(*)
C     .. Local Scalars ..
      INTEGER           I, J, JJ, JK, K, KI, LDHNB, NL, NORD
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( NC.LT.0 ) THEN
         INFO = -1
      ELSE IF( NB.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TF01QD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( NC, NB, N ).EQ.0 )
     $   RETURN
C
      LDHNB = LDH*NB
      NL = 1
      K = 1
C
      DO 60 I = 1, NC
C
         DO 50 J = 1, NB
            NORD = IORD(K)
            H(I,J) = MA(NL)
            JK = J
C
            DO 20 KI = 1, NORD - 1
               JK = JK + NB
               H(I,JK) = MA(NL+KI) - DDOT( KI, AR(NL), 1, H(I,J),
     $                                     -LDHNB )
   20       CONTINUE
C
            DO 40 JJ = J, J + (N - NORD - 1)*NB, NB
               JK = JK + NB
               H(I,JK) = -DDOT( NORD, AR(NL), 1, H(I,JJ), -LDHNB )
   40       CONTINUE
C
            NL = NL + NORD
            K = K + 1
   50    CONTINUE
C
   60 CONTINUE
C
      RETURN
C *** Last line of TF01QD ***
      END


      program DRDSVA
c>> 1996-06-27 DRDSVA   Krogh  Special code for C conversion.
c>> 1996-05-28 DRDSVA   Krogh  Removed implicit statement.
c>> 1994-10-19 DRDSVA   Krogh  Changes to use M77CON
c>> 1989-03-07 DRDSVA   CLL
c     Demo driver for DSVA, Singular Value Analysis.
c
c     Mar 1987, C. L. Lawson & S. Y. Chiu, JPL.  This sample problem
c     taken from the book, Solving Least Squares Problems,
c     Prentice-Hall, 1974, by C. L. Lawson and R. J. Hanson.
c     ------------------------------------------------------------------
c--D replaces "?": DR?SVA, ?SVA
c     ------------------------------------------------------------------
      integer I, J, KPVEC(4), M, MDATA, MMAX, N, NMAX, NMAX2
      parameter(MMAX = 15, NMAX = 5, NMAX2 = NMAX*2)
      double precision A(MMAX,NMAX), B(MMAX), SING(NMAX)
      double precision D(NMAX), WORK(NMAX2)
      character*6 NAMES(NMAX)
c
      data ((A(I,J),J=1,5),I=1,15) /
     *-.13405547D0,-.20162827D0,-.16930778D0,-.18971990D0,-.17387234D0,
     *-.10379475D0,-.15766336D0,-.13346256D0,-.14848550D0,-.13597690D0,
     *-.08779597D0,-.12883867D0,-.10683007D0,-.12011796D0,-.10932972D0,
     * .02058554D0, .00335331D0,-.01641270D0, .00078606D0, .00271659D0,
     *-.03248093D0,-.01876799D0, .00410639D0,-.01405894D0,-.01384391D0,
     * .05967662D0, .06667714D0, .04352153D0, .05740438D0, .05024962D0,
     * .06712457D0, .07352437D0, .04489770D0, .06471862D0, .05876455D0,
     * .08687186D0, .09368296D0, .05672327D0, .08141043D0, .07302320D0,
     * .02149662D0, .06222662D0, .07213486D0, .06200069D0, .05570931D0,
     * .06687407D0, .10344506D0, .09153849D0, .09508223D0, .08393667D0,
     * .15879069D0, .18088339D0, .11540692D0, .16160727D0, .14796479D0,
     * .17642887D0, .20361830D0, .13057860D0, .18385729D0, .17005549D0,
     * .11414080D0, .17259611D0, .14816471D0, .16007466D0, .14374096D0,
     * .07846038D0, .14669563D0, .14365800D0, .14003842D0, .12571177D0,
     * .10803175D0, .16994623D0, .14971519D0, .15885312D0, .14301547D0 /
c
      data (B(I),I=1,15) /
     *-.4361D0, -.3437D0, -.2657D0, -.0392D0, .0193D0, .0747D0,
     * .0935D0,  .1079D0, .1930D0, .2058D0, .2606D0, .3142D0,
     * .3529D0, .3615D0, .3647D0 /
c
      data NAMES /'Earth ', 'Water ', 'Air   ', 'Fire  ', 'Time  '/
      data KPVEC / 1, 111111, -1, 76/
c     ------------------------------------------------------------------
c
      M = MMAX
      N = NMAX
      MDATA = M
      print '(''   DRDSVA..    Demonstrate Singular Value Analysis''/
     *   ''   Listing of input matrix, A, and vector, B, follows..'')'
c++ Code for ~.C. is active
      print '(/(5F12.7,F13.4))',
     *      ((A(I,J),J=1,N),B(I),I=1,M)
c++ Code for .C. is inactive
c%%  for (i = 1; i <= m; i++){
c%%     printf( "\n" );
c%%     for (j = 1; j <= n; j++)
c%%        printf( "%12.7f", a[j - 1][i - 1] );
c%%     printf( "%13.4f", B[i] );}
c%%  fprintf( stdout, " \n\n\n \n" );
c++ End
      print '(1X///1X)'
c
      call DSVA(A, MMAX, M, N, MDATA, B, SING, KPVEC, NAMES, 1, D, WORK)
c
      stop
      end


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C          PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSPLR TO SOLVE
C     THE EQUATION
C
C     (1/R)(D/DR)(R*(DU/DR)) + (1/R**2)(D/DTHETA)(DU/DTHETA) = 16*R**2
C
C     ON THE QUARTER-DISK 0 .LT. R .LT. 1, 0 .LT. THETA .LT. PI/2 WITH
C     WITH THE BOUNDARY CONDITIONS
C
C     U(1,THETA) = 1 - COS(4*THETA), 0 .LE. THETA .LE. 1
C
C     AND
C
C     (DU/DTHETA)(R,0) = (DU/DTHETA)(R,PI/2) = 0,  0 .LE. R .LE. 1.
C
C     (NOTE THAT THE SOLUTION U IS UNSPECIFIED AT R = 0.)
C          THE R-INTERVAL WILL BE DIVIDED INTO 50 PANELS AND THE
C     THETA-INTERVAL WILL BE DIVIDED INTO 48 PANELS.
C
      DIMENSION       F(100,50)  ,BDC(51)    ,BDD(51)    ,W(1114)    ,
     1                R(51)      ,THETA(49)
C
C     FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF.  ALSO NOTE THAT W
C     IS DIMENSIONED 4*(N+1) + (13 + INT(LOG2(N+1)))*(M+1) .
C
      IDIMF = 100
      A = 0.
      B = 1.
      M = 50
      MBDCND = 5
      C = 0.
      PI = PIMACH(DUM)
      D = PI/2.
      N = 48
      NBDCND = 3
      ELMBDA = 0.
C
C     AUXILIARY QUANTITIES.
C
      MP1 = M+1
      NP1 = N+1
C
C     GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING
C     BOUNDARY DATA AND THE RIGHT SIDE OF THE POISSON EQUATION.
C
      DO 101 I=1,MP1
         R(I) = FLOAT(I-1)/50.
  101 CONTINUE
      DO 102 J=1,NP1
         THETA(J) = FLOAT(J-1)*PI/96.
  102 CONTINUE
C
C     GENERATE BOUNDARY DATA.
C
      DO 103 I=1,MP1
         BDC(I) = 0.
         BDD(I) = 0.
  103 CONTINUE
C
C     BDA AND BDB ARE DUMMY VARIABLES.
C
      DO 104 J=1,NP1
         F(MP1,J) = 1.-COS(4.*THETA(J))
  104 CONTINUE
C
C     GENERATE RIGHT SIDE OF EQUATION.
C
      DO 106 I=1,M
         DO 105 J=1,NP1
            F(I,J) = 16.*R(I)**2
  105    CONTINUE
  106 CONTINUE
      CALL HWSPLR (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F,
     1             IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR.  THE EXACT SOLUTION IS
C                U(R,THETA) = R**4*(1 - COS(4*THETA))
C
      ERR = 0.
      DO 108 I=1,MP1
         DO 107 J=1,NP1
            Z = ABS(F(I,J)-R(I)**4*(1.-COS(4.*THETA(J))))
            IF (Z .GT. ERR) ERR = Z
  107    CONTINUE
  108 CONTINUE
      PRINT 1001 , IERROR,ERR,W(1)
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HWSPLR EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 6.19134E-04/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 882//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,F4.0)
C
      END


module lcg
  ! Linear congruential random number generator
  use global_variables
  implicit none

  private :: Iterate_lcg
  public :: Init_lcg, Rand_lcg

  ! parameters from "Numerical Recipies"
  integer(DP), parameter, private :: M = 4294967296_DP
  integer(DP), parameter, private :: A = 1664525_DP
  integer(DP), parameter, private :: C = 1013904223_DP
  integer(DP), private, save :: rand_val = 0_DP

  interface Rand_lcg
     module procedure Rand_lcg1, Rand_lcgN, Rand_lcgNN
  end interface Rand_lcg

contains

  subroutine Init_lcg(seed)
    implicit none
    integer, intent(in) :: seed
    if (seed < 0 .or. seed > m) then
       write(*,*) 'Error: bad lcg seed'
    else
       rand_val = seed
    end if
  end subroutine Init_lcg

  subroutine Iterate_lcg()
    implicit none
    rand_val = mod((A*rand_val+C), M)
  end subroutine Iterate_lcg

  function Rand_lcg1() result(r)
    implicit none
    real(DP) :: r
    call Iterate_lcg()
    r = abs(real(rand_val,kind=DP) / real(M,kind=DP))
  end function Rand_lcg1

  function Rand_lcgN(n) result(r)
    implicit none
    integer, intent(in) :: n
    real(DP), dimension(n) :: r
    integer :: i
    do i = 1, n
       call Iterate_lcg()
       r(n) = abs(real(rand_val, kind=DP) / real(M, kind=DP))
    end do
  end function Rand_lcgN

  function Rand_lcgNN(n,nn) result(r)
    implicit none
    integer, intent(in) :: n,nn
    real(DP), dimension(n,nn) :: r
    integer :: i,j
    do i = 1, n
       do j = 1, nn
          call Iterate_lcg()
          r(i,j) = abs(real(rand_val, kind=DP) / real(M, kind=DP))
       end do
    end do
  end function Rand_lcgNN

end module lcg


      SUBROUTINE svdsolveuv(m, n, mp, np, wcut, file, a, b, x)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER m, n, mp, np
      REAL(rprec) wcut
      CHARACTER file*(*)
      REAL(rprec), DIMENSION(mp,np) :: a
      REAL(rprec), DIMENSION(n) :: x
      REAL(rprec), DIMENSION(m) :: b
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec) :: zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: n1, nonzero, nlast, istat, i, j, iunit
      REAL(rprec), ALLOCATABLE :: u(:,:), w(:), v(:,:)
      REAL(rprec) :: wmax, wcuta, udotb
C-----------------------------------------------

c       Solves Matrix equation A X = B for X using SVD method
c       Allows supression of weights, storage and recall of answers
c       Uses svd routines from numerical recipes
c       Prashant Valanju (Sept 1998) pvalanju@mail.utexas.edu

c       Almost same as SvdSolveB except this one stores U, W, V
c       rather than basis vectors.
c       Use this one when you want to change both B and weights for fixed A

c       Inputs:
c       A(M,N) - Matrix with physical dimensions (Mp,Np)
c       B(N)   - R.H.S. of A X = B
c       M      - Number of rows of A to use
c       N      - Number of columns of A to use
c       Mp,NP  - Storage dimensions of A(Mp,Np)
c       Wcut   - Cutoff parameter
c                If Wcut = 0, writes answers into "file", all weights are kept
c                If Wcut < 0, reads previous answers from "file",
c                              and uses -Wcut for weights to keep
c                If 0 < Wcut < 1 : Cuts off weights with w(i)/wmax < wcut
c                      Use this to cut off small weights, does calculation
c                If Wcut = integer > 1, keeps Wcut weights, does calculation
c                      Use this to cut off fixed number of weights
c       Output:
c       X(N)   - Solution of A X = B
c
      n1 = n

c     ALLOCATE local arrays
      ALLOCATE (u(mp,np), w(np), v(np,np), stat=istat)
      IF (istat .eq. 0) THEN                       !have enough memory
         iunit = 41

         x(:n1) = zero                    !zero answer from previous CALL
         wcuta = ABS(wcut)
c...............................
c     If Wcut < 0 use precalculated weights to get answer fast
c        use wcuta = ABS(wcut) for everything
c     If any error happens while reading "file", do full svd calculation
         IF (wcut .lt. 0) THEN         !Read file from previous calculation
            CALL safe_open(iunit, istat, file, 'old', 'formatted')
            IF (istat .ne. 0) GOTO 98
            READ (iunit, *, err=98)
            READ (iunit, *, err=98)
            READ (iunit, *, err=98) m, n, nonzero
            DO i = 1, n     !Read exactly the same way they were written
               READ (iunit, *, err=98) w(i)         !READ i-th weight
               DO j = 1, n
                  READ (iunit, *, err=98) v(j,i)
               END DO
               DO j = 1, m
                  READ (iunit, *, err=98) u(j,i)
               END DO
            END DO
            CLOSE(unit=iunit)

            GOTO 99                !Use U, w, V matrices to calculate X
         ENDIF                     !End of precalculated branch Wcut < 0
   98    CONTINUE
c.......................................
c     If Wcut .ge. 0, do full svd calculation
c     Initialize all to zero to wipe out effects of old call
         DO j = 1, n
            w(j) = zero        !Zero all weights
            u(:m,j) = a(:m,j)  !Because U will be changed by svdcmp
            v(:n,j) = zero
         END DO

         CALL svdcmp (u, m, n, mp, np, w, v)     !Do SVD decomposition

c       Sort weights and matrices with DECREASING weights
c       Permute weight w(i) AND column vectors U(*,i), V(*,i) at the same time
         CALL sortsvd (m, n, mp, np, w, u, v)

c       Find the number of nonzero weights (already dcreasing ordered)
         DO nonzero = n, 1, -1
c                                   !Found first nonzero weight, get out
            IF (w(nonzero) .ne. 0) EXIT
         END DO
         IF (nonzero .le. 0) GOTO 999

c............................................
c        Decide how many weights to keep
   99    CONTINUE
         IF (wcuta .gt. 1) THEN
            nlast = wcuta
         ELSE                                    !cutoff small weights
            wMAX = w(1)                     !weights are already ordered
            nlast = 0
            DO i = 1, nonzero
               IF (w(i) .gt. wmax*wcuta) THEN
                  nlast = nlast + 1              !accept this weight
               ELSE
                  GOTO 96
               END IF
            END DO
         END IF

c       Find solution X and basis vectors (put into columns of V)
c       This is the NR SVBKSB routine
   96    CONTINUE
         IF (nlast.le.0 .or. nlast.gt.nonzero) nlast = nonzero
         DO i = 1, nlast     !Calc i-th coeff (U.b/w) for noNonzero w(i)
c        First calculate i-th coeff (U(i)*b/w(i)) in the SUM in eq 14.3.17 (NR)
c                            !Dot product of i-th column of U with B
c                            !summed over all plasma points
            udotb = SUM(u(:m,i)*b(:m))
c                        !=(Ui.b/wi) in eq 14.3.17, saves many divisions
            udotb = udotb/w(i)
c         Now run DOwn the i-th column of the vector V(j,i)
c                         !j-th entry (row) of vectors in eq 14.3.17
c                         !add it to the j-th entry of X
            x(:n) = x(:n) + udotb*v(:n,i)
c                                  !This did the svdbksb, faster than NR
         END DO                   !and also calculated the basis vectors

c............................................
c       Write ALL weights and U, V into SVD file (IF Wcut=0)
         IF (wcut .eq. 0) THEN
            CALL safe_open(iunit, istat, file, 'unknown', 'formatted')
            WRITE (iunit, *) 'Max w = ', w(1), ', Min w = ', w(nonzero)
            WRITE (iunit, *) 'Ratio = ', w(1)/w(nonzero)
            WRITE (iunit, *) m, n, nonzero
            DO i = 1, n
               WRITE (iunit, *) w(i)                !WRITE i-th weight
               DO j = 1, n
                  WRITE (iunit, *) v(j,i)
               END DO
               DO j = 1, m
                  WRITE (iunit, *) u(j,i)
               END DO
            END DO
            CLOSE(unit=iunit)
         END IF
c................................................
      END IF
  999 CONTINUE

      DEALLOCATE (u, w, v, stat=istat)

      END SUBROUTINE svdsolveuv


module type_reference_element
#include <messenger.h>
    use mod_kinds,          only: rk, ik
    use mod_constants,      only: NFACES, ZERO, ONE, XI_DIR, ETA_DIR, ZETA_DIR
    use mod_gauss_legendre, only: quadrature_nodes, quadrature_weights
    use mod_nodes_uniform,  only: uniform_nodes, uniform_weights
    use mod_polynomial,     only: polynomial_val, dpolynomial_val, ddpolynomial_val
    use mod_inv,            only: inv
    use ieee_arithmetic,    only: ieee_is_nan
    implicit none

    !>  A reference element data type.
    !!
    !!  Contains references nodes/weights, interpolators, and projectors.
    !!
    !!
    !!
    !!
    !! nodes_r(.'s) for P1 element     nodes_r(.'s) for P2 element
    !!        .-----------.                  .-----.-----.
    !!       /           /|                 /     /     /|
    !!      /           / |                .-----.-----. |
    !!     /           /  |               /     /     /| .
    !!    .-----------.   |              .-----.-----. |/|
    !!    |           |   |              |     |     | . |
    !!    |           |   .              |     |     |/| .
    !!    |           |  /               .-----.-----. |/
    !!    |           | /                |     |     | .
    !!    |           |/                 |     |     |/
    !!    .-----------.                  .-----.-----.
    !!
    !!
    !!
    !!  Example of quadrature interpolation nodes(x's) on faces. Note,
    !!  the interpolation nodes are independent of the element reference
    !!  nodes, self%nodes_r.
    !!
    !!        .-----------.                  .-----.-----.
    !!       /  x    x   /|                 /  x  /  x  /|
    !!      /           / |                .-----.-----. |
    !!     /  x    x   / x|               /  x  /  x  /|x.
    !!    .-----------.   |              .-----.-----. |/|
    !!    |           |x x|              |     |     |x.x|
    !!    |  x    x   |   .              |  x  |  x  |/| .
    !!    |           |x /               .-----.-----.x|/
    !!    |  x    x   | /                |  x  |  x  | .
    !!    |           |/                 |     |     |/
    !!    .-----------.                  .-----.-----.
    !!
    !!
    !!  The interpolator matrices compute the interpolation of polynomial
    !!  quantities at the interpolation nodes(x's).
    !!
    !!      values_{at inodes} = matmul(val_e, modes)
    !!
    !!  The nodes_to_modes projector matrix, acts on values at the reference
    !!  nodes(nodes_r, .'s). When the nodes_to_modes projector matrix,
    !!  acting on values located at nodes_r, computes modal coefficients
    !!  representing the original quantity as a polynomial expansion on
    !!  the reference element.
    !!
    !!      modes = matmul(nodes_to_modes, values_{at nodes_r})
    !!
    !!
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/26/2017
    !!
    !---------------------------------------------------------------------
    type, public :: reference_element_t

        ! Reference element type/nodes
        integer(ik)                 :: element_type
        real(rk),       allocatable :: nodes_r(:,:)          ! Nodes defining the parametric reference element.
        real(rk),       allocatable :: nodes_to_modes(:,:)  ! linear projector. Takes values at 'nodes_r' and computes modal coefficients
                                                            ! NOTE: nterms of the nodes_to_mdoes projector does not correspond to
                                                            !       the number of terms in the interpolator matrices. The number of
                                                            !       terms in the projector is equal to the number of reference
                                                            !       nodes.

        ! Interpolator settings
        character(:),   allocatable :: polynomial           ! polynomial type being interpolated
        character(:),   allocatable :: node_set             ! node set defined for the interpolators
        integer(ik)                 :: level
        integer(ik)                 :: nterms_rule

        ! Interpolation nodes/weights
        real(rk),       allocatable :: nodes_ie(:,:)        ! nodes_3d(nnodes, 3). xi = nodes(:,1), eta = nodes(:,2), zeta = nodes(:,3)
        real(rk),       allocatable :: iweights_e(:)        ! weights_3d(nnodes)
        real(rk),       allocatable :: nodes_if(:,:,:)      ! nodes_2d(nnodes, 3, nfaces). xi = nodes(:,1,iface), eta = nodes(:,2,iface), zeta = nodes(:,3,iface)
        real(rk),       allocatable :: iweights_f(:)        ! weights_2d(nnodes)

        ! Interpolators
        real(rk),       allocatable :: val_e(:,:)           ! element interpolator, expansion value  to elem nodes
        real(rk),       allocatable :: ddxi_e(:,:)          ! element interpolator, expansion ddxi   to elem nodes
        real(rk),       allocatable :: ddeta_e(:,:)         ! element interpolator, expansion ddeta  to elem nodes
        real(rk),       allocatable :: ddzeta_e(:,:)        ! element interpolator, expansion ddzeta to elem nodes

        real(rk),       allocatable :: dd_dxidxi_e(:,:)     ! element interpolator
        real(rk),       allocatable :: dd_dxideta_e(:,:)    ! element interpolator
        real(rk),       allocatable :: dd_dxidzeta_e(:,:)   ! element interpolator
        real(rk),       allocatable :: dd_detadeta_e(:,:)   ! element interpolator
        real(rk),       allocatable :: dd_detadzeta_e(:,:)  ! element interpolator
        real(rk),       allocatable :: dd_dzetadzeta_e(:,:) ! element interpolator

        real(rk),       allocatable :: val_f(:,:,:)             ! face    interpolator, expansion value  to face nodes
        real(rk),       allocatable :: ddxi_f(:,:,:)            ! face    interpolator, expansion ddxi   to face nodes
        real(rk),       allocatable :: ddeta_f(:,:,:)           ! face    interpolator, expansion ddeta  to face nodes
        real(rk),       allocatable :: ddzeta_f(:,:,:)          ! face    interpolator, expansion ddzeta to face nodes

        real(rk),       allocatable :: dd_dxidxi_f(:,:,:)       ! face interpolator, dxidxi
        real(rk),       allocatable :: dd_dxideta_f(:,:,:)      ! face interpolator, dxideta
        real(rk),       allocatable :: dd_dxidzeta_f(:,:,:)     ! face interpolator, dxidzeta
        real(rk),       allocatable :: dd_detadeta_f(:,:,:)     ! face interpolator, detadeta
        real(rk),       allocatable :: dd_detadzeta_f(:,:,:)    ! face interpolator, detadzeta
        real(rk),       allocatable :: dd_dzetadzeta_f(:,:,:)   ! face interpolator, dzetadzeta

        logical :: element_initialized       = .false.
        logical :: nodes_initialized         = .false.
        logical :: weights_initialized       = .false.
        logical :: interpolation_initialized = .false.
    contains

        ! Initialize
        procedure           :: init_element
        procedure           :: init_interpolator
        procedure,  private :: init_interpolator_nodes
        procedure,  private :: init_interpolator_matrices

        ! Produce
        generic             :: nodes        => nodes_element,   nodes_face
        procedure, private  :: nodes_element
        procedure, private  :: nodes_face

        generic             :: weights      => weights_element, weights_face
        procedure, private  :: weights_element
        procedure, private  :: weights_face

        generic             :: interpolator => interpolate_element, interpolate_face
        procedure, private  :: interpolate_element
        procedure, private  :: interpolate_face

        ! Query
        procedure   :: nnodes_r     ! number of nodes in the reference node set
        procedure   :: nnodes_ie    ! Number of interpolation nodes in the element set
        procedure   :: nnodes_if    ! Number of interpolation nodes in the face set

        procedure   :: nterms_r     ! number of terms in the reference node data
        procedure   :: nterms_i     ! number of terms in the interpolator node data

    end type reference_element_t
    !********************************************************************

contains

    !>  Initialize the reference element.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/29/2017
    !!
    !-------------------------------------------------------------------
    subroutine init_element(self,element_type)
        class(reference_element_t), intent(inout)   :: self
        integer(ik),                intent(in)      :: element_type

        real(rk),   allocatable :: temp(:,:)
        integer(ik)             :: nnodes, iterm, inode, ierr

        !
        ! Set element type, initialize reference nodes.
        !
        self%element_type = element_type
        self%nodes_r      = uniform_nodes(element_type,dim=3)

        !
        ! Compute nodes-to-modes projection matrix
        !
        !
        ! Compute the values of each mapping term at each mesh point
        !
        nnodes = self%nnodes_r()
        if (allocated(temp)) deallocate(temp)
        allocate(temp(nnodes,nnodes), stat=ierr)
        if (ierr /= 0) call AllocationError

        do iterm = 1,nnodes
            do inode = 1,nnodes
                temp(inode,iterm) = polynomial_val(3,nnodes,iterm,[self%nodes_r(inode,1),self%nodes_r(inode,2),self%nodes_r(inode,3)])
            end do
        end do
        ! Invert matrix so that it can multiply a vector of
        ! element points to compute the mode amplitudes of the x,y mappings
        self%nodes_to_modes = inv(temp)

        self%element_initialized = .true.

    end subroutine init_element
    !*******************************************************************

    !>  Initialize interpolation nodes.
    !!
    !!  @param[in]  polynomial  String indicating the polynomial basis
    !!  @param[in]  nterms      Number of terms in the polynomial expansion being interpolated from
    !!  @param[in]  node_set    String indicating the node set being interpolated to
    !!  @param[in]  level       Integer indicator for the level of resolution in the interpolation node set
    !!  @param[in]  nterms_rule Number of terms used as a rule to construct the node set resolution
    !!
    !!  In the case where we want an interpolation from the mesh coordinate expansion
    !!  to the quadrature nodes, we could use the number of terms in the mesh
    !!  expansion for 'nterms' and the number of terms in the solution expansion
    !!  for 'nterms_rule'. In this way, the quadrature node set used to interpolate
    !!  the mesh coordinate expansion will coincide with the interpolation set
    !!  for the solution expansion.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/28/2017
    !!
    !-------------------------------------------------------------------
    subroutine init_interpolator(self,polynomial,nterms,node_set,level,nterms_rule)
        class(reference_element_t), intent(inout)   :: self
        character(*),               intent(in)      :: polynomial
        integer(ik),                intent(in)      :: nterms
        character(*),               intent(in)      :: node_set
        integer(ik),                intent(in)      :: level
        integer(ik),                intent(in)      :: nterms_rule

        character(:),   allocatable :: user_msg

        call self%init_interpolator_nodes(node_set,level,nterms_rule)

        call self%init_interpolator_matrices(polynomial,nterms)

        self%interpolation_initialized = .true.

    end subroutine init_interpolator
    !*******************************************************************

    !>  Initialize the interpolation node set.
    !!
    !!  nodes_ie
    !!  iweights_e (maybe)
    !!  nodes_if
    !!  iweights_f (maybe)
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/29/2017
    !!
    !-----------------------------------------------------------------------
    subroutine init_interpolator_nodes(self,node_set,level,nterms_rule)
        class(reference_element_t), intent(inout)   :: self
        character(*),               intent(in)      :: node_set
        integer(ik),                intent(in)      :: level
        integer(ik),                intent(in)      :: nterms_rule

        integer(ik)             :: iface, ierr
        real(rk),   allocatable :: nodes_3d(:,:), nodes_2d(:,:)
        real(rk),   allocatable :: weights_3d(:), weights_2d(:)

        !
        ! Reset node/weight initialization flags
        !
        self%nodes_initialized   = .false.
        self%weights_initialized = .false.

        self%node_set            = trim(node_set)
        self%level               = level
        self%nterms_rule         = nterms_rule

        !
        ! Generate 3D/2D node sets
        !
        select case(trim(node_set))
            case('Uniform')
                nodes_3d   = uniform_nodes(level,dim=3)
                nodes_2d   = uniform_nodes(level,dim=2)
                weights_3d = uniform_weights(level,dim=3)
                weights_2d = uniform_weights(level,dim=2)

            case('Quadrature')
                nodes_3d   = quadrature_nodes(  nterms=nterms_rule, level=level,dim=3)
                nodes_2d   = quadrature_nodes(  nterms=nterms_rule, level=level,dim=2)
                weights_3d = quadrature_weights(nterms=nterms_rule, level=level,dim=3)
                weights_2d = quadrature_weights(nterms=nterms_rule, level=level,dim=2)

                self%weights_initialized = .true.
            case default
                call chidg_signal_one(FATAL,"reference_element%init_nodes: requested node set not implemented.", trim(node_set))
        end select

        !
        ! Set nodes (if provided)
        !
        if (allocated(nodes_3d) .and. allocated(nodes_2d)) then
            ! Set 3D element nodes
            self%nodes_ie = nodes_3d

            ! Set 2D face nodes
            if (allocated(self%nodes_if)) deallocate(self%nodes_if)
            allocate(self%nodes_if(size(nodes_2d,1),3,NFACES), stat=ierr)
            if (ierr /= 0) call AllocationError

            iface = 1
            self%nodes_if(:,1,iface) = -ONE
            self%nodes_if(:,2,iface) = nodes_2d(:,1)
            self%nodes_if(:,3,iface) = nodes_2d(:,2)

            iface = 2
            self%nodes_if(:,1,iface) = ONE
            self%nodes_if(:,2,iface) = nodes_2d(:,1)
            self%nodes_if(:,3,iface) = nodes_2d(:,2)

            iface = 3
            self%nodes_if(:,1,iface) = nodes_2d(:,1)
            self%nodes_if(:,2,iface) = -ONE
            self%nodes_if(:,3,iface) = nodes_2d(:,2)

            iface = 4
            self%nodes_if(:,1,iface) = nodes_2d(:,1)
            self%nodes_if(:,2,iface) = ONE
            self%nodes_if(:,3,iface) = nodes_2d(:,2)

            iface = 5
            self%nodes_if(:,1,iface) = nodes_2d(:,1)
            self%nodes_if(:,2,iface) = nodes_2d(:,2)
            self%nodes_if(:,3,iface) = -ONE

            iface = 6
            self%nodes_if(:,1,iface) = nodes_2d(:,1)
            self%nodes_if(:,2,iface) = nodes_2d(:,2)
            self%nodes_if(:,3,iface) = ONE

            self%nodes_initialized = .true.

        end if !nodes

        !
        ! Set weights (if provided)
        !
        if (allocated(self%iweights_e)) deallocate(self%iweights_e)
        if (allocated(self%iweights_f)) deallocate(self%iweights_f)
        if (allocated(weights_3d) .and. allocated(weights_2d)) then
            ! Set 3D element weights
            self%iweights_e = weights_3d

            ! Set 2D element weights
            self%iweights_f = weights_2d

            self%weights_initialized = .true.
        end if

    end subroutine init_interpolator_nodes
    !***********************************************************************

    !>  Initialize polynomial interpolation matrices to compute polynomial
    !!  quantities at the interpolation node locations.
    !!
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/29/2017
    !!
    !-----------------------------------------------------------------------
    subroutine init_interpolator_matrices(self,polynomial,nterms)
        class(reference_element_t), intent(inout)   :: self
        character(*),               intent(in)      :: polynomial
        integer(ik),                intent(in)      :: nterms

        integer(ik)             :: iterm, inode, iface, spacedim, ierr, nnodes
        real(rk)                :: xi, eta, zeta
        real(rk),   allocatable :: temp(:,:)

        !
        ! Store polynomial
        !
        self%polynomial = trim(polynomial)
        spacedim = 3

        !
        ! Compute element interpolators
        !
        if (allocated(self%val_e)) deallocate(self%val_e,           &
                                              self%ddxi_e,          &
                                              self%ddeta_e,         &
                                              self%ddzeta_e,        &
                                              self%dd_dxidxi_e,     &
                                              self%dd_dxideta_e,    &
                                              self%dd_dxidzeta_e,   &
                                              self%dd_detadeta_e,   &
                                              self%dd_detadzeta_e,  &
                                              self%dd_dzetadzeta_e)
        allocate(self%val_e(          self%nnodes_ie(), nterms),    &
                 self%ddxi_e(         self%nnodes_ie(), nterms),    &
                 self%ddeta_e(        self%nnodes_ie(), nterms),    &
                 self%ddzeta_e(       self%nnodes_ie(), nterms),    &
                 self%dd_dxidxi_e(    self%nnodes_ie(), nterms),    &
                 self%dd_dxideta_e(   self%nnodes_ie(), nterms),    &
                 self%dd_dxidzeta_e(  self%nnodes_ie(), nterms),    &
                 self%dd_detadeta_e(  self%nnodes_ie(), nterms),    &
                 self%dd_detadzeta_e( self%nnodes_ie(), nterms),    &
                 self%dd_dzetadzeta_e(self%nnodes_ie(), nterms), stat=ierr)
        if (ierr /= 0) call AllocationError

        do iterm = 1,nterms
            do inode = 1,self%nnodes_ie()
                xi   = self%nodes_ie(inode,1)
                eta  = self%nodes_ie(inode,2)
                zeta = self%nodes_ie(inode,3)

                ! Value
                self%val_e(   inode,iterm) =  polynomial_val(spacedim,nterms,iterm,[xi,eta,zeta])

                ! First derivatives
                self%ddxi_e(  inode,iterm) = dpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],XI_DIR)
                self%ddeta_e( inode,iterm) = dpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ETA_DIR)
                self%ddzeta_e(inode,iterm) = dpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ZETA_DIR)

                ! Second/mixed derivatives
                self%dd_dxidxi_e(    inode,iterm) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],XI_DIR,XI_DIR  )
                self%dd_dxideta_e(   inode,iterm) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],XI_DIR,ETA_DIR )
                self%dd_dxidzeta_e(  inode,iterm) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],XI_DIR,ZETA_DIR)

                self%dd_detadeta_e(  inode,iterm) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ETA_DIR,ETA_DIR )
                self%dd_detadzeta_e( inode,iterm) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ETA_DIR,ZETA_DIR)

                self%dd_dzetadzeta_e(inode,iterm) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ZETA_DIR,ZETA_DIR)
            end do
        end do

        !
        ! Compute face interpolators
        !
        if (allocated(self%val_f))    deallocate(self%val_f,            &
                                                 self%ddxi_f,           &
                                                 self%ddeta_f,          &
                                                 self%ddzeta_f,         &
                                                 self%dd_dxidxi_f,      &
                                                 self%dd_dxideta_f,     &
                                                 self%dd_dxidzeta_f,    &
                                                 self%dd_detadeta_f,    &
                                                 self%dd_detadzeta_f,   &
                                                 self%dd_dzetadzeta_f)

        allocate(self%val_f(          self%nnodes_if(), nterms, NFACES), &
                 self%ddxi_f(         self%nnodes_if(), nterms, NFACES), &
                 self%ddeta_f(        self%nnodes_if(), nterms, NFACES), &
                 self%ddzeta_f(       self%nnodes_if(), nterms, NFACES), &
                 self%dd_dxidxi_f(    self%nnodes_if(), nterms, NFACES), &
                 self%dd_dxideta_f(   self%nnodes_if(), nterms, NFACES), &
                 self%dd_dxidzeta_f(  self%nnodes_if(), nterms, NFACES), &
                 self%dd_detadeta_f(  self%nnodes_if(), nterms, NFACES), &
                 self%dd_detadzeta_f( self%nnodes_if(), nterms, NFACES), &
                 self%dd_dzetadzeta_f(self%nnodes_if(), nterms, NFACES), stat=ierr)
        if (ierr /= 0) call AllocationError

        do iface = 1,NFACES
            do iterm = 1,nterms
                do inode = 1,self%nnodes_if()
                    xi   = self%nodes_if(inode,1,iface)
                    eta  = self%nodes_if(inode,2,iface)
                    zeta = self%nodes_if(inode,3,iface)

                    ! Value
                    self%val_f(   inode,iterm,iface) =  polynomial_val(spacedim,nterms,iterm,[xi,eta,zeta])

                    ! First-derivatives
                    self%ddxi_f(  inode,iterm,iface) = dpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],XI_DIR)
                    self%ddeta_f( inode,iterm,iface) = dpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ETA_DIR)
                    self%ddzeta_f(inode,iterm,iface) = dpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ZETA_DIR)

                    ! Second/midxed-derivatives
                    self%dd_dxidxi_f(     inode,iterm,iface) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],XI_DIR,XI_DIR)
                    self%dd_dxideta_f(    inode,iterm,iface) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],XI_DIR,ETA_DIR)
                    self%dd_dxidzeta_f(   inode,iterm,iface) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],XI_DIR,ZETA_DIR)
                    self%dd_detadeta_f(   inode,iterm,iface) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ETA_DIR,ETA_DIR)
                    self%dd_detadzeta_f(  inode,iterm,iface) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ETA_DIR,ZETA_DIR)
                    self%dd_dzetadzeta_f( inode,iterm,iface) = ddpolynomial_val(spacedim,nterms,iterm,[xi,eta,zeta],ZETA_DIR,ZETA_DIR)

                end do
            end do
        end do

    end subroutine init_interpolator_matrices
    !***********************************************************************

    !>
    !!
    !!
    !!
    !!
    !-------------------------------------------------------------------
    function nodes_element(self) result(nodes_)
        class(reference_element_t), intent(in)  :: self

        real(rk),       allocatable :: nodes_(:,:)
        character(:),   allocatable :: user_msg

        user_msg = "reference_element_t: tried to return element nodes without being &
                    initialized. Make sure init_nodes is getting called."
        if (.not. self%nodes_initialized) call chidg_signal(FATAL,user_msg)

        nodes_ = self%nodes_ie

    end function nodes_element
    !*******************************************************************

    !>
    !!
    !!
    !!
    !!
    !-------------------------------------------------------------------
    function nodes_face(self,iface) result(nodes_)
        class(reference_element_t), intent(in)  :: self
        integer(ik),                intent(in)  :: iface

        real(rk),       allocatable :: nodes_(:,:)
        character(:),   allocatable :: user_msg

        user_msg = "reference_element_t: tried to return face nodes without being &
                    initialized. Make sure init_nodes is getting called."
        if (.not. self%nodes_initialized) call chidg_signal(FATAL,user_msg)

        nodes_ = self%nodes_if(:,:,iface)

    end function nodes_face
    !*******************************************************************

    !>
    !!
    !!
    !!
    !!
    !-------------------------------------------------------------------
    function weights_element(self) result(weights_)
        class(reference_element_t), intent(in)  :: self

        real(rk),       allocatable :: weights_(:)
        character(:),   allocatable :: user_msg

        user_msg = "reference_element_t: tried to return element weights without being &
                    initialized. Make sure init_nodes is getting called."
        if (.not. self%weights_initialized) call chidg_signal(FATAL,user_msg)

        weights_ = self%iweights_e

    end function weights_element
    !*******************************************************************

    !>
    !!
    !!  NOTE: we don't actually use the 'iface' argument in the call.
    !!  it is just there to be consistent with the other calls and it
    !!  also helps differentiate this routine from the weights_element
    !!  routine for the generic interface.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!
    !!
    !-------------------------------------------------------------------
    function weights_face(self,iface) result(weights_)
        class(reference_element_t), intent(in)  :: self
        integer(ik),                intent(in)  :: iface

        real(rk),       allocatable :: weights_(:)
        character(:),   allocatable :: user_msg

        user_msg = "reference_element_t: tried to return face weights without being &
                    initialized. Make sure init_nodes is getting called."
        if (.not. self%weights_initialized) call chidg_signal(FATAL,user_msg)

        weights_ = self%iweights_f

    end function weights_face
    !*******************************************************************

    !>  Return an interpolator for the element volume node set.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/28/2017
    !!
    !-------------------------------------------------------------------
    function interpolate_element(self,selector) result(interpolator_)
        class(reference_element_t), intent(in)  :: self
        character(*),               intent(in)  :: selector

        real(rk),   allocatable :: interpolator_(:,:)

        select case(trim(selector))
            case('Value')
                interpolator_ = self%val_e
            case('ddxi')
                interpolator_ = self%ddxi_e
            case('ddeta')
                interpolator_ = self%ddeta_e
            case('ddzeta')
                interpolator_ = self%ddzeta_e
            case('dxidxi')
                interpolator_ = self%dd_dxidxi_e
            case('dxideta')
                interpolator_ = self%dd_dxideta_e
            case('dxidzeta')
                interpolator_ = self%dd_dxidzeta_e
            case('detadeta')
                interpolator_ = self%dd_detadeta_e
            case('detadzeta')
                interpolator_ = self%dd_detadzeta_e
            case('dzetadzeta')
                interpolator_ = self%dd_dzetadzeta_e
            case default
                call chidg_signal_one(FATAL,"reference_element%interpolate: Invalid selector for element interpolator.", trim(selector))
        end select

    end function interpolate_element
    !*******************************************************************

    !>  Return an interpolator for the face node set.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/28/2017
    !!
    !-------------------------------------------------------------------
    function interpolate_face(self,selector,iface) result(interpolator_)
        class(reference_element_t), intent(in)  :: self
        character(*),               intent(in)  :: selector
        integer(ik),                intent(in)  :: iface

        real(rk),   allocatable :: interpolator_(:,:)

        select case(trim(selector))
            case('Value')
                interpolator_ = self%val_f(:,:,iface)
            case('ddxi')
                interpolator_ = self%ddxi_f(:,:,iface)
            case('ddeta')
                interpolator_ = self%ddeta_f(:,:,iface)
            case('ddzeta')
                interpolator_ = self%ddzeta_f(:,:,iface)
            case('dxidxi')
                interpolator_ = self%dd_dxidxi_f(:,:,iface)
            case('dxideta')
                interpolator_ = self%dd_dxideta_f(:,:,iface)
            case('dxidzeta')
                interpolator_ = self%dd_dxidzeta_f(:,:,iface)
            case('detadeta')
                interpolator_ = self%dd_detadeta_f(:,:,iface)
            case('detadzeta')
                interpolator_ = self%dd_detadzeta_f(:,:,iface)
            case('dzetadzeta')
                interpolator_ = self%dd_dzetadzeta_f(:,:,iface)
            case default
                call chidg_signal_one(FATAL,"reference_element%interpolate: Invalid selector for face interpolator.", trim(selector))
        end select

    end function interpolate_face
    !*******************************************************************

    !>  Return number of nodes in the reference node set.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/30/2017
    !!
    !-------------------------------------------------------------------
    pure function nnodes_r(self) result(nnodes)
        class(reference_element_t), intent(in)  :: self

        integer(ik) :: nnodes

        !if (.not. self%element_initialized) call chidg_signal(FATAL,"reference_element%nnodes_r: reference element has not been initialized.")

        nnodes = size(self%nodes_r,1)

    end function nnodes_r
    !*******************************************************************

    !>  Return number of nodes in the element interpolation node set.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/30/2017
    !!
    !-------------------------------------------------------------------
    pure function nnodes_ie(self) result(nnodes)
        class(reference_element_t), intent(in)  :: self

        integer(ik) :: nnodes

        !if (.not. self%interpolation_initialized) call chidg_signal(FATAL,"reference_element%nnodes_i: interpolation has not been initialized.")

        !nnodes = size(self%val_e,1)
        nnodes = size(self%nodes_ie,1)

    end function nnodes_ie
    !*******************************************************************

    !>  Return number of nodes in the face interpolation node set.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/30/2017
    !!
    !-------------------------------------------------------------------
    pure function nnodes_if(self) result(nnodes)
        class(reference_element_t), intent(in)  :: self

        integer(ik) :: nnodes

        !if (.not. self%interpolation_initialized) call chidg_signal(FATAL,"reference_element%nnodes_i: interpolation has not been initialized.")

        !nnodes = size(self%val_f,1)
        nnodes = size(self%nodes_if,1)

    end function nnodes_if
    !*******************************************************************

    !>  Return number of terms in the linear projector.
    !!
    !!  NOTE: the number of terms in the linear projector matrix should
    !!        equal the number of nodes defined for the reference element.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/30/2017
    !!
    !-------------------------------------------------------------------
    function nterms_r(self) result(nterms)
        class(reference_element_t), intent(in)  :: self

        integer(ik) :: nterms

        if (.not. self%element_initialized) call chidg_signal(FATAL,"reference_element%nterms_r: reference element has not been initialized.")

        nterms = size(self%nodes_to_modes,1)

    end function nterms_r
    !*******************************************************************

    !>  Return number of terms the interpolators are contstructed for.
    !!
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   6/30/2017
    !!
    !-------------------------------------------------------------------
    function nterms_i(self) result(nterms)
        class(reference_element_t), intent(in)  :: self

        integer(ik) :: nterms

        if (.not. self%interpolation_initialized) call chidg_signal(FATAL,"reference_element%nterms_i: reference element interpolators have not been initialized.")

        nterms = size(self%val_e,2)

    end function nterms_i
    !*******************************************************************

end module type_reference_element


c............................................................rinvgj
      SUBROUTINE rinvgj(ainv,a,arraydim,n)
C   ********************************************************************
C   *                                                                  *
C   *                      AINV = A**(-1)                              *
C   *                                                                  *
C   *  invert A using the GAUSS-JORDAN - algorithm                     *
C   *  the 1- matrix is not set up and use is made of its structure    *
C   *                                                                  *
C   *                    REAL*8 VERSION                                *
C   *                                                                  *
C   ********************************************************************

      IMPLICIT NONE
c                                                        scan columns
C     .. Scalar Arguments ..
      INTEGER arraydim,n
C     ..
C     .. Array Arguments ..
      REAL a(arraydim,arraydim),ainv(arraydim,arraydim)
C     ..
C     .. Local Scalars ..
      REAL t,t1
      INTEGER icol,l,ll
C     ..
      DO 60 icol = 1,n
c                                               make A(ICOL,ICOL) = 1
         t1 = 1.0/a(icol,icol)
         DO 10 l = (icol+1),n
            a(icol,l) = a(icol,l)*t1
   10    CONTINUE
         DO 20 l = 1, (icol-1)
            ainv(icol,l) = ainv(icol,l)*t1
   20    CONTINUE
         ainv(icol,icol) = t1
c                                    make A(LL,ICOL) = 0 for LL<>ICOL
         DO 50 ll = 1,n
            IF (ll.NE.icol) THEN
               t = a(ll,icol)
               DO 30 l = (icol+1),n
                  a(ll,l) = a(ll,l) - a(icol,l)*t
   30          CONTINUE
               DO 40 l = 1, (icol-1)
                  ainv(ll,l) = ainv(ll,l) - ainv(icol,l)*t
   40          CONTINUE
               ainv(ll,icol) = -t1*t
            END IF
   50    CONTINUE
   60 CONTINUE
      RETURN
      END


! initialize.f90
! author: sunder

!-----------------------------------------------------------------------
! Allocate memory, initialize various data and also the initial
! condition
!-----------------------------------------------------------------------

subroutine initialize
    use ader_weno
    implicit none

    integer :: i, j, p, m, alpha, q, center, L, iGP
    double precision, dimension(0:N) :: phi_p, phi_m, phi
    double precision, dimension(N+1,N+1) :: MS, FRm
    double precision, dimension(nVar) :: q0
    double precision, dimension(N+1) :: phi_xi, phi_i
    double precision :: xiL, xiR, shift, xp, total

    ! Initialize basic stuff

    dx = (xR - xL)/REAL(IMAX)
    dt = CFL*dx
    time = 0.0d0
    timestep = 0
    nDOF = N+1

    if (mod(N,2) .eq. 0) then
        nStencils = 3
    else
        nStencils = 4
    end if

    nGhostCells = 2*(N+1) -1

    ! Allocate required memory

    allocate(  x(1-nGhostCells:IMAX+nGhostCells) )
    allocate(  uh(nVar, 1-nGhostCells:IMAX+nGhostCells) )
    allocate(  duh(nVar, IMAX) )
    allocate(  qbnd(nVar, 2, 0:IMAX+1) ) ! 2 corresponds to 2 faces per cell
    allocate(  Fbnd(nVar, 2, 0:IMAX+1) )
    allocate(  F(nVar, IMAX+1) )

    ! Initialize the grid

    do i = 1-nGhostCells, IMAX+nGhostCells
        x(i) = xL + (REAL(i)-0.5)*dx
    end do

    ! Basis functions

    xiL = 0.0d0
    xiR = 1.0d0

    allocate(  xGP(N+1) )
    allocate(  wGP(N+1) )
    allocate(  phiL(N+1) )
    allocate(  phiR(N+1) )

    call gauleg(xiL, xiR, xGP, wGP, N+1)

    ! Find the basis function values at the left and the right end of the unit cell

    do i = 1, N+1
        call lagrange_basis_values(i, xiL, phi)
        phiL(i) = phi(0)
        call lagrange_basis_values(i, xiR, phi)
        phiR(i) = phi(0)
    end do

    ! WENO Related data

    allocate (lin_wt(nStencils)) ! Calculate linear weights

    lin_wt(1) = lambda_s
    lin_wt(2) = lambda_s
    lin_wt(3) = lambda

    if (nStencils .eq. 4) then
        lin_wt(4) = lambda
    end if

    total = sum(lin_wt)

    lin_wt = lin_wt/total

    allocate( OS_M(N+1, N+1) ) ! Initialize the oscillation indicator matrix

    OS_M = 0.0d0

    do p = 1, N+1
        do m = 1, N+1
            do q = 1, N+1
                call lagrange_basis_values(p, xGP(q), phi_p)
                call lagrange_basis_values(m, xGP(q), phi_m)
                do alpha = 1, N
                    OS_M(p,m) = OS_M(p,m) + wGP(q)*phi_p(alpha)*phi_m(alpha)
                end do
            end do
        end do
    end do

    allocate( iMCL(N+1, N+1) ) ! Initialize center left stencil coefficient matrix
    allocate( iML(N+1, N+1) )  ! Initialize left-sided coefficient matrix
    allocate( iMCR(N+1, N+1) ) ! Initialize center right-sided coefficient matrix
    allocate( iMR(N+1, N+1) )  ! Initialize right-sided coefficient matrix

    ! Centered left side stencil

    MS = 0.0d0
    L = floor(real(N/2)) + 1

    do i = 1, N+1
        center = i - 1 - L
        do j = 1, N+1
            do q = 1, N+1
                shift = xGP(q) + DBLE(center)
                call lagrange_basis_values(j, shift, phi)
                MS(i,j) = MS(i,j) + wGP(q)*phi(0)
            end do
        end do
    end do

    call MatrixInverse(N+1,MS,iMCL)

    ! Centered right side stencil (Use this stencil for odd-ordered schemes)

    MS = 0.0d0
    L = floor(real(N/2))

    do i = 1, N+1
        center = i - 1 - L
        do j = 1, N+1
            do q = 1, N+1
                shift = xGP(q) + DBLE(center)
                call lagrange_basis_values(j, shift, phi)
                MS(i,j) = MS(i,j) + wGP(q)*phi(0)
            end do
        end do
    end do

    call MatrixInverse(N+1,MS,iMCR)

    ! Left sided stencil

    MS = 0.0d0
    L = N

    do i = 1, N+1
        center = i - 1 - L
        do j = 1, N+1
            do q = 1, N+1
                shift = xGP(q) + dble(center)
                call lagrange_basis_values(j, shift, phi)
                MS(i,j) = MS(i,j) + wGP(q)*phi(0)
            end do
        end do
    end do

    call MatrixInverse(N+1,MS,iML)

    ! Right sided stencil

    MS = 0.0d0
    L = 0

    do i = 1, N+1
        center = i - 1 - L
        do j = 1, N+1
            do q = 1, N+1
                shift = xGP(q) + DBLE(center)
                call lagrange_basis_values(j, shift, phi)
                MS(i,j) = MS(i,j) + wGP(q)*phi(0)
            end do
        end do
    end do

    call MatrixInverse(N+1,MS,iMR)

    ! ADER related data

    allocate( Kxi(N+1, N+1) ) ! Element stiffness matrix
    allocate( K1(N+1, N+1) ) ! Element stiffness matrix
    allocate( iK1(N+1, N+1) ) ! Element stiffness matrix
    allocate( F0(N+1) ) ! Time flux matrix

    Kxi = 0.0d0

    DO iGP = 1, N+1
        call BaseFunc1D(phi_i,phi_xi,xGP(iGP))
        DO i = 1, N+1
            DO j = 1, N+1
                Kxi(i,j) = Kxi(i,j) + wGP(iGP)*phi_xi(i)*phi_i(j)
            end do
        end do
    end do

    do i = 1, N+1
        do j = 1, N+1
            FRm(i,j) = phiR(i)*phiR(j)   ! Left contribution to the right flux matrix   (m = left  of the interface)
        end do
    end do

    ! The time flux matrices for the ADER-DG predictor method are given by the principle of upwinding in time (causality principle)
    K1 = FRm - Kxi ! upwinding in time = information comes from smaller times
    F0 = phiL   ! upwinding in time = information comes from smaller times
    call MatrixInverse(N+1,K1,iK1)

    ! Initialize the solution

    do i = 1, IMAX
        uh(:,i) = 0.0
        do q = 1, N+1
            xp = x(i) - 0.5d0*dx + dx*xGP(q)
            call initial_field(q0, xp)
            uh(:,i) = uh(:,i) + wGP(q)*q0
        end do
    end do

end subroutine initialize


!/home/zq822358/programming/ppvi/PVItoolbox

module pv_inversion

implicit none

contains

  subroutine balnc(fco, aps, ac, h, s, qe, tha, pe, part, thrs, maxx, maxxt,    &
                   omegs, omegh, nx, ny, nl)
  ! Calculates geopotential height and streamfunction by inverting an
  ! input pv field using the charney (1955) balance equation.

  !f2py      integer, intent(hide)    :: nx, ny, nl
  !f2py      real, intent(in)         :: fco(nx,ny)
  !f2py      real, intent(in)         :: aps(nx,ny)
  !f2py      real, intent(in)         :: ac(ny,5)
  !f2py      real, intent(inout)     :: h(nx,ny,nl)
  !f2py      real, intent(inout)     :: s(nx,ny,nl)
  !f2py      real, intent(inout)     :: qe(nx,ny,nl)
  !f2py      real, intent(inout)     :: tha(nx,ny,2)
  !f2py      real, intent(in)         :: pe(nl)
  !f2py      real, intent(in)         :: part
  !f2py      real, intent(in)         :: thrs
  !f2py      integer, intent(in)      :: maxx
  !f2py      integer, intent(in)      :: maxxt
  !f2py      real, intent(in)         :: omegs
  !f2py      real, intent(in)         :: omegh

  !-Input variables-------------------------------------------------------------
  ! Grid dimensions
  integer, intent(in) :: nx, ny, nl

  ! coriolis parameter
  real, intent(in) :: fco(nx,ny)

  ! ap ! cos(latitude)
  real, intent(in) :: aps(nx,ny)

  ! a  ! coefficients for 2-d laplacian operator
  real, intent(in) :: ac(ny,5)

  ! hz ! geopotential height
  real, intent(inout) :: h(nx,ny,nl)

  ! si ! streamfunction
  real, intent(inout) :: s(nx,ny,nl)

  ! q  ! pv (/0.01 pvu)
  real, intent(inout) :: qe(nx,ny,nl)

  ! tha(i,j,m)= boundary theta
  !    m=1 is lower boundary (midway between k=1    and k=2)
  !    m=2 is upper boundary (midway between k=nl-1 and k=nl)
  real, intent(inout) :: tha(nx,ny,2)

  ! pi ! exner function
  real, intent(in) :: pe(nl)

  ! prt ! relaxation parameter
  real, intent(in) :: part

  ! thr ! threshold parameter
  real, intent(in) :: thrs

  ! max ! maximum iterations
  real, intent(in) :: maxx

  ! maxt ! maximum cycles
  real, intent(in) :: maxxt

  ! omegas ! relaxation parameter for 2-d poisson equation
  real, intent(in) :: omegs

  ! omegah ! relaxation parameter for 3-d poisson equation
  real, intent(in) :: omegh

  !-Local variables-------------------------------------------------------------
      real :: mi,zm,rh(ny,nx,nl),zpl(ny,nx),zpp(ny),rs,gpts,            &
     &        stb(ny,nx,nl),asi(ny,nx,nl),bb(nl),bh(nl),bl(nl),         &
     &        vor,old(ny,nx,nl),dpi2(nl),nlco(ny,nx),coef(ny,nl),       &
     &        dh(ny,nx,nl),znl,rhs(ny,nx,nl),delh(ny,nx,nl),            &
     &        dsi(ny,nx,nl),vozro(nl),spzro(nl),maxhz(nl),              &
     &        minvor(nl),maxvor(nl),                                    &
     &        betas,dhmax,rha,rhst,sxx,sxy,syy,                         &
     &        zhl,zhp,zmrs,zl,zsl,zsp,zp

      integer :: i,J,K,igtz,ihm,iitot,iltz,insq,                        &
     &           itc,itc1,itcm,itcold,itct,jhm,khm

      logical :: it,icon

!-----------------------------------------------------------------------!
!                          start of subroutine                          !
!-----------------------------------------------------------------------!
      mi=9999.90
      gpts=float(ny*nx*(nl-2))

      iltz=0
      igtz=0
      insq=0
      itct=0
      itc1=0
      itc=0
      iitot=0
      itcold=0

      do k=1,nl
        vozro(k)=0.
        minvor(k)=100000.
        maxvor(k)=-100000.
      end do

      do i=2,ny-1
        zpp(i)=1./16.
        do  j=2,nx-1
          zpl(i,j)=1./(16.*aps(i,j)*aps(i,j))
          nlco(i,j)=2./( aps(i,j)*aps(i,j) )
        end do
      end do

      do k=1,nl
        bb(k)=0.
        bh(k)=0.
        bl(k)=0.
      end do

      do k=2,nl-1
        bb(k)=-2./( (pe(k+1)-pe(k))*(pe(k)-pe(k-1)) )
        bh(k)=2./( (pe(k+1)-pe(k))*(pe(k+1)-pe(k-1)) )
        bl(k)=2./( (pe(k)-pe(k-1))*(pe(k+1)-pe(k-1)) )
        dpi2(k)=(pe(k+1) - pe(k-1))/2.
        do i=1,ny
          coef(i,k)=ac(i,3)/bb(k)
        end do
      end do

      do k=1,nl
        maxhz(k)=0
      end do

      do k=1,nl
        do j=1,nx
          do i=1,ny
            old(i,j,k)=h(i,j,k)
            if (h(i,j,k)>maxhz(k)) then
              maxhz(k)=h(i,j,k)
            end if
          end do
        end do
      end do
!-----------------------------------------------------------------------!

  900 continue
      if (iitot == 0) go to 700
      itcm=0
      itc1=0
      do k=1,nl
        spzro(k)=0.
      end do

      do k=2,nl-1
        do j=2,nx-1
          do i=2,ny-1
            old(i,j,k)=s(i,j,k)
            if (k == 2) then
              old(i,j,1)=s(i,j,1)
            else if (k == nl-1) then
              old(i,j,nl)=s(i,j,nl)
            end if
            delh(i,j,k)= ac(i,1)*h(i-1,j,k) + ac(i,2)*h(i,j-1,k) +      &
     &                   ac(i,3)*h(i,j,k)   + ac(i,4)*h(i,j+1,k) +      &
     &                   ac(i,5)*h(i+1,j,k)

            stb(i,j,k)=bl(k)*h(i,j,k-1) + bh(k)*h(i,j,k+1) +            &
     &                 bb(k)*h(i,j,k)

            if (stb(i,j,k) <= 0.0001) then
              stb(i,j,k)=0.0001

!     modify boundary theta (k=2) or pv if static stability
!     becomes too small. theta becomes smaller; pv becomes larger
!     by a small amount (0.2 nondimensionally, which works out to
!     be perhaps a tenth of a degree K.

              if (k == 2) then
                tha(i,j,1)=tha(i,j,1)-0.2
              end if
              qe(i,j,k)=qe(i,j,k) + 0.2/(pe(k)-pe(k+1))
              spzro(k)=spzro(k) + 1
            end if
            sxx=s(i,j+1,k) + s(i,j-1,k) - 2.*s(i,j,k)
            syy=s(i-1,j,k) + s(i+1,j,k) - 2.*s(i,j,k)
            sxy=( s(i-1,j+1,k) - s(i-1,j-1,k) -                         &
     &            s(i+1,j+1,k) + s(i+1,j-1,k)  )/4.
            betas=0.25*((fco(i-1,j)-fco(i+1,j))*                        &
     &                  (s(i-1,j,k)-s(i+1,j,k)) +                       &
     &                  (fco(i,j+1)-fco(i,j-1))*                        &
     &                  (s(i,j+1,k)-s(i,j-1,k)) )
            zhp=h(i-1,j,k+1)-h(i+1,j,k+1)-h(i-1,j,k-1)+h(i+1,j,k-1)
            zhl=h(i,j+1,k+1)-h(i,j-1,k+1)-h(i,j+1,k-1)+h(i,j-1,k-1)
            zsp=s(i-1,j,k+1)-s(i+1,j,k+1)-s(i-1,j,k-1)+s(i+1,j,k-1)
            zsl=s(i,j+1,k+1)-s(i,j-1,k+1)-s(i,j+1,k-1)+s(i,j-1,k-1)
            zl=zpl(i,j)*zhl*zsl/(dpi2(k)*dpi2(k))
            zp=zpp(i)*zhp*zsp/(dpi2(k)*dpi2(k))
            znl=nlco(i,j)*( sxx*syy - sxy*sxy ) + betas
            rhst = qe(i,j,k) - fco(i,j)*stb(i,j,k) + delh(i,j,k) -      &
     &             znl + zl + zp
            rhs(i,j,k)=rhst/(fco(i,j) + stb(i,j,k))

          end do
        end do
      end do

  23  format(f6.0,' neg stabilities.')
      do k=1,nl
        spzro(k)=0.
      end do

!*************iteration for psi **********************
      do k=2,nl-1
        itc=0
  800   continue
        it=.true.
        do j=2,nx-1
          do i=2,ny-1
            rs = ac(i,1)*s(i-1,j,k) + ac(i,2)*s(i,j-1,k) +              &
     &           ac(i,3)*s(i,j,k)   + ac(i,4)*s(i,j+1,k) +              &
     &           ac(i,5)*s(i+1,j,k) - rhs(i,j,k)
            dsi(i,j,k)=-omegs*rs/ac(i,3)
            s(i,j,k) = s(i,j,k) + dsi(i,j,k)
!*******check accuracy criterion *******************************
            if (abs(dsi(i,j,k)) > thrs) then
              it=.false.
            end if
          end do
        end do

        itc=itc+1
        if (it) then
          icon=.true.
          if (itc > itcm) itcm=itc
          if (itc == 1) itc1=itc1 + 1
        else
          if (itc < maxx) then
            go to 800
          else
            icon=.true.
          end if
        end if
      end do

      if (iitot > 0) then
        itct=itct + itcm
        do k=1,nl
          do j=2,nx-1
            do i=2,ny-1
              s(i,j,k)=part*s(i,j,k) + (1.-part)*old(i,j,k)
              old(i,j,k)=h(i,j,k)
            end do
          end do
        end do
      end if

!*************calculate the rhs of bal-pv eQuation (phi,h) ************

  700 continue
      do k=2,nl-1
        do j=2,nx-1
          do i=2,ny-1
            vor = ac(i,1)*s(i-1,j,k) + ac(i,2)*s(i,j-1,k) +             &
     &            ac(i,3)*s(i,j,k)   + ac(i,4)*s(i,j+1,k) +             &
     &            ac(i,5)*s(i+1,j,k)
            if (vor <= minvor(k)) then
              minvor(k)=vor
            end if
            if (vor >= maxvor(k)) then
              maxvor(k)=vor
            end if
            if (vor <= 0.0001-fco(i,j)) then
              vor = (0.0001 - fco(i,j))
!     increase pv where absolute vorticity is too small. similar to
!     case where stratification is too small.
              qe(i,j,k)=qe(i,j,k) + 0.01
              vozro(k)=vozro(k) + 1
            end if
            asi(i,j,k)=fco(i,j) + vor
            sxx=s(i,j+1,k)+s(i,j-1,k)-2.*s(i,j,k)
            syy=s(i-1,j,k)+s(i+1,j,k)-2.*s(i,j,k)
            sxy=( s(i-1,j+1,k) - s(i-1,j-1,k) -                         &
     &            s(i+1,j+1,k) + s(i+1,j-1,k)  )/4.
            zhp=h(i-1,j,k+1)-h(i+1,j,k+1)-h(i-1,j,k-1)+h(i+1,j,k-1)
            zhl=h(i,j+1,k+1)-h(i,j-1,k+1)-h(i,j+1,k-1)+h(i,j-1,k-1)
            zsp=s(i-1,j,k+1)-s(i+1,j,k+1)-s(i-1,j,k-1)+s(i+1,j,k-1)
            zsl=s(i,j+1,k+1)-s(i,j-1,k+1)-s(i,j+1,k-1)+s(i,j-1,k-1)
            zl=zpl(i,j)*zhl*zsl/(dpi2(k)*dpi2(k))
            zp=zpp(i)*zhp*zsp/(dpi2(k)*dpi2(k))
            betas=0.25*(                                                &
     &                  ( fco(i-1,j) - fco(i+1,j) )*                    &
     &                  ( s(i-1,j,k) - s(i+1,j,k) ) +                   &
     &                  ( fco(i,j+1) - fco(i,j-1) )*                    &
     &                  ( s(i,j+1,k) - s(i,j-1,k) ) )
            rha=fco(i,j)*vor + nlco(i,j)*(sxx*syy - sxy*sxy) + betas
            rh(i,j,k)=rha + qe(i,j,k) + zl + zp

          end do
        end do
      end do

  24  format(i11,2f11.3,f6.0,' neg abs vorticities in phi eQ.')
      do k=1,nl
        vozro(k)=0.
      end do

!*************solve for h at each level *****************

      itc=0
  701 it=.true.
      zmrs=0.
      do k=2,nl-1
        do j=2,nx-1
          do i=2,ny-1
            if (k == 2) then
              rs = ac(i,1)*h(i-1,j,k) +                                 &
     &             ac(i,2)*h(i,j-1,k) +                                 &
     &            (ac(i,3) + asi(i,j,k)*(bb(k)+bl(k)) )*h(i,j,k) +      &
     &             ac(i,4)*h(i,j+1,k) +                                 &
     &             ac(i,5)*h(i+1,j,k) +                                 &
     &             asi(i,j,k)*(bh(k)*h(i,j,k+1) +                       &
     &             tha(i,j,1)/dpi2(k)) - rh(i,j,k)
              zm = h(i,j,k)
              h(i,j,k) = zm - omegh*rs/(ac(i,3) +                       &
     &                                  asi(i,j,k)*(bb(k)+bl(k)))

            else if (k == nl-1) then
              rs = ac(i,1)*h(i-1,j,k) +                                 &
     &             ac(i,2)*h(i,j-1,k) +                                 &
     &            (ac(i,3) + asi(i,j,k)*(bb(k)+bh(k)) )*h(i,j,k) +      &
     &             ac(i,4)*h(i,j+1,k) +                                 &
     &             ac(i,5)*h(i+1,j,k) +                                 &
     &             asi(i,j,k)*(bl(k)*h(i,j,k-1) -                       &
     &             tha(i,j,2)/dpi2(k)) - rh(i,j,k)
              zm = h(i,j,k)
              h(i,j,k) = zm - omegh*rs/(ac(i,3) +                       &
     &                                  asi(i,j,k)*(bb(k)+bh(k)))

            else
              rs = ac(i,1)*h(i-1,j,k) +                                 &
     &             ac(i,2)*h(i,j-1,k) +                                 &
     &            (ac(i,3) + asi(i,j,k)*bb(k) )*h(i,j,k) +              &
     &             ac(i,4)*h(i,j+1,k) +                                 &
     &             ac(i,5)*h(i+1,j,k) +                                 &
     &             asi(i,j,k)*( bh(k)*h(i,j,k+1) +                      &
     &                          bl(k)*h(i,j,k-1) ) -                    &
     &             rh(i,j,k)
              zm = h(i,j,k)
              h(i,j,k) = zm - omegh*rs/(ac(i,3) +                       &
     &                                  asi(i,j,k)*bb(k))
            end if
            dh(i,j,k)=h(i,j,k) - zm
            zmrs=zmrs + abs(dh(i,j,k))
            if (abs(dh(i,j,k)) > thrs) then
              it=.false.
            end if

          end do
        end do
      end do

      if (amod(float(itc),5.) == 0) then
        dhmax=thrs/10.
        zmrs=zmrs/gpts
        do k=2,nl-1
          do j=2,nx-1
            do i=2,ny-1
              if (abs(dh(i,j,k)) > dhmax) then
                dhmax=abs(dh(i,j,k))
                ihm=i
                jhm=j
                khm=k
              end if
            end do
          end do
        end do

  716   format(2e9.2,3i5,f8.3)
      end if
      zmrs=0.

      itc=itc+1
      if (it) then
        itct=itct + itc
        do j=1,nx
          do i=1,ny
            h(i,j,1) = h(i,j,2) + tha(i,j,1)*(pe(2)-pe(1))
            s(i,j,1) = s(i,j,2) + tha(i,j,1)*(pe(2)-pe(1))
            h(i,j,nl) = h(i,j,nl-1) - tha(i,j,2)*(pe(nl)-pe(nl-1))
            s(i,j,nl) = s(i,j,nl-1) - tha(i,j,2)*(pe(nl)-pe(nl-1))
          end do
        end do

        if (iitot > 0) then
          do k=1,nl
            do j=2,nx-1
              do i=2,ny-1
                h(i,j,k)=part*h(i,j,k) + (1.-part)*old(i,j,k)
              end do
            end do
          end do
        end if
        if ( (itc > itcold+10).and.(iitot > 30) ) then
          print*,'started diverging'
          go to 901
        end if
        itcold=itc
        if ((itc == 1).and.(itc1 == nl-2)) then
          print*,'total convergence.'
        else
          iitot=iitot + 1
  22      format(i4,' total iteration(s).')
          if (iitot > maxxt) then
            print*,'too many total iterations.'
            go to 901
          else
            go to 900
          end if
        end if
      else
        if (itc < maxx) then
          go to 701
        else
          print*,'too many iterations for hght.'
          icon=.false.
          go to 901
        end if
      end if
!*******************************************************
 901  return
      end subroutine balnc

end module pv_inversion


C
C FFTPACKAGE FOR PSEUDOSPECTRAL ADVECTION CALCULATIONS   05/04/84
C
C PURPOSE  THIS PACKAGE CONSISTS OF PROGRAMS WHICH PERFORM FAST FOURIER
C          TRANSFORMS FOR BOTH COMPLEX AND REAL PERIODIC SEQUENCES AND
C          CERTIAN OTHER SYMMETRIC SEQUENCES THAT ARE LISTED BELOW.
C
C            RFFTI     INITIALIZE  RFFTF AND RFFTB
C            RFFTF     FORWARD TRANSFORM OF A REAL PERIODIC SEQUENCE
C            RFFTB     BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY
C
C     ******************************************************************
C
C     SUBROUTINE RFFTI(N,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE RFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C     BOTH RFFTF AND RFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH
C     A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C     STORED IN WSAVE.
C
C     INPUT PARAMETER
C
C     N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED.
C
C     OUTPUT PARAMETER
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.
C             THE SAME WORK ARRAY CAN BE USED FOR BOTH RFFTF AND RFFTB
C             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS
C             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF
C             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF RFFTF OR RFFTB.
C
C     ******************************************************************
C
C     SUBROUTINE RFFTF(N,R,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE RFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL
C     PERODIC SEQUENCE (FOURIER ANALYSIS). THE TRANSFORM IS DEFINED
C     BELOW AT OUTPUT PARAMETER R.
C
C     INPUT PARAMETERS
C
C     N       THE LENGTH OF THE ARRAY R TO BE TRANSFORMED.  THE METHOD
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C             N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED
C
C     R       A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C             TO BE TRANSFORMED
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.
C             IN THE PROGRAM THAT CALLS RFFTF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB.
C
C
C     OUTPUT PARAMETERS
C
C     R       R(1) = THE SUM FROM I=1 TO I=N OF R(I)
C
C             IF N IS EVEN SET L =N/2   , IF N IS ODD SET L = (N+1)/2
C
C               THEN FOR K = 2,...,L
C
C                  R(2*K-2) = THE SUM FROM I = 1 TO I = N OF
C
C                       R(I)*COS((K-1)*(I-1)*2*PI/N)
C
C                  R(2*K-1) = THE SUM FROM I = 1 TO I = N OF
C
C                      -R(I)*SIN((K-1)*(I-1)*2*PI/N)
C
C             IF N IS EVEN
C
C                  R(N) = THE SUM FROM I = 1 TO I = N OF
C
C                       (-1)**(I-1)*R(I)
C
C      *****  NOTE
C                  THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF
C                  FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT
C                  SEQUENCE BY N.
C
C     WSAVE   CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN
C             CALLS OF RFFTF OR RFFTB.
C
C
C     ******************************************************************
C
C     SUBROUTINE RFFTB(N,R,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE RFFTB COMPUTES THE REAL PERODIC SEQUENCE FROM ITS
C     FOURIER COEFFICIENTS (FOURIER SYNTHESIS). THE TRANSFORM IS DEFINED
C     BELOW AT OUTPUT PARAMETER R.
C
C     INPUT PARAMETERS
C
C     N       THE LENGTH OF THE ARRAY R TO BE TRANSFORMED.  THE METHOD
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C             N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED
C
C     R       A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C             TO BE TRANSFORMED
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.
C             IN THE PROGRAM THAT CALLS RFFTB. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB.
C
C
C     OUTPUT PARAMETERS
C
C     R       FOR N EVEN AND FOR I = 1,...,N
C
C                  R(I) = R(1)+(-1)**(I-1)*R(N)
C
C                       PLUS THE SUM FROM K=2 TO K=N/2 OF
C
C                        2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                       -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C             FOR N ODD AND FOR I = 1,...,N
C
C                  R(I) = R(1) PLUS THE SUM FROM K=2 TO K=(N+1)/2 OF
C
C                       2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                      -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C      *****  NOTE
C                  THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF
C                  FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT
C                  SEQUENCE BY N.
C
C     WSAVE   CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN
C             CALLS OF RFFTB OR RFFTF.
      SUBROUTINE RFFTI (N,WSAVE)
      DIMENSION       WSAVE(*)
CX30127 CALL SBINX (127)
CY30127 CALL SBINY (127)
      IF (N .EQ. 1) THEN
CX40128 CALL SBOUTX (128)
CY40128 CALL SBOUTY (128)
      RETURN
      ENDIF
c      CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
CX40128 CALL SBOUTX (128)
CY40128 CALL SBOUTY (128)
      RETURN
      END


C NCLFORTSTART
      SUBROUTINE DWGTVOLRMSE(T,Q,WGTZ,WGTY,WGTX,MX,NY,KZ,TMSG,QMSG,
     +                       IFLAG,RMSE)
      IMPLICIT NONE
      INTEGER MX,NY,KZ,IFLAG
      DOUBLE PRECISION T(MX,NY,KZ),Q(MX,NY,KZ)
      DOUBLE PRECISION WGTX(MX),WGTY(NY),WGTZ(KZ)
      DOUBLE PRECISION TMSG,QMSG
      DOUBLE PRECISION RMSE
C NCLEND

C NCL: rmsqTQ = wgtVolRmse (T,Q,wgtz,wgty,wgtx,flag)
C compute the weighted root-mean-square-difference [rmse]
c .   This could have been programmed more efficiently.

      INTEGER NL,ML,KL,KMSG
      DOUBLE PRECISION SUMD,SUMW,WGTXY,SUMTQ,SUMWZ,VARTQ

C Nomenclature:
C INPUT:
C t      - 3D array
C q      - 3D array
C wgtz   - 1D array of length "kz"
C wgty   - 1D array of length "ny"
C wgtx   - 1D array of length "mx"
C mx     - 1st [fastest varying] dimension of "t" [eg, longitude]
C ny     - 2nd                   dimension of "t" [eg, latitude ]
C kz     - 3rd [slowest varying] dimension of "t" [eg, latitude ]
c tmsg   - msg value
c qmsg   - msg value
C iflag  - flag
C          =0 compute  rmse ignoring msg values
C          =1 if any msg data is encountered return as msg

C OUTPUT:
C rmse   - volume root-mean-square-difference [weighted]

      SUMD = 0.0D0
      SUMW = 0.0D0
      RMSE = TMSG
      KMSG = 0

      DO NL = 1,NY
          DO ML = 1,MX
              SUMTQ = 0
              SUMWZ = 0.0D0
c                                     sum wgted vertical differences
c                                     at each lat/lon point
              DO KL = 1,KZ
                  IF (T(ML,NL,KL).NE.TMSG .AND.
     +                Q(ML,NL,KL).NE.QMSG) THEN
                      SUMTQ = SUMTQ + WGTZ(KL)*
     +                        (T(ML,NL,KL)-Q(ML,NL,KL))**2
                      SUMWZ = SUMWZ + WGTZ(KL)
                  ELSE
                      KMSG = KMSG + 1
                  END IF
              END DO
c                                      return if user desired
              IF (IFLAG.EQ.1 .AND. KMSG.NE.0) RETURN
c                            wgt vertical mean square difference
c                            by areal wgts x/lon and y/lat
              IF (SUMWZ.GT.0.0D0) THEN
                  VARTQ = (SUMTQ/SUMWZ)
                  WGTXY = WGTX(ML)*WGTY(NL)
                  SUMD  = SUMD + WGTXY*VARTQ
                  SUMW = SUMW + WGTXY
              END IF

          END DO
      END DO
c                          compute wgted rmse
      IF (SUMW.GT.0.0D0) THEN
          RMSE = SQRT(SUMD/SUMW)
      END IF

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DWGTVOLRMSECCM(T,Q,DPT,DPQ,WGTY,WGTX,MX,NY,KZ,TMSG,
     +                         QMSG,IFLAG,RMSE)
      IMPLICIT NONE
      INTEGER MX,NY,KZ,IFLAG
      DOUBLE PRECISION T(MX,NY,KZ),Q(MX,NY,KZ)
      DOUBLE PRECISION WGTX(MX),WGTY(NY)
      DOUBLE PRECISION DPT(MX,NY,KZ),DPQ(MX,NY,KZ)
      DOUBLE PRECISION TMSG,QMSG
      DOUBLE PRECISION RMSE
C NCLEND

C NCL: rmsqTQ = wgtVolRmse_ccm (T,Q,dpT,dpQ,wgty,wgtx,flag)
C compute the weighted root-mean-square-difference [rmse]
c .   This could have been programmed more efficiently.

      INTEGER NL,ML,KL,KMSG
      DOUBLE PRECISION SUMD,SUMW,WGTXY,SUMTQ,SUMDP,WGTDP,VARTQ

C Nomenclature:
C INPUT:
C t      - 3D array
C q      - 3D array
C dpt    - 3D array same size as "t" and "q"
C dpq    - 3D array same size as "t" and "q"
C wgty   - 1D array of length "ny"
C wgtx   - 1D array of length "mx"
C mx     - 1st [faster varying] dimension of "t" [eg, longitude]
C ny     - 2nd [slower varying] dimension of "t" [eg, latitude ]
C kz     - 3rd [slower varying] dimension of "t" [eg, latitude ]
c tmsg   - msg value
c qmsg   - msg value
C iflag  - flag
C          =0 compute  rmse ignoring msg values
C          =1 if any msg data is encountered return as msg

C OUTPUT:
C rmse   - volume root-mean-square-difference [weighted]
C          Dave Williamson suggested the use of the mean "dp"

      SUMD = 0.0D0
      SUMW = 0.0D0
      RMSE = TMSG
      KMSG = 0

      DO NL = 1,NY
          DO ML = 1,MX
              SUMTQ = 0.0D0
              SUMDP = 0.0D0
c                                     sum wgted vertical differences
c                                     at each lat/lon point
              DO KL = 1,KZ
                  IF (T(ML,NL,KL).NE.TMSG .AND.
     +                Q(ML,NL,KL).NE.QMSG) THEN
                      WGTDP = 0.5D0* (DPT(ML,NL,KL)+DPQ(ML,NL,KL))
                      SUMTQ = SUMTQ + WGTDP*(T(ML,NL,KL)-Q(ML,NL,KL))**2
                      SUMDP = SUMDP + WGTDP
                  ELSE
                      KMSG = KMSG + 1
                  END IF
              END DO
c                                      return if user desired
              IF (IFLAG.EQ.1 .AND. KMSG.NE.0) RETURN
c                        wgt vertical mean square difference
c                        by areal wgts x/lon and y/lat
              IF (SUMDP.GT.0.0D0) THEN
                  VARTQ = SUMTQ/SUMDP
                  WGTXY = WGTX(ML)*WGTY(NL)
                  SUMD  = SUMD + WGTXY*VARTQ
                  SUMW  = SUMW + WGTXY
              END IF

          END DO
      END DO
c                          compute wgted rmse
      IF (SUMW.GT.0.0D0) THEN
          RMSE = SQRT(SUMD/SUMW)
      END IF

      RETURN
      END


!
!  Written by Leandro Martínez, 2009-2011.
!  Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez,
!  Ernesto G. Birgin.
!
! Subroutine eulerrmat: Computes the rotation matrix from the
!                       Euler angles
!
! Note that:
! In this routine, beta is a rotation about the y-axis
!                  gama is a rotation about the z-axis
!                  teta is a rotation about the x-axis

subroutine eulerrmat(beta,gama,teta,v1,v2,v3)

  implicit none
  double precision :: beta, gama, teta
  double precision :: cb, sb, cg, sg, ct, st
  double precision :: v1(3), v2(3), v3(3)

  cb = dcos(beta)
  sb = dsin(beta)
  cg = dcos(gama)
  sg = dsin(gama)
  ct = dcos(teta)
  st = dsin(teta)

  v1(1)=-sb * sg * ct + cb * cg
  v1(2)=-sb * cg * ct - cb * sg
  v1(3)= sb * st

  v2(1)= cb * sg * ct + sb * cg
  v2(2)= cb * cg * ct - sb * sg
  v2(3)=-cb * st

  v3(1)= sg * st
  v3(2)= cg * st
  v3(3)= ct

  return
end subroutine eulerrmat

!
! Subroutine compcart: Compute cartesian coordinates using
!                      the center of mass, the canonical coordinates
!                      and the rotation matrix
!

subroutine compcart(icart,xbar,ybar,zbar,&
                    xcoor,ycoor,zcoor,v1,v2,v3)

  use compute_data, only : xcart
  implicit none
  integer :: icart
  double precision :: xbar, ybar, zbar
  double precision :: xcoor, ycoor, zcoor
  double precision :: v1(3), v2(3), v3(3)

  xcart(icart,1) = xbar + xcoor*v1(1) + ycoor*v2(1) + zcoor*v3(1)
  xcart(icart,2) = ybar + xcoor*v1(2) + ycoor*v2(2) + zcoor*v3(2)
  xcart(icart,3) = zbar + xcoor*v1(3) + ycoor*v2(3) + zcoor*v3(3)

  return
end subroutine compcart

!
! Subroutine eulerfixed: This routine was added because it defines
!                        the rotation in the "human" way, an is thus used
!                        to set the position of the fixed molecules.
!     That means: beta is a counterclockwise rotation around x axis.
!                 gama is a counterclockwise rotation around y axis.
!                 teta is a counterclockwise rotation around z axis.
!     The other routine should better do this as well, but then we need to change
!     all the derivative calculations, just for the sake of human interpretation
!     of the rotation which, in that case, is not really important. Maybe some day.
!

subroutine eulerfixed(beta,gama,teta,v1,v2,v3)

  implicit none
  double precision :: beta, gama, teta
  double precision :: c1, s1, c2, s2, c3, s3
  double precision :: v1(3), v2(3), v3(3)

  c1 = dcos(beta)
  s1 = dsin(beta)
  c2 = dcos(gama)
  s2 = dsin(gama)
  c3 = dcos(teta)
  s3 = dsin(teta)

  v1(1) = c2*c3
  v1(2) = c1*s3 + c3*s1*s2
  v1(3) = s1*s3 - c1*c3*s2

  v2(1) = -c2*s3
  v2(2) = c1*c3 - s1*s2*s3
  v2(3) = c1*s2*s3 + c3*s1

  v3(1) = s2
  v3(2) = -c2*s1
  v3(3) = c1*c2

  return
end subroutine eulerfixed


! File flaplace90_arrays.f90
! Author: Ramon Crehuet
subroutine timestep(u,n,m,dx,dy,error)
implicit none
real (kind=8), dimension(0:n-1,0:m-1), intent(inout):: u

real (kind=8), intent(in) :: dx,dy
real (kind=8), intent(out) :: error
integer, intent(in) :: n,m
real (kind=8), dimension(0:n-1,0:m-1) :: diff
real (kind=8) :: dx2,dy2,dnr_inv

!f2py intent(in) :: dx,dy
!f2py intent(in,out) :: u
!f2py intent(out) :: error
!f2py intent(hide) :: n,m

dx2 = dx*dx
dy2 = dy*dy
dnr_inv = 0.5d0 / (dx2+dy2)

diff=u

u(1:n-2, 1:m-2) = ((u(0:n-3, 1:m-2) + u(2:n-1, 1:m-2))*dy2 + &
                         (u(1:n-2,0:m-3) + u(1:n-2, 2:m-1))*dx2)*dnr_inv

error=sqrt(sum((u-diff)**2))

end subroutine