MODULE SPECIAL

  IMPLICIT NONE

  CONTAINS

  !> @brief Computes determinant of 3x3 matrix
  SUBROUTINE DETERMINANT3X3(numPoints,bufferSize,bufferInterval,inMatrix,matrixDeterminant)

    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(3)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(6)
    REAL(KIND=8),    INTENT(IN)      :: inMatrix(9*numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: matrixDeterminant(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)
    jStart = bufferInterval(3)
    jEnd   = bufferInterval(4)
    kStart = bufferInterval(5)
    kEnd   = bufferInterval(6)
    nPlane = xSize * bufferSize(2)

    DO K = kStart, kEnd
       zIndex = (K-1)*nPlane
       DO J = jStart, jEnd
          yzIndex = zIndex + (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yzIndex + I

             matrixDeterminant(bufferIndex) =                &
                  inMatrix(bufferIndex)*                     &
                  (inMatrix(bufferIndex+8*numPoints) * &
                  inMatrix(bufferIndex+4*numPoints)-   &
                  inMatrix(bufferIndex+7*numPoints)*   &
                  inMatrix(bufferIndex+5*numPoints))-  &

                  inMatrix(bufferIndex+3*numPoints)*   &
                  (inMatrix(bufferIndex+8*numPoints)*  &
                  inMatrix(bufferIndex+numPoints) -    &
                  inMatrix(bufferIndex+7*numPoints) *  &
                  inMatrix(bufferIndex+2*numPoints)) + &

                  inMatrix(bufferIndex+6*numPoints)*   &
                  (inMatrix(bufferIndex+5*numPoints)*  &
                  inMatrix(bufferIndex+numPoints)-     &
                  inMatrix(bufferIndex+4*numPoints)*   &
                  inMatrix(bufferIndex+2*numPoints))

          END DO
       END DO
    END DO
  END SUBROUTINE DETERMINANT3X3

  !> @brief Computes determinant of 2x2 matrix
  SUBROUTINE DETERMINANT2X2(numPoints,bufferSize,bufferInterval,inMatrix,matrixDeterminant)

    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(2)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(4)
    REAL(KIND=8),    INTENT(IN)      :: inMatrix(4*numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: matrixDeterminant(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)
    jStart = bufferInterval(3)
    jEnd   = bufferInterval(4)
    nPlane = xSize * bufferSize(2)

    DO J = jStart, jEnd
       yIndex = (J-1)*xSize
       DO I = iStart, iEnd
          bufferIndex = yIndex + I

          matrixDeterminant(bufferIndex) =                &
               (inMatrix(bufferIndex)*                    &
               inMatrix(bufferIndex+3*numPoints)) -       &
               (inMatrix(bufferIndex+numPoints)*          &
               inMatrix(bufferIndex+2*numPoints))
       END DO
    END DO

  END SUBROUTINE DETERMINANT2X2

  !> @brief Computes buf1*buf4 - buf2*buf3 + buf7*(buf5 - buf6)
  SUBROUTINE METRICSUM4(numDim,numPoints,bufferSize,bufferInterval,&
       buf1,buf2,buf3,buf4,buf5,buf6,buf7,metricSum)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: buf1(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: buf2(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: buf3(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: buf4(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: buf5(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: buf6(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: buf7(numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: metricSum(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          metricSum(I) = buf1(I)*buf4(I) - buf2(I)*buf3(I) + buf7(I)*(buf5(I)-buf6(I))
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             metricSum(bufferIndex) = buf1(bufferIndex)*buf4(bufferIndex) - &
                  buf2(bufferIndex)*buf3(bufferIndex) + &
                  buf7(bufferIndex)*(buf5(bufferIndex)-buf6(bufferIndex))
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                metricSum(bufferIndex) = buf1(bufferIndex)*buf4(bufferIndex) - &
                     buf2(bufferIndex)*buf3(bufferIndex) + &
                     buf7(bufferIndex)*(buf5(bufferIndex)-buf6(bufferIndex))
             END DO
          END DO
       END DO
    ENDIF
  END SUBROUTINE METRICSUM4

  SUBROUTINE VECTORCROSSPRODUCT(v1,v2,y)

    IMPLICIT NONE

    REAL(KIND=8), INTENT(IN)  :: v1(3), v2(3)
    REAL(KIND=8), INTENT(OUT) :: y(3)

    y(1) = v1(2)*v2(3) - v1(3)*v2(2)
    y(2) = v1(3)*v2(1) - v1(1)*v2(3)
    y(3) = v1(1)*v2(2) - v1(2)*v2(1)

  END SUBROUTINE VECTORCROSSPRODUCT

END MODULE SPECIAL


! filename = sum.f90
! Purpose: To be used as a shared library

! Function to sum two real valued numbers
FUNCTION sum(x,y)
    double precision :: sum
    double precision, intent(in) :: x, y

    sum = x+y
END FUNCTION sum

! Subroutine to add two real valued numbers
SUBROUTINE sum_sub(x,y,output)
    double precision, intent(in) :: x, y
    double precision, intent(out) :: output

    output = x+y
END SUBROUTINE sum_sub

! function to calculate average of array of doubles
FUNCTION average(length, values)
    integer, intent(in) :: length
    double precision, intent(in) :: values(length)
    double precision :: average

    average = 0.0
    DO i = 1, length
        average = average + values(i)
    ENDDO
    average = average/length
END FUNCTION average


c     # ---------------------------------------------------------------
      double precision function q0_physical(xp,yp,zp)
      implicit none

      double precision xp, yp, zp

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      integer initchoice
      common /initchoice_comm/ initchoice

      double precision xc0, yc0, r0
      common /cylinder_init_comm/ xc0, yc0, r0

      double precision xp0, yp0, zp0, r, q0, Hsmooth

      integer k

      call mapc2m_cylinder(xc0,yc0,xp0,yp0,zp0)

c     # Sphere centered at (0.5,0.5,0) on swirl
      if (initchoice .eq. 1) then
          q0 = 1.d0
      elseif (initchoice .eq. 2) then
          r = sqrt((xp - xp0)**2 + (yp-yp0)**2 + (zp-zp0)**2)
          q0 = 1 - Hsmooth(r - r0)
      endif
      q0_physical = q0

      end

c     # ---------------------------------------------------------------
      double precision function Hsmooth(r)
      implicit none

      double precision r

      Hsmooth = (tanh(r/0.02d0) + 1)/2.d0

      end

      double precision function q0_init(xc,yc)
      implicit none

      double precision xc,yc

      double precision xp, yp, zp
      double precision q0_physical

      call mapc2m_cylinder(xc,yc,xp,yp,zp)

      q0_init = q0_physical(xp,yp,zp)

      end


module par
IMPLICIT NONE
real*8 r,z,phi
real*8,parameter::pi=dacos(-1.d0)
endmodule par

program twodintx
use  par
implicit none

REAL*8 X(3,2),Y(3,2),DATA(4500),RES,ERR,r1,r2,theta1,theta2
INTEGER IWORK(1000),NU,ND,NEVALS,IFLAG
EXTERNAL F
r=2.82842712474619d0
z=-2.d0
phi=-2.35619449019234d0

r1=1.52651490011283d0
r2=1.95095241255724d0
theta1=0.d0
theta2=2.d0*pi
X(1,1)=r1
Y(1,1)=theta1
X(2,1)=r2
Y(2,1)=theta1
X(3,1)=r2
Y(3,1)=theta2
X(1,2)=r1
Y(1,2)=theta1
X(2,2)=r2
Y(2,2)=theta2
X(3,2)=r1
Y(3,2)=theta2
NU=0
ND=0
IFLAG=1
CALL TWODQ(F,2,X,Y,1.E-08,1,200,32000,RES,ERR,NU,ND, NEVALS,IFLAG,DATA,IWORK)
PRINT*,RES,ERR,NEVALS,IFLAG

end program twodintx

real*8 FUNCTION F(t,theta)
use par
implicit none
real*8 t,theta
F=t/dsqrt(z**2+t**2+r**2-2.d0*r*t*dcos(phi-theta))
RETURN
END FUNCTION F


!Функция поверхности
function sedlo(a,b) result(c)
	implicit none
	real,intent(in) :: a,b
	real :: c
	c = (a*a-b*b)/4
end function sedlo

program main
!       Используем графическую библиотеку
	USE Plotter
	implicit none
!	Тип, хранящий указатель
	type(functions):: one_surface
!       Указываем что мы используем функцию с выводом типа real
		real, external :: sedlo
!	Мы собираемся отправить функцию поверхности
	one_surface%function_surface=>sedlo
!       Шаг по осям
		call Set_Step_X(1.)
		call Set_Step_Y(1.)
!       Передаём в функцию Размер окна, ограничения по осям Х и У и указатели с их количеством
	call DrawGraph(960,720,-5.,5.,-5.,5.,one_surface)
end


        program locate

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c LOCATE - This program transforms I,J coordinates of an SSM/I grid cell
c          to latitude and longitude coordinates. This program provides
c          the inverse functions as well. LOCATE interfaces to the revised
c          forms of the subroutines, MAPXY and MAPLL.
c
c  User-defined Paramters:
c
c     gtype   : Integer supplied by the user to describe one of the three
c               grid cell dimensions (12.5 km, 25.0 km).
c
c     ihem    : Integer supplied by the user to describe one of the two
c               polar regions (1=North , 2=South)
c
c     itrans  : Integer supplied by the user to describe the type of
c               transformation LOCATE will perform (1=I,J-to-Lat,Lon;
c               2=Lat,Lon-to-I,J)
c
c     i,j     : Integers supplied by the user when itrans = 1. These
c               integers describe the position of a cell in an SSM/I grid.
c
c     lat,lon : Reals supplied by the user when itrans = 2. These
c               integers describe the latitude and longitude in an SSM/I
c               grid which LOCATE will transform to an I,J grid cell position.
c               Note: All latitudes and longitudes must be entered as
c                     positive numbers!
c
c  Internal:
c
c     x,y     : Distance in kilometers from the origin of the grid
c               (ie., pole).
c
c     alat,
c     alon    : Computed latitude and longitude returned from MAPXY.
c
c     SGN     : Sign of the latitude (positive = north latitude,
c               negative = south latitude)
c
c     delta   : Meridian offset for the SSM/I grids (0 degrees for
c               the South Polar grids; 45 degrees for the North Polar
c               grids.
c
c     kk      : Integer variable used for reorientation of the grid. The
c               grid is 'flipped' in the Y direction for transformations.
c
c     SLAT    : Standard latitude for the SSM/I grids is 70 degrees.
c
c     numy    : Number of lines in an SSM/I grid. This attribute varies
c               for each of the six grids.
c
c     cell    : Size of the SSM/I grid ( 12.5 km, 25.0 km)
c
c     xydist  : Distance from the origin of the grid in the cartesian plane.
c               The x-y coordinates for the edge of the lower left pixel
c               is (3850.0, 5350.0) for the northern grids and
c               (3950.0, 3950.0) for the southern grids.
c
c     RE      : Radius of the earth in kilometers.
c
c     E       : Eccentricity of the Hughes ellipsoid
c
c     E2      : Eccentricity squared
c
c     PI      : Pi
c  Written by  V.J.Troisi - January, 1990
c  Updated by  N.A.Sandoval - November, 1995 - Switched i,j in the
c              equation to be consistent i-row, j-column.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        real SLAT,E,RE,PI
        real alat,alon,x,y
        integer ihem
        real lat, lon
        real SGN, delta
        integer numy(2,3)
        real cell(2), xydist(2,2)
        data numy / 896, 664, 448, 332, 224, 166 /
        data cell     / 12.5 , 25.0 /
        data xydist   / 3850.0 , 5350.0 , 3950.0 , 3950 /

        SLAT = 70.
        RE = 6378.273
        E2 = .006693883
        PI = 3.141592654
        E =  sqrt(E2)
c
c Query for the SSM/I grid cell size.
c
        print *,'Enter the grid cell dimension:'
        print *,' 1. 12.5 Km'
        print *,' 2. 25.0 Km'
        read *,gtype
c
c Query for polar region of interest.
c
        print *,'Enter the hemisphere of interest:'
        print *,' 1. North'
        print *,' 2. South'
        read *,ihem
c
c Define the sign and meridian offset (delta) for the SSM/I grids.
c
        if (ihem.eq.1) then
           SGN   = 1.0
           delta = 45.
        else
           SGN   = -1.0
           delta = 0.0
        endif
c
c Query for translation type.
c
        print *,'Enter one of the following transform functions:'
        print *,' 1. Convert I,J to Latitude, Longitude'
        print *,' 2. Convert Latitude, Longitude to I,J'
        read *, itrans
c
c Start translation
c
        if (itrans.eq.1) then
c
c Obtain the I,J position of the grid cell to transform to Latitude
c and Longitude
c
          print *,'Enter the column number'
          if(ihem.eq.1 .and. gtype.eq.1)
     +      print *,'the valid range is (1-608)'
          if(ihem.eq.1 .and. gtype.eq.2)
     +      print *,'the valid range is (1-304)'
          if(ihem.eq.2 .and. gtype.eq.1)
     +      print *,'the valid range is (1-632)'
          if(ihem.eq.2 .and. gtype.eq.2)
     +      print *,'the valid range is (1-316)'
          read *,j

          print *,'Enter the row number'
          if(ihem.eq.1 .and. gtype.eq.1)
     +      print *,'the valid range is (1-896)'
          if(ihem.eq.1 .and. gtype.eq.2)
     +      print *,'the valid range is (1-448)'
          if(ihem.eq.2 .and. gtype.eq.1)
     +      print *,'the valid range is (1-664)'
          if(ihem.eq.2 .and. gtype.eq.2)
     +      print *,'the valid range is (1-332)'
          read *,i
c
c Convert I,J pairs to x and y distances from origin. For some image
c display programs, the grid will be 'flipped' in the 'Y' direction.
c+
c Changed j for i and i for j to be consistant, NAS (11/95).
c-
             x=((j-1)*cell(gtype))-(xydist(1,ihem)-cell(gtype)/2.)
             kk=numy(ihem,gtype)-(i-1)
             y=((kk-1)*cell(gtype))-(xydist(2,ihem)-cell(gtype)/2.)
c
c Transform x and y distances to latitude and longitude
c
             call mapxy (x,y,alat,alon,SLAT,SGN,E,RE)
c
c Transform radians to degrees.
c
             alon=alon*180./PI
             alat=alat*180./PI
             alon=alon-delta
c
c Convert longitude to positive degrees
c
             if (alon.le.0.0) alon=alon+360.
             if (alon.ge.360.0) alon=alon-360.
c
c Print the latitude and longitude for the center of the I,J cell.
c
             print *,alat,alon
       else
c
c Obtain the latitude and longitude pair and transform to cell where
c that pair is located.
c
             print *,'Enter latitude and longitude (positive values):'
             read *,lat,lon
c
c Transform degrees to radians
c
             alat=abs(lat)*PI/180.
             alon=(lon+delta)*PI/180.
c
c Transform latitude and longitude to x and y distances from origin
c
           call mapll (x,y,alat,alon,SLAT,SGN,E,RE)
           print *,x,y
c
c Convert x and y distances from origin to I,J pair (ii,jj)
c
             ii=nint((x+xydist(1,ihem)-cell(gtype)/2.)/cell(gtype))+1
             jj=nint((y+xydist(2,ihem)-cell(gtype)/2.)/cell(gtype))+1
c
c Flip grid orientation in the 'Y' direction
c
             kk=numy(ihem,gtype)-(jj-1)
c
c Print the I,J location of the cell.
c
             print *,ii,kk

          endif
      end


	  subroutine shape
        use fluid_variables
	  implicit none

	  integer iq

	  if (nen.eq.4) then
		call quad3d4n(iquad, nquad, xq, wq, nsdpad, nquadpad)
	  else if (nen.eq.8) then
		call quad3d8n(iquad, nquad, xq, wq, nsdpad, nquadpad)
	  end if
      do iq=1,nquad
		if(nen.eq.4) then
		  sq(0,1,iq) = xq(1,iq)
		  sq(0,2,iq) = xq(2,iq)
		  sq(0,3,iq) = xq(3,iq)
		  sq(0,4,iq) = 1 - xq(1,iq) - xq(2,iq) - xq(3,iq)
        else
		  sq(0,1,iq) = (1 - xq(1,iq))	&
			   * (1 - xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(0,2,iq) = (1 + xq(1,iq))	&
			   * (1 - xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(0,3,iq) = (1 + xq(1,iq))	&
			   * (1 + xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(0,4,iq) = (1 - xq(1,iq))	&
			   * (1 + xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(0,5,iq) = (1 - xq(1,iq))	&
			   * (1 - xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(0,6,iq) = (1 + xq(1,iq))	&
			   * (1 - xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(0,7,iq) = (1 + xq(1,iq))	&
			   * (1 + xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(0,8,iq) = (1 - xq(1,iq))	&
			   * (1 + xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(1,1,iq) = - (1 - xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(1,2,iq) = + (1 - xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(1,3,iq) = + (1 + xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(1,4,iq) = - (1 + xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(1,5,iq) = - (1 - xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(1,6,iq) = + (1 - xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(1,7,iq) = + (1 + xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(1,8,iq) = - (1 + xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(2,1,iq) = - (1 - xq(1,iq)) * (1 - xq(3,iq)) / 8
		  sq(2,2,iq) = - (1 + xq(1,iq)) * (1 - xq(3,iq)) / 8
		  sq(2,3,iq) = + (1 + xq(1,iq)) * (1 - xq(3,iq)) / 8
		  sq(2,4,iq) = + (1 - xq(1,iq)) * (1 - xq(3,iq)) / 8
		  sq(2,5,iq) = - (1 - xq(1,iq)) * (1 + xq(3,iq)) / 8
		  sq(2,6,iq) = - (1 + xq(1,iq)) * (1 + xq(3,iq)) / 8
		  sq(2,7,iq) = + (1 + xq(1,iq)) * (1 + xq(3,iq)) / 8
		  sq(2,8,iq) = + (1 - xq(1,iq)) * (1 + xq(3,iq)) / 8
		  sq(3,1,iq) = - (1 - xq(1,iq)) * (1 - xq(2,iq)) / 8
		  sq(3,2,iq) = - (1 + xq(1,iq)) * (1 - xq(2,iq)) / 8
		  sq(3,3,iq) = - (1 + xq(1,iq)) * (1 + xq(2,iq)) / 8
		  sq(3,4,iq) = - (1 - xq(1,iq)) * (1 + xq(2,iq)) / 8
		  sq(3,5,iq) = + (1 - xq(1,iq)) * (1 - xq(2,iq)) / 8
		  sq(3,6,iq) = + (1 + xq(1,iq)) * (1 - xq(2,iq)) / 8
		  sq(3,7,iq) = + (1 + xq(1,iq)) * (1 + xq(2,iq)) / 8
		  sq(3,8,iq) = + (1 - xq(1,iq)) * (1 + xq(2,iq)) / 8
        endif
	  enddo
	  return
	  end

	  subroutine shape2d
	  use fluid_variables

	  implicit none

	  integer iq

	  if (nen==3) then
		call quad2d3n(iquad, nquad, xq, wq, nsdpad, nquadpad)
	  else if (nen==4) then
		call quad2d4n(iquad, nquad, xq, wq, nsdpad, nquadpad)
	  end if
      do iq=1,nquad
		if(nen==3) then
		  sq(0,1,iq) = xq(1,iq)
		  sq(0,2,iq) = xq(2,iq)
		  sq(0,3,iq) = 1 - xq(1,iq) - xq(2,iq)
        elseif (nen==4) then
		  sq(0,1,iq) = (1 - xq(1,iq)) * (1 - xq(2,iq)) / 4
		  sq(0,2,iq) = (1 + xq(1,iq)) * (1 - xq(2,iq)) / 4
		  sq(0,3,iq) = (1 + xq(1,iq)) * (1 + xq(2,iq)) / 4
		  sq(0,4,iq) = (1 - xq(1,iq)) * (1 + xq(2,iq)) / 4

		  sq(1,1,iq) = - (1 - xq(2,iq)) / 4
		  sq(1,2,iq) = + (1 - xq(2,iq)) / 4
		  sq(1,3,iq) = + (1 + xq(2,iq)) / 4
		  sq(1,4,iq) = - (1 + xq(2,iq)) / 4

		  sq(2,1,iq) = - (1 - xq(1,iq)) / 4
		  sq(2,2,iq) = - (1 + xq(1,iq)) / 4
		  sq(2,3,iq) = + (1 + xq(1,iq)) / 4
		  sq(2,4,iq) = + (1 - xq(1,iq)) / 4

        endif
	  enddo
	  return
	end subroutine shape2d


************************************************************************
*     UPDATE_EST - Updates the estimated yield of magic beans given
*       some additional amount of rainfall
************************************************************************
*
*     VARIABLES
*
*     INPUT RAIN      = Additional rainfall
*
*     INOUT YIELD_EST = Crop yield to update
*
************************************************************************

************************************************************************
*     CROP_YIELD - Estimate the yield of magic beans given a simple
*       model for rainfall
************************************************************************
*
*     VARIABLES
*
*     INPUT MAX_RAIN   = The maximum rain for the month
*     INPUT CONSITENCY = The consistency of the rainfall
*       (higher = more consistent)
*     INPUT ABSORBTION = Estimates the % of rainfall absorbed into the
*       soil (i.e. % lost due to evaporation, runoff)
*
*     OUTPUT YIELD_EST = The estimated yield of magic beans
*
*     DAY              = The current day of the month
*     RAIN             = The rainfall estimate for the current day
*
************************************************************************
      PROGRAM CROP_YIELD
      IMPLICIT NONE

      INTEGER DAY
      DOUBLE PRECISION RAIN, YIELD_EST, TOTAL_RAIN, NEWS
      DOUBLE PRECISION MAX_RAIN, CONSISTENCY, ABSORBTION

      MAX_RAIN = 4.0
      CONSISTENCY = 64.0
      ABSORBTION = 0.6

      YIELD_EST = 0
      TOTAL_RAIN = 0

      DO 20 DAY=1,31
        PRINT *, "(", DAY, CONSISTENCY, MAX_RAIN, ABSORBTION, ")"
*       Compute rainfall for the current day
        RAIN = (-(DAY - 16) ** 2 / CONSISTENCY + MAX_RAIN) * ABSORBTION
        PRINT *, RAIN

*       Update rainfall estimate
        YIELD_EST = UPDATE_EST(RAIN, TOTAL_RAIN, YIELD_EST)
        NEWS = TEST_FUNC(TOTAL_RAIN, YIELD_EST)

        PRINT *, "Day ", DAY, " Estimate: ", YIELD_EST

   20 ENDDO

      PRINT *, "Crop Yield(%): ", YIELD_EST
      PRINT *, "News: ", NEWS

      CONTAINS
       DOUBLE PRECISION FUNCTION UPDATE_EST(RAIN, TOTAL_RAIN, YIELD_EST)
          IMPLICIT NONE
          DOUBLE PRECISION RAIN, YIELD_EST, TOTAL_RAIN
          TOTAL_RAIN = TOTAL_RAIN + RAIN

*         Yield increases up to a point
          IF(TOTAL_RAIN .le. 40) THEN
            YIELD_EST = -(TOTAL_RAIN - 40) ** 2 / 16 + 100

*         Then sharply declines
          ELSE
              YIELD_EST = -TOTAL_RAIN + 140
          ENDIF
          UPDATE_EST = YIELD_EST

        END FUNCTION UPDATE_EST

       DOUBLE PRECISION FUNCTION TEST_FUNC(TOTAL_RAIN, YIELD_EST)
          IMPLICIT NONE
          DOUBLE PRECISION TOTAL_RAIN, YIELD_EST, NEW_VAR
          NEW_VAR = 5.0
          IF (NEW_VAR .le. 4.0) THEN
            TEST_FUNC = TOTAL_RAIN
          ELSE
            TEST_FUNC = YIELD_EST
          ENDIF

       END FUNCTION TEST_FUNC

      END PROGRAM CROP_YIELD


      DOUBLE PRECISION FUNCTION sla_GMST (UT1)
*+
*     - - - - -
*      G M S T
*     - - - - -
*
*  Conversion from universal time to sidereal time (double precision)
*
*  Given:
*    UT1    dp     universal time (strictly UT1) expressed as
*                  modified Julian Date (JD-2400000.5)
*
*  The result is the Greenwich mean sidereal time (double
*  precision, radians).
*
*  The IAU 1982 expression (see page S15 of 1984 Astronomical Almanac)
*  is used, but rearranged to reduce rounding errors.  This expression
*  is always described as giving the GMST at 0 hours UT.  In fact, it
*  gives the difference between the GMST and the UT, which happens to
*  equal the GMST (modulo 24 hours) at 0 hours UT each day.  In this
*  routine, the entire UT is used directly as the argument for the
*  standard formula, and the fractional part of the UT is added
*  separately.  Note that the factor 1.0027379... does not appear in the
*  IAU 1982 expression explicitly but in the form of the coefficient
*  8640184.812866, which is 86400x36525x0.0027379...
*
*  See also the routine sla_GMSTA, which delivers better numerical
*  precision by accepting the UT date and time as separate arguments.
*
*  Called:  sla_DRANRM
*
*  P.T.Wallace   Starlink   14 October 2001
*
*  Copyright (C) 2001 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION UT1

      DOUBLE PRECISION sla_DRANRM

      DOUBLE PRECISION D2PI,S2R
      PARAMETER (D2PI=6.283185307179586476925286766559D0,
     :           S2R=7.272205216643039903848711535369D-5)

      DOUBLE PRECISION TU

*  Julian centuries from fundamental epoch J2000 to this UT
      TU=(UT1-51544.5D0)/36525D0

*  GMST at this UT
      sla_GMST=sla_DRANRM(MOD(UT1,1D0)*D2PI+
     :                    (24110.54841D0+
     :                    (8640184.812866D0+
     :                    (0.093104D0-6.2D-6*TU)*TU)*TU)*S2R)

      END


      SUBROUTINE SBLLGD (FLON,FLAT,NPAIR,X,Y,ILLGD,ISTAT)
C
C     THIS SUBROUTINE CONVERTS THE LONGITUDE AND LATITUDE COORDINATE
C     LOCATION ON EARTH TO THE HRAP GRID SYSTEM LOCATION (AND VICE-
C     VERSA).  IF ILLGD=1, GRID POINTS ARE DETERMINED FROM LONGITUDE
C     AND LATITUDE.  IF ILLGD=0, LONGITUDE AND LATITUDE ARE COMPUTED
C     FROM THE GRID POINTS. (ASSUMES NORTH POLE = 401,1601)
C     LONGITUDE IS ASSUMED TO BE GREATER THAN 0
C     COPIED FROM CALB>MAP>SFGRID.F77 ON 10/24/88
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 FLAT,FLON,X,Y,YFLAT,XFLON,XX,YY
C
      DIMENSION X(1),Y(1),FLON(1),FLAT(1)
C
      DATA DEGRAD/.01745329/
      DATA EARTHR/6371.2/
      DATA STLAT/60./
      DATA STLON/105./
      DATA RADDEG/57.2957795/
C
      ISTAT=0
      XMESH=4.7625
      TLAT=STLAT*DEGRAD
      RE=(EARTHR*(1.0+DSIN(TLAT)))/XMESH
C
      IF (ILLGD.EQ.1) THEN
C
C       COMPUTE GRID POINTS FROM LONGITUDE AND LATITUDE.
C
        DO I=1,NPAIR
          XFLON = FLON(I)
          YFLAT = FLAT(I)
          X(I) = 0.
          Y(I) = 0.
          IF (YFLAT.GE.10..AND.YFLAT.LE.80.AND.
     X        XFLON.GE.40.AND.XFLON.LE.180.) THEN
            XLAT=DBLE(YFLAT)*DEGRAD
            WLONG=(DBLE(XFLON)+180.0-STLON)*DEGRAD
            R=(RE*DCOS(XLAT))/(1.0+DSIN(XLAT))
            X(I)=R*DSIN(WLONG)
            Y(I)=R*DCOS(WLONG)
          ELSE
            ISTAT = -1
          ENDIF
        ENDDO
        DO I=1,NPAIR
          X(I)=X(I)+401
          Y(I)=Y(I)+1601
        ENDDO
      ELSE
C
C       COMPUTE LONG/LAT FROM THE GRID POINTS.
C
        GI2 = RE**2
        DO I=1,NPAIR
          XX = X(I)
          YY = Y(I)
          IF (XX.GE.1..AND.XX.LE.1161.AND.
     X       YY.GE.1..AND.YY.LE.1601.) THEN
            XX=XX-401
            YY=YY-1601
            RR=XX*XX+YY*YY
            IF (RR.NE.0.0) THEN
              FLAT(I)=DASIN((GI2-RR)/(GI2+RR))*RADDEG
              ANG=ATAN2(YY,XX)*RADDEG
              IF(ANG.LT.0.0) ANG=ANG+360.
              FLON(I)=270.+STLON-ANG
              IF (FLON(I).LT.0.0) FLON(I)=FLON(I)+360.
              IF (FLON(I).GE.360.) FLON(I)=FLON(I)-360.
            ELSE
              FLON(I)=0.0
              FLAT(I)=90.0
            ENDIF
          ELSE
            ISTAT = -1
            FLON(I) = 0.
            FLAT(I) = 0.
          ENDIF
        ENDDO
      ENDIF
      RETURN
      END


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/33197
!
! Fortran 2008 complex trigonometric functions: tan, cosh, sinh, tanh
!
! Compile-time simplificiations
!
implicit none
real(4), parameter :: pi  = 2*acos(0.0_4)
real(8), parameter :: pi8 = 2*acos(0.0_8)
real(4), parameter :: eps  = 10*epsilon(0.0_4)
real(8), parameter :: eps8 = 10*epsilon(0.0_8)
complex(4), parameter :: z0_0  = cmplx(0.0_4, 0.0_4, kind=4)
complex(4), parameter :: z1_1  = cmplx(1.0_4, 1.0_4, kind=4)
complex(4), parameter :: zp_p  = cmplx(pi,    pi,    kind=4)
complex(8), parameter :: z80_0 = cmplx(0.0_8, 0.0_8, kind=8)
complex(8), parameter :: z81_1 = cmplx(1.0_8, 1.0_8, kind=8)
complex(8), parameter :: z8p_p = cmplx(pi8,   pi8,   kind=8)

if (abs(tan(z0_0)  - cmplx(0.0,0.0,4)) > eps) call abort()
if (abs(tan(z1_1)  - cmplx(0.27175257,1.0839232,4)) > eps) call abort()
if (abs(tan(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort()
if (abs(tan(z81_1) - cmplx(0.27175258531951174_8,1.0839233273386946_8,8)) > eps8) call abort()

if (abs(cosh(z0_0)  - cmplx(1.0,0.0,4)) > eps) call abort()
if (abs(cosh(z1_1)  - cmplx(0.83372992,0.98889768,4)) > eps) call abort()
if (abs(cosh(z80_0) - cmplx(1.0_8,0.0_8,8)) > eps8) call abort()
if (abs(cosh(z81_1) - cmplx(0.83373002513114913_8,0.98889770576286506_8,8)) > eps8) call abort()

if (abs(sinh(z0_0)  - cmplx(0.0,0.0,4)) > eps) call abort()
if (abs(sinh(z1_1)  - cmplx(0.63496387,1.2984575,4)) > eps) call abort()
if (abs(sinh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort()
if (abs(sinh(z81_1) - cmplx(0.63496391478473613_8,1.2984575814159773_8,8)) > eps8) call abort()

if (abs(tanh(z0_0)  - cmplx(0.0,0.0,4)) > eps) call abort()
if (abs(tanh(z1_1)  - cmplx(1.0839232,0.27175257,4)) > eps) call abort()
if (abs(tanh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call abort()
if (abs(tanh(z81_1) - cmplx(1.0839233273386946_8,0.27175258531951174_8,8)) > eps8) call abort()

end
! { dg-final { scan-tree-dump-times "abort" 0 "original" } }


! advect_1d_FV.f90
!
! solve the linear advection equation, in conservative form:
!   a_t + [f(a)]_x=0
!   f(a) = u*a
!   a=a(x,t) (user defined)
!   u=constant (user defined)
! using a second order finite volume predictor-corrector scheme and optional
! gradient limiters. Boundaries are periodic.
!
!  https://github.com/JOThurgood/SimpleCFD/wiki
!
! Update - added a option to set t_end as negative.
! This enables a logical that changes the sign of dt and
! the directionality of the Riemann problem.

module shared_data
  implicit none
  integer, parameter :: num=selected_real_kind(p=15)
  integer :: nx !number of cells
  integer :: ix
  integer(num) :: step, nsteps
  real(num) :: u
  real(num) :: time=0.0_num, t_end, dt
  real(num) :: x_min, x_max
  real(num) :: dxb, dxc !redundant, dx=dxb=dxc=constant here
  real(num), dimension(:), allocatable :: xb, xc
  real(num), dimension(:), allocatable :: a,a1, a1L, a1R
    !solution and states at half time step indicated by 1
  real(num) :: CFL !cfl modifier
  !keyword codes
  integer :: limiter
  integer, parameter :: lim_unlimited = 1, lim_minmod = 2
  logical :: reverse_time = .false.
  contains
end module shared_data

module setup

  use shared_data

  implicit none

  contains

  subroutine initial_setup
    call control
    if (t_end < 0.0_num) reverse_time = .true.
    call setup_1dfvgrid
    call initial_conditions
  end subroutine initial_setup

  subroutine control !user control variables
    u = 1.0_num
    nx = 64
    x_min = 0.0_num
    x_max = 1.0_num
    t_end = 0.25_num
    CFL = 0.7_num
    nsteps = -1   !set to -1 to run till t_end
    limiter = lim_unlimited !lim_unlimited, lim_minmod
  end subroutine control

  subroutine initial_conditions !choose by commenting or add your own
    call top_hat
    !call gaussian
  end subroutine initial_conditions

  subroutine top_hat
    a = 0.0_num
    do ix = 0,nx+1
      if ((xc(ix) .ge. 1.0_num/3.0_num) .and. (xc(ix) .le. 2.0_num/3.0_num)) &
        & a(ix) = 1.0_num
    enddo
  end subroutine top_hat

  subroutine gaussian
    real(num) :: fwhm, sigma,x0,xx
    a = 0.0_num
    fwhm = 0.2_num
    x0 = 0.5_num
    sigma = fwhm / 2.35482_num
    do ix = 0,nx+1
      xx = xc(ix) - x0
      a(ix) = 1.0_num * exp(-xx**2 / 2.0_num / sigma**2 )
    enddo
  end subroutine gaussian

  subroutine setup_1dfvgrid !setup grid  + allocate other vars
    allocate(xc(-1:nx+2))  !cell center (cc) - counts from 1 to nx, with 2 guard
    allocate(xb(-2:nx+2))  !cell boundary (cb) - counts from 0 to nx, with 2 gds
    allocate(a(-1:nx+2))   !cc + 2 guards
    allocate(a1(0:nx))  !cb - then used to calc a cc var in corrector step
    allocate(a1L(0:nx)) !cb   (no guards needed)
    allocate(a1R(0:nx)) !cb
    dxb = (x_max - x_min) / REAL(nx,num)
    dxc = dxb !redundant for uniform grids dxb=dxc=dx=constant
    do ix = -2, nx+2
      xb(ix) = x_min + REAL(ix,num) * dxb
      if (ix /= -2) xc(ix) = xb(ix) - dxc/2.0_num
    enddo
  end subroutine setup_1dfvgrid

end module setup

module solver

  use shared_data

  implicit none

  contains

  subroutine update
    call boundary
    call set_dt
    call predictor
    call corrector
    time = time + dt
  end subroutine update

  subroutine boundary !periodic
    a(-1) = a(nx-1)
    a(0) = a(nx)
    a(nx+1) = a(1)
    a(nx+2) = a(2)
  end subroutine boundary

  subroutine set_dt
    dt = CFL * dxc / abs(u)
    if (reverse_time) dt = -dt
  end subroutine set_dt

  subroutine predictor
    call interface_states
    call reimann
  end subroutine predictor

  subroutine corrector
    do ix = 1,nx
      a(ix)  = a(ix)  - dt / dxb * (u*a1(ix)-u*a1(ix-1))
    enddo
  endsubroutine corrector

  subroutine interface_states
    !be careful with cc vs cb here
    real(num) dadx
    do ix = 0, nx ! states on boundary defined at xb

      !left state
      if (limiter == lim_minmod) then
        dadx = minmod( ( a(ix)-a(ix-1) )/dxb, ( a(ix+1)-a(ix) )/dxb )
      else
        dadx = ( a(ix+1) - a(ix-1) ) / 2.0_num / dxb
      endif
      a1L(ix) = a(ix) + 0.5_num * dxb * (1.0_num - dt * u / dxb) *  dadx

      !right state
      if (limiter == lim_minmod) then
        dadx = minmod( ( a(ix+1)-a(ix) )/dxb, ( a(ix+2)-a(ix+1) )/dxb )
      else
        dadx = ( a(ix+2) - a(ix) ) / 2.0_num / dxb
      endif

      a1R(ix) = a(ix+1) - 0.5_num * dxb * (1.0_num + dt * u / dxb) *  dadx
    enddo
  end subroutine interface_states

  subroutine reimann

    if (.not. reverse_time) then !forward time
      if (u < 0.0_num) then
        a1 = a1R
      else if (u > 0.0_num) then
        a1 = a1L
      endif
    else ! reverse time
      if (u > 0.0_num) then
        a1 = a1R
      else if (u < 0.0_num) then
        a1 = a1L
      endif
    endif

  end subroutine reimann

  real(num) function minmod(a,b)  ! "a" is an unforunate choice of var name!
    real(num), intent(in) :: a, b !left and right difference so change to l+r?
    if ( (abs(a) < abs(b)) .and. (a*b > 0) )then
      minmod = a
    else if ( (abs(a) > abs(b)) .and. (a*b > 0) ) then
      minmod = b
    else
      minmod = 0.0_num
    endif
  end function minmod

end module solver

module diagnostics

  use shared_data

  implicit none

  contains

  subroutine do_io
    integer :: out_unit =10
    open(out_unit, file="xc.dat", access="stream")
    write(out_unit) xc
    close(out_unit)
    open(out_unit, file="a.dat", access="stream")
    write(out_unit) a
    close(out_unit)
    call execute_command_line("python plot_advect_1d_FV.py")
  end subroutine do_io

end module diagnostics

program advect_1d_FV !main driver

  use shared_data
  use setup
  use solver
  use diagnostics

  implicit none

  call initial_setup

  do
   if ((step >= nsteps .and. nsteps >= 0) .or. (abs(time) >= abs(t_end))) exit !*
    step = step + 1
    call update
  enddo

  call do_io

  print *, 'Done in',step,'steps', 'with CFL',CFL

end program advect_1d_FV

!* uses abs(time) for purposes of testing negative t_end


***********************************************************************
c                    ORBEL_FGET.F
***********************************************************************
*     PURPOSE:  Solves Kepler's eqn. for hyperbola using hybrid approach.
*
*             Input:
*                           e ==> eccentricity anomaly. (real scalar)
*                        capn ==> hyperbola mean anomaly. (real scalar)
*             Returns:
*                  orbel_fget ==>  eccentric anomaly. (real scalar)
*
*     ALGORITHM: Based on pp. 70-72 of Fitzpatrick's book "Principles of
*           Cel. Mech. ".  Quartic convergence from Danby's book.
*     REMARKS:
*     AUTHOR: M. Duncan
*     DATE WRITTEN: May 11, 1992.
*     REVISIONS: 2/26/93 hfl
***********************************************************************

	real*8 function orbel_fget(e,capn)

      include '../swift.inc'

c...  Inputs Only:
	real*8 e,capn

c...  Internals:
	integer i,IMAX
	real*8 tmp,x,shx,chx
	real*8 esh,ech,f,fp,fpp,fppp,dx
	PARAMETER (IMAX = 10)

c----
c...  Executable code

c Function to solve "Kepler's eqn" for F (here called
c x) for given e and CAPN.

c  begin with a guess proposed by Danby
	if( capn .lt. 0.d0) then
	   tmp = -2.d0*capn/e + 1.8d0
	   x = -log(tmp)
	else
	   tmp = +2.d0*capn/e + 1.8d0
	   x = log( tmp)
	endif

	orbel_fget = x

	do i = 1,IMAX
	  call orbel_schget(x,shx,chx)
	  esh = e*shx
	  ech = e*chx
	  f = esh - x - capn
c	  write(6,*) 'i,x,f : ',i,x,f
	  fp = ech - 1.d0
	  fpp = esh
	  fppp = ech
	  dx = -f/fp
	  dx = -f/(fp + dx*fpp/2.d0)
	  dx = -f/(fp + dx*fpp/2.d0 + dx*dx*fppp/6.d0)
	  orbel_fget = x + dx
c   If we have converged here there's no point in going on
	  if(abs(dx) .le. TINY) RETURN
	  x = orbel_fget
	enddo

	write(6,*) 'FGET : RETURNING WITHOUT COMPLETE CONVERGENCE'
	return
	end   ! orbel_fget
c------------------------------------------------------------------


!!This module finds the srHNFs for a target volume.
!!Wiley Morgan Started 3/17
!!
Module srHNF_brute
  use num_types
  use combinatorics, only: binomial
  use numerical_utilities
  use vector_matrix_utilities, only: matrix_inverse

  implicit none
  private
  public get_srHNFs,find_pg_gens

CONTAINS

  !!Finds all the possible diagonals of the HNF matrices of a
  !!given size
  !!<parameter name="detS" regular="true">Cell size, i.e., determinant
  !!of S matrix.</parameter>
  !!<parameter name="diagonals">All possible diagonals.</parameter>
  SUBROUTINE get_HNF_diagonals(detS, diagonals)
    integer, intent(in) :: detS
    integer, pointer :: diagonals(:,:)

    integer i, j, id, quotient, status
    integer :: tempDiag(3,detS*3)

    id = 0 ! Number of diagonals found
    do i = 1,detS ! Loop over possible first factors
       if (.not. mod(detS,i)==0) cycle
       quotient = detS/i
       do j = 1,quotient  ! Loop over possible second/third factors
          if (.not. mod(quotient,j)==0) cycle
          id = id + 1
          tempDiag(:,id) = (/i, j, quotient/j /) ! Construct the factor triplet
       enddo
    enddo
    allocate(diagonals(3,id),STAT=status)
    if(status/=0) stop "Allocation failed in get_HNF_diagonals, module deriv..."
    diagonals = tempDiag(:,1:id)
  END SUBROUTINE get_HNF_diagonals

  !!This subroutine does a brute force search to find and return the
  !!HNFs preserve the symmetry of the parent lattice.
  !!<parameter name="parent" regular="True">The parent lattice.
  !!<parameter name="gens" regular="True">The generators of the point group.</parameter>
  !!<parameter name="volume" regular="True">Volume factor for the HNF.</parameter>
  !!<parameter name="srHNFS" regular="True">Returned list of symmetry preserving HNFs.</parameter>
  !!<parameter name="eps_" regular="True">epsilon for checking equivalence in floating
  !!point arithmetic.</parameter>
  SUBROUTINE get_srHNFs(parent,gens,volume,srHNFs,eps_)
    real(dp), intent(in) :: gens(:,:,:), parent(3,3)
    integer, intent(in) :: volume
    real(dp), intent(in), optional :: eps_
    integer, allocatable, dimension(:,:,:) :: srHNFs

    integer :: nfound, N, HNF(3,3), current_max
    real(dp) :: eps, B(3,3)
    integer, pointer :: d(:,:) => null()
    integer :: i, j, k, l    ! Loop counters
    integer :: status
    integer, allocatable :: temp_srHNFs(:,:,:)
    integer, allocatable :: temp_storage(:,:,:)

    if(.not. present(eps_)) then
       eps = 1e-10_dp
    else
       eps = eps_
    end if

    call get_HNF_diagonals(volume,d)
    N = size(d,2)

    current_max = 10
    allocate(temp_srHNFs(3,3,current_max),STAT=status)
    if(status/=0) stop "Failed to allocate memory in get_srHNFs"
    nfound = 0
    do i = 1,N ! Loop over the permutations of the diagonal elements of the HFNs
       do j = 0,d(2,i)-1  ! Look over possible values of row 2, element 1
          do k = 0,d(3,i)-1  ! Ditto for row 3, element 1
             do l = 0,d(3,i)-1  ! Ditto for row 3, element 2
                HNF(:,:) = reshape((/ d(1,i),      j,     k,        &
                     0, d(2,i),     l,        &
                     0,      0, d(3,i)  /), (/3,3/))
                B = matmul(parent,HNF)
                if (symm_pres(B,gens,eps_=eps)) then
                   if (nfound == current_max) then
                      current_max = current_max*2
                      allocate(temp_storage(3,3,size(temp_srHNFs,3)),STAT=status)
                      if(status/=0) stop "Failed to allocate memory in get_srHNFs"
                      temp_storage = temp_srHNFs
                      deallocate(temp_srHNFs)
                      allocate(temp_srHNFs(3,3,current_max),STAT=status)
                      if(status/=0) stop "Failed to allocate memory in get_srHNFs"
                      temp_srHNFs = 0
                      temp_srHNFs(:,:,1:nfound) = temp_storage(:,:,1:nfound)
                      deallocate(temp_storage)
                   end if
                   nfound = nfound+1 ! Count the srHNFs
                   temp_srHNFs(:,:,nfound) = HNF
                end if
             enddo;enddo;enddo  ! End loops over values for off-diagonal elements
    enddo ! End loop over all unique triplets of target determinant (volume)
    allocate(srHNFs(3,3,nfound))
    srHNFs(:,:,1:nfound) = temp_srHNFs(:,:,1:nfound)
    if (associated(d)) then
       deallocate(d)
    end if
    if (allocated(temp_storage)) then
       deallocate(temp_storage)
    end if
    deallocate(temp_srHNFs)
  end SUBROUTINE get_srHNFs

  !!This function determines if a lattice has the desired
  !!symmetries.
  !!<parameter name="lat" regular="True">The super lattice vectors.</parameter>
  !!<parameter name="pg" regular="True">The poing group operators we want to check for.</parameter>
  !!<parameter name="eps_" regular="True">epsilon for checking equivalence in floating
  !!point arithmetic.</parameter>
  logical function symm_pres(lat,pg,eps_)
    real(dp), intent(in) :: lat(3,3)
    real(dp), intent(in) :: pg(:,:,:)
    real(dp), intent(in), optional :: eps_

    real(dp) :: eps
    integer :: i
    real(dp) :: RB(3,3), N(3,3), latinv(3,3)

    if(.not. present(eps_)) then
       eps = 1e-10_dp
    else
       eps = eps_
    end if

    symm_pres = .True.
    do i=1,size(pg,3)
       RB = matmul(pg(:,:,i),lat)
       call matrix_inverse(lat,latinv)
       N = matmul(latinv,RB)
       if (.not. equal(N,nint(N),eps)) then
          symm_pres = .False.
          exit
       end if
    end do

  end function symm_pres

  !!Finds the generators of a given point group.
  !!<parameter name="pg" regular="True">The point group.</parameter>
  !!<parameter name="gens" regular="True">The generators of the point group.</parameter>
  !!<parameter name="eps" regular="True">epsilon for checking equivalence in floating
  !!point arithmetic.</parameter>
  subroutine find_pg_gens(pg,gens,eps)
    real(dp), pointer, intent(in) :: pg(:,:,:)
    real(dp), allocatable, intent(out) :: gens(:,:,:)
    real(dp), intent(in) :: eps

    real(dp), allocatable :: test_gens(:,:,:)
    integer :: n_gens, status, i, j, gens_found
    logical :: found_gens
    integer, allocatable :: combs(:,:)

    gens_found = 0
    n_gens = 2
    found_gens = .False.

    do while ((found_gens .eqv. .False.) .and. (n_gens < 4))
       call combinations(size(pg,3),n_gens,combs)
       allocate(test_gens(3,3,n_gens),STAT=status)
       if(status/=0) stop "Failed to allocate memory in find_pg_gens"
       do i=1,size(combs,2)
          do j=1,n_gens
             test_gens(:,:,j) = pg(:,:,combs(j,i))
          end do
          if (forms_group(test_gens,pg,eps) .eqv. .True.) then
             allocate(gens(3,3,n_gens),STAT=status)
             if(status/=0) stop "Failed to allocate memory in find_pg_gens"
             gens(:,:,:) = test_gens(:,:,:)
             found_gens = .True.
             exit
          end if
       end do

       n_gens = n_gens + 1
       deallocate(test_gens)
    end do

    if (allocated(combs)) then
       deallocate(combs)
    end if
  end subroutine find_pg_gens

  !!Determines if a set of generators forms the group.
  !!<parameter name="gens" regular="True">The test set of generators.</parameter>
  !!<parameter name="pg" regular="True">The pg we want to be able to generate.</parameter>
  !!<parameter name="eps" regular="True">epsilon for checking equivalence in floating
  !!point arithmetic.</parameter>
  logical function forms_group(gens,pg,eps)
    real(dp), intent(in) :: gens(:,:,:), pg(:,:,:)
    real(dp), intent(in) :: eps

    integer :: elements, i, j, k, nf, temp_int, status
    real(dp), allocatable :: test_set(:,:,:)
    real(dp) :: test(3,3)
    logical :: growing, in_group

    forms_group = .True.
    allocate(test_set(3,3,size(pg,3)),STAT=status)
    if(status/=0) stop "Failed to allocate memory in forms_group"
    test_set = 0
    elements = 0

    do i=1,size(gens,3)
       test_set(:,:,i) = gens(:,:,i)
       elements = elements + 1
    end do

    do i=1, size(gens,3)
       do j=1,size(gens,3)
          test = matmul(gens(:,:,i),gens(:,:,j))
          in_group = .False.
          do k=1,size(test_set)
             if (equal(test,test_set(:,:,k),eps)) then
                in_group = .True.
                exit
             end if
          end do
          if (in_group .eqv. .False.) then
             elements = elements + 1
             if (elements > size(test_set,3)) then
                forms_group = .False.
                exit
             end if
             test_set(:,:,elements) = test
          end if
       end do
       if (forms_group .eqv. .False.) then
          exit
       end if
    end do

    growing = .True.
    do while (growing .eqv. .True.)
       nf = 0
       temp_int = elements
       do i=1, size(gens,3)
          do j=1,temp_int
             test = matmul(gens(:,:,i),test_set(:,:,j))
             in_group = .False.
             do k=1,size(test_set)
                if (equal(test,test_set(:,:,k),eps)) then
                   in_group = .True.
                   exit
                end if
             end do
             if (in_group .eqv. .False.) then
                elements = elements + 1
                nf = nf + 1
                if (elements > size(test_set,3)) then
                   forms_group = .False.
                   exit
                end if
                test_set(:,:,elements) = test
             end if
          end do
          if (forms_group .eqv. .False.) then
             exit
          end if
       end do

       if ((nf == 0) .or. (forms_group .eqv. .False.)) then
          growing = .False.
       end if
    end do

    if (size(test_set,3) /= size(pg,3)) then
       forms_group = .False.
    else
       do i=1,size(pg,3)
          in_group = .False.
          do j=1,size(test_set)
             if (equal(pg(:,:,i),test_set(:,:,j),eps)) then
                forms_group = .True.
                exit
             else
                forms_group = .False.
             end if
          end do
          if (forms_group .eqv. .False.) then
             exit
          end if
       end do
    end if
    deallocate(test_set)
  end function forms_group

  !!Finds all pair or triplet combinations of numbers 1 to n.
  !!<parameter name="n" regular="True">The largest number in the pairs.</parameter>
  !!<parameter name="comb" regular="True">The resulting combinations.</parameter>
  !!<parameter name="r" regular="True">2 if for pairs, 3 if for triplets.</parameter>
  subroutine combinations(n,r,comb)
    integer, intent(in) :: n, r
    integer, allocatable, intent(out) :: comb(:,:)

    integer :: n_combs, status, i, j, k, combs_found

    if (allocated(comb)) then
       deallocate(comb)
    end if
    if (r == 2) then

       n_combs = binomial(n,2)
       combs_found = 0
       allocate(comb(3,n_combs),STAT=status)
       if(status/=0) stop "Failed to allocate memory in combinations"
       do i = 1,n-1
          do j = i+1, n
             combs_found = combs_found + 1
             comb(:,combs_found) = (/i,j,0/)
          end do
       end do
    elseif (r==3) then
       n_combs = binomial(n,3)
       combs_found = 0
       allocate(comb(3,n_combs),STAT=status)
       if(status/=0) stop "Failed to allocate memory in combinations"
       do i = 1,n-2
          do j = i+1, n-1
             do k = j+1, n
                combs_found = combs_found + 1
                comb(:,combs_found) = (/i,j,k/)
             end do
          end do
       end do
    else
       stop "combinations only works for pair and triplets (r=2 or 3)"
    end if
  end subroutine combinations
end Module srHNF_brute


c***********************************************************
c Test of minimisation routines from "Numerical Recipees"
c
c JLP
c Version 12/03/2001
c***********************************************************
      program dcv_test0
      integer i,iter,n
      parameter(n=2)
      real p(n),ftol,fret
      external func_test,dfunc_test
      external func,dfunc

      write(6,*) "Test with Banana function"

c Starting point:
      p(1)= -1.9
      p(2)= 2.
c Tolerance
      ftol=1.e-3
      call frprmn(p,n,ftol,iter,fret,func,dfunc)
c      call frprmn(p,n,ftol,iter,fret,func_test,dfunc_test)
      write(6,11) p(1),p(2),iter,fret
11    format(" Location of the minimum:",2(F12.3,1X),/,
     1       " Number of iterations:",I4,/,
     1       " Value of the minimum:",E12.5)
      end
!-------------------------------------------------------------------
! Function:
! Banana function : start at X=[-1.9;2]. minimum at X=[1;1] : f(X)=0;
!-------------------------------------------------------------------
      real function func_test(x)
      real x(*)
      func = (1. - x(1))**2 + 100*(x(2) - x(1))**2
      end
!-------------------------------------------------------------------
! Gradient:
! BANANA FUNCTION
! z = 100*(x(2)-x(1))^2 + (1-x(1))^2
!  dx = [  -200*(x(2) - x(1))-2*(1-x(1)); 200*(x(2)-x(1)) ];
!-------------------------------------------------------------------
      subroutine dfunc_test(x,dx)
      real x(*),dx(*)
      dx(1) = -200*(x(2)-x(1)) - 2*(1-x(1))
      dx(2) = 200*(x(2)-x(1))
      return
      end
      real function func(x)
      real x(*)
      func = (1. - x(1))**2 + 100*(x(2) - x(1))**2
      end
      subroutine dfunc(x,dx)
      real x(*),dx(*)
      dx(1) = -200*(x(2)-x(1)) - 2*(1-x(1))
      dx(2) = 200*(x(2)-x(1))
      return
      end


      SUBROUTINE ftest(data1,n1,data2,n2,f,prob)
      INTEGER n1,n2
      REAL f,prob,data1(n1),data2(n2)
CU    USES avevar,betai
      REAL ave1,ave2,df1,df2,var1,var2,betai
      call avevar(data1,n1,ave1,var1)
      call avevar(data2,n2,ave2,var2)
      if(var1.gt.var2)then
        f=var1/var2
        df1=n1-1
        df2=n2-1
      else
        f=var2/var1
        df1=n2-1
        df2=n1-1
      endif
      prob=2.*betai(0.5*df2,0.5*df1,df2/(df2+df1*f))
      if(prob.gt.1.)prob=2.-prob
      return
      END

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


program variables_02
implicit none
integer :: x, y
x = 2
y = x + 1
if (y /= 3) error stop

x = 2
y = 3
y = (x+2)*(1-y)+1
if (y /= -7) error stop

x = 2
y = -x*(-x)
if (y /= 4) error stop
end program


C     File: goto_06.f
C     A simple program with a single forward conditional goto and
C     a single backward unconditional goto.
C     The program computes and prints out the values of n! for n in [1,10].

      program factorial
      implicit none

      integer i, n, fact

      i = 0
      n = 10
      fact = 1

 111  i = i + 1

      if (i .le. n) goto 222

      stop

 222  fact = fact * i

      write (*, 10) i, fact

      goto 111

 10   format('i = ', I3, '; fact = ', I8)

      end program factorial


      SUBROUTINE sor(a,b,c,d,e,f,u,jmax,rjac)
      INTEGER jmax,MAXITS
      DOUBLE PRECISION rjac,a(jmax,jmax),b(jmax,jmax),c(jmax,jmax),
     *d(jmax,jmax),e(jmax,jmax),f(jmax,jmax),u(jmax,jmax),EPS
      PARAMETER (MAXITS=1000,EPS=1.d-5)
      INTEGER ipass,j,jsw,l,lsw,n
      DOUBLE PRECISION anorm,anormf,omega,resid
      anormf=0.d0
      do 12 j=2,jmax-1
        do 11 l=2,jmax-1
          anormf=anormf+abs(f(j,l))
11      continue
12    continue
      omega=1.d0
      do 16 n=1,MAXITS
        anorm=0.d0
        jsw=1
        do 15 ipass=1,2
          lsw=jsw
          do 14 j=2,jmax-1
            do 13 l=lsw+1,jmax-1,2
              resid=a(j,l)*u(j+1,l)+b(j,l)*u(j-1,l)+c(j,l)*u(j,l+1)+d(j,
     *l)*u(j,l-1)+e(j,l)*u(j,l)-f(j,l)
              anorm=anorm+abs(resid)
              u(j,l)=u(j,l)-omega*resid/e(j,l)
13          continue
            lsw=3-lsw
14        continue
          jsw=3-jsw
          if(n.eq.1.and.ipass.eq.1) then
            omega=1.d0/(1.d0-.5d0*rjac**2)
          else
            omega=1.d0/(1.d0-.25d0*rjac**2*omega)
          endif
15      continue
        if(anorm.lt.EPS*anormf)return
16    continue
      pause 'MAXITS exceeded in sor'
      END

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


subroutine SHExpandDH(grid, n, cilm, lmax, norm, sampling, csphase, &
                      lmax_calc, exitstatus)
!------------------------------------------------------------------------------
!
!   This routine will expand a grid containing n samples in both longitude
!   and latitude (or n x 2n, see below) into spherical harmonics. This routine
!   makes use of the sampling theorem presented in driscoll and healy (1994)
!   and employs ffts when calculating the sin and cos terms. The number of
!   samples, n, must be even for this routine to work, and the spherical
!   harmonic expansion is exact if the function is bandlimited to degree n/2-1.
!   Legendre functions are computed on the fly using the scaling methodology
!   presented in holmes and featherston (2002). When norm is 1, 2 or 4, these
!   are accurate to about degree 2800. When norm is 3, the routine is only
!   stable to about degree 15! If the optional parameter lmax_calc is
!   specified, the spherical harmonic coefficients will only be calculated up
!   to this degree.
!
!   If sampling is 1 (default), the input grid contains n samples in latitude
!   from 90 to -90+interval, and n samples in longitude from 0 to
!   360-2*interval, where interval is the latitudinal sampling interval 180/n.
!   Note that the datum at 90 degees north latitude is ultimately downweighted
!   to zero, so this point does not contribute to the spherical harmonic
!   coefficients. If sampling is 2, the input grid must contain n samples in
!   latitude and 2n samples in longitude. In this case, the sampling intervals
!   in latitude and longitude are 180/n and 360/n respectively. when performing
!   the ffts in longitude, the frequencies greater than n/2-1 are simply
!   discarded to prevent aliasing.
!
!   Calling Parameters
!
!       IN
!           grid        Equally sampled grid in latitude and longitude of
!                       dimension (1:n, 1:n) or and equally spaced grid of
!                       dimension (1:n,2n).
!           n           Number of samples in latitude and longitude (for
!                       sampling=1), or the number of samples in latitude (for
!                       sampling=2).
!
!       OUT
!           cilm        Array of spherical harmonic coefficients with dimension
!                       (2, lmax+1, lmax+1), or, if lmax_calc is present
!                       (2, lmax_calc+1, lmax_calc+1).
!           lmax        Spherical harmonic bandwidth of the grid. This
!                       corresponds to the maximum spherical harmonic degree of
!                       the expansion if the optional parameter lmax_calc is
!                       not specified.
!
!       OPTIONAL (IN)
!           norm        Normalization to be used when calculating legendre
!                       functions
!                           (1) "geodesy" (default)
!                           (2) schmidt
!                           (3) unnormalized
!                           (4) orthonormalized
!           sampling    (1) Grid is n latitudes by n longitudes (default).
!                       (2) Grid is n by 2n. the higher frequencies resulting
!                       from this oversampling are discarded, and hence not
!                       aliased into lower frequencies.
!           csphase     1: Do not include the condon-shortley phase factor of
!                       (-1)^m (default). -1: Apply the condon-shortley phase
!                       factor of (-1)^m.
!           lmax_calc   The maximum spherical harmonic degree calculated in the
!                       spherical harmonic expansion.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!       1.  This routine does not use the fast legendre transforms that
!           are presented in driscoll and heally (1994).
!       2.  Use of a n by 2n grid is implemented because many geographic grids
!           are sampled this way. when taking the fourier transforms in
!           longitude, all of the higher frequencies are ultimately discarded.
!           If, instead, every other column of the grid were discarded to form
!           a nxn grid, higher frequencies could be aliased into lower
!           frequencies.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use FFTW3
    use SHTOOLS, only: DHaj
    use ftypes
    use, intrinsic :: iso_c_binding

    implicit none

    real(dp), intent(in) :: grid(:,:)
    real(dp), intent(out) :: cilm(:,:,:)
    integer(int32), intent(in) :: n
    integer(int32), intent(out) :: lmax
    integer(int32), intent(in), optional :: norm, sampling, csphase, lmax_calc
    integer(int32), intent(out), optional :: exitstatus
    complex(dp) :: cc(n+1), ccs(n+1)
    integer(int32) :: l, m, i, l1, m1, i_eq, i_s, lnorm, astat(4), &
                      lmax_comp, nlong
    type(C_PTR) :: plan, plans
    real(dp) :: pi, gridl(2*n), gridls(2*n), aj(n), fcoef1(2, n/2+1), &
                fcoef2(2, n/2+1), theta, prod, scalef, rescalem, u, p, pmm, &
                pm1, pm2, z, ffc(1:2,-1:1)
    real(dp), save, allocatable :: sqr(:), ff1(:,:), ff2(:,:)
    integer(int8), save, allocatable :: fsymsign(:,:)
    integer(int32), save :: lmax_old = 0, norm_old = 0
    integer(int32) :: phase

!$OMP   threadprivate(sqr, ff1, ff2, fsymsign, lmax_old, norm_old)

    if (present(exitstatus)) exitstatus = 0

    lmax = n / 2 - 1

    if (present(lmax_calc)) then
        if (lmax_calc > lmax) then
            print*, "Error --- SHExpandDH"
            print*, "LMAX_CALC must be less than or equal to LMAX."
            print*, "LMAX = ", lmax
            print*, "LMAX_CALC = ", lmax_calc
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            lmax_comp = min(lmax, lmax_calc)

        end if

    else
        lmax_comp = lmax

    end if

    if (present(sampling)) then
        if (sampling /= 1 .and. sampling /= 2) then
            print*, "Error --- SHExpandDH"
            print*, "Optional parameter sampling must be " // &
                    "1 (N by N) or 2 (N by 2N)."
            print*, "Input value is ", sampling
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

    end if

    if (mod(n,2) /= 0) then
        print*, "Error --- SHExpandDH"
        print*, "The number of samples in latitude and longitude, " // &
                "N, must be even."
        print*, "Input value is ", n
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    else if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax_comp+1 .or. &
             size(cilm(1,1,:)) < lmax_comp+1) then
        print*, "Error --- SHExpandDH"
        print*, "CILM must be dimensioned as (2, LMAX_COMP+1, " // &
                "LMAX_COMP+1) where LMAX_COMP = MIN(N/2, LMAX_CALC+1)"
        print*, "N = ", n
        if (present(lmax_calc)) print*, "LMAX_CALC = ", lmax_calc
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (present(sampling)) then
        if (sampling == 1) then
            if (size(grid(:,1)) < n .or. size(grid(1,:)) < n) then
                print*, "Error --- SHExpandDH"
                print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
                print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
                if (present(exitstatus)) then
                    exitstatus = 1
                    return
                else
                    stop
                end if

            end if

        else if (sampling == 2) then
            if (size(grid(:,1)) < n .or. size(grid(1,:)) < 2*n) then
                print*, "Error --- SHExpandDH"
                print*, "GRIDDH must be dimensioned as (N, 2*N) where N is ", n
                print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
                if (present(exitstatus)) then
                    exitstatus = 1
                    return
                else
                    stop
                end if

            end if

        end if

    else
        if (size(grid(:,1)) < n .or. size(grid(1,:)) < n) then
            print*, "Error --- SHExpandDH"
            print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
            print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(csphase)) then
        if (csphase /= -1 .and. csphase /= 1) then
            print*, "Error --- SHExpandDH"
            print*, "CSPHASE must be 1 (exclude) or -1 (include)."
            print*, "Input value is ", csphase
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            phase = csphase

        end if

    else
        phase = 1

    end if

    if (present(norm)) then
        if (norm > 4 .or. norm < 1) then
            print*, "Error --- SHExpandDH"
            print*, "Parameter norm must be 1 (geodesy), 2 (schmidt), " // &
                    "3 (unnormalized), or 4 (orthonormalized)."
            print*, "Input value is ", norm
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

        lnorm = norm

    else
        lnorm = 1

    end if

    pi = acos(-1.0_dp)

    cilm = 0.0_dp

    scalef = 1.0e-280_dp

    if (present(exitstatus)) then
        call DHaj(n, aj, exitstatus=exitstatus)
        if (exitstatus /= 0) return
    else
        call DHaj(n, aj)
    end if

    aj(1:n) = aj(1:n) * sqrt(4.0_dp*pi)
    ! Driscoll and Heally use unity normalized spherical harmonics

    if (present(sampling)) then
        if (sampling == 1) then
            nlong = n

        else
            nlong = 2 * n

        end if

    else
        nlong = n

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate recursion constants used in computing the legendre functions.
    !
    !--------------------------------------------------------------------------
    if (lmax_comp /= lmax_old .or. lnorm /= norm_old) then
        if (allocated (sqr)) deallocate (sqr)
        if (allocated (ff1)) deallocate (ff1)
        if (allocated (ff2)) deallocate (ff2)
        if (allocated (fsymsign)) deallocate (fsymsign)

        allocate (sqr(2*lmax_comp+1), stat=astat(1))
        allocate (ff1(lmax_comp+1,lmax_comp+1), stat=astat(2))
        allocate (ff2(lmax_comp+1,lmax_comp+1), stat=astat(3))
        allocate (fsymsign(lmax_comp+1,lmax_comp+1), stat=astat(4))

        if (sum(astat(1:4)) /= 0) then
            print*, "Error --- SHExpandDH"
            print*, "Problem allocating arrays SQR, FF1, FF2, or FSYMSIGN", &
                astat(1), astat(2), astat(3), astat(4)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if

        end if

        !----------------------------------------------------------------------
        !
        !   Calculate signs used for symmetry of legendre functions about
        !   equator
        !
        !----------------------------------------------------------------------
        do l = 0, lmax_comp, 1
            do m = 0, l, 1
                if (mod(l-m,2) == 0) then
                    fsymsign(l+1,m+1) = 1

                else
                    fsymsign(l+1,m+1) = -1

                end if

            end do

        end do

        !----------------------------------------------------------------------
        !
        !   Precompute square roots of integers that are used several times.
        !
        !----------------------------------------------------------------------
        do l = 1, 2 * lmax_comp + 1
            sqr(l) = sqrt(dble(l))
        end do

        !----------------------------------------------------------------------
        !
        !   Precompute multiplicative factors used in recursion relationships
        !       p(l,m) = x*f1(l,m)*p(l-1,m) - p(l-2,m)*f2(l,m)
        !       k = l*(l+1)/2 + m + 1
        !   Note that prefactors are not used for the case when m=l as a
        !   different recursion is used. furthermore, for m=l-1, plmbar(l-2,m)
        !   is assumed to be zero.
        !
        !----------------------------------------------------------------------
        select case (lnorm)
            case(1,4)
                if (lmax_comp /= 0) then
                    ff1(2,1) = sqr(3)
                    ff2(2,1) = 0.0_dp

                end if

                do l = 2, lmax_comp, 1
                    ff1(l+1,1) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
                    ff2(l+1,1) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)

                    do m = 1, l - 2, 1
                        ff1(l+1,m+1) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) &
                                       / sqr(l-m)
                        ff2(l+1,m+1) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                                       / sqr(2*l-3) / sqr(l+m) / sqr(l-m)

                    end do

                    ff1(l+1,l) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                    ff2(l+1,l) = 0.0_dp

                end do

            case(2)
                if (lmax_comp /= 0) then
                    ff1(2,1) = 1.0_dp
                    ff2(2,1) = 0.0_dp

                end if

                do l = 2, lmax_comp, 1
                    ff1(l+1,1) = dble(2*l-1) / dble(l)
                    ff2(l+1,1) = dble(l-1) / dble(l)

                    do m = 1, l - 2, 1
                        ff1(l+1,m+1) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                        ff2(l+1,m+1) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) &
                                       / sqr(l-m)

                    end do

                    ff1(l+1,l)= dble(2*l-1) / sqr(l+m) / sqr(l-m)
                    ff2(l+1,l) = 0.0_dp

                end do

            case(3)
                do l = 1, lmax_comp, 1
                    ff1(l+1,1) = dble(2*l-1) / dble(l)
                    ff2(l+1,1) = dble(l-1) / dble(l)

                    do m = 1, l-1, 1
                        ff1(l+1,m+1) = dble(2*l-1) / dble(l-m)
                        ff2(l+1,m+1) = dble(l+m-1) / dble(l-m)

                    end do

                end do

        end select

        lmax_old = lmax_comp
        norm_old = lnorm

    end if

    !--------------------------------------------------------------------------
    !
    !   Create generic plan for gridl and gridls.
    !
    !--------------------------------------------------------------------------
    plan = fftw_plan_dft_r2c_1d(nlong, gridl(1:nlong), cc, FFTW_MEASURE)
    plans = fftw_plan_dft_r2c_1d(nlong, gridls(1:nlong), ccs, FFTW_MEASURE)

    !--------------------------------------------------------------------------
    !
    !   Integrate over all latitudes. Take into account symmetry of the
    !   plms about the equator.
    !
    !--------------------------------------------------------------------------
    i_eq = n / 2 + 1  ! index correspondong to the equator

    do i = 2, i_eq - 1, 1
        theta = (i-1) * pi / dble(n)
        z = cos(theta)
        u = sqrt( (1.0_dp-z) * (1.0_dp+z) )

        gridl(1:nlong) = grid(i,1:nlong)
        call fftw_execute_dft_r2c(plan, gridl, cc)   ! take fourier transform
        fcoef1(1,1:n/2) = sqrt(2*pi) * aj(i) * dble(cc(1:n/2)) / dble(nlong)
        fcoef1(2,1:n/2) = -sqrt(2*pi) * aj(i) * aimag(cc(1:n/2)) / dble(nlong)

        i_s = 2 * i_eq - i

        gridls(1:nlong) = grid(i_s,1:nlong)
        call fftw_execute_dft_r2c(plans, gridls, ccs)
        fcoef2(1,1:n/2) = sqrt(2*pi) * aj(i_s) * dble(ccs(1:n/2)) / dble(nlong)
        fcoef2(2,1:n/2) = -sqrt(2*pi) * aj(i_s) * aimag(ccs(1:n/2)) / &
                          dble(nlong)

        select case (lnorm)
            case (1,2,3);    pm2 = 1.0_dp
            case (4);        pm2 = 1.0_dp / sqrt(4*pi)

        end select

        cilm(1,1,1) = cilm(1,1,1) + pm2 * (fcoef1(1,1) + fcoef2(1,1))
        ! fsymsign = 1

        if (lmax_comp == 0) cycle

        pm1 = ff1(2,1) * z * pm2
        cilm(1,2,1) = cilm(1,2,1) + pm1 * (fcoef1(1,1) - fcoef2(1,1))
        ! fsymsign = -1

        ffc(1,-1) = fcoef1(1,1) - fcoef2(1,1)
        ffc(1, 1) = fcoef1(1,1) + fcoef2(1,1)

        do l = 2, lmax_comp, 1
            l1 = l + 1
            p = ff1(l1,1) * z * pm1 - ff2(l1,1) * pm2
            pm2 = pm1
            pm1 = p
            cilm(1,l1,1) = cilm(1,l1,1) + p * ffc(1,fsymsign(l1,1))

        end do

        select case (lnorm)
            case (1,2);  pmm = sqr(2) * scalef
            case (3);    pmm = scalef
            case (4);    pmm = sqr(2) * scalef / sqrt(4*pi)

        end select

        rescalem = 1.0_dp / scalef

        do m = 1, lmax_comp-1, 1
            m1 = m + 1
            rescalem = rescalem * u

            select case (lnorm)
                case (1,4)
                    pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                    pm2 = pmm

                case (2)
                    pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                    pm2 = pmm / sqr(2*m+1)

                case (3)
                    pmm = phase * pmm * (2*m-1)
                    pm2 = pmm

            end select

            fcoef1(1:2,m1) = fcoef1(1:2,m1) * rescalem
            fcoef2(1:2,m1) = fcoef2(1:2,m1) * rescalem

            cilm(1:2,m1,m1) = cilm(1:2,m1,m1) + pm2 * &
                              (fcoef1(1:2,m1) + fcoef2(1:2,m1))
            ! fsymsign = 1

            pm1 = z * ff1(m1+1,m1) * pm2

            cilm(1:2,m1+1,m1) = cilm(1:2,m1+1,m1) + pm1 * &
                                (fcoef1(1:2,m1) - fcoef2(1:2,m1))
            ! fsymsign = -1

            ffc(1:2,-1) = fcoef1(1:2,m1) - fcoef2(1:2,m1)
            ffc(1:2, 1) = fcoef1(1:2,m1) + fcoef2(1:2,m1)

            do l = m + 2, lmax_comp, 1
                l1 = l + 1
                p = z * ff1(l1,m1) * pm1-ff2(l1,m1) * pm2
                pm2 = pm1
                pm1 = p
                cilm(1:2,l1,m1) = cilm(1:2,l1,m1) + p * &
                                  ffc(1:2,fsymsign(l1,m1))

            end do

        end do

        rescalem = rescalem * u

        select case (lnorm)
            case (1,4)
                pmm = phase * pmm * sqr(2*lmax_comp+1) &
                      / sqr(2*lmax_comp) * rescalem
            case (2)
                pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            case (3)
                pmm = phase * pmm * (2*lmax_comp-1) * rescalem

        end select

        cilm(1:2,lmax_comp+1,lmax_comp+1) = cilm(1:2,lmax_comp+1,lmax_comp+1) &
                                            + pmm * ( fcoef1(1:2,lmax_comp+1) &
                                            + fcoef2(1:2,lmax_comp+1) )
                        ! fsymsign = 1
    end do

    ! finally, do equator
    i = i_eq

    z = 0.0_dp
    u = 1.0_dp

    gridl(1:nlong) = grid(i,1:nlong)
    call fftw_execute_dft_r2c(plan, gridl, cc)
    fcoef1(1,1:n/2) = sqrt(2*pi) * aj(i) * dble(cc(1:n/2)) / dble(nlong)
    fcoef1(2,1:n/2) = -sqrt(2*pi) * aj(i) * aimag(cc(1:n/2)) / dble(nlong)

    select case (lnorm)
        case (1,2,3); pm2 = 1.0_dp
        case (4);     pm2 = 1.0_dp / sqrt(4*pi)
    end select

    cilm(1,1,1) = cilm(1,1,1) + pm2 * fcoef1(1,1)

    if (lmax_comp /= 0) then
        do l = 2, lmax_comp, 2
            l1 = l + 1
            p = - ff2(l1,1) * pm2
            pm2 = p
            cilm(1,l1,1) = cilm(1,l1,1) + p * fcoef1(1,1)

        end do

        select case (lnorm)
            case (1,2);  pmm = sqr(2) * scalef
            case (3);    pmm = scalef
            case (4);    pmm = sqr(2) * scalef / sqrt(4 * pi)
        end select

        rescalem = 1.0_dp / scalef

        do m = 1, lmax_comp-1, 1
            m1 = m + 1

            select case (lnorm)
                case (1,4)
                    pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                    pm2 = pmm

                case (2)
                    pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                    pm2 = pmm / sqr(2*m+1)

                case (3)
                    pmm = phase * pmm * (2*m-1)
                    pm2 = pmm

            end select

            fcoef1(1:2,m1) = fcoef1(1:2,m1) * rescalem

            cilm(1:2,m1,m1) = cilm(1:2,m1,m1) + pm2 * fcoef1(1:2,m1)

            do l = m + 2, lmax_comp, 2
                l1 = l + 1
                p = - ff2(l1,m1) * pm2
                pm2 = p
                cilm(1:2,l1,m1) = cilm(1:2,l1,m1) + p * fcoef1(1:2,m1)

            end do

        end do

            select case (lnorm)
                    case(1,4)
                        pmm = phase * pmm * sqr(2*lmax_comp+1) &
                              / sqr(2*lmax_comp) * rescalem
                    case(2)
                        pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
                    case(3)
                        pmm = phase * pmm * (2*lmax_comp-1) * rescalem
            end select

            cilm(1:2,lmax_comp+1,lmax_comp+1) = &
                            cilm(1:2,lmax_comp+1,lmax_comp+1) &
                            + pmm * fcoef1(1:2,lmax_comp+1)

        end if

    call fftw_destroy_plan(plan)
    call fftw_destroy_plan(plans)

    !--------------------------------------------------------------------------
    !
    !   Divide by integral of Ylm*Ylm
    !
    !--------------------------------------------------------------------------
    select case(lnorm)
        case(1)
            do l = 0, lmax_comp, 1
                cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) / (4*pi)
            end do

        case (2)
            do l = 0, lmax_comp, 1
                cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) * (2*l+1) / (4*pi)
            end do

        case(3)
            do l = 0, lmax_comp, 1
                prod = 4 * pi / dble(2*l+1)
                cilm(1,l+1,1) = cilm(1,l+1,1) / prod
                prod = prod / 2.0_dp

                do m = 1, l-1, 1
                    prod = prod * (l+m) * (l-m+1)
                    cilm(1:2,l+1,m+1) = cilm(1:2,l+1,m+1) / prod

                end do

                !do m=l case
                if (l /= 0) cilm(1:2,l+1,l+1) = cilm(1:2,l+1, l+1) / (prod*2*l)

            end do

    end select

end subroutine SHExpandDH


      SUBROUTINE slGEOC (P, H, R, Z)
*+
*     - - - - -
*      G E O C
*     - - - - -
*
*  Convert geodetic position to geocentric (double precision)
*
*  Given:
*     P     dp     latitude (geodetic, radians)
*     H     dp     height above reference spheroid (geodetic, metres)
*
*  Returned:
*     R     dp     distance from Earth axis (AU)
*     Z     dp     distance from plane of Earth equator (AU)
*
*  Notes:
*
*  1  Geocentric latitude can be obtained by evaluating ATAN2(Z,R).
*
*  2  IAU 1976 constants are used.
*
*  Reference:
*
*     Green,R.M., Spherical Astronomy, CUP 1985, p98.
*
*  Last revision:   22 July 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION P,H,R,Z

*  Earth equatorial radius (metres)
      DOUBLE PRECISION A0
      PARAMETER (A0=6378140D0)

*  Reference spheroid flattening factor and useful function
      DOUBLE PRECISION F,B
      PARAMETER (F=1D0/298.257D0,B=(1D0-F)**2)

*  Astronomical unit in metres
      DOUBLE PRECISION AU
      PARAMETER (AU=1.49597870D11)

      DOUBLE PRECISION SP,CP,C,S

*  Geodetic to geocentric conversion
      SP = SIN(P)
      CP = COS(P)
      C = 1D0/SQRT(CP*CP+B*SP*SP)
      S = B*C
      R = (A0*C+H)*CP/AU
      Z = (A0*S+H)*SP/AU

      END


module mod_fillps
  use mod_types
  implicit none
  private
  public fillps
  contains
  subroutine fillps(lo,hi,dxf,dyf,dzf,dt,up,vp,wp,p)
    !
    !  fill the right-hand side of the Poisson equation for the correction pressure.
    !
    !  the discrete divergence is:
    !
    !  w(i,j,k)-w(i,j,k-1)   v(i,j,k)-v(i,j-1,k)   u(i,j,k)-u(i-1,j,k)
    !  ------------------- + ------------------- + -------------------  = div
    !          dz                    dy                    dx
    !
    implicit none
    integer , intent(in ), dimension(3) :: lo,hi
    real(rp), intent(in ), dimension(lo(1)-1:) :: dxf
    real(rp), intent(in ), dimension(lo(2)-1:) :: dyf
    real(rp), intent(in ), dimension(lo(3)-1:) :: dzf
    real(rp), intent(in ) :: dt
    real(rp), intent(in ), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:) :: up,vp,wp
    real(rp), intent(out), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:) :: p
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(lo,hi,p,up,vp,wp,dt,dxf,dyf,dzf) &
    !$OMP PRIVATE(i,j,k)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          p(i,j,k) = ( &
                      (wp(i,j,k)-wp(i,j,k-1))/dzf(k) + &
                      (vp(i,j,k)-vp(i,j-1,k))/dyf(j) + &
                      (up(i,j,k)-up(i-1,j,k))/dxf(i) &
                     )/dt
        enddo
      enddo
    enddo
    !$OMP END PARALLEL DO
  end subroutine fillps
end module mod_fillps


! Example of specifications with combined regions
!
! Regions can be combined with intersection (*) or union (+).
program combinedregion
implicit none

integer i
parameter (n=10)
real a(0:n,0:n)
real b(0:n,0:n)

! This is a nine-point stencil
do i=1, n
 do j=1, n
  x = a(i, j) + a(i-1, j) + a(i+1, j)
  y = a(i, j-1) + a(i-1, j-1) + a(i+1, j-1)
  z = a(i, j+1) + a(i-1, j+1) + a(i+1, j+1)
  != stencil readOnce, centered(depth=1, dim=1)*centered(depth=1, dim=2) :: a
  b(i, j) = (x + y + z) / 9.0
 end do
end do

! This is a five point stencil
do i=1, n
 do j=1, n
  != stencil readOnce, pointed(dim=1)*centered(depth=1, dim=2) + centered(depth=1, dim=1)*pointed(dim=2) :: a
  b(i,j) = -4*a(i,j) + a(i+1, j) + a(i-1,j) + a(i,j-1) + a(i,j+1)
 end do
end do

end


! Program to test the DIM intrinsic
program intrinsic_dim
   implicit none
   integer i, j
   real(kind=4) :: r, s
   real(kind=8) :: p, q

   i = 1
   j = 4
   if (dim (i, j) .ne. 0) call abort
   if (dim (j, i) .ne. 3) call abort
   r = 1.0
   s = 4.0
   if (dim (r, s) .ne. 0.0) call abort
   if (dim (s, r) .ne. 3.0) call abort
   p = 1.0
   q = 4.0
   if (dim (p, q) .ne. 0.0) call abort
   if (dim (q, p) .ne. 3.0) call abort
end program


module module_privs

   implicit none

   integer, parameter, private :: sp = selected_real_kind(6, 37)
   integer, parameter, private :: dp = selected_real_kind(15, 307)
   integer, parameter, private :: qp = selected_real_kind(33, 4931)

   real(kind=sp), protected :: pi_sigl = &
   3.141592653589793238462643383279502884197169399375105820974944592307&
   &8164062862089986280348253421170679821480865132823066470938446_sp
   real(kind=dp), protected :: pi_dble = &
   3.141592653589793238462643383279502884197169399375105820974944592307&
   &8164062862089986280348253421170679821480865132823066470938446_dp
   real(kind=qp), protected :: pi_quad = &
   3.141592653589793238462643383279502884197169399375105820974944592307&
   &8164062862089986280348253421170679821480865132823066470938446_qp
   real :: x = 50.25
   real, protected :: x_prot = 512.125
   real :: y = 3.0

contains

   subroutine show_pi_3()
      print *, 'PI with  6 digits', kind(pi_sigl), pi_sigl
      print *, 'PI with 15 digits', kind(pi_dble), pi_dble
      print *, 'PI with 33 digits', kind(pi_quad), pi_quad
   end subroutine show_pi_3

end module module_privs

program main

   use module_privs, my_y => y

   implicit none

   call show_pi_3()

   print *, 'x from inside the module : ', x
   x = 25.50
   print *, 'x changed outside module : ', x

   print *, 'x_prot:', x_prot
   ! This variable is protected and cannot be changed
   ! Uncommenting the line below will not compile
   !x_prot = 125.512
   print *, 'x_prot:', x_prot

   ! The variable 'y' is not visible as it was renamed
   !print *, y
   print *, 'my_y:', my_y

end program main