*----------------------------------------------------------------------_
*
      Program MyEmp1
*
*     Purpose: Solve the vibration problem
*
      Implicit None
*
*-- Common Definitions
*
*   Write file index
      Integer           IOut, IOTmp
      Common /IO/       IOut, IOTmp
*   Calculation Parameter
      Double Precision  Gmr
      Common /CalPar/   Gmr
*   Constants
      Double Precision  Pi
      Common /Const/    Pi
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Global Integral grid number
      Integer           IGridN
      Common /Grid/     IGridN
*   Zero Tolerence (Two values refers to the error or warning situation)
      Double Precision  Thr0, ThrW0
      Common /ZeroTh/   Thr0, ThrW0
*   Deviation Threahold
*!!   Non-FORTRAN77 syntax: An effort to make the variables stored into
*!!   the memories of the same length
      Integer*8         ItrMax
      Double Precision  DevX, DevY
      Common /DevThr/   ItrMax, DevX, DevY
*
*-- Internal Functions
*
      Double Precision  Itg5P1, Itg5P2, RtSecI, Func1
      External          Itg5P1, ITg5P2, RtSecI, Func1
      Integer           IFlr
      External          IFlr
*
*-- Internal Variables
*
*   Maximun Quantum Number (Related with DevX)
      Integer           IQntN
*
*-----------------------------------------------------------------------

*-- Initialize Common Variables

*   IO
      IOut = 11
      IOTmp = 12
*   CalPar
      Gmr = 200.0D0
*   Const
      Pi = DACos(-1.0D0)
*   ErStat
      IStat = 0
*   Grid
      IGridN = 100000
*   ZeroTh
      Thr0 = 1.0D-7
      ThrW0 = 1.0D-10
*   DevThr
      ItrMax = 150
      DevX = 1.0D-10
      DevY = 1.0D-10

*-- File I/O
      Open(IOut, File='01-07.txt')

*-- I/O Format
C1000 Format (1x,A50)
C1010 Format (1x,A50,A10,F15.7)
C1020 Format (1x,A50,A10,8x,I7)
C1030 Format (1x,A50,A10,D15.8)

*-- Find Maximun Quantum Number and Call the Subroutine Main
      IQntN = IFlr(Func1(-DevX)/Pi-0.5D0)
      If (IQntN.EQ.0) then
        Print *, 'No acceptable quantum number! Exit Program!'
        Stop
      End If
      Call MainPg(IQntN)

      Stop
      End Program MyEmp1

*----------------------------------------------------------------------_
*
      Subroutine MainPg(IQntN)
*
*     Purpose: Main program for this problem
*
      Implicit None
*
*-- Common Definitions
*
*   Write file index
      Integer           IOut, IOTmp
      Common /IO/       IOut, IOTmp
*   Calculation Parameter
      Double Precision  Gmr
      Common /CalPar/   Gmr
*   Constants
      Double Precision  Pi
      Common /Const/    Pi
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Global Integral grid number
      Integer           IGridN
      Common /Grid/     IGridN
*   Deviation Threahold
*!!   Non-FORTRAN77 syntax: An effort to make the variables stored into
*!!   the memories of the same length
      Integer*8         ItrMax
      Double Precision  DevX, DevY
      Common /DevThr/   ItrMax, DevX, DevY
*
*-- Internal Functions
*
      Double Precision  Itg5P1, Itg5P2, RtSecI, Func1, IFlr
      External          Itg5P1, ITg5P2, RtSecI, Func1, IFlr
*
*-- Internal Variables
*
*   Dummy
      Integer           I
*   Maximun Quantum Number (Related with DevX)
      Integer           IQntN
*   Internal Root Guess
      Double Precision  RtLoI, RtUpI
*   Internal Result Temporary Store
      Double Precision  RtI
*   Result
      Integer           IQntV(IQntN+1)
      Double Precision  EngV(IQntN+1), ItgLoV(IQntN+1), ItgUpV(IQntN+1)
*
*-----------------------------------------------------------------------

*-- I/O Format
 1000 Format(A47)
 1010 Format(A8,A15,2(A12))
 1020 Format(I8,F15.6,2(F12.6))
 1030 Format(I8,D15.5,2(F12.6))

*-- Set the first root search condition
      RtLoI = -1.0D0+DevX
      RtUpI = -DevX

      Do 10 I = 0, IQntN
*     Root Solve
        RtI = RtSecI(Func1, (DBLE(I)+0.5D0)*Pi, RtLoI, RtUpI)
*     Result Write In
        IQntV(I+1)  = I
        EngV(I+1)   = RtI
        ItgLoV(I+1) = 1.5D0 - 0.5D0 * Sqrt(1.0D0 + RtI)
        ItgUpV(I+1) = 1.5D0 + 0.5D0 * Sqrt(1.0D0 + RtI)
*     Prepare for the next solve
        RtLoI = RtI
        RtUpI = RtI * 1.0D-5
        If (RtUpI.GT.-DevX) RtUpI = DevX
  10  Continue

      Write(IOut,1000) '-----------------------------------------------'
      Write(IOut,1010) '   Level', '         Energy', '        XMin',
     $                 '        XMax'
      Write(IOut,1000) '-----------------------------------------------'
      Do 20 I = 0, IQntN
        If(-EngV(I+1).GE.1.0D-2) then
        Write(IOut,1020) IQntV(I+1), EngV(I+1), ItgLoV(I+1), ItgUpV(I+1)
        Else
        Write(IOut,1030) IQntV(I+1), EngV(I+1), ItgLoV(I+1), ItgUpV(I+1)
        End If
  20  Continue
      Write(IOut,1000) '-----------------------------------------------'

      End Subroutine MainPg

************************************************************************
*                                                                      *
*     USER DEFINE SUBROUTINES                                          *
*                                                                      *
************************************************************************

*-----------------------------------------------------------------------
*
      Function Func1(Eng)
*
*     Purpose: The integral of the Gmr * (e - v(x))^0.5
*     Note:    This function actually has two variables: x, Gmr. Gmr is
*              pre-defined by the common blocks.
*
      Implicit None
*
*-- Common Definitions
      Integer           IOut, IOTmp
      Common /IO/       IOut, IOTmp
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Calculation Parameter
      Double Precision  Gmr
      Common /CalPar/   Gmr
*   Global Integral grid number
      Integer           IGridN
      Common /Grid/     IGridN
*
*-- Variables
*
      Double Precision  Func1, Eng
*
*-- Internal Variables
*
*   Integral Limit
      Double Precision  IntgLo, IntgUp
*   Integral Core Function
      Double Precision  Func1C
      External          Func1C
*   Integral Routine
      Double Precision  Itg5P2
      External          Itg5P2
*
*-----------------------------------------------------------------------

      IntgLo = 1.5D0 - 0.5D0 * Sqrt(1.0D0 + Eng)
      IntgUp = 1.5D0 + 0.5D0 * Sqrt(1.0D0 + Eng)

      Func1 = Gmr * Itg5P2(Func1C, Eng, IntgLo, IntgUp, IGridN)

      Call Err
      Return
      End Function Func1

*-----------------------------------------------------------------------
*
      Function Func1C(Eng, Var)
*
*     Purpose: The integral core of Func1
*
      Implicit None
*
*-- Common Definitions
*
*   Write file index
      Integer           IOut, IOTmp
      Common /IO/       IOut, IOTmp
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*
      Double Precision  Func1C, Eng, Var
      Double Precision  Tmp
*
*-----------------------------------------------------------------------

      Tmp = Eng - 4.0D0 * (Var-1.5)**2 + 1
      Call Test0(Tmp)
      Func1C = DSqrt(Tmp)

      End Function Func1C

************************************************************************
*                                                                      *
*     MATHEMATICAL BACKGROUND UTILITIES                                *
*                                                                      *
************************************************************************

*-----------------------------------------------------------------------
*
      Subroutine Err
*
*     Purpose: The integral core of Func1
*
      Implicit None
*
*-- Common Definitions
*
*   Write file index
      Integer           IOut, IOTmp
      Common /IO/       IOut, IOTmp
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*
*-----------------------------------------------------------------------

      If (IStat.GT.0) then
        Write(IOut,*) 'Error Return!'
        Write(IOut,*) 'Return Code: ', IStat
        Stop
      End If

      End Subroutine

************************************************************************
*                                                                      *
*     MATHEMATICAL BACKGROUND UTILITIES                                *
*                                                                      *
************************************************************************

*-----------------------------------------------------------------------
*
      Subroutine DmMath
*
*     Purpose: Present the commonly used variables and subroutines
*              There should be no routines call this subroutine.
*
*     Note:    All variables are predefined as double precision; all
*              subroutines are specified by double precision. If
*              variables are defined as Integer / Single Float /
*              Logical, then the first letter of the names of the
*              variables should implicit it's precision (I/S/L), and
*              it's second letter should be upper case.
*
*-- Variables
*
      Double Precision  Var, Var1, Var2, Var3
*       Var(x)    Input variables which need no explanations
      Integer           IGridN
*       IGridN    Grid numbers for various methods
      Double Precision  DevThr(3)
*       DevThr    1: Maximun Iteration Number (Stored by double)
*                 2: Maximun Deviation by X axis
*                 3: Maximun Deviation by Y axis
*
*-- Subroutines
*
*
*
*-- Functions
*
*     Integer   DFlr      Evaluate the floor of a double precision
*                         float number
*     Double    Itg5P1    Integral using Bode's method
*     Double    RtSecI    Find root inside certain area
*
*
*-----------------------------------------------------------------------

      End subroutine DmMath

*-----------------------------------------------------------------------
*
      Function RtSecI(Func, Num, RtLo, RtUp)
*
*     Purpose: Find the root with secant method, where the first two
*              guesses are provided mannually.
*              The root-finding problem should be expressed as:
*                Func(Root) == Num
*
      Implicit None
*
*-- Common Blocks
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Deviation Threahold
      Integer*8         ItrMax
      Double Precision  DevX, DevY
      Common /DevThr/   ItrMax, DevX, DevY
*
*-- Variables
*
      Double Precision  RtSecI, Func, Num, RtLo, RtUp
      External          Func
*
*   Func    The function we are concerning
*   Num     The right hand side of the equation
*   RtLo    The minimun guess
*   RtUp    The maximun guess
*   DevThr  Deviation Threahold
*
*   Note: Should have (Func(RtLo)-Num) * (Func(RtUp)-Num) < 0
*         or we probably have no or even roots inside within the maximun
*         guess or the minimun guess.
*
*-- Internal Variables
*
*   Iteration Dummy
      Integer           Itr
*   Internal maximun and minimun guess
      Double Precision  RtLoI, RtUpI
*   Internal Result
      Double Precision  FncLo, FncUp, FncSec
*
*-----------------------------------------------------------------------

*   Initialize internal guess
      RtLoI = RtLo
      RtUpI = RtUp
      Itr = 0
      FncLo = Func(RtLoI) - Num
      FncUp = Func(RtUpI) - Num

*   Find the root
  10  Continue
        Itr = Itr + 1
        RtSecI = ( RtLoI * FncUp - RtUpI * FncLo ) / ( FncUp - FncLo )
        FncSec = Func(RtSecI) - Num
        RtLoI = RtUpI
        FncLo = FncUp
        RtUpI = RtSecI
        FncUp = FncSec
*   Converge Judgement
      If ( (Itr.LT.ItrMax).And.( DAbs(RtUpI-RtLoI).GT.DevX.Or.
     $      (DAbs(FncUp).GT.DevY.And.(FncUp-FncLo).GT.DevY))) then
*     Not converged
        Go To 10
      Else If ( (Itr.GE.ItrMax).And.( DAbs(RtUpI-RtLoI).GT.DevX.Or.
     $      (DAbs(FncUp).GT.DevY.And.(FncUp-FncLo).GT.DevY))) then
*     Not converged but reached the maximun iteration
        Print *, 'Error Info in Function [RtSecI]'
        Print *, 'Not converged but reached the maximun iteration'
        Print *, 'Last Iteration Information:'
        Print *, 'Upper Guess: ', RtUpI, '  Lower Guess: ', RtLoI,
     $           'Upper Func: ', FncUp, '  Lower Guess: ', FncLo
        IStat = 1
      Else
        Return
      End If

      Call Err
      Return
      End Function RtSecI

*-----------------------------------------------------------------------
*
      Function Itg5P1(Func, IntgLo, IntgUp, IGridN)
*
*     Purpose: Integral using Bode's method (Func(Var))
*
*-- Variables
*
      Implicit None
*
      Double Precision  Itg5P1, Func, IntgLo, IntgUp
      Integer           IGridN
      External          Func
*
*   Func      The function integrated
*   IntgUp    Upper limit of the integral
*   InteLo    Lower limit of the integral
*
*-- Internal Variables
*
*   Decleared elsewere
      Integer           IFlr
      External          IFlr
*   Dummy
      Integer           I
*   Iteration Number
      Integer           Itr
*   Iteration Maximun
      Integer           ItrMax
*   Grid Seperation
      Double Precision  H
*
*-----------------------------------------------------------------------

*   Redefining Integral grids and make the separation
      Itr = IFlr(DBLE(IGridN) / 4.0D0)
      H = (IntgUp - IntgLo) / (4.0D0 * DBLE(Itr))

*   Initial and final point calculation
      Itg5P1 = 7.0D0 * (Func(IntgLo) - Func(IntgUp))

*   Internal grid point calculation
      Do 10 I = 1, Itr
        Itg5P1 = Itg5P1 + 32.0D0 * Func(IntgLo + DBLE(I*4-3) * H)
     $                  + 12.0D0 * Func(IntgLo + DBLE(I*4-2) * H)
     $                  + 32.0D0 * Func(IntgLo + DBLE(I*4-1) * H)
     $                  + 14.0D0 * Func(IntgLo + DBLE(I*4  ) * H)
  10  Continue

*   Coefficient multiplication
      Itg5P1 = Itg5P1 * H * 2.0D0 / 45.0D0

      Call Err
      Return
      End Function

*-----------------------------------------------------------------------
*
      Function Itg5P2(Func, VM, IntgLo, IntgUp, IGridN)
*
*     Purpose: Integral using Bode's method (Func(VM, VarMain,VarInt))
*
*-- Variables
*
      Implicit None
*
      Double Precision  Itg5P2, Func, IntgLo, IntgUp, VM
      Integer           IGridN
      External          Func
*
*   Func      The function integrated
*   IntgUp    Upper limit of the integral
*   InteLo    Lower limit of the integral
*   VM        Main Variable but not used in the integral
*
*-- Internal Variables
*
*   Decleared elsewere
      Integer           IFlr
      External          IFlr
*   Dummy
      Integer           I
*   Iteration Number
      Integer           Itr
*   Iteration Maximun
      Integer           ItrMax
*   Grid Seperation
      Double Precision  H
*
*-----------------------------------------------------------------------

*   Redefining Integral grids and make the separation
      Itr = IFlr(DBLE(IGridN) / 4.0D0)
      H = (IntgUp - IntgLo) / (4.0D0 * DBLE(Itr))

*   Initial and final point calculation
      Itg5P2 = 7.0D0 * (Func(VM, IntgLo) - Func(VM, IntgUp))

*   Internal grid point calculation
      Do 10 I = 1, Itr
        Itg5P2 = Itg5P2 + 32.0D0 * Func(VM, IntgLo + DBLE(I*4-3) * H)
     $                  + 12.0D0 * Func(VM, IntgLo + DBLE(I*4-2) * H)
     $                  + 32.0D0 * Func(VM, IntgLo + DBLE(I*4-1) * H)
     $                  + 14.0D0 * Func(VM, IntgLo + DBLE(I*4  ) * H)
  10  Continue

*   Coefficient multiplication
      Itg5P2 = Itg5P2 * H * 2.0D0 / 45.0D0

      Call Err
      Return
      End Function

*-----------------------------------------------------------------------
*
      Function IFlr(Var)
*
*     Purpose: Evaluate the floor of a double precision float number
*
*-- Variables
*
      Implicit None
*
      Integer           IFlr
      Double Precision  Var
*
*-----------------------------------------------------------------------

      IFlr = Int(Var)

      If (Var.LT.0.0D0) IFlr = IFlr - 1

      Return
      End Function IFlr

*-----------------------------------------------------------------------
*
      Subroutine Test0(Var)
*
      Implicit None
*
*-- Common Definitions
*
*   Write file index
      Integer           IOut, IOTmp
      Common /IO/       IOut, IOTmp
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Zero Tolerence (Two values refers to the error or warning situation)
      Double Precision  Thr0, ThrW0
      Common /ZeroTh/   Thr0, ThrW0
*
*-- Variables
      Double Precision  Var
*
*-----------------------------------------------------------------------

      If (Var.LT.0) then
        If (-Var.LE.ThrW0) then
          Var = 0.0D0
        Else If (-Var.LE.Thr0) then
      Write(IOut,*)'Tested variable less than 0 but larger than 1.0D-15'
          Write(IOut,*) 'Variable value: ', Var
          Var = 0.0D0
        Else
          Write(IOut,*) 'Tested variable less than 0. Error return.'
          Write(IOut,*) 'Variable value: ', Var
          IStat = 1
          Return
        End If
      End If

      Call Err
      Return
      End Subroutine Test0


      SUBROUTINE mapxy (X,Y,ALAT,ALONG,SLAT,SLON,SGN,E,RE)
C$*****************************************************************************
C$                                                                            *
C$                                                                            *
C$    DESCRIPTION:                                                            *
C$                                                                            *
C$    This subroutine converts from Polar Stereographic (X,Y) coordinates     *
C$    to geodetic latitude and longitude for the polar regions. The equations *
C$    are from Snyder, J. P., 1982,  Map Projections Used by the U.S.         *
C$    Geological Survey, Geological Survey Bulletin 1532, U.S. Government     *
C$    Printing Office.  See JPL Technical Memorandum 3349-85-101 for further  *
C$    details.                                                                *
C$                                                                            *
C$                                                                            *
C$    ARGUMENTS:                                                              *
C$                                                                            *
C$    Variable   Type       I/O    Description                                *
C$                                                                            *
C$    X          REAL        I     Polar Stereographic X Coordinate (km)      *
C$    Y          REAL        I     Polar Stereographic Y Coordinate (km)      *
C$    ALAT       REAL        O     Geodetic Latitude (degrees, +90 to -90)    *
C$    ALONG      REAL        O     Geodetic Longitude (degrees, 0 to 360)     *
C$                                                                            *
C$                                                                            *
C$                  Written by C. S. Morris - April 29, 1985                  *
C$                  Revised by C. S. Morris - December 11, 1985               *
C$                                                                            *
C$                  Revised by V. J. Troisi - January 1990                    *
C$                  SGN - provide hemisphere dependency (+/- 1)               *
C$                                                                            *
C      LAST MODIFIED 6 April 1994 Robert Grumbine                             *
C$*****************************************************************************
      IMPLICIT none

      REAL X,Y,ALAT,ALONG,E,E2,CDR,PI, SLAT, SLON
      REAL CHI, CM, RE, RHO, SGN, SL, T
C$*****************************************************************************
C$                                                                            *
C$    DEFINITION OF CONSTANTS:                                                *
C$                                                                            *
C$    Conversion constant from degrees to radians = 57.29577951.              *
      CDR=57.29577951
      E2=E*E
      PI=3.141592654
C$                                                                            *
C$*****************************************************************************
      SL = SLAT*PI/180.
      RHO=SQRT(X**2+Y**2)

      IF (RHO .LE. 0.1) THEN
        ALAT=90.*SGN
        ALONG=0.0
      ELSE
        CM=COS(SL)/SQRT(1.0-E2*(SIN(SL)**2))
        T=TAN((PI/4.0)-(SL/(2.0)))/((1.0-E*SIN(SL))/
     1    (1.0+E*SIN(SL)))**(E/2.0)

        IF (ABS(SLAT-90.).LT.1.E-5) THEN
          T=RHO*SQRT((1.+E)**(1.+E)*(1.-E)**(1.-E))/2./RE
         ELSE
          T=RHO*T/(RE*CM)
        END IF
        CHI=(PI/2.0)-2.0*ATAN(T)
        ALAT=CHI + ((E2/2.0) + (5.0*E2**2.0/24.0) +
     1   (E2**3.0/12.0))*SIN(2*CHI) +
     2   ((7.0*E2**2.0/48.0) + (29.0*E2**3/240.0))*SIN(4.0*CHI) +
     3   (7.0*E2**3.0/120.0)*SIN(6.0*CHI)

        ALAT  = SGN*ALAT
        ALONG = ATAN2(SGN*Y, SGN*X)
        ALONG = SGN*ALONG
        ALAT  = ALAT * CDR
        ALONG = ALONG * CDR - SLON

      ENDIF

      RETURN
      END


module sw_utils
    implicit none
    private
    logical, save :: sw_allocated = .false.
    ! - double precision
    integer, parameter, public :: idp = kind(1.0d0)

    real(idp), parameter, public :: PI = 4.0_idp*atan(1.0)

    ! -------------------------------------
    ! number of point in x and y directions
    ! -------------------------------------
    integer, parameter, public :: NX = 101
    integer, parameter, public :: NY = 101

    ! --------------------
    ! number of time steps
    ! --------------------
    integer, parameter, public :: NT = 10001

    ! ----------------------------------------------
    ! upper and lower bounds for x and y dimensions
    ! ----------------------------------------------
    real(idp), parameter, public :: XUPPER = 5.0_idp     ! xend
    real(idp), parameter, public :: XLOWER = -5.0_idp    ! xstart
    real(idp), parameter, public :: YUPPER = 6.0_idp     ! ystart
    real(idp), parameter, public :: YLOWER = -6.0_idp    ! yend

    ! -----------------------------
    ! start and end point for time
    ! -----------------------------
    real(idp), parameter, public :: TSTART = 0.0_idp
    real(idp), parameter, public :: TEND = 1000.0_idp

    ! ----------------------------
    ! length of x-axis and y-axis
    ! ----------------------------
    real(idp), parameter, public :: XLENGTH = (XUPPER - XLOWER)
    real(idp), parameter, public :: YLENGTH = (YUPPER - YLOWER)

    ! -----------------------
    ! total time or duration
    ! -----------------------
    real(idp), parameter, public :: TLENGTH = (TEND - TSTART)

    ! ---------------------------
    ! spatial grid step dx and dy
    ! ---------------------------
    real(idp), parameter, public :: DX = XLENGTH/dble(NX-1)
    real(idp), parameter, public :: DY = YLENGTH/dble(NY-1)

    ! ----------
    ! time step
    ! ----------
    real(idp), parameter, public :: DT = TLENGTH/dble(NT-1)

    ! ---------------------
    ! gravitation constant
    ! ---------------------
    real(idp), parameter, public :: G = 9.8065_idp

    ! ------------
    ! base height
    ! ------------
    real(idp), parameter, public :: H0 = 1.0_idp

    ! --------------------------
    ! rotation parameter, omega
    ! --------------------------
    real(idp), parameter, public :: OMEGA = 0.1_idp

    ! -------------
    ! viscous drag
    ! -------------
    real(idp), parameter, public :: vd = 0.001_idp

    ! -----------------------
    ! viscosity of the fluid
    ! -----------------------
    real(idp), parameter, public :: nu = 0.000015_idp

    ! -------------
    ! perturbation
    ! -------------
    real(idp), parameter, public :: PERTURB = 0.01_idp

    ! ----------------------
    ! output data file name
    ! ----------------------
    character(len=*), parameter, public :: swfname = "sw_data.nc"

    ! =====================================
    ! public variables' name and constants
    ! =====================================
    real(idp), dimension(1:NX), public :: xdata
    real(idp), dimension(1:NY), public :: ydata
    real(idp), allocatable, public :: tdata(:)
    real(idp), allocatable, public :: xxdata(:, :)
    real(idp), allocatable, public :: yydata(:, :)
    real(idp), allocatable, public :: fdata(:, :)
    real(idp), allocatable, public :: udata(:, :, :)
    real(idp), allocatable, public :: vdata(:, :, :)
    real(idp), allocatable, public :: hdata(:, :, :)

    ! ---------------------------------
    ! public subroutines and functions
    ! ---------------------------------
    public swMeshgrid
    public swAllocateData
    public swDeallocateData
    public swSaveData

contains
    subroutine swAllocateData()
        implicit none
        if ( .not. sw_allocated ) then
            allocate(tdata(NT))
            allocate(xxdata(NX, NY))
            allocate(yydata(NX, NY))
            allocate(fdata(NX, NY))
            allocate(udata(NX, NY, NT))
            allocate(vdata(NX, NY, NT))
            allocate(hdata(NX, NY, NT))
            sw_allocated = .true.
        endif
    end subroutine swAllocateData

    subroutine swDeallocateData()
        implicit none
        if (sw_allocated) then
            deallocate(tdata)
            deallocate(xxdata)
            deallocate(yydata)
            deallocate(fdata)
            deallocate(udata)
            deallocate(vdata)
            deallocate(hdata)
            sw_allocated = .false.
        endif
    end subroutine swDeallocateData

    ! ---
    subroutine swMeshgrid(x, y, xx, yy, nx, ny)
        implicit none
        integer, intent(in) :: nx, ny
        real(kind=8), dimension(1:nx), intent(in) :: x
        real(kind=8), dimension(1:ny), intent(in) :: y
        real(kind=8), dimension(1:nx, 1:ny), intent(out) :: xx, yy
        xx = spread(x, 1, size(y))
        yy = spread(y, 2, size(x))
    end subroutine swMeshgrid

    subroutine swSaveData()
        use netcdf
        implicit none

        ! -----------------------------------------
        ! number of dimensions for large variables
        ! -----------------------------------------
        integer, parameter :: NDIMS3 = 3
        integer, parameter :: NDIMS2 = 2

        ! ------------------------
        ! id for netcdf variables
        ! ------------------------
        integer :: ncid

        ! ----------------
        ! dimension names
        ! ----------------
        character(len=*), parameter :: xname = "X Distance"
        character(len=*), parameter :: yname = "Y Distance"
        character(len=*), parameter :: tname = "T Time"

        ! --------------
        ! dimension ids
        ! --------------
        integer :: xdimID, ydimID, tdimID

        ! --------------------
        ! shape of dimensions
        ! --------------------
        integer :: dimID3(NDIMS3)
        integer :: dimID2(NDIMS2)

        ! ---------------
        ! variable names
        ! ---------------
        character(len=*), parameter :: uname = "U_Velocity"
        character(len=*), parameter :: vname = "V_Velocity"
        character(len=*), parameter :: hname = "H_Level"
        character(len=*), parameter :: fname = "F_Coriolis"

        ! ----------------------------------
        ! Units for the dimension variables
        ! ----------------------------------
        character(len=*), parameter :: units = "units"
        character(len=*), parameter :: u_units = "m/s"
        character(len=*), parameter :: v_units = "m/s"
        character(len=*), parameter :: h_units = "m"
        character(len=*), parameter :: f_units = "1/s"
        character(len=*), parameter :: x_units = "meters_east"
        character(len=*), parameter :: y_units = "meters_north"
        character(len=*), parameter :: t_units = "seconds_forward"

        ! ---------------------------
        ! variable IDs for variables
        ! ---------------------------
        integer :: uvarID, vvarID, hvarID, fvarID

        ! -----------------------------------------
        ! variable IDs for the dimension variables
        ! -----------------------------------------
        integer :: xvarID, yvarID, tvarID

        write(*, *) "Defined all data variables and their IDs."

        ! ----------------
        ! create the file
        ! ----------------
        call check(nf90_create(                                     &
            swfname, or(nf90_clobber, nf90_64bit_offset), ncid)   &
        )

        ! ----------------------
        ! define the dimensions
        ! ----------------------
        call check(nf90_def_dim(ncid, xname, NX, xdimID))
        call check(nf90_def_dim(ncid, yname, NY, ydimID))
        call check(nf90_def_dim(ncid, tname, NT, tdimID))

        ! ---------------------------
        ! create dimension variables
        ! ---------------------------
        call check(nf90_def_var(ncid, xname, NF90_DOUBLE, xdimID, xvarID))
        call check(nf90_def_var(ncid, yname, NF90_DOUBLE, ydimID, yvarID))
        call check(nf90_def_var(ncid, tname, NF90_DOUBLE, tdimID, tvarID))

        ! ----------------------------------
        ! set attributes for the dimensions
        ! ----------------------------------
        call check(nf90_put_att(ncid, xvarID, units, x_units))
        call check(nf90_put_att(ncid, yvarID, units, y_units))
        call check(nf90_put_att(ncid, tvarID, units, t_units))

        write(*, *) "Dimensions' unit attribute added"

        ! ----------------------
        ! create variable slots
        ! ----------------------
        dimID3 = (/ xdimID, ydimID, tdimID /)
        dimID2 = (/ xdimID, ydimID /)

        call check(nf90_def_var(ncid, uname, NF90_DOUBLE, dimID3, uvarID))
        call check(nf90_def_var(ncid, vname, NF90_DOUBLE, dimID3, vvarID))
        call check(nf90_def_var(ncid, hname, NF90_DOUBLE, dimID3, hvarID))
        call check(nf90_def_var(ncid, fname, NF90_DOUBLE, dimID2, fvarID))

        write(*, *) "Data variables created"

        ! ----------------------------------
        ! set attribute for data variabales
        ! ----------------------------------
        call check(nf90_put_att(ncid, uvarID, units, u_units))
        call check(nf90_put_att(ncid, vvarID, units, v_units))
        call check(nf90_put_att(ncid, hvarID, units, h_units))
        call check(nf90_put_att(ncid, fvarID, units, f_units))

        write(*, *) "Data variable unit attribute added"

        ! --------------------------
        ! clode variable definition
        ! --------------------------
        call check(nf90_enddef(ncid))

        ! ------------------------------
        ! write the dimension variables
        ! ------------------------------
        call check(nf90_put_var(ncid, xvarID, xdata))
        write(*, *) "Wrote x dimension variable"
        call check(nf90_put_var(ncid, yvarID, ydata))
        write(*, *) "Wrote y dimension variable"
        call check(nf90_put_var(ncid, tvarID, tdata))
        write(*, *) "Wrote t dimension variable"

        ! -------------------------
        ! write the data variables
        ! -------------------------
        call check(nf90_put_var(ncid, uvarID, udata))
        write(*, *) "Wrote u data variable"
        call check(nf90_put_var(ncid, vvarID, vdata))
        write(*, *) "Wrote v data variable"
        call check(nf90_put_var(ncid, hvarID, hdata))
        write(*, *) "Wrote h (i.e height) data variable"
        call check(nf90_put_var(ncid, fvarID, fdata))
        write(*, *) "Wrote f (i.e coriolis) data variable"

        ! --------------
        ! close the file
        ! ---------------
        call check(nf90_close(ncid))

    contains
        subroutine check(status)
            implicit none
            integer, intent(in) :: status
            if(status /= nf90_noerr) then
                write(*, *) trim(nf90_strerror(status))
                stop "Stopped"
            endif
        end subroutine check
    end subroutine swSaveData
end module sw_utils


PROGRAM gd_test
  USE randmod
  USE general_tools
  USE debug_tools
  USE checkpoint
  USE gd_tools
IMPLICIT NONE
  INTEGER, PARAMETER :: &
    ip_xsize=512,&
    ip_ysize=510
  REAL(KIND=cp), PARAMETER ::&
    rp_xmin = -2*rp_pi,&
    rp_xmax = +2*rp_pi,&
    rp_ymin = -2*rp_pi,&
    rp_ymax = +2*rp_pi

  !CALL test_1D()
  CALL test_2D()

CONTAINS

  SUBROUTINE test_1D()
    INTEGER :: ibi
    REAL(KIND=cp) :: rl_dx, rl_rand
    REAL(KIND=cp), DIMENSION(ip_xsize) :: rla_x, rla_phi, rla_f, rla_f_noise, rla_f_gd, rla_res
    TYPE(dyn_rVector), DIMENSION(4) :: tla_save

    rl_dx = (rp_xmax - rp_xmin)/REAL(ip_xsize-1)
    DO ibi = 1, ip_xsize
      rla_x(ibi) = rp_xmin+REAL(ibi-1, cp)*rl_dx
    END DO
    rla_f = 1.0*sin(rla_x)
    rla_phi = 1.0
    !initializing random numbers generator
    CALL init_normal_rand(mu=0.0_cp, sigma=0.5_cp, radius=1.5_cp, nright=256, stat=.FALSE.)
    !Adding noise
    DO ibi = 1, ip_xsize
      CALL normal_rand(rl_rand)
      rla_f_noise(ibi) = rla_f(ibi) + rl_rand
      rla_phi(ibi) = 1.0 - MIN( 1.0, ABS(rl_rand) )
    END DO

    CALL gd_projection(rla_f_noise, rla_f_gd, rla_phi, rl_dx, 50)
    rla_res = rla_f_gd-rla_f
    tla_save(1) = rla_x
    tla_save(2) = rla_f
    tla_save(3) = rla_f_noise
    tla_save(4) = rla_f_gd
    CALL debug('', 'Original noise *****************************')
    CALL debug(MAXVAL( ABS(rla_f_noise) ),      '  MAXVAL    = ')
    CALL debug(SUM( ABS(rla_f_noise) )/ip_xsize, '  MEAN      = ')
    CALL debug(SQRT( SUM(rla_f_noise**2) ),     '  L2 norm   = ')
    CALL debug('', '********************************************')
    CALL debug('', 'Residual from GD ***************************')
    CALL debug(MAXVAL( ABS(rla_res) ),      '  MAXVAL    = ')
    CALL debug(SUM( ABS(rla_res) )/ip_xsize, '  MEAN      = ')
    CALL debug(SQRT( SUM(rla_res**2) ),     '  L2 norm   = ')
    CALL debug('', '********************************************')

    CALL save_trj( tla_save(2:4), 'runtime_gd_test.dat', ld_column = .TRUE. )
    CALL reset_drv_array( tla_save )
    CALL finilize_normal_rand()
    CALL debug('', 'GD_test 1D end')
  END SUBROUTINE test_1D

  SUBROUTINE test_2D()
    INTEGER :: ibi, ibj
    REAL(KIND=cp) :: rl_dx, rl_dy, rl_rand
    REAL(KIND=cp), DIMENSION(ip_xsize, ip_ysize) :: rla_x, rla_y, rla_phi, rla_f, rla_f_noise, rla_f_gd, rla_res
    TYPE(dyn_rVector), DIMENSION(4) :: tla_save

    rl_dx = (rp_xmax - rp_xmin)/REAL(ip_xsize-1)
    rl_dy = (rp_ymax - rp_ymin)/REAL(ip_ysize-1)
    DO ibi = 1, ip_xsize
      rla_x(ibi, :) = rp_xmin+REAL(ibi-1, cp)*rl_dx
    END DO
    DO ibj = 1, ip_ysize
      rla_y(:, ibj) = rp_ymin+REAL(ibj-1, cp)*rl_dy
    END DO
    rla_f = 1.0*sin(SQRT(rla_x**2 + rla_y**2))
    rla_phi = 1.0
    !initializing random numbers generator
    CALL init_normal_rand(mu=0.0_cp, sigma=0.5_cp, radius=1.5_cp, nright=256, stat=.FALSE.)
    !Adding noise
    DO ibj = 1, ip_ysize
      DO ibi = 1, ip_xsize
        CALL normal_rand(rl_rand)
        rla_f_noise(ibi, ibj) = rla_f(ibi, ibj) + rl_rand
        rla_phi(ibi, ibj) = 1.0 - MIN( 1.0, ABS(rl_rand) )
      END DO
    END DO

    CALL debug('', 'Calling gd_projection')
    CALL gd_projection(rla_f_noise, rla_f_gd, rla_phi, rl_dx, rl_dy, 20)
    rla_res = rla_f_gd-rla_f
    CALL debug('', 'After gd_projection')
    CALL debug('', 'Original noise *****************************')
    CALL debug(MAXVAL( ABS(rla_f_noise) ),      '  MAXVAL    = ')
    CALL debug(SUM( ABS(rla_f_noise) )/(ip_xsize*ip_xsize), '  MEAN      = ')
    CALL debug(SQRT( SUM(rla_f_noise**2) ),     '  L2 norm   = ')
    CALL debug('', '********************************************')
    CALL debug('', 'Residual from GD ***************************')
    CALL debug(MAXVAL( ABS(rla_res) ),      '  MAXVAL    = ')
    CALL debug(SUM( ABS(rla_res) )/(ip_xsize*ip_xsize), '  MEAN      = ')
    CALL debug(SQRT( SUM(rla_res**2) ),     '  L2 norm   = ')
    CALL debug('', '********************************************')

!     tla_save(1) = rla_x
!     tla_save(2) = rla_f
!     tla_save(3) = rla_f_noise
!     tla_save(4) = rla_f_gd
!     CALL save_trj( tla_save(2:4), 'runtime_gd_test.dat', ld_column = .TRUE. )
!     CALL reset_drv_array( tla_save )
    CALL finilize_normal_rand()
    CALL debug('', 'GD_test 2D end')
  END SUBROUTINE test_2D

END PROGRAM gd_test


c     # ------------------------------------------------------------------
c     # MAPC2M_PILLOWDISK
c     # ------------------------------------------------------------------
c     #
c     # Maps a logically rectangular Cartesian grid in [-1,1]x[-1,1] to
c     # the unit disk.
c     #
c     # ------------------------------------------------------------------
      subroutine mapc2m_pillowdisk(blockno,xc1,yc1,xp,yp,zp)
      implicit none

      double precision xc1,yc1,xp,yp,zp
      double precision xc,yc,zc
      integer blockno

c     # Map to [-1,1]x[-1,1]
      call mapc2m_cart(blockno,xc1,yc1,xc,yc,zc)

c     # Get circle of radius sqrt(2.d0)
      call mapc2p_disk_circle(xc,yc,xp,yp)

      xp = xp/sqrt(2.d0)
      yp = yp/sqrt(2.d0)
      zp = 0

      return
      end

      subroutine mapc2p_disk_circle(x1,y1,xp,yp)
      implicit none

      double precision xc,yc,xp,yp, x1,y1
      double precision xi,eta,x,y, minxy,maxxy

      xc = x1
      yc = y1

      xi = min(abs(xc),abs(yc))
      eta = max(abs(xc),abs(yc))
      eta = max(eta,1.d-10)

      call map_disk_north_sector(xi,eta,x,y)

      minxy = min(abs(x),abs(y))
      maxxy = max(abs(x),abs(y))

      if (abs(xc) .le. abs(yc))  then
c        # In NS sectors
         xp = sign(1.d0,xc)*minxy
         yp = sign(1.d0,yc)*maxxy
      else
c        # In EW sectors
         xp = sign(1.d0,xc)*maxxy
         yp = sign(1.d0,yc)*minxy
      endif

      end

      subroutine map_disk_north_sector(xi,eta,x,y)
      implicit none

      double precision xi,eta,x,y

      x = xi
      y = sqrt(2 - xi**2) - sqrt(2 - eta**2) + eta

      end


C     PROGRAM No. 1: GRID GENERATOR FOR 2-D AIRFOILS
C     ----------------------------------------------
C     THIS PROGRAM IS AN AUTOMATED COMPLEX AIRFOIL TRANSFORMATION OF THE
C       TYPE PRESENTED BY VAN DE VOOREN AND DE JONG (1970). THE RESULTING
C       AIRFOIL MAY HAVE A NON-ZERO TRAILING EDGE ANGLE. THIS FORMULATION
C       IS FOR NON-CAMBERED AIRFOILS ONLY (PROGRAMMED BY STEVEN YON, 1989).

      OPEN(8,FILE='AFOIL2.DAT',STATUS='NEW')
      OPEN(10,FILE='CP.DAT',STATUS='NEW')

      WRITE(6,*) 'READY TO START VAN DE VOOREN TRANSFORMATION'
      WRITE(6,*) 'ENTER THICKNESS COEFF. E'
      READ(5,*) E
      WRITE(6,*) 'ENTER T.E. ANGLE COEFF. K'
      READ(5,*) AK
      TL=1.0
      A=2*TL*(E+1)**(AK-1)/(2**AK)
      WRITE(6,*) 'ENTER THE ANGLE OF ATTACK IN DEGREES'
      READ(5,*) ALPHA
      AL=ALPHA/57.2958
      WRITE(6,*) 'ENTER NUMBER OF AIRFOIL PANELS,M'
      WRITE(6,*) 'WITH WHICH TO MODEL THE AIRFOIL'
      WRITE(6,*)'(NOTE THAT M SHOULD BE AN EVEN FACTOR OF 360)'
      READ(5,*) M
      ITHETA=360/M

C     THE DO LOOP WILL RUN THROUGH THE CIRCLE PLANE WITH
C     THE SPECIFIED ANGULAR INTERVAL AND TRANSFORM EACH
C     POINT TO THE AIRFOIL PLANE

      DO I=0,360,ITHETA
      IF(I.EQ.0.OR.I.EQ.360) THEN
         X=1
         Y=0
         CP=1
         WRITE(8,*) X,' ,',Y
         IF(AK.EQ.2.AND.I.EQ.0) GOTO 25
         IF(AK.EQ.2.AND.I.EQ.360) GOTO 25
         WRITE(10,*) X,' ,',CP

 25   CONTINUE
         GOTO 100
      ELSE
         GOTO 50
      END IF

 50   CONTINUE
         TH=I/57.2958
         R1=SQRT((A*(COS(TH)-1))**2+(A*SIN(TH))**2)
         R2=SQRT((A*(COS(TH)-E))**2+(A*SIN(TH))**2)
      IF(TH.EQ.0) THEN
         TH1=1.5708
         ELSE
         TH1=(ATAN((A*SIN(TH))/(A*(COS(TH)-1))))+3.1415927
      END IF

      IF(COS(TH)-E.LT.0.AND.SIN(TH).GT.0) THEN
         TH2=(ATAN((A*SIN(TH))/(A*(COS(TH)-E))))+3.1415927
         ELSE IF(COS(TH)-E.LT.0.AND.SIN(TH).LT.0) THEN
         TH2=(ATAN((A*SIN(TH))/(A*(COS(TH)-E))))+3.1415927
         ELSE IF(COS(TH)-E.GT.0.AND.SIN(TH).LT.0) THEN
         TH2=(ATAN((A*SIN(TH))/(A*(COS(TH)-E))))+2*3.1415927
         ELSE
         TH2=(ATAN((A*SIN(TH))/(A*(COS(TH)-E))))
      END IF

C     THIS PART COMPUTES THE TRANSFORMED POSITIONS

      COM1=((R1**AK)/(R2**(AK-1)))/((COS((AK-1)*TH2))**2+(SIN((AK-1)*
     *   TH2))**2)
      X=COM1*(COS(AK*TH1)*COS((AK-1)*TH2)+SIN(AK*TH1)*SIN((AK-1)*TH2))+
     *   TL
      Y=COM1*(SIN(AK*TH1)*COS((AK-1)*TH2)-COS(AK*TH1)*SIN((AK-1)*TH2))

      WRITE(8,*) X,' ,',Y

C     THIS PART COMPUTES THE TRANSFORMED PRESSURE
C      DISTRIBUTION

      A1=COS((AK-1)*TH1)*COS(AK*TH2)+SIN((AK-1)*TH1)*SIN(AK*TH2)
      B1=SIN((AK-1)*TH1)*COS(AK*TH2)-COS((AK-1)*TH1)*SIN(AK*TH2)
      C1=(COS(AK*TH2))**2+(SIN(AK*TH2))**2
      P=A*(1-AK+AK*E)
      D1=A1*(A*COS(TH)-P)-B1*A*SIN(TH)
      D2=A1*A*SIN(TH)+B1*(A*COS(TH)-P)

      TEMP=2*C1*(SIN(AL)-SIN(AL-TH))/(D1**2+D2**2)
      COM2=TEMP*(R2**AK)/(R1**(AK-1))
      VX=D1*SIN(TH)+D2*COS(TH)
      VY=-(D1*COS(TH)-D2*SIN(TH))
      CP=1-COM2**2*(VX**2+VY**2)

      WRITE(10,*) X,' ,',CP

 100  CONTINUE
      END DO

      CLOSE(8)
      CLOSE(10)
      STOP
      END


      Subroutine transpole(pole1,width1,x1,y,jac)
c**********************************************************************
c     This routine transfers evenly spaced x values between 0 and 1
c     to y values with a pole at y=pole with width width and returns
c     the appropriate jacobian for this.  If x<del or x>1-del, uses
c     a linear transformation.  This ensures ability to cover entire
c     region, even away from B.W.
c
c     If pole<0 then assumes have sqrt(1d0/(x^2+a^2)) type pole
c     If pole<0 then assumes have x/(x^2+a^2) type pole
c
c**********************************************************************
      implicit none
c
c     Constants
c
      double precision del
      parameter       (del=1d-22)          !Must agree with del in untranspole
c
c     Arguments
c
      double precision pole,width,y,jac
      double precision x1

c
c     Local
c
      double precision z,zmin,zmax,xmin,xmax,ez
      double precision pole1,width1,x,xc
      double precision a,b
c
c     small width treatment
c
      double precision small_width_treatment
      common/narrow_width/small_width_treatment
c-----
c  Begin Code
c-----
      pole=pole1
      width=width1

      x = x1
      if (pole .gt. 0d0) then
         if (width.lt.pole*small_width_treatment)then
            width = pole * small_width_treatment
            jac = jac * width/width1
         endif

         zmin = atan((-pole)/width)/width
         zmax = atan((1d0-pole)/width)/width
         if (x .gt. del .and. x .lt. 1d0-del) then
            z = zmin+(zmax-zmin)*x
            y = pole+width*tan(width*z)
            jac = jac *(width/cos(width*z))**2*(zmax-zmin)
         elseif (x .lt. del) then
            xmin = 0d0
            z    = zmin+(zmax-zmin)*del
            xmax = pole+width*tan(width*z)
            y = xmin+x*(xmax-xmin)/del
            jac = jac*(xmax-xmin)/del
         else
            xmax = 1d0
            z    = zmin+(zmax-zmin)*(1d0-del)
            xmin = pole+width*tan(width*z)
            y = xmin+(x+del-1d0)*(xmax-xmin)/del
            jac = jac*(xmax-xmin)/del
         endif
      elseif(pole .gt. -1d0) then       !1/sqrt(x^2+width^2) t-channel
         if (x .gt. .5d0) then          !Don't do anything here t>0
            y=x
         else
            zmin = log(2d0*width)       !2*width is because x->1-2*x
            zmax = log(1d0+sqrt(1d0+4d0*width*width))
            x=1d0-x*2d0
            z = zmin+(zmax-zmin)*x
            ez = exp(z)
            y = (1d0-.5d0*(ez-4d0*width*width/ez))/2d0
            jac = jac *(zmax-zmin)*.5d0*(ez+4d0*width*width/ez)
c            x = .5d0*(1d0-x)
         endif
c-------
c    tjs 3/5/2011  Perform 1/x transformation  using y=xo^(1-x)
c-------
      elseif(pole .eq. -15d0 .and. width .gt. 0d0) then !1/x   limit of width
c         if (x .lt. width) then      !No transformation below cutoff
         xc = width
         xc = 1d0/(1d0-log(width))
         if (x .le. xc) then      !No transformation below cutoff
            y=x*width/xc
            jac = jac * width / xc
         else
            z = (x-xc)/(1d0-xc)
            y=width**(1d0-z)
            jac = jac * y * (-log(width))/(1d0-xc)
c            write(*,*) "trans",x,y,z
         endif
c         write(*,*) 'Transpole called',x,y
         return
      elseif(pole .ge. -2d0 .and. width .gt. 0d0) then !1/x^2   limit of width
         if (x .lt. width) then      !No transformation below cutoff
            y=x
         else
c---------
c   tjs 5/1/2008  modified for any y=x^-n transformation
c-----------
            z = 1d0 - x + width
            b = ( 1d0-width) / (width**(pole+1d0) - 1d0)
            a = width - b
            y = a + b * z**(pole+1)
            jac = jac * abs((pole+1d0) * b * z**(pole))
c            write(*,*) "pre-trans",x,y
c            call untranspole(pole,width,x,y,jac)
c            write(*,*) "post-trans",x,y
c-----uncomment for 1/x^2 tjs -------
c            x = 1d0-x+width
c            y=width/x
c            jac = jac*width/(x*x)
c------------------------------------

c            write(*,*) 'trans',x,width/(x*x)
         endif

      elseif(pole .gt. -1d99) then       !1/sqrt(x^2+width^2) s-channel
         zmin = log(width)
         zmax = log(1d0+sqrt(1d0+width*width))
         if (x .gt. del .and. x .lt. 1d0-del) then
            z = zmin+(zmax-zmin)*x
            ez = exp(z)
            y = .5d0*(ez-width*width/ez)
            jac = jac *(zmax-zmin)*.5d0*(ez+width*width/ez)
         elseif (x .le. del) then
            xmin = 0d0
            z    = zmin+(zmax-zmin)*del
            ez   = exp(z)
            xmax = .5d0*(ez-width*width/ez)
            y = xmin+x*(xmax-xmin)/del
            jac = jac*(xmax-xmin)/del
         else
            xmax = 1d0
            z    = zmin+(zmax-zmin)*(1d0-del)
            ez   = exp(z)
            xmin = .5d0*(ez-width*width/ez)
            y = xmin+(x+del-1d0)*(xmax-xmin)/del
            jac = jac*(xmax-xmin)/del
         endif
      elseif(pole .gt. -8d99) then
         zmin = .5d0*log(width*width)
         zmax = .5d0*log(1d0+width*width)
         if (x .gt. del .and. x .lt. 1d0-del) then
            z = zmin+(zmax-zmin)*x
            ez = exp(2d0*z)
            y = sqrt(ez-width*width)
            jac = jac *(zmax-zmin)*ez/sqrt(ez-width*width)
         elseif (x .lt. del) then
            xmin = 0d0
            z    = zmin+(zmax-zmin)*del
            xmax = sqrt(exp(2d0*z)-width*width)
            y = xmin+x*(xmax-xmin)/del
            jac = jac*(xmax-xmin)/del
         else
            xmax = 1d0
            z    = zmin+(zmax-zmin)*(1d0-del)
            xmin = sqrt(exp(2d0*z)-width*width)
            y = xmin+(x+del-1d0)*(xmax-xmin)/del
            jac = jac*(xmax-xmin)/del
         endif
      endif
      end

      Subroutine untranspole(pole1,width1,x,y1,jac)
c**********************************************************************
c     This routine transfers takes values of y for a given pole and
c     width, and returns the value of x (which an evenly placed
c     random number) would have been used to get that value of y.
c     it also returns the jacobian associated with this choice.
c**********************************************************************
      implicit none
c
c     Constants
c
      double precision del
      parameter       (del=1d-22)          !Must agree with del in untranspole
c
c     Arguments
c
      double precision pole1,width1,y1,jac
      real*8 x
c
c     small width treatment
c
      double precision small_width_treatment
      common/narrow_width/small_width_treatment
c
c     Local
c
      double precision z,zmin,zmax,xmin,xmax,ez
      double precision pole,width,y,xc
      double precision a,b
      double precision xgmin,xgmax       ! these should be identical
      parameter (xgmin=-1d0, xgmax=1d0)  ! to the ones in genps.inc
c-----
c  Begin Code
c-----
      pole=pole1
      width=width1
      y = y1
      if (pole .gt. 0d0) then                   !BW
         if (width.lt.pole*small_width_treatment)then
            width = pole * small_width_treatment
            jac = jac * width/width1
         endif
         zmin = atan((-pole)/width)/width
         zmax = atan((1d0-pole)/width)/width
         z = atan((y-pole)/width)/width
         x = (z-zmin)/(zmax-zmin)
         if (x .le. del) then
            xmin = 0d0
            z    = zmin+(zmax-zmin)*del
            xmax = pole+width*tan(width*z)
            if(xmin.lt.xmax) then
               x = (y-xmin)*del/(xmax-xmin)
            else
               x=xmin
            endif
            jac = jac*(xmax-xmin)/del
         elseif (x .ge. 1d0-del) then
            xmax = 1d0
            z    = zmin+(zmax-zmin)*(1d0-del)
            xmin = pole+width*tan(width*z)
            if(xmin.lt.xmax) then
               x = (y-xmin)*del/(xmax-xmin)-del+1d0
            else
               x=xmin
            endif
            jac = jac*(xmax-xmin)/del
c RF (2014/07/07): code is not protected against this special case. In this case,
c simply set x to 1 and the jac to zero so that this PS point will not
c contribute (but you do get the correct xbin_min and xbin_max in
c sample_get_x)
            if (y.eq.xgmax .and. xmin.ge.xgmax) then
               x=1d0
               jac=0d0
            endif
         else
            jac = jac *(width/cos(width*z))**2*(zmax-zmin)
         endif
c-------
c    tjs 3/5/2011  Perform 1/x transformation  using y=xo^(1-x)
c-------
      elseif(pole .eq. -15d0 .and. width .gt. 0d0) then !1/x   limit of width
         xc = 1d0/(1d0-log(width))
c         xc = width
         if (y .le. width) then      !No transformation below cutoff
            x = y*xc/width
         else
            z = 1d0-log(y)/log(width)
            x = z*(1d0-xc) + xc
c            write(*,*) "untrans",x,y,z
         endif
         return
      elseif(pole .gt. -1d0) then !1/sqrt((.5-x)^2+width^2)  t-channel
         if (y .gt. .5d0) then
            x=y
         else
            zmin = log(width*2d0)
            zmax = log(1d0+sqrt(1d0+4d0*width*width))
            y = (1d0-2d0*y)
            z = log(y+sqrt(y*y+4d0*width*width))
            x = (z - zmin)/(zmax-zmin)
            x = .5d0*(1d0-x)
            ez = exp(z)
            jac = jac *(zmax-zmin)*.5d0*(ez+4d0*width*width/ez)
            y = (1d0-y)/2d0
         endif

      elseif(pole .gt. -5d0 .and. width .gt. 0d0) then !1/x^2   limit of width
         if (y .lt. width) then      !No transformation below cutoff
            x=y
         else
c---------
c   tjs 5/1/2008  modified for any y=x^-n transformation
c-----------
            b = ( 1d0-width) / (width**(pole+1d0) - 1d0)
            a = width - b
            z = ((y-a)/b)**(1d0/(pole+1))
            x = 1d0 - z + width
            jac = jac * abs((pole+1d0) * b * z**(pole))

c-------------------
c Uncomment below for y=1/x^2
c-------------------
c            x=width/y
c            write(*,*) 'untr',x,width/(x*x)
c            jac = jac*width/(x*x)
c            x = 1d0-x+width
         endif

      elseif(pole .gt. -5d99) then !1/sqrt(x^2+width^2)  s-channel
         zmin = log(width)
         zmax = log(1d0+sqrt(1d0+width*width))
         if (pole .gt. -1d0 .and. y .lt. -pole) y=-pole-y
         z = log(y+sqrt(y*y+width*width))
         x = (z - zmin)/(zmax-zmin)
         if (x .gt. del .and. x .lt. 1d0-del) then
            ez = exp(z)
            jac = jac *(zmax-zmin)*.5d0*(ez+width*width/ez)
         elseif (x .lt. del) then
            xmin = 0d0
            z    = zmin+(zmax-zmin)*del
            ez   = exp(z)
            xmax = .5d0*(ez-width*width/ez)
c            y = xmin+x*(xmax-xmin)/del
            if(xmin.lt.xmax) then
               x = (y-xmin)*del/(xmax-xmin)
            else
               x=xmin
            endif
            jac = jac*(xmax-xmin)/del
         else
            xmax = 1d0
            z    = zmin+(zmax-zmin)*(1d0-del)
            ez   = exp(z)
            xmin = .5d0*(ez-width*width/ez)
c            y = xmin+(x+del-1d0)*(xmax-xmin)/del
            x = (y-xmin)*del/(xmax-xmin)-del+1d0
            jac = jac*(xmax-xmin)/del
         endif
      endif
      end


program invert
  use gauss
  use mats
  implicit none
  real, allocatable :: mat(:, :), M(:, :)
  integer :: n

  print *, 'Enter matrix side length:'
  read (*, *) n
  allocate(mat(n, n))

  print *, 'Enter matrix values:'
  read (*, *) mat
  allocate(M(2 * n, n))
  M(:n, :) = mat
  M(n + 1:, :) = identity(n)

  call reduce(M)
  print *, 'Inverted matrix:'
  call print_mat(M(n + 1:, :))
end program invert