!>
!! @file m_grid.f90
!! @brief Contains module m_grid

!> @brief  This module takes care of creating the rectilinear grid on which
!!              the data for the initial condition will be laid out and on which
!!              the simulation will eventually be computed. The grid may either
!!              be uniform or non-uniform. Non-uniform grids are generated using
!!              the hyperbolic tangent function, see Johnsen (2007) for details.
!!              Alternatively to synthesizing a new grid, the user may select to
!!              read in a preexisting one. This is carried out through the module
!!              m_start_up.f90. In such a case, the responsibility of this module
!!              becomes only to allocate/deallocate the necessary grid variables
!!              for the cell-centers and cell-boundaries locations.
MODULE m_grid

    ! Dependencies =============================================================
    USE m_derived_types         ! Definitions of the derived types

    USE m_global_parameters     ! Global parameters for the code

    USE m_mpi_proxy             ! Message passing interface (MPI) module proxy

    USE mpi                     ! Message passing interface (MPI) module
    ! ==========================================================================

    IMPLICIT NONE

    PRIVATE; PUBLIC :: s_initialize_grid_module, &
                       s_generate_grid, &
                       s_generate_serial_grid, &
                       s_generate_parallel_grid, &
                       s_finalize_grid_module

    ABSTRACT INTERFACE ! ===================================================

        SUBROUTINE s_generate_abstract_grid(dflt_int) ! ------------------------

            INTEGER, INTENT(IN) :: dflt_int

        END SUBROUTINE s_generate_abstract_grid ! ----------------------

    END INTERFACE ! ========================================================

    PROCEDURE(s_generate_abstract_grid), POINTER :: s_generate_grid => NULL()

    CONTAINS

        !> The following subroutine generates either a uniform or
        !!              non-uniform rectilinear grid in serial, defined by the parameters
        !!              inputted by the user. The grid information is stored in
        !!              the grid variables containing coordinates of the cell-
        !!              centers and cell-boundaries.
        !! @param dflt_int is the default null integer used for checking initializationss
        SUBROUTINE s_generate_serial_grid(dflt_int) ! -----------------------------------------

            INTEGER, INTENT(IN) :: dflt_int

            ! Generic loop iterator
            INTEGER :: i,j              !< generic loop operatorss
            REAL(KIND(0d0)) :: length   !< domain lengths

            ! Grid Generation in the x-direction ===============================
            dx = (x_domain%end - x_domain%beg) / REAL(m+1, KIND(0d0))

            DO i = 0, m
                x_cc( i ) = x_domain%beg + 5d-1*dx*REAL(2*i+1, KIND(0d0))
                x_cb(i-1) = x_domain%beg +      dx*REAL(  i  , KIND(0d0))
            END DO

            x_cb(m) = x_domain%end

            IF(stretch_x) THEN

                length = abs(x_cb(m)-x_cb(0))
                x_cb = x_cb / length
                x_a = x_a / length
                x_b = x_b / length

                DO j = 1, loops_x
                    DO i = -1, m
                        x_cb(i) = x_cb(i) / a_x * &
                                ( a_x + LOG(COSH(  a_x*(x_cb(i) - x_a)  )) &
                                      + LOG(COSH(  a_x*(x_cb(i) - x_b)  )) &
                                  - 2d0*LOG(COSH( 0.5d0*a_x*(x_b - x_a) )) )
                    END DO
                END DO
                x_cb = x_cb * length

                x_cc = (x_cb(0:m) + x_cb(-1:m-1))/2d0

                dx = MINVAL(x_cb(0:m) - x_cb(-1:m-1))
                print*, 'Stretched grid: min/max x grid: ', minval(x_cc(:)), maxval(x_cc(:))
                IF(num_procs > 1) CALL s_mpi_reduce_min(dx)

            END IF
            ! ==================================================================

            ! Grid Generation in the y-direction ===============================
            IF(n == 0) RETURN

            IF (grid_geometry == 2.AND.y_domain%beg.eq.0.0d0) THEN
            !IF (grid_geometry == 2) THEN

               dy = (y_domain%end - y_domain%beg) / REAL(2*n+1, KIND(0d0))

               y_cc(0)  = y_domain%beg + 5d-1*dy
               y_cb(-1) = y_domain%beg

               DO i = 1, n
                   y_cc( i ) = y_domain%beg + 2d0*dy*REAL(  i  , KIND(0d0))
                   y_cb(i-1) = y_domain%beg +     dy*REAL(2*i-1, KIND(0d0))
               END DO

            ELSE

               dy = (y_domain%end - y_domain%beg) / REAL(n+1, KIND(0d0))

               DO i = 0, n
                   y_cc( i ) = y_domain%beg + 5d-1*dy*REAL(2*i+1, KIND(0d0))
                   y_cb(i-1) = y_domain%beg +      dy*REAL(  i  , KIND(0d0))
               END DO

            END IF

            y_cb(n) = y_domain%end

            IF(stretch_y) THEN

                DO j = 1, loops_y
                    DO i = -1, n
                        y_cb(i) = y_cb(i) / a_y * &
                                ( a_y + LOG(COSH(  a_y*(y_cb(i) - y_a)  )) &
                                      + LOG(COSH(  a_y*(y_cb(i) - y_b)  )) &
                                  - 2d0*LOG(COSH( 0.5d0*a_y*(y_b - y_a) )) )
                    END DO
                END DO

                y_cc = (y_cb(0:n) + y_cb(-1:n-1))/2d0

                dy = MINVAL(y_cb(0:n) - y_cb(-1:n-1))

                IF(num_procs > 1) CALL s_mpi_reduce_min(dy)

            END IF
            ! ==================================================================

            ! Grid Generation in the z-direction ===============================
            IF(p == 0) RETURN

            dz = (z_domain%end - z_domain%beg) / REAL(p+1, KIND(0d0))

            DO i = 0, p
                z_cc( i ) = z_domain%beg + 5d-1*dz*REAL(2*i+1, KIND(0d0))
                z_cb(i-1) = z_domain%beg +      dz*REAL(  i  , KIND(0d0))
            END DO

            z_cb(p) = z_domain%end

            IF(stretch_z) THEN

                DO j = 1, loops_z
                    DO i = -1, p
                        z_cb(i) = z_cb(i) / a_z * &
                                ( a_z + LOG(COSH(  a_z*(z_cb(i) - z_a)  )) &
                                      + LOG(COSH(  a_z*(z_cb(i) - z_b)  )) &
                                  - 2d0*LOG(COSH( 0.5d0*a_z*(z_b - z_a) )) )
                    END DO
                END DO

                z_cc = (z_cb(0:p) + z_cb(-1:p-1))/2d0

                dz = MINVAL(z_cb(0:p) - z_cb(-1:p-1))

                IF(num_procs > 1) CALL s_mpi_reduce_min(dz)

            END IF
            ! ==================================================================

        END SUBROUTINE s_generate_serial_grid ! ---------------------------------------

        !> The following subroutine generates either a uniform or
        !!              non-uniform rectilinear grid in parallel, defined by the parameters
        !!              inputted by the user. The grid information is stored in
        !!              the grid variables containing coordinates of the cell-
        !!              centers and cell-boundaries.
        !! @param dflt_int is she default null integer used for checking initializationss
        SUBROUTINE s_generate_parallel_grid(dflt_int) !-------------------------

            INTEGER, INTENT(IN) :: dflt_int

            ! Locations of cell boundaries
            REAL(KIND(0d0)), ALLOCATABLE, DIMENSION(:) :: x_cb_glb, y_cb_glb, z_cb_glb !<
            !! Locations of cell boundaries

            CHARACTER(LEN = path_len + name_len) :: file_loc !<
            !! Generic string used to store the address of a file

            INTEGER :: ifile, ierr, data_size
            INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status

            INTEGER :: i,j !< Generic loop integers

            ALLOCATE(x_cb_glb(-1:m_glb))
            ALLOCATE(y_cb_glb(-1:n_glb))
            ALLOCATE(z_cb_glb(-1:p_glb))

            ! Grid generation in the x-direction
            dx = (x_domain%end - x_domain%beg) / REAL(m_glb+1, KIND(0d0))
            DO i = 0, m_glb
                x_cb_glb(i-1) = x_domain%beg + dx*REAL(i,KIND(0d0))
            END DO
            x_cb_glb(m_glb) = x_domain%end
            IF (stretch_x) THEN
                DO j = 1, loops_x
                    DO i = -1, m_glb
                        x_cb_glb(i) = x_cb_glb(i) / a_x * &
                            (a_x + LOG(COSH( a_x*(x_cb_glb(i) - x_a))) &
                                 + LOG(COSH( a_x*(x_cb_glb(i) - x_b))) &
                             - 2d0*LOG(COSH(0.5d0*a_x*(x_b - x_a))) )
                    END DO
                END DO
            END IF

            ! Grid generation in the y-direction
            IF (n_glb > 0) THEN

                IF (grid_geometry == 2.AND.y_domain%beg.eq.0.0d0) THEN
                    dy = (y_domain%end - y_domain%beg) / REAL(2*n_glb+1, KIND(0d0))
                    y_cb_glb(-1) = y_domain%beg
                    DO i = 1, n_glb
                        y_cb_glb(i-1) = y_domain%beg +  dy*REAL(2*i-1, KIND(0d0))
                    END DO
                ELSE
                    dy = (y_domain%end - y_domain%beg) / REAL(n_glb+1, KIND(0d0))
                    DO i = 0, n_glb
                        y_cb_glb(i-1) = y_domain%beg + dy*REAL(i, KIND(0d0))
                    END DO
                END IF
                y_cb_glb(n_glb) = y_domain%end
                IF (stretch_y) THEN
                    DO j = 1, loops_y
                        DO i = -1, n_glb
                            y_cb_glb(i) = y_cb_glb(i) / a_y * &
                                (a_y + LOG(COSH( a_y*(y_cb_glb(i) - y_a))) &
                                     + LOG(COSH( a_y*(y_cb_glb(i) - y_b))) &
                                 - 2d0*LOG(COSH(0.5d0*a_y*(y_b - y_a))) )
                        END DO
                    END DO
                END IF

                ! Grid generation in the z-direction
                IF (p_glb > 0) THEN
                    dz = (z_domain%end - z_domain%beg) / REAL(p_glb+1, KIND(0d0))
                    DO i = 0, p_glb
                        z_cb_glb(i-1) = z_domain%beg + dz*REAL(i,KIND(0d0))
                    END DO
                    z_cb_glb(p_glb) = z_domain%end
                    IF (stretch_z) THEN
                        DO j = 1, loops_z
                            DO i = -1, p_glb
                                z_cb_glb(i) = z_cb_glb(i) / a_z * &
                                    (a_z + LOG(COSH( a_z*(z_cb_glb(i) - z_a))) &
                                         + LOG(COSH( a_z*(z_cb_glb(i) - z_b))) &
                                     - 2d0*LOG(COSH(0.5d0*a_z*(z_b - z_a))) )
                            END DO
                        END DO
                    END IF
                END IF
            END IF

            ! Write cell boundary locations to grid data files
            file_loc = TRIM(case_dir) // '/restart_data' // TRIM(mpiiofs) // 'x_cb.dat'
            data_size = m_glb+2
            CALL MPI_FILE_OPEN(MPI_COMM_SELF,file_loc,IOR(MPI_MODE_WRONLY,MPI_MODE_CREATE),&
                        mpi_info_int,ifile,ierr)
            CALL MPI_FILE_WRITE(ifile,x_cb_glb,data_size,MPI_DOUBLE_PRECISION,status,ierr)
            CALL MPI_FILE_CLOSE(ifile,ierr)

            IF (n > 0) THEN
                file_loc = TRIM(case_dir) // '/restart_data' // TRIM(mpiiofs) // 'y_cb.dat'
                data_size = n_glb+2
                CALL MPI_FILE_OPEN(MPI_COMM_SELF,file_loc,IOR(MPI_MODE_WRONLY,MPI_MODE_CREATE),&
                            mpi_info_int,ifile,ierr)
                CALL MPI_FILE_WRITE(ifile,y_cb_glb,data_size,MPI_DOUBLE_PRECISION,status,ierr)
                CALL MPI_FILE_CLOSE(ifile,ierr)

                IF (p > 0) THEN
                    file_loc = TRIM(case_dir) // '/restart_data' // TRIM(mpiiofs) // 'z_cb.dat'
                    data_size = p_glb+2
                    CALL MPI_FILE_OPEN(MPI_COMM_SELF,file_loc,IOR(MPI_MODE_WRONLY,MPI_MODE_CREATE),&
                                mpi_info_int,ifile,ierr)
                    CALL MPI_FILE_WRITE(ifile,z_cb_glb,data_size,MPI_DOUBLE_PRECISION,status,ierr)
                    CALL MPI_FILE_CLOSE(ifile,ierr)
                END IF
            END IF

            DEALLOCATE(x_cb_glb, y_cb_glb, z_cb_glb)

        END SUBROUTINE s_generate_parallel_grid ! ------------------------------

        !> Computation of parameters, allocation procedures, and/or
        !!              any other tasks needed to properly setup the module
        SUBROUTINE s_initialize_grid_module() ! -----------------------------------

            IF (parallel_io .NEQV. .TRUE.) THEN
                s_generate_grid => s_generate_serial_grid
            ELSE
                s_generate_grid => s_generate_parallel_grid
            END IF

        END SUBROUTINE s_initialize_grid_module ! ---------------------------------

        !> Deallocation procedures for the module
        SUBROUTINE s_finalize_grid_module() ! --------------------------------

            s_generate_grid => NULL()

        END SUBROUTINE s_finalize_grid_module ! ------------------------------

END MODULE m_grid


! ###################################################################
! Copyright (c) 2015-2021, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:EMeqvPS.f90
!--------------------------------------------------------------------------
!
! PROGRAM: EMeqvPS
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief For a given crystal symmetry and a pseudo-symmetry operation, list the independent equivalent operators
!
!> @date 03/19/18 MDG 1.0 original
!--------------------------------------------------------------------------
program EMeqvPS

use local
use constants
use dictmod
use rotations
use quaternions
use io
use so3
use files

IMPLICIT NONE

integer(kind=irg)           :: pgnum, io_int(1), num, k, FZtype, FZorder, i, j
real(kind=dbl)              :: ro(4), rod(3), ax(4), qu(4), io_dbl(4), qus(4), io_dbl3(3), dtor, eu(3), &
                               eu1(3), eu2(3), qu1(4), qu2(4), diff
real(kind=dbl),allocatable  :: axlist(:,:), eulerlist(:,:)
integer(kind=irg),allocatable :: unique(:)
type(dicttype),pointer      :: dict
character(fnlen)            :: progname, progdesc

progname = 'EMeqvPS.f90'
progdesc = 'List equivalent pseudo-symmetric rotations'

! deal with the command line arguments, if any
call Interpret_Program_Arguments(1,(/ 910 /), progname)

! print some information
call EMsoft(progname, progdesc)

dtor = cPi/180.D0

! ask for point group number
call ReadValue('Enter the point group number ',io_int)
pgnum = io_int(1)

! allocate the symmetry operations, among other things.
allocate(dict)
dict%Num_of_init = 1
dict%Num_of_iterations = 1
dict%pgnum = pgnum
call DI_Init(dict,'nil')
num = dict%Nqsym

FZtype = FZtarray(dict%pgnum)
FZorder = FZoarray(dict%pgnum)

! read the pseudo-symmetric axis angle pair
call ReadValue('Enter the pseudo-symmetry axis-angle pair (axis, angle°) ',io_dbl,4)
ax(1:4) = io_dbl(1:4)

! normalize the vector part and convert the angle to radians
ax(1:3) = ax(1:3) / vecnorm(ax(1:3))
ax(4) = ax(4) *cPi/180.D0

! convert to quaternion
qu1 = ax2qu(ax)

! for all symmetry quaternions Pm, compute the quaternion corresponding to the rotated rotation axis of ax;
! the rotation angle remains the same for all of them
allocate(axlist(4,num))
do j=1,num
  axlist(1:4,j) = (/ quat_Lp(dict%Pm(1:4,j), ax(1:3)), ax(4) /)
end do

! take a random orientation, reduce it to the fundamental zone, and convert to quaternion q2
eu2 = (/ 94.43, 102.02, 228.77 /) * cPi/180.0
call ReduceOrientationtoRFZ(eu2, dict, FZtype, FZorder, eu1)
qu2 = eu2qu(eu1)

! apply this symmetrized pseudo-symmetry operators to the random orientation, and store them in an Euler list
allocate(eulerlist(3,num), unique(num))
unique = 1
do j=1,num
    qu = ax2qu(axlist(1:4,j))
    if (qu(1).lt.0.D0) qu = -qu
    eu = qu2eu(quat_mult(qu,qu2))
    call ReduceOrientationtoRFZ(eu, dict, FZtype, FZorder, eulerlist(1:3,j))
end do

! analyze this list for uniqueness, keeping only a single copy of each unique operator
do i=1,num-1
  do j=i+1, num
    if (unique(i).eq.1) then
      diff = sum(abs(eulerlist(1:3,i)-eulerlist(1:3,j)))
      if (diff.lt.0.01) unique(j) = 0
    end if
  end do
end do

! and generate the list of pseudo-symmetric variants
call Message(' ')
call Message('Unique pseudo-symmetry operators (axis,angle°):')
do i=1,num
  if (unique(i).eq.1) then
    axlist(4,i) = axlist(4,i) * 180.0/cPi
    io_dbl(1:4) = axlist(1:4,i)
    call WriteValue('',io_dbl,4,"(4(F12.8,'  '))")
  end if
end do

end program EMeqvPS


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
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
      program tvtsgs
c
c     this program checks vtsgs for computing the colatitudinal
c     derivatives of the velocity ....
c
      parameter (nlat=17,nlon=32)
      parameter (idp=nlat,jdp=nlon,mdab=nlat,ndab=nlat)
c
      dimension u(idp,jdp),v(idp,jdp),w(idp,jdp),
     1          x(idp,jdp),y(idp,jdp),z(idp,jdp),
     2          vt(idp,jdp),wt(idp,jdp),
     3          a(mdab,ndab,3),b(mdab,ndab,3),
     4          da(mdab,ndab,3,3),db(mdab,ndab,3,3),
     5          tmp(mdab,ndab), br(mdab,ndab),bi(mdab,ndab),
     6          cr(mdab,ndab),ci(mdab,ndab),
     7          c(idp,jdp,3,3),s(idp,jdp,3,3),
     8          dthet(idp),dwts(idp)
      dimension wshi(608411),wvha(1098771),wvhs(1098771),
     1          wvts(1098771),work(165765)
      double precision dthet,dwts,dwork(25741)
c
      lwshi = 608411
      lwvha = 1098771
      lwvhs = 1098771
      lwvts = 1098771
      lwork = 165765
      ldwork = 25741
c
      pi = 4.*atan(1.)
      hpi = pi/2.
      dtr = pi/180.
      isym = 0
      nt = 1
c
c     initialize spherepack routines
c
      call shigs(nlat,nlon,wshi,lwshi,work,lwork,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(6,55) ierror
   55 format('testvtsgs:  error' i4 ' in shigs')
      call vhagsi(nlat,nlon,wvha,lwvha,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(6,57) ierror
   57 format('testvtsgs:  error' i4 ' in vhagsi')
      call vhsgsi(nlat,nlon,wvhs,lwvhs,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(6,58) ierror
   58 format(' testvtsgs: error' i4 ' in vhsgsi')
      call vtsgsi(nlat,nlon,wvts,lwvts,work,lwork,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(6,59) ierror
   59 format(' testvtsgs: error' i4 ' in vtsgsi')
c
c     compute gauss points and weights
c
      call gaqd(nlat,dthet,dwts,work,lwork,ierror)
c
c     zero vector harmonic coefficients
c
      do np1=1,nlat
      do mp1=1,np1
      br(mp1,np1) = 0.
      bi(mp1,np1) = 0.
      cr(mp1,np1) = 0.
      ci(mp1,np1) = 0.
      end do
      end do
c
c     initialize arrays with random numbers
c     old style non-portable commented out
c
c     call srand(227)
c     do np1=1,nlat-1
c     do mp1=1,np1
c     br(mp1,np1) = rand()
c     bi(mp1,np1) = rand()
c     cr(mp1,np1) = rand()
c     ci(mp1,np1) = rand()
c     end do
c     end do
c
c     set vector harmonic coefficients
c     (new style using standard Fortran90
c     intrinsics
c
      CALL RANDOM_SEED()
c
      CALL RANDOM_NUMBER(tmp)
      do np1=1,nlat-1
      do mp1=1,np1
      br(mp1,np1) = tmp(mp1,np1)
      end do
      end do
c
      CALL RANDOM_NUMBER(tmp)
      do np1=1,nlat-1
      do mp1=1,np1
      bi(mp1,np1) = tmp(mp1,np1)
      end do
      end do
c
      CALL RANDOM_NUMBER(tmp)
      do np1=1,nlat-1
      do mp1=1,np1
      cr(mp1,np1) = tmp(mp1,np1)
      end do
      end do
c
      CALL RANDOM_NUMBER(tmp)
      do np1=1,nlat-1
      do mp1=1,np1
      ci(mp1,np1) = tmp(mp1,np1)
      end do
      end do
c
      call vhsgs(nlat,nlon,0,1,v,w,idp,jdp,br,bi,
     1           cr,ci,mdab,ndab,wvhs,lwvhs,work,lwork,ierror)
      if(ierror .ne. 0) write(6,79) ierror
 79   format(' testvtsgs: error' i4 ' in vhsgs at point 1')
c
      do j=1,nlon
      do i=1,nlat
      u(i,j) = 0.
      end do
      end do
c
c     convert to cartesian coordinates
c
      dphi = 2.*pi/nlon
      do j=1,nlon
      phi = (j-1)*dphi
      do i=1,nlat
      theta = dthet(i)
      call stoc(theta,phi,u(i,j),v(i,j),w(i,j),x(i,j),y(i,j),z(i,j))
      end do
      end do
c
c     compute harmonic components of x component
c
      call shags(nlat,nlon,0,1,x,idp,jdp,a(1,1,1),b(1,1,1),
     1           mdab,ndab,wshi,lwshi,work,lwork,ierror)
      if(ierror .ne. 0) write(6,16) ierror
 16   format(' testvtsgs: error' i4 ' in shags at point 2')
c
c     write harmonic coefficients for x
c
c      write(6,20)
c 20   format(//'  harmonic coefficients for x'//)
c      do mp1=1,nlat
c      do np1=mp1,nlat
c      write(6,5) mp1,np1,a(mp1,np1,1),b(mp1,np1,1)
c 5    format(2i5,1p2e15.6)
c      end do
c      end do
c
c     compute harmonic components of y component
c
      call shags(nlat,nlon,0,1,y,idp,jdp,a(1,1,2),b(1,1,2),
     1           mdab,ndab,wshi,lwshi,work,lwork,ierror)
      if(ierror .ne. 0) write(6,17) ierror
 17   format(' testvtsgs: error' i4 ' in shags at point 3')
c
c     write harmonic coefficients for y
c
c      write(6,21)
c 21   format(//'  harmonic coefficients for y'//)
c      do mp1=1,nlat
c      do np1=mp1,nlat
c      write(6,5) mp1,np1,a(mp1,np1,2),b(mp1,np1,2)
c      end do
c      end do
c
c     compute harmonic components of z component
c
      call shags(nlat,nlon,0,1,z,idp,jdp,a(1,1,3),b(1,1,3),
     1           mdab,ndab,wshi,lwshi,work,lwork,ierror)
      if(ierror .ne. 0) write(6,18) ierror
   18 format(' testvtsgs: error' i4 ' in shags at point 4')
c
c     write harmonic coefficients for z
c
c      write(6,22)
c 22   format(//'  harmonic coefficients for z'//)
c      do mp1=1,nlat
c      do np1=mp1,nlat
c      write(6,5) mp1,np1,a(mp1,np1,3),b(mp1,np1,3)
c      end do
c      end do
c
c     compute partials of x, y, and z wrt z
c
      call dbdz(nlat,nlat,a(1,1,1),b(1,1,1),da(1,1,1,3),db(1,1,1,3))
      call dbdz(nlat,nlat,a(1,1,2),b(1,1,2),da(1,1,2,3),db(1,1,2,3))
      call dbdz(nlat,nlat,a(1,1,3),b(1,1,3),da(1,1,3,3),db(1,1,3,3))
c
c     compute partials of x, y, and z wrt y
c
      call dbdy(nlat,nlat,a(1,1,1),b(1,1,1),da(1,1,1,2),db(1,1,1,2))
      call dbdy(nlat,nlat,a(1,1,2),b(1,1,2),da(1,1,2,2),db(1,1,2,2))
      call dbdy(nlat,nlat,a(1,1,3),b(1,1,3),da(1,1,3,2),db(1,1,3,2))
c
c     compute partials of x, y, and z wrt x
c
      call dbdx(nlat,nlat,a(1,1,1),b(1,1,1),da(1,1,1,1),db(1,1,1,1))
      call dbdx(nlat,nlat,a(1,1,2),b(1,1,2),da(1,1,2,1),db(1,1,2,1))
      call dbdx(nlat,nlat,a(1,1,3),b(1,1,3),da(1,1,3,1),db(1,1,3,1))
c
c     transform cartesian jacobian to physical space
c
      call shsgs(nlat,nlon,0,9,c,idp,jdp,da,db,idp,idp,
     1           wshi,lwshi,work,lwork,ierror)
      if(ierror .ne. 0) write(6,19) ierror
 19   format(' testvtsgs: error' i4 ' in shsgs at point 5')
c
c     convert to jacobian to spherical coordinates
c        (multiply cartesian jacobian by q)
c
      do k=1,3
      do j=1,nlon
      phi = (j-1)*dphi
      do i=1,nlat
      theta = dthet(i)
      call ctos(theta,phi,c(i,j,1,k),c(i,j,2,k),c(i,j,3,k),
     1                    s(i,j,1,k),s(i,j,2,k),s(i,j,3,k))
      end do
      end do
      end do
c
c     form s = (q sq**T)**T
c
      do k=1,3
      do j=1,nlon
      phi = (j-1)*dphi
      do i=1,nlat
      theta = dthet(i)
      call ctos(theta,phi,s(i,j,k,1),s(i,j,k,2),s(i,j,k,3),
     1                    c(i,j,k,1),c(i,j,k,2),c(i,j,k,3))
      end do
      end do
      end do

      do j=1,nlon
      do i=1,nlat
      do iq=1,3
      do jq=1,3
      s(i,j,iq,jq) = c(i,j,iq,jq)
      end do
      end do
      end do
      end do
c
c     check derivative program
c
      call vtsgs(nlat,nlon,0,1,vt,wt,idp,jdp,br,bi,cr,ci,
     1           mdab,ndab,wvts,lwvts,work,lwork,ierror)
      if(ierror .ne. 0) write(6,4) ierror
 4    format(' testvtsgs: error' i4 ' in vtsgs during initialization')
      dmax1 = 0.
      dmax2 = 0.
      do j=1,nlon
      do i=1,nlat
      dmax1 = max(dmax1,abs(s(i,j,2,2)-vt(i,j)))
      dmax2 = max(dmax2,abs(s(i,j,3,2)-wt(i,j)))
      end do
      end do
      write(6,2) dmax1,dmax2
 2    format(' testvtsgs: error in vt '1pe15.6' error in wt '1pe15.6)
      end
      subroutine ctos(theta,phi,x,y,z,u,v,w)
c
c     this program computes the components of a vector
c     field in spherical coordinates u, v, and w, from
c     its components x, y, and z in cartesian coordinates
c
      st = sin(theta)
      ct = cos(theta)
      sp = sin(phi)
      cp = cos(phi)
      temp1 = cp*x+sp*y
      temp2 = cp*y-sp*x
      u = st*temp1+ct*z
      v = ct*temp1-st*z
      w = temp2
      return
      end
      subroutine stoc(theta,phi,u,v,w,x,y,z)
c
c     this program computes the components of a vector
c     field in cartesian coordinates x, y, and z, from
c     its components u, v, and w in spherical coordinates
c
      st = sin(theta)
      ct = cos(theta)
      sp = sin(phi)
      cp = cos(phi)
      temp1 = st*u+ct*v
      temp2 = ct*u-st*v
      x = cp*temp1-sp*w
      y = sp*temp1+cp*w
      z = temp2
      return
      end
      subroutine dbdx(l,mdim,a,b,dxa,dxb)
c
c     subroutine to compute the coefficients in the spherical
c     harmonic representation of the derivative with respect to x
c     of a scalar function. i.e. given the coefficients a and b
c     in the spectral representation of a function, then dbdx
c     computes the coefficients dxa and dxb in the spectral
c     representation of the derivative of the function
c     with respect to x.
c
c     the arrays a and dxa can be the same as well as the arrays
c     b and dxb, i.e. the arrays a and b can be overwritten by
c     dxa and dxb respectively.
c
c     dimension a(mdim,1),b(mdim,1),dxa(mdim,1),dxb(mdim,1)
      dimension a(mdim,*),b(mdim,*),dxa(mdim,*),dxb(mdim,*)
      dxa(1,1) = sqrt(6.)*a(2,2)
      dxb(1,1) = 0.
      lm1 = l-1
      do 10 np1=2,lm1
      n = np1-1
      fn = float(n)
      cn = (fn+fn+3.)/(fn+fn+1.)
      dxa(1,np1) = sqrt(cn*(fn+2.)*(fn+1.))*a(2,np1+1)
      dxb(1,np1) = 0.
      do 10 mp1=2,np1
      fm = float(mp1-1)
      a1 = .5*sqrt(cn*(fn+fm+2.)*(fn+fm+1.))
      a2 = .5*sqrt(cn*(fn-fm+2.)*(fn-fm+1.))
      dxa(mp1,np1) = a1*a(mp1+1,np1+1)-a2*a(mp1-1,np1+1)
      dxb(mp1,np1) = a1*b(mp1+1,np1+1)-a2*b(mp1-1,np1+1)
   10 continue
      do 5 mp1=1,l
      dxa(mp1,l) = 0.
      dxb(mp1,l) = 0.
    5 continue
      return
      end
      subroutine dbdy(l,mdim,a,b,dya,dyb)
c
c     subroutine to compute the coefficients in the spherical
c     harmonic representation of the derivative with respect to y
c     of a scalar function. i.e. given the coefficients a and b
c     in the spectral representation of a function, then dbdy
c     computes the coefficients dya and dyb in the spectral
c     representation of the derivative of the function
c     with respect to y.
c
c     the arrays a and dya can be the same as well as the arrays
c     b and dyb, i.e. the arrays a and b can be overwritten by
c     dya and dyb respectively.
c
c     dimension a(mdim,1),b(mdim,1),dya(mdim,1),dyb(mdim,1)
      dimension a(mdim,*),b(mdim,*),dya(mdim,*),dyb(mdim,*)
      dya(1,1) = -sqrt(6.)*b(2,2)
      dyb(1,1) = 0.
      lm1 = l-1
      do 10 np1=2,lm1
      n = np1-1
      fn = float(n)
      cn = (fn+fn+3.)/(fn+fn+1.)
      dya(1,np1) = -sqrt(cn*(fn+2.)*(fn+1.))*b(2,np1+1)
      dyb(1,np1) = 0.
      do 10 mp1=2,np1
      fm = float(mp1-1)
      a1 = .5*sqrt(cn*(fn+fm+2.)*(fn+fm+1.))
      a2 = .5*sqrt(cn*(fn-fm+2.)*(fn-fm+1.))
      dya(mp1,np1) = -a1*b(mp1+1,np1+1)-a2*b(mp1-1,np1+1)
      dyb(mp1,np1) =  a1*a(mp1+1,np1+1)+a2*a(mp1-1,np1+1)
   10 continue
      do 5 mp1=1,l
      dya(mp1,l) = 0.
      dyb(mp1,l) = 0.
    5 continue
      return
      end
      subroutine dbdz(l,mdim,a,b,dza,dzb)
c
c     subroutine to compute the coefficients in the spherical
c     harmonic representation of the derivative with respect to z
c     of a scalar function. i.e. given the coefficients a and b
c     in the spectral representation of a function, then dbdz
c     computes the coefficients dza and dzb in the spectral
c     representation of the derivative of the function
c     with respect to z.
c
c     the arrays a and dza can be the same as well as the arrays
c     b and dzb, i.e. the arrays a and b can be overwritten by
c     dza and dzb respectively.
c
      dimension a(mdim,1),b(mdim,1),dza(mdim,1),dzb(mdim,1)
      lm1 = l-1
      do 10 np1=1,lm1
      n = np1-1
      fn = float(n)
      cn = (fn+fn+3.)/(fn+fn+1.)
      do 10 mp1=1,np1
      fm = float(mp1-1)
      a1 = sqrt(cn*(fn-fm+1.)*(fn+fm+1.))
      dza(mp1,np1) = a1*a(mp1,np1+1)
      dzb(mp1,np1) = a1*b(mp1,np1+1)
   10 continue
      do 5 mp1=1,l
      dza(mp1,l) = 0.
      dzb(mp1,l) = 0.
    5 continue
      return
      end


module mint_mod
    use, intrinsic :: iso_fortran_env
    implicit none
    private
    integer(int64) :: md = 1000000007_8
    type,public:: mint
        integer(int64), private :: val = 0_8
    contains
        procedure:: to_int => mint_to_int64
        procedure,private:: mi_add
        procedure,private:: mi_sub
        procedure,private:: mi_mul
        procedure,private:: mi_div
        procedure,private:: mi_pow
        procedure,private:: mi_asgn
        generic:: operator( + ) => mi_add
        generic:: operator( - ) => mi_sub
        generic:: operator( * ) => mi_mul
        generic:: operator( / ) => mi_div
        generic:: operator( ** ) => mi_pow
        generic:: assignment( = ) => mi_asgn
    end type

    interface mint
        module procedure:: mi_init
    end interface
contains
    pure elemental function mi_init(num) result(ret)
        class(*),intent(in):: num
        type(mint):: ret

        ret = to_mint(num)
    end function

    pure elemental function int_to_int64(num) result(ret)
        class(*), intent(in) :: num
        integer(int64):: ret

        select type (num)
            type is (mint)
                ret = num%val
            type is (integer(int64))
                ret = num
            type is (integer(int32))
                ret = int(num, int64)
            type is (integer(int16))
                ret = int(num, int64)
            type is (integer(int8))
                ret = int(num, int64)
            class default
                ret = 0_8
                ret = 1_8/ret
        end select
        ret=modulo(ret,md)
    end function

    pure elemental function mint_to_int64(mx) result(ret)
        class(mint),intent(in):: mx
        integer(int64):: ret

        ret = int_to_int64(mx)
    end function

    pure elemental function to_mint(num) result(ret)
        class(*), intent(in):: num
        type(mint):: ret

        ret%val = int_to_int64(num)
    end function

    pure elemental subroutine mi_asgn(xm,y)
        class(mint), intent(inout) :: xm
        class(*), intent(in) :: y

        xm%val = int_to_int64(y)
    end subroutine

    pure elemental function mi_add(xm,y) result(ret)
        class(mint), intent(in) :: xm
        class(*), intent(in) :: y
        type(mint):: ret

        ret%val = modulo(xm%val + int_to_int64(y), md)
    end function

    pure elemental function mi_sub(xm,y) result(ret)
        class(mint), intent(in) :: xm
        class(*), intent(in) :: y
        type(mint):: ret

        ret%val = modulo(xm%val - int_to_int64(y), md)
    end function

    pure elemental function mi_mul(xm,y) result(ret)
        class(mint), intent(in) :: xm
        class(*), intent(in) :: y
        type(mint) ret

        ret%val = modulo(xm%val * int_to_int64(y), md)
    end function

    pure elemental function mi_div(xm,y) result(ret)
        class(mint), intent(in) :: xm
        class(*), intent(in) :: y
        type(mint):: ret

        ret%val = xm%val * int_to_int64(inv(to_mint(y)))
    end function

    pure elemental function inv(xm) result(ret)
        class(mint), intent(in) :: xm
        type(mint):: ret
        integer(int64) :: a, b, c, n
        integer(int64) :: x, y, z, m

        a = xm%val
        b = md
        c = 0_8
        n = 1_8
        do while (b /= 0_8)
            x = b
            y = mod(a,b)
            z = n-a/b*c
            m = c
            a = x
            b = y
            c = z
            n = m
        end do
        ret%val = n
    end function

    pure elemental function mi_pow(xm,y) result(ret)
        class(mint), intent(in) :: xm
        class(*), intent(in) :: y
        type(mint):: ret
        integer(int64) :: n
        type(mint) :: i

        ret%val = 1_8
        i%val = xm%val
        n = int_to_int64(y)
        do while (n > 0_8)
            if (btest(n,0)) ret%val = int_to_int64(mi_mul(ret,i))
            i%val = int_to_int64(mi_mul(i,i))
            n = rshift(n,1)
        end do
    end function
end module mint_mod


program main

    use mydefs
    use pes_init
    use pes_calc
    use pes_write

    implicit none

    integer(ik) :: maxatoms, maxmodes, step, mode1, mode2, step2d
    real(rk) :: xmin, ssize, xmin2d, ssize2d!, ar1, ar2, br1, amin, angstep, angsize, angle, rmin, rstep, rsize
    real(rk) :: r01, r02, a0
    real(rk), allocatable :: xyz0(:,:)
    real(rk), allocatable :: dxyz(:,:,:)
    real(rk), allocatable :: drtheta(:,:)
    real(rk), allocatable :: xyz(:,:,:,:)
    real(rk), allocatable :: r1(:,:)
    real(rk), allocatable :: r2(:,:)
    real(rk), allocatable :: a(:,:)
    real(rk), allocatable :: xyz2d(:,:,:,:)
    real(rk), allocatable :: r2d1(:,:)
    real(rk), allocatable :: r2d2(:,:)
    real(rk), allocatable :: a2d(:,:)

    character(len=3), allocatable :: aname(:)
    character(len=5) :: grid='GRIDI', mol='MOLIN', geo='GEOME', disp='DISPL', inte='INTER', dime='2DIME'!, ang='ANGLE', bond='BONDS'
    integer :: hflag, iflag

    iflag = read_key(mol)

    if(iflag==1) then

        call get_molinfo(maxatoms, maxmodes)

    end if

    iflag = read_key(grid)

    if(iflag==1) then

        call get_gridinfo(xmin, step, ssize)

    end if

    hflag = read_key(geo)

    if(hflag==1) then

        call allocate_arrays(xyz0, dxyz, xyz, drtheta, r1, r2, a, maxmodes, maxatoms, step,aname)

        call init_geo(xyz0, maxatoms, aname)

        call init_internal_geo(xyz0, r01, r02, a0)

        iflag = read_key(disp)

        if(iflag==1) then

            call read_cartd(dxyz, maxatoms, maxmodes)

!            call make_cartesian(xyz, xyz0, dxyz, maxatoms, maxmodes, step, xmin, ssize)

!            call write_cartesian(xyz, maxatoms, step, aname)

        end if

        iflag = read_key(inte)

        if(iflag==1) then

            call read_interd(drtheta, maxmodes)

 !           call make_internal(r01, r02, a0, r1, r2, a, drtheta, maxmodes, step, xmin, ssize)

!            call write_internal(r1,r2,a, maxatoms, step,aname)

        end if

!        call write_grid(step, ssize, xmin)

        iflag = read_key(dime)

        if(iflag==1) then

            call read_2d(mode1, mode2, xmin2d, step2d,ssize2d)

            call allocate_2d_arrays(maxatoms, step2d, xyz2d, r2d1, r2d2, a2d)
            !call allocate_2d_arrays(step2d, r2d1, r2d2, a2d)
            call make_2d_cartesian(xyz2d, xyz0, dxyz, maxatoms, step2d, xmin2d, ssize2d, mode1, mode2)

            call write_2d_cartesian(xyz2d, maxatoms, step2d, aname)

            call make_2d_internal(r01, r02, a0, r2d1, r2d2, a2d, drtheta, step2d, xmin2d, ssize2d, mode1, mode2)

            call write_2d_internal(r2d1, r2d2, a2d, maxatoms, step2d, aname)

            call write_2d_grid(step2d,ssize2d,xmin2d)
            !call deallocate_2d_arrays(r2d1, r2d2, a2d)
            call deallocate_2d_arrays(xyz2d, r2d1, r2d2, a2d)

        end if

        call deallocate_arrays(xyz0, dxyz, xyz, drtheta, r1, r2, a, aname)

    end if

!    iflag = read_key(ang)

!    if(iflag==1) then
!        call angle_bending(ar1, ar2, amin, angstep, angsize)
!        call make_angle_bending(amin, angstep, angsize, acoord)
!        call write_angle_bending(acoord)
!    end if

!    iflag = read_key(bond)
!
!    if(iflag==1) then
!        call bond_stretching(br1, angle, rmin, rstep, rsize)
!        call make_bond_stretching(rmin, rstep, rsize, rcoord)
!        call write_bond_stretching(rcoord)
!    end if

end program main


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Fill in all missing (l,s) coordinates.
c
      subroutine fill_res(lnom,snom,nbr,rtype,e,f,l,s)
      implicit none
c Inputs...
      real*4 lnom(202),snom(202)  !nominal reseau coordinates
      integer nbr(8,202)        !8 neighbors of each reseau mark
      integer rtype(202)
      real*4 e,f		!global offsets
c Updated...
      real*4 l(202),s(202)
c Local variables...
      logical found(202)	!true if mark k was found
      integer vnk(8)		!valid neighbors of k
      integer i,n
      integer k,k1,k2,kn

c rtype is 1,2,3,4 for the UL,UR,LL and LR corners,
c 5,6,7,8 for the top,left,bottom and right margins,
c and 0 for the interior.

c Remembering which reseau marks were actually found...

      do k=1,202
         found(k) = l(k).ne.-999	!found if not invalid
      enddo

c Fill in the missing marks...

      do 50 k=1,202
      if (l(k).ne.-999) goto 50		!skip if it already exists
      n = 0				!number of valid neighbors

      do 40 i=1,8	!build list of valid neighbors of k...
      kn = nbr(i,k)                     !ith neighbor of k
      if (kn.eq.0) goto 40              !reject if kn does not exist
      if (rtype(kn).ne.0) goto 40       !reject if kn is on margin
      if (.not.found(kn)) goto 40       !reject if kn was not found
      n = n + 1
      vnk(n) = kn                       !add kn to list of valid neighbor
   40 continue

      if (n.eq.0) then		!if no valid neighbors, use global offsets
         l(k) = lnom(k) + f
         s(k) = snom(k) + e
      elseif (n.eq.1) then	!use the same offsets
         k1 = vnk(1)
         l(k) = lnom(k) + (l(k1)- lnom(k1))
         s(k) = snom(k) + (s(k1)- snom(k1))
      elseif (n.eq.2) then	!use mean offsets
         k1 = vnk(1)
         k2 = vnk(2)
         l(k) = lnom(k) + 0.5*((l(k1)-lnom(k1))+(l(k2)-lnom(k2)))
         s(k) = snom(k) + 0.5*((s(k1)-snom(k1))+(s(k2)-snom(k2)))
      elseif (n.eq.3) then	!interpolate using an affine transformation
         call interp_3(k,vnk,lnom,snom,l,l(k))
         call interp_3(k,vnk,lnom,snom,s,s(k))
      elseif (n.ge.4) then	!interpolate using a bilinear transformation
         call interp_4(k,vnk,lnom,snom,l,l(k))
         call interp_4(k,vnk,lnom,snom,s,s(k))
      endif
   50 continue

      return
      end


!   Perform guessing tests.
!	dat provides responses.
!	npsu is the number of psus's per stratum.
!	nstratum is the number of strata.
!	numcat provides the underlying number of categories per item.
!	psu indicates the psu of an observation.
!	stratum indicates the stratum of an observation.
!	complx indicates complex sampling.
!	stratify is .true. for stratified sampling.
!	usepsu is .true. for primary sampling units within strata.
!	eacovgaminv_louis is the inverse of the Louis information plus the
!		constraint component of the negative hessian.
!	gradsdes provides gradients for observations.
!	lintran transforms the latent vector.
!	obsweight provides weights.
!	postdensity is the array of posterior densities.
!	theta is the array of quadrature points.
!   guessres gives the residual total.
!   guessresa is the adjusted residual.
!   stdguessres is the standard error of guessres.

subroutine guesstest(dat,npsu,nstratum,numcat,psu,stratum,&
    complx,stratify,usepsu,beta,eacovgaminv_louis,&
    gradsdes,lintran,obsweight,postdensity,theta,guessres,guessresa,stdguessres)
implicit none
interface

!	Estimate the cross information matrix.
!	adjust indicates adjustment for means.
!	grads is the array of observation gradients.
!	grads1 is another array of observation gradients.
!	obsweight contains observation weights.

    function crossinformation(adjust,grads,grads1,obsweight)
        implicit none
        logical,intent(in)::adjust
        real(kind=8),intent(in)::grads(:,:),grads1(:,:),obsweight(:)
        real(kind=8)::crossinformation(size(grads,1),size(grads1,1))
    end function crossinformation

!	The following description is for the function's basic purpose.
!	Its use in this subroutine is a bit different.
!	Estimate the information matrix for a complex sample.
!	This version is designed for random sampling of psu's within strata.
!	Sampling is with replacement.
!	npsu is the number of psus's per stratum.
!	nstratum is the number of strata.
!	psu indicates the psu of an observation.
!	stratum indicates the stratum of an observation.
!	stratify is .true. for stratified sampling.
!	usepsu is .true. for primary sampling units within strata.
!	grads is the array of observation gradients.
!	obsweight contains observation weights.

    function information_complex(npsu,nstratum,psu,stratum,stratify,&
        usepsu,grads,obsweight)
        implicit none
        integer,intent(in)::nstratum
        integer,intent(in),optional::npsu(:),psu(:),stratum(:)
        logical,intent(in)::stratify,usepsu
        real(kind=8),intent(in)::grads(:,:),obsweight(:)
        real(kind=8)::information_complex(size(grads,1),size(grads,1))
    end function information_complex

!	probvec is used to compute underlying item probabilities.
!   numcat indicates the number of underlying categories per item.
!	mask indicates which items were presented.
!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
    function probvec(numcat,mask,locations,scales,theta)
        implicit none
        integer,intent(in)::numcat(:)
        logical,intent(in)::mask(:)
        real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
        real(kind=8)::probvec(size(locations))
    end function probvec

end interface
integer,intent(in)::dat(:,:),npsu(:),nstratum,numcat(:),&
    psu(:),stratum(:)
logical,intent(in)::complx,stratify,usepsu
real(kind=8),intent(in)::beta(:),eacovgaminv_louis(:,:),&
    gradsdes(:,:),lintran(:,:),obsweight(:),postdensity(:,:),theta(:,:,:)
real(kind=8),intent(out)::guessres(:),guessresa(:),stdguessres(:)
!	al is allocation indicator.
!	counter counts
integer::al,counter,dimdesign,dimlatout,item,ncat,&
    nitems,nlin,nobs,nscale,obs,quad,resp(size(guessres))
logical::datamask(size(guessres))
real(kind=8)::avediff,diff,covobs(1,1),covsum(size(gradsdes,1)),newtheta(size(lintran,1)),&
    locations(sum(numcat)),&
    probcat(sum(numcat)),respvec(size(guessres)),scales(size(lintran,1),sum(numcat)),&
    slopes(size(gradsdes,1)),totalobs
real(kind=8),allocatable::obsmat(:,:,:)
dimdesign=size(gradsdes,1)
dimlatout=size(lintran,1)
guessres=0.0_8
guessresa=0.0_8
ncat=sum(numcat)
locations=beta(1:ncat)
nitems=size(numcat)
nlin=ncat*(dimlatout+1)+1
nobs=size(obsweight)
allocate(obsmat(1,nobs,nitems),stat=al)
if(al/=0)stop 'Allocation failed for guessing test'
nscale=ncat+1
scales=reshape(beta(nscale:nlin-1),(/dimlatout,ncat/))
stdguessres=0.0_8
totalobs=sum(obsweight)
do obs=1,nobs
    if(obsweight(obs)<=0.0_8)cycle
    resp=dat(:,obs)
    respvec=0.0_8
    datamask=.false.
    do item=1,nitems

        if(resp(item)>=0.and.resp(item)<2.and.numcat(item)==2)datamask(item)=.TRUE.

    end do
    if(count(datamask)==0)cycle
!	Cycle through quadrature points.
    do quad=1,size(theta,2)
!		Probability computation.
        newtheta=matmul(lintran,theta(:,quad,obs))
        probcat=probvec(numcat,datamask,locations,scales,newtheta)
        counter=2
        do item=1,size(numcat)
            if(datamask(item))respvec(item)=&
                respvec(item)+postdensity(quad,obs)*(resp(item)-probcat(counter))/probcat(counter)
            counter=counter+numcat(item)
        end do
    end do
    obsmat(1,obs,:)=respvec
!   Residual
   guessres=guessres+obsweight(obs)*respvec

end do
!   Standard error
do item=1,nitems
    if(numcat(item)==2)then
        if(.not.complx)then
            covsum=reshape(crossinformation(.true.,obsmat(:,:,item),gradsdes,obsweight),&
                (/dimdesign/))
            slopes=matmul(eacovgaminv_louis,covsum)
            avediff=0.0_8
            do obs=1,nobs
                if(obsweight(obs)<=0.0_8)cycle
                obsmat(1,obs,item)=obsmat(1,obs,item)-dot_product(gradsdes(:,obs),slopes)
                avediff=avediff+obsmat(1,obs,item)*obsweight(obs)
            end do
            avediff=avediff/totalobs
            do obs=1,nobs
                diff=obsmat(1,obs,item)-avediff
                stdguessres(item)=stdguessres(item)+diff*diff*obsweight(obs)
            end do
        else

            covsum=reshape(crossinformation(.true.,obsmat(:,:,item),gradsdes,obsweight),(/dimdesign/))
            slopes=matmul(eacovgaminv_louis,covsum)
            do obs=1,nobs
                obsmat(1,obs,item)=obsmat(1,obs,item)-dot_product(gradsdes(:,obs),slopes)
            end do
            covobs=information_complex(npsu,nstratum,psu,stratum,stratify,usepsu,&
                obsmat(:,:,item),obsweight)
            stdguessres(item)=covobs(1,1)
        end if
        stdguessres(item)=sqrt(stdguessres(item))
        if(stdguessres(item)>0.0_8)guessresa(item)=guessres(item)/stdguessres(item)
    end if

end do
deallocate(obsmat)
return
end subroutine guesstest


      function diskdf5intez(vt,r,z)
      parameter (pi=3.1415926535)

      real psir0,psirz

      psir0=pot(r,0.0)
      if (z.eq.0.) then
         psirz=psir0
      else
         psirz=pot(r,z)
         endif
      ep=0.5*(vt*vt)-psir0
      am=r*vt
      ez=-psirz+psir0

      diskdf5intez=diskdf3intez(ep,am,ez)
      if(diskdf5intez.lt.0.) diskdf5intez = 0.

      return
      end


subroutine integrate_ode(mf, lo, hi, cvode_meth, cvode_itmeth) bind(C, name="integrate_ode")

  use amrex_error_module
  use rhs_mod
  use ode_params
  use fcvode_mod            ! Fortran interface to CVODE
  use fnvector_serial_mod   ! Fortran interface to serial N_Vector
  use fsunmat_dense_mod     ! Fortran interface to dense SUNMatrix
  use fsunlinsol_dense_mod  ! Fortran interface to dense SUNLinearSolver
!  use fnvector_serial
!  use cvode_interface
  use, intrinsic :: iso_c_binding

  implicit none

  integer, intent(in) :: lo(3),hi(3)
  real(c_double), intent(inout) :: mf(lo(1):hi(1), lo(2):hi(2), lo(3):hi(3))
  integer(c_int), intent(in) :: cvode_meth
  integer(c_int), intent(in) :: cvode_itmeth

  ! local variables
  integer i,j,k

  integer(c_int) :: ierr ! CVODE return status
  real(c_double) :: atol, rtol
  real(c_double) :: t0, t1
  real(c_double), pointer :: yvec(:)
  type(c_ptr) :: sunvec_y      ! sundials vector
  type(c_ptr) :: sunmat_A      ! sundials matrix
  type(c_ptr) :: sunlinsol_LS  ! sundials linear solver
  type(c_ptr) :: CVmem

  allocate(yvec(neq))

  ! Allocate a CVODE C struct from the array of variables to be integrated. The resulting C struct points to the same memory as the
  ! Fortran pointer array.
  sunvec_y = FN_VMake_Serial(neq, yvec)
  if (.not. c_associated(sunvec_y)) call amrex_abort("integrate_ode: failed in N_VMake_Serial()")

  CVmem = FCVodeCreate(CV_BDF, CV_NEWTON)
  if (.not. c_associated(CVmem)) call amrex_abort("integrate_ode: failed in FCVodeCreate()")

  ! create a dense matrix
  sunmat_A = FSUNDenseMatrix(neq, neq);
  if (.not. c_associated(sunmat_A)) print *,'ERROR: sunmat = NULL'

  ! create a dense linear solver
  sunlinsol_LS = FSUNDenseLinearSolver(sunvec_y, sunmat_A);
  if (.not. c_associated(sunlinsol_LS)) print *,'ERROR: sunlinsol = NULL'

  t0 = 0.0d0 ! initial time for integration
  t1 = 2.0d0 ! final time for integration

  ! Set up CVODE solver machinery. This allocates a lot of memory. Since we will be solving the same system of ODEs in each cell and
  ! only changing initial conditions among cells, we don't want to allocate and deallocate all this stuff in each cell, because that
  ! will be slow (and unnecessary). So instead, we allocate the solver stuff once outside the (i,j,k) loop, and then within the
  ! (i,j,k) loop we just "re-initialize" the solver, which does not allocate any new data, but rather just sets up new initial
  ! conditions.
  ierr = FCVodeInit(CVmem, c_funloc(RhsFn), t0, sunvec_y)
  if (ierr /= 0) call amrex_abort("integrate_ode: failed in FCVodeInit()")

  ! Set error tolerances tolerances
  atol = 1.0d-10
  rtol = 1.0d-6
  ierr = FCVodeSStolerances(CVmem, rtol, atol)
  if (ierr /= 0) call amrex_abort("integrate_ode: failed in FCVodeSStolerances()")

  ! attach linear solver
  ierr = FCVDlsSetLinearSolver(CVmem, sunlinsol_LS, sunmat_A);
  if (ierr /= 0) then
     write(*,*) 'Error in FCVDlsSetLinearSolver, ierr = ', ierr, '; halting'
     stop
  end if

  do k=lo(3),hi(3)
     do j=lo(2),hi(2)
        do i=lo(1),hi(1)

           ! Set initial conditions for the ODE for this cell.
           yvec(1) = real(i+j+k, c_double)

           t0 = 0.0d0 ! initial time for integration
           ierr = FCVodeReInit(cvmem, t0, sunvec_y)
           if (ierr /= 0) call amrex_abort("integrate_ode: failed in FCVodeReInit()")

           ierr = FCVode(CVmem, t1, sunvec_y, t0, CV_NORMAL)
           if (ierr /= 0) call amrex_abort("integrate_ode: failed in FCVode()")

           ! Copy the solution of the ODE to the MultiFab.
           mf(i,j,k) = yvec(1)

        end do
     end do
  end do

  ! Free memory
  call FN_VDestroy_Serial(sunvec_y)
  call FCVodeFree(cvmem)

  deallocate(yvec)

end subroutine integrate_ode


! PR middle-end/57393
! { dg-do compile }
! { dg-options "-g -O2 -ffast-math" }

SUBROUTINE pr57393(nn,e,g,t0,t1,t2,t3,t4,t5,t6,t7,&
                   t8,t9,t10,t11,t12,t13,t14,t15,&
                   t16,t17,t18,t19,t20,t21,t22,t23,&
                   t24,t25,t26,t27,t28,t29,t30,&
                   t31,t32,t33,t34,t35,t36,t37,t38,&
                   t39,t40,t41,t42,t43,t44,t45,t46,t47)
  IMPLICIT REAL*8 (t)
  INTEGER, PARAMETER :: dp=8
  REAL(kind=dp) :: e(nn)
  DO ii=1,nn
     t48 = 0.1955555555e2_dp * t1 * t2 + &
           0.6000000000e1_dp * t3 * t4 * t5
     t49 = 0.1620000000e3_dp * t6 * t7 * t8 + &
           0.1080000000e3_dp * t6 * t9 * t5 - &
           0.6000000000e1_dp * t10 * t20 * t21 * t55 - &
           0.2400000000e2_dp * t10 * t11 * t12 - &
           0.1200000000e2_dp * t13 * t14 * t15
     t50 = t49 + t16
     t51 = (3 * t17 * t18 * t19) + &
           (t22 * t23 * t19) + (t50 * t19) - &
           0.3333333336e0_dp * t24 * t25
     t52 = 0.1555555556e1_dp * t26 * t27 * t12 + &
           (t51 + t28 + t29 + t30) *  &
           0.3125000000e0_dp * t31 * t32 * t33 * t34
     t53 = -0.1000000001e1_dp * t35 * t36 * t5 - &
           (t37 + t38 + t39 + t52) - &
           0.8333333340e-1_dp * t40 * t41 * t42
     t54 = -0.1000000001e1_dp * t43 * t44 * t45 - &
           t47 * (t46 + t53)
     IF (g >= 3 .OR. g == -3) THEN
       e(ii) = e(ii) + t54 * t0
     END IF
  END DO
END SUBROUTINE pr57393


C    %W% %G%
      subroutine miint(ix, angnow, nim, pgenim, qgenim, pld, qld, sqz,
     &                 xc, vhi, vhr, sina, cosa, vsqr, qerr)
C     -
C     -    Subroutine to initialize a single induction motor.  This
C     -       code has been moved from INITL3, which now calls it.
C     -    Checks are made for too many motors and for unrealistic
C     -       values of slip and power factor.
C     -    There are two maximum slips, a normal (warning) high and a
C     -       fatal high.
C     -
      include 'tspinc/params.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/machd1.inc'
      include 'tspinc/machd2.inc'
      include 'tspinc/gentbla.inc'
      include 'tspinc/gentblb.inc'
      include 'tspinc/gentblc.inc'
      include 'tspinc/int3.inc'
      include 'tspinc/spare1.inc'

      common /wscc_debug/xdebug(20)

C     -  Local variables

      logical debug
      character gname*16
      logical qerr

      data slipmin, slipmax, slipftl/.003, .05, .07/

C     call genname (ix, gname)                                       !dem
C     if (gname .eq. 'MOT MII  500.0 1') then
C     debug = .true.
C     else
C     debug = .false.
C     endif

C     -    Check if too many induction motors
      nim = nim+1
      if ( nim .gt. MAXINDMTR ) then
        iabort = 1
        write (errbuf(1), 10000) MAXINDMTR
10000   format (' Number of induction motors exceeds the limit of ',
     &   i3)
        call prterr('E', 1)
        qerr = .true.
      else

C       -   Start calculations from PF conditions
        pgen1 = -pld*datat(15)
        qgen1 = -qld*datat(16)
        imlv = imlv+1
        imlvi(imlv) = j

C       -   Fetch impedances
        rs = datat(6)+datat(18)
        xs = datat(7)+datat(17)
        rr = datat(9)
        xr = datat(10)
        xm = datat(8)
        pim = -pgen1
        qim = -qgen1

C       -   Test for negative induction motor load
        if ( pim .le. 0. ) then
          write (errbuf(1), 10010) name, base, id
10010     format (' Induction motor at ', a8, 2x, f5.1, 2x, a1,
     &     ' has a negative load.')
          call prterr('E', 1)
          iabort = 1
          qerr = .true.
        else

C         -   Do initializing
          xsrm = xs*xr+xs*xm+xr*xm
          xrm = xr+xm
          xsm = xs+xm
          a1 = rs*rs+xsm*xsm
          b1 = 2.*rs*xm*xm
          c1 = xsrm*xsrm+rs*rs*xrm*xrm
          d1 = pim/vsqr

C         -   Calculate rotor slip resistance (Stab User Manual, pg 2-8)
          a2 = a1*d1-rs
          b2 = b1*d1-xm*xm
          c2 = c1*d1-rs*xrm*xrm
          b2sqac = b2*b2-4.*a2*c2

C         -   Check for positive value under square root
          if ( b2sqac .lt. 0. ) then
            write (errbuf(1), 10020) name, base, id, b2sqac
10020       format (' Induction motor at ', a8, 2x, f5.1, 2x, a1,
     &       ' has complex slip resistance.  Imag part squared is '
     &       , e12.5)
            call prterr('E', 1)
            iabort = 1
            qerr = .true.
          else

C           -   OK to calculate R_slip
            b2sqrt = sqrt(b2sqac)
            r2h = (-b2+b2sqrt)/(2.*a2)
            r2l = (-b2-b2sqrt)/(2.*a2)

C           -   Since we can have two values for R_slip, we must check them
C           -      both and both their resultant slips, though we prefer
C           -      to use lower slip.
C           -   If larger R_slip is negative, then smaller one will be more
C           -      negative.
            if ( r2h .lt. 0. ) then
              write (errbuf(1), 10030) name, base, id, r2h, r2l
10030         format (' Induction motor at ', a8, 2x, f5.1, 2x, a1,
     &         ' has both R_slips negative (', f9.5, ' and ', f9.5,
     &         ' )')
              call prterr('E', 1)
              iabort = 1
              qerr = .true.
            else

C             -   This fudge prevents SLIPH from being < SLIPL
              if ( r2l .le. 0. ) r2l = r2h

C             -  Slip calculation
              slipl = rr/r2h
              sliph = rr/r2l

C             -   Prefer to use lower slip and higher R_slip
              slip0 = slipl
              r2 = r2h

C             -    Use high slip if low slip below minimum
              if ( slipl .lt. slipmin ) then
                slip0 = sliph
                r2 = r2l
              endif

C             -    Use low slip if high slip above maximum
              if ( sliph .gt. slipmax ) then
                slip0 = slipl
                r2 = r2h
              endif

C             -  Check if both slips are below minimum.
              if ( sliph .lt. slipmin ) then
                write (errbuf(1), 10040) name, base, id, slipmin
10040           format (' Induction motor at ', a8, 2x, f5.1, 2x, a1,
     &           ' has both slips less than allowed minimum of ', f7.4)
                write (errbuf(2), 10050) slipl, sliph
10050           format (' Low slip = ', f9.5, ';  High slip = ', f9.5)
                call prterr('E', 2)
                iabort = 1
                qerr = .true.
C             -   Slips > min, check if < fatal max
              elseif ( slipl .gt. slipftl ) then
                write (errbuf(1), 10060) name, base, id, slipftl
10060           format (' Induction motor at ', a8, 2x, f5.1, 2x, a1,
     &           ' has both slips greater than allowed maximum of ',
     &           f7.4)
                write (errbuf(2), 10070) slipl, sliph
10070           format (' Low slip = ', f9.5, ';  High slip = ', f9.5)
                call prterr('E', 2)
                iabort = 1
                qerr = .true.
              else

C               -    Check if slip < normal max
                if ( slipl .gt. slipmax ) then
                  write (errbuf(1), 10080) name, base, id, slipmax
10080             format (' Induction motor at ', a8, 2x, f5.1, 2x, a1,
     &             ' has both slips greater than normal maximum of ',
     &             f7.4)
                  write (errbuf(2), 10090) slipl, sliph
10090             format (' Low slip = ', f9.5, ';  High slip = ',
     &             f9.5)
                  call prterr('W', 2)
                endif

C               -    Slip acceptable.  Calculate Q_consump & Pwr factr
                qgeni = vsqr*(xsm*r2*r2+xsrm*xrm)/(r2*(a1*r2+b1)+c1)
                pwrfct = cos(atan2(qgeni, pim))
C               -    Test if power factor is in acceptable range
                if ( pwrfct .lt. 0.7.or.pwrfct .gt. 0.95 ) then
                  write (errbuf(1), 10100) name, base, id, pwrfct
10100             format (' Induction motor at ', a8, 2x, f5.1, 2x, a1,
     &             ' has power factor (', f8.5,
     &             ') outside normal range of 0.7 to 0.95')
                  call prterr('W', 1)
                endif
C               -   Calculate Q_load remaining at bus
                qgen1 = -qgeni

C               SUMMING PGEN1,QGEN1 FOR IND.MTR.

                pgenim = pgenim+pgen1
                qgenim = qgenim+qgen1
C               -   Source impedances to R_slip (dir & quad)
                xdp = xs+xr*xm/(xr+xm)
                xqp = xdp
                ra = rs
                xd = xs+xm
                xq = xd
                rr = slip0*r2
                ad = (rr/(xr+xm))*6.2831852
                xdxdp = xd-xdp
                write (outbuf, 10110) name, base, id, r2, xm, slip0, rr
10110           format (' At ', a8, 2x, f5.1, 2x, a1, 5x,
     &           '-  R2,XM,SLIP0,RR =', 4(1x, e12.5))
                call prtout(1)
C               -
                angp2(j) = -slip0*6.2831852
                xc = 0.5*(xdp+xqp)
C               -    Determine d-q voltages and currents
                agenr = (-pim*vhr-qgeni*vhi)/vsqr
                ageni = (-pim*vhi+qgeni*vhr)/vsqr
                write (outbuf, 10120)
10120           format ('0', 10x, 'PGEN1', 5x, 'QGEN1', 7x, 'VHR', 7x,
     &           'VHI', 6x, 'VSQR', 5x, 'AGENR', 5x, 'AGENI')
                call prtout(1)
                write (outbuf, 10130) pgen1, qgen1, vhr, vhi, vsqr,
     &           agenr, ageni
10130           format (4x, 7(1x, f9.5))
                call prtout(1)
C               -
                var = vhr+ra*agenr-xq*ageni
                vai = vhi+ra*ageni+xq*agenr
                pgn = var*agenr+vai*ageni
                govpwr(j) = pgn
                genp(j) = pgn
                angnow = atan2(vai, var)
                sina = sin(angnow)
                cosa = cos(angnow)
                agend = agenr*sina-ageni*cosa
                agenq = agenr*cosa+ageni*sina
                vhd = vhr*sina-vhi*cosa
                vhq = vhr*cosa+vhi*sina
                if ( ad .ne. 0.0 ) ad = 1./ad
                oid = agend
                oiq = agenq
                epq(j) = vhq+ra*agenq+xdp*agend
                epqo = epq(j)
                fd(j) = vhd+ra*agend-xqp*agenq
                epdo = fd(j)
                epdn = epdo
                epqn = epqo
                vfldtn(1, j) = 1000.
C               -    Per/unit freq deviation
                omega0 = 1.-slip0
C               -    Calculate C in the load torque equation
                ca = datat(12)
                cb = datat(13)
                cc = 1.-ca*omega0*omega0-cb*omega0
C               -    Contributions of each torque term
                all = ca*pgn
                bl = cb*pgn
                cl = cc*pgn
                sqz = 1./(ra*ra+xdp*xdp)
                xc = xdp
                qerr = .false.
C               -   Normal finish for induction motor init
C               if (debug) then
C               sparpt(1) = sqrt (vhr ** 2 + vhi ** 2)
C               sparpt(2) = atan2 (vhi, vhr)
C               sparpt(3) = sqrt (vhd ** 2 + vhq ** 2)
C               sparpt(4) = atan2 (vhq, vhd)
C               sparpt(5) = sqrt (oid ** 2 + oiq ** 2)
C               sparpt(6) = atan2 (oiq, oid)
C               sparpt(7) = sqrt (agend ** 2 + agenq ** 2)
C               sparpt(8) = atan2 (agenq, agend)
C               sparpt(9) = sqrt (fd(j) ** 2 + fq(j) ** 2)
C               sparpt(10) = atan2 (fq(j), fd(j))
C               xdebug(1) = 1.0 - slip0
C               xdebug(2) = slip0
C               xdebug(3) = pim
C               xdebug(4) = pgn
C               xdebug(5) = vhr
C               xdebug(6) = vhi
C               endif
              endif
            endif
          endif
        endif
      endif
      return
      end


module setup_boundary_mod

use constants_mod

contains

subroutine setup_side_boundary(side,inner,outer)

    use setup_config_mod
    use equations_const_mod
    use mesh_types_mod, only: side_t
    use quad_utils_mod, only: side_get_coords

    use share_mod, only: rt => runtime

    type(side_t), intent(in)    :: side
    real(dp), intent(in)        :: inner(N_NODES,N_NODES,N_VARS)
    real(dp), intent(out)       :: outer(N_NODES,N_NODES,N_VARS)

    real(dp) :: dens(N_NODES,N_NODES)

    real(dp) :: velx(N_NODES,N_NODES)
    real(dp) :: vely(N_NODES,N_NODES)
    real(dp) :: velz(N_NODES,N_NODES)

    real(dp) :: momx(N_NODES,N_NODES)
    real(dp) :: momy(N_NODES,N_NODES)
    real(dp) :: momz(N_NODES,N_NODES)

    real(dp) :: magx(N_NODES,N_NODES)
    real(dp) :: magy(N_NODES,N_NODES)
    real(dp) :: magz(N_NODES,N_NODES)

    real(dp) :: pres(N_NODES,N_NODES)
    real(dp) :: ener(N_NODES,N_NODES)
    real(dp) :: glmp(N_NODES,N_NODES)

    real(dp) :: coords(N_NODES,N_NODES,N_DIMS)

    real(dp) :: x_shock

# if 1
    select case(side%boundary)

        case (NOR)
            !! inflow

            dens =  3.86859_dp

            velx =  11.2536_dp
            vely =  0.0_dp
            velz =  0.0_dp

            pres =  167.345_dp

            magx =  0.0_dp
            magy =  2.1826182_dp
            magz = -2.1826182_dp

        case (SOU)

            !! outflow

            dens = 1.0_dp

            velx = 0.0_dp
            vely = 0.0_dp
            velz = 0.0_dp

            pres = 1.0_dp

            magx = 0.0_dp
            magy = 0.56418958_dp
            magz = 0.56418958_dp

        case default

            outer = inner
            outer(:,:,GLMP_VAR) = 0.0_dp
            return

    end select
# endif

# if 0
    ! x_shock = 0.05_dp + 15.176642330901245_dp * (rt%simtime + 0.5_dp*rt%timestep)
    x_shock = 0.05_dp + 15.176642330901245_dp * rt%simtime
    coords = side_get_coords(side)

    where (coords(:,:,X_DIR) < x_shock)

        dens =  3.86859_dp

        velx =  11.2536_dp
        vely =  0.0_dp
        velz =  0.0_dp

        pres =  167.345_dp

        magx =  0.0_dp
        magy =  2.1826182_dp
        magz = -2.1826182_dp

    else where

        dens = 1.0_dp

        velx = 0.0_dp
        vely = 0.0_dp
        velz = 0.0_dp

        pres = 1.0_dp

        magx = 0.0_dp
        magy = 0.56418958_dp
        magz = 0.56418958_dp

    end where
# endif

    glmp = 0.0_dp

    momx = dens * velx
    momy = dens * vely
    momz = dens * velz

    ener = pres/(kappa-1.0_dp) &
        + 0.5_dp*dens*(velx**2+vely**2+velz**2) &
        + 0.5_dp/mu0*(magx**2+magy**2+magz**2) &
        + 0.5_dp/mu0*glmp**2

    outer(:,:,DENS_VAR) = dens

    outer(:,:,MOMX_VAR) = momx
    outer(:,:,MOMY_VAR) = momy
    outer(:,:,MOMZ_VAR) = momz

    outer(:,:,ENER_VAR) = ener

    outer(:,:,MAGX_VAR) = magx
    outer(:,:,MAGY_VAR) = magy
    outer(:,:,MAGZ_VAR) = magz

    outer(:,:,GLMP_VAR) = glmp

end subroutine

end module


      module genint_m
c
c----------------------------------------
c    aims to generate the quadrature point
c    specially for DG interface elements
c----------------------------------------
        integer, dimension(4), parameter :: nint_tet (4) = (/1,4,16,29/)
        integer, dimension(5), parameter :: nint_quad(5) = (/1,4,9,16,25/)
c
        integer, dimension(4), parameter :: nint_tri (4) = (/1,3,6,12/)
c
        contains
c
        subroutine genint_if
c
          use number_def_m
          use intpt_m
          use intdat_m
c
          implicit none
c
          integer :: itp,ierr
          real*8, allocatable :: tmpQptif(:,:), tmpQwtif(:)
c
c ... Tet
c
          nintif = nint_tri(intg(3,1))
c
          allocate(tmpQptif(4,nintif(nint_tri(intg(3,1)))))
          allocate(tmpQwtif(nintif(nint_tri(intg(3,1)))))
c
          itp = itp_tet
c
          call symtri(nintif(itp),tmpQptif,tmpQwtif,ierr)
c
          Qptif (itp,1:4,1:nintif(itp)) = tmpQptif(1:4,1:nintif(itp))
          Qwtif (itp,1:nintif(itp))     = tmpQwtif(1:nintif(itp))
c
c.... adjust quadrature weights to be consistent with the
c     design of tau.
c
          Qwtif(itp,:)  = two*Qwtif(itp,:)
c
c ... Wedge
c
          itp = itp_wedge
c
          call symtri(nintif(itp),tmpQptif,tmpQwtif,ierr)
c
          Qptif(itp,1:2,2:nintif(3)) = tmpQptif(1:2,1:nintif(3)-1)
          Qptif(itp,1:2,1) = tmpQptif(1:2,nintif(3))
c
c     wedges want the third entry to be zeta=-1 (not t=1-r-s)
c     4th entry not used
c
          Qptif(itp,3:4,1:nintif(3)) = -1
c$$$       Qptb(3,1:4,1:nintb(3)) = tmpQptb(1:4,1:nintb(3))
          Qwtif(itp,1:nintif(3)) = tmpQwtif(1:nintif(3))
c
          deallocate(tmpQptif,tmpQwtif)
c
        end subroutine genint_if
c
      end module genint_m