!..................................................................................................................................
! LICENSING
! Copyright (C) 2013  National Renewable Energy Laboratory
!
!    Glue is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as
!    published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version.
!
!    This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
!    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
!
!    You should have received a copy of the GNU General Public License along with Module2.
!    If not, see <http://www.gnu.org/licenses/>.
!
!**********************************************************************************************************************************
!    This file is the "glue code" example for the new FAST modularization.
!
!    This code embodies the formulation and numerical methods for "Predictor-Corrector Loose Coupling."   The methods
!    employed here share similarities with those described in Gasmi et al. (2013).   However, the method used here is a
!    "symmetric" predictor-corrector approach (order of module UpdateStates does not matter).    Further, the method reduces
!    to an explicit method when only the prediction step is taken (pc_max = 1 below).   However, for all modules, inputs
!    and outputs are stored for up to three steps, allowing up to quadratic interpolation or exptrapolation of input and
!    output data.
!
!    The test problem is a simple two-degree-of-freedom damped oscillator, where each "mass" is treated by a module; see
!    Gasmi et al. (2013) for details.
!
!    Three fourth-order explicit numerical time integrators are included: Runge-Kutta (RK4), Adams-Bashforth (AB4), and
!    Adams-Bashforth-Moulton (ABM4).    RK4 and ABM4 have an implcit dependence on other-module data.
!
!    Numerical experiments have shown that, if quadratic interpolation of inputs and outpus is employed, order of accuracy of
!    the methods with pc_max predictor-corrector iterations are as follows (with Mod1 & Ice using same integrator):
!
!    RK4, PC1: third order
!    RK4, PC2: third order (but more accurate than PC1)
!
!    AB4, PC1: fourth order
!    AB4, PC2: fourth order (should be identical to PC1; no implicit dependence on other-module data)
!
!    ABM4, PC1: third order
!    ABM4, PC2: fourth order
!
!    NOTE: These convergence results can be obtained only when the multi-step methods have their first three steps initialized
!          with the exact benchmark solution.
!
!    References:
!
!    Gasmi, A., M. A. Sprague, J. M. Jonkman, and W. B. Jones, Numerical stability and accuracy of temporally coupled
!    multi-physics modules in wind turbine CAE tools. In proceedings of the 32nd ASME Wind Energy Symposium, 51st AIAA
!    Aerospace Sciences Meeting including the New Horizons Forum and Aerospace Exposition, Grapevine, TX, January 7-10,
!    2013.   Also published as NREL Report No. CP-2C00-57298.   Available in pdf format at:
!    http://www.nrel.gov/docs/fy13osti/57298.pdf
!
!**********************************************************************************************************************************
PROGRAM MAIN

   USE Module1
   USE Module1_Types

   USE IceDyn
   USE IceDyn_Types

   USE NWTC_Library

   IMPLICIT NONE

   ! global glue-code-specific variables

   INTEGER(IntKi)                     :: ErrStat          ! Error status of the operation
   CHARACTER(1024)                    :: ErrMsg           ! Error message if ErrStat /= ErrID_None
   CHARACTER(1024)                    :: OutFileName      ! Name of the output file

   REAL(DbKi)                         :: dt_global        ! fixed/constant global time step
   REAL(DbKi)                         :: t_initial        ! time at initialization
   REAL(DbKi)                         :: t_final          ! time at simulation end
   REAL(DbKi)                         :: t_global         ! global-loop time marker

   INTEGER(IntKi)                     :: n_t_final        ! total number of time steps
   INTEGER(IntKi)                     :: n_t_global       ! global-loop time counter

   INTEGER(IntKi)                     :: pc_max           ! 1:explicit loose; 2:pc loose
   INTEGER(IntKi)                     :: pc               ! counter for pc iterations

   INTEGER(IntKi)                     :: Mod1_interp_order     ! order of interpolation/extrapolation
   INTEGER(IntKi)                     :: ID_interp_order      ! order of interpolation/extrapolation

   ! Module1 Derived-types variables; see Registry_Module1.txt for details

   TYPE(Mod1_InitInputType)           :: Mod1_InitInput
   TYPE(Mod1_ParameterType)           :: Mod1_Parameter
   TYPE(Mod1_ContinuousStateType)     :: Mod1_ContinuousState
   TYPE(Mod1_ContinuousStateType)     :: Mod1_ContinuousStateDeriv
   TYPE(Mod1_InitOutputType)          :: Mod1_InitOutput
   TYPE(Mod1_DiscreteStateType)       :: Mod1_DiscreteState
   TYPE(Mod1_ConstraintStateType)     :: Mod1_ConstraintState
   TYPE(Mod1_OtherStateType)          :: Mod1_OtherState

   TYPE(Mod1_InputType),Dimension(:),Allocatable   :: Mod1_Input
   REAL(DbKi) , DIMENSION(:), ALLOCATABLE          :: Mod1_InputTimes

   TYPE(Mod1_OutputType),Dimension(:),Allocatable  :: Mod1_Output
   REAL(DbKi) , DIMENSION(:), ALLOCATABLE          :: Mod1_OutputTimes

   TYPE(Mod1_InputType)   :: u1    ! local variable for extrapolated inputs
   TYPE(Mod1_OutputType)  :: y1    ! local variable for extrapolated outputs

   ! Module IceLoad deived data typed needed in pc-coupling; predicted states

   TYPE(Mod1_ContinuousStateType)     :: Mod1_ContinuousState_pred
   TYPE(Mod1_DiscreteStateType)       :: Mod1_DiscreteState_pred
   TYPE(Mod1_ConstraintStateType)     :: Mod1_ConstraintState_pred

   ! Module IceLoad Derived-types variables; see Registry_Module2.txt

   TYPE(ID_InitInputType)           :: ID_InitInput
   TYPE(ID_ParameterType)           :: ID_Parameter
   TYPE(ID_ContinuousStateType)     :: ID_ContinuousState
   TYPE(ID_ContinuousStateType)     :: ID_ContinuousStateDeriv
   TYPE(ID_InitOutputType)          :: ID_InitOutput
   TYPE(ID_DiscreteStateType)       :: ID_DiscreteState
   TYPE(ID_ConstraintStateType)     :: ID_ConstraintState
   TYPE(ID_OtherStateType)          :: ID_OtherState

   ! Module IceLoad deived data typed needed in pc-coupling; predicted states

   TYPE(ID_ContinuousStateType)     :: ID_ContinuousState_pred
   TYPE(ID_DiscreteStateType)       :: ID_DiscreteState_pred
   TYPE(ID_ConstraintStateType)     :: ID_ConstraintState_pred

   TYPE(ID_InputType),Dimension(:),Allocatable    :: ID_Input
   REAL(DbKi) , DIMENSION(:), ALLOCATABLE          :: ID_InputTimes

   TYPE(ID_OutputType),Dimension(:),Allocatable  :: ID_Output
   REAL(DbKi) , DIMENSION(:), ALLOCATABLE          :: ID_OutputTimes

   TYPE(ID_InputType)   :: u2    ! local variable for extrapolated inputs
   TYPE(ID_OutputType)  :: y2    ! local variable for extrapolated outputs

   ! local variables
   Integer(IntKi)                     :: i               ! counter for various loops

   REAL(DbKi)                         :: exact           ! exact solution
   REAL(DbKi)                         :: rms_error       ! rms error
   REAL(DbKi)                         :: rms_error_norm  ! rms error normalization
   CHARACTER(200)                     :: Frmt
   CHARACTER(1)                       :: Dlim = TAB
   Integer(IntKi)                     :: Un

   ! -------------------------------------------------------------------------
   ! Initialization of glue-code time-step variables
   ! -------------------------------------------------------------------------

   t_initial = 0.
   t_final   = 250.

   pc_max = 1  ! Number of predictor-corrector iterations; 1 corresponds to an explicit calculation where UpdateStates
               ! is called only once  per time step for each module; inputs and outputs are extrapolated in time and
               ! are available to modules that have an implicit dependence on other-module data

   ! specify time increment; currently, all modules will be time integrated with this increment size
   dt_global = 0.0125

   n_t_final = ((t_final - t_initial) / dt_global )

   t_global = t_initial

   ! initialize rms-error quantities
   rms_error      = 0.
   rms_error_norm = 0.

   ! define polynomial-order for ModName_Input_ExtrapInterp and ModName_Output_ExtrapInterp
   ! Must be 0, 1, or 2
   Mod1_interp_order = 2
   ID_interp_order = 2

   !Module1: allocate Input and Output arrays; used for interpolation and extrapolation
   Allocate(Mod1_Input(Mod1_interp_order + 1))
   Allocate(Mod1_InputTimes(Mod1_interp_order + 1))

   Allocate(Mod1_Output(Mod1_interp_order + 1))
   Allocate(Mod1_OutputTimes(Mod1_interp_order + 1))

   ! Module2: allocate Input and Output arrays; used for interpolation and extrapolation

   Allocate(ID_Input(ID_interp_order + 1))
   Allocate(ID_InputTimes(ID_interp_order + 1))

   Allocate(ID_Output(ID_interp_order + 1))
   Allocate(ID_OutputTimes(ID_interp_order + 1))

   ! -------------------------------------------------------------------------
   ! Initialization of Modules
   !  note that in this example, we are assuming that dt_global is not changed
   !  in the modules, i.e., that both modules are called at the same glue-code
   !  defined coupling interval.
   ! -------------------------------------------------------------------------

   CALL Mod1_Init( Mod1_InitInput, Mod1_Input(1), Mod1_Parameter, Mod1_ContinuousState, Mod1_DiscreteState, &
                   Mod1_ConstraintState, Mod1_OtherState, Mod1_Output(1), dt_global, Mod1_InitOutput, ErrStat, ErrMsg )

   ! We fill Mod1_InputTimes with negative times, but the Mod1_Input values are identical for each of those times; this allows
   ! us to use, e.g., quadratic interpolation that effectively acts as a zeroth-order extrapolation and first-order extrapolation
   ! for the first and second time steps.  (The interpolation order in the ExtrapInput routines are determined as
   ! order = SIZE(Mod1_Input)
   do i = 1, Mod1_interp_order + 1
      Mod1_InputTimes(i) = t_initial - (i - 1) * dt_global
      Mod1_OutputTimes(i) = t_initial - (i - 1) * dt_global
   enddo

   do i = 1, Mod1_interp_order
     Call Mod1_CopyInput (Mod1_Input(i),  Mod1_Input(i+1),  0, Errstat, ErrMsg)
     Call Mod1_CopyOutput (Mod1_Output(i),  Mod1_Output(i+1),  0, Errstat, ErrMsg)
   enddo

   ID_InitInput%InputFile = 'IceDyn_Input.dat'
   ID_InitInput%RootName = 'IceDyn_Mod1Test'

   CALL ID_Init( ID_InitInput, ID_Input(1), ID_Parameter, ID_ContinuousState, ID_DiscreteState, &
                   ID_ConstraintState, ID_OtherState, ID_Output(1), dt_global, ID_InitOutput, ErrStat, ErrMsg )

   do i = 1, ID_interp_order + 1
      ID_InputTimes(i) = t_initial - (i - 1) * dt_global
      ID_OutputTimes(i) = t_initial - (i - 1) * dt_global
   enddo

   do i = 1, ID_interp_order
     Call ID_CopyInput (ID_Input(i),  ID_Input(i+1),  0, Errstat, ErrMsg)
     Call ID_CopyOutput (ID_Output(i),  ID_Output(i+1),  0, Errstat, ErrMsg)
   enddo

   ! -------------------------------------------------------------------------
   ! Time-stepping loops
   ! -------------------------------------------------------------------------

   ! Open output file
   OutFileName = Trim(ID_parameter%RootName)//'.txt'
   CALL GetNewUnit (Un)
   CALL OpenFOutFile (Un, OutFileName, ErrStat, ErrMsg)

   ! write headers for output columns:
   Frmt = '(A8)'
   WRITE (Un, Frmt, ADVANCE = 'no') TRIM ('Time')

   Frmt = '(3(:,A,A10))'
   WRITE (Un, Frmt, ADVANCE = 'no') Dlim, 'StrDisp', Dlim, 'IceDisp', Dlim, 'IceForce'

   ! CALL WrScr1( '  Time (t)         Numerical q_1(t) Analytical q_1(t)' )
   ! CALL WrScr(  '  ---------------  ---------------- -----------------' )

   ! write initial condition for q1
   ! CALL WrScr  ( '  '//Num2LStr(t_global)//'  '//Num2LStr( Mod1_ContinuousState%q)//'  '//Num2LStr(Mod1_ContinuousState%q))

   Frmt = '(/ F8.3)'
   WRITE (Un, Frmt, ADVANCE = 'no') t_global

   Frmt = '(A,F10.4,A,F10.4,A,E10.3E2)'
   WRITE (Un, Frmt, ADVANCE = 'no') Dlim, Mod1_ContinuousState%q, Dlim, ID_ContinuousState%q, Dlim, ID_Output(1)%fice

   DO n_t_global = 0, n_t_final

      ! Solve input-output relations; this section of code corresponds to Eq. (35) in Gasmi et al. (2013)
      ! This code will be specific to the underlying modules

      call Mod1_ID_InputOutputSolve(t_global, &
                   Mod1_Input(1), Mod1_Parameter, Mod1_ContinuousState, Mod1_DiscreteState, &
                   Mod1_ConstraintState, Mod1_OtherState, Mod1_Output(1), &
                   ID_Input(1), ID_Parameter, ID_ContinuousState, ID_DiscreteState, &
                   ID_ConstraintState, ID_OtherState, ID_Output(1),  &
                   ErrStat, ErrMsg)

      ! extrapolate inputs and outputs to t + dt; will only be used by modules with an implicit dependence on input data.

      CALL Mod1_Input_ExtrapInterp(Mod1_Input, Mod1_InputTimes, u1, t_global + dt_global, ErrStat, ErrMsg)

      CALL Mod1_Output_ExtrapInterp(Mod1_Output, Mod1_OutputTimes, y1, t_global + dt_global, ErrStat, ErrMsg)

      ! Shift "window" of the Mod1_Input and Mod1_Output

      do i = Mod1_interp_order, 1, -1
         Call Mod1_CopyInput (Mod1_Input(i),  Mod1_Input(i+1),  0, Errstat, ErrMsg)
         Call Mod1_CopyOutput (Mod1_Output(i),  Mod1_Output(i+1),  0, Errstat, ErrMsg)
         Mod1_InputTimes(i+1) = Mod1_InputTimes(i)
         Mod1_OutputTimes(i+1) = Mod1_OutputTimes(i)
      enddo

      Call Mod1_CopyInput (u1,  Mod1_Input(1),  0, Errstat, ErrMsg)
      Call Mod1_CopyOutput (y1,  Mod1_Output(1),  0, Errstat, ErrMsg)
      Mod1_InputTimes(1) = t_global + dt_global
      Mod1_OutputTimes(1) = t_global + dt_global

      ! extrapolate inputs and outputs to t + dt; will only be used by modules with an implicit dependence on input data.

      CALL ID_Input_ExtrapInterp(ID_Input, ID_InputTimes, u2, t_global + dt_global, ErrStat, ErrMsg)

      CALL ID_Output_ExtrapInterp(ID_Output, ID_OutputTimes, y2, t_global + dt_global, ErrStat, ErrMsg)

      ! Shift "window" of the Ice_Input and Ice_Output

      do i = ID_interp_order, 1, -1
         Call ID_CopyInput (ID_Input(i),  ID_Input(i+1),  0, Errstat, ErrMsg)
         Call ID_CopyOutput (ID_Output(i),  ID_Output(i+1),  0, Errstat, ErrMsg)
         ID_InputTimes(i+1) = ID_InputTimes(i)
         ID_OutputTimes(i+1) = ID_OutputTimes(i)
      enddo

      Call ID_CopyInput (u2,  ID_Input(1),  0, Errstat, ErrMsg)
      Call ID_CopyOutput (y2,  ID_Output(1),  0, Errstat, ErrMsg)
      ID_InputTimes(1) = t_global + dt_global
      ID_OutputTimes(1) = t_global + dt_global

      do pc = 1, pc_max

         !----------------------------------------------------------------------------------------
         ! Module 1
         !----------------------------------------------------------------------------------------

         ! copy ContinuousState to ContinuousState_pred; don't modify ContinuousState until completion of PC iterations

         Call Mod1_CopyContState   (Mod1_ContinuousState, Mod1_ContinuousState_pred, 0, Errstat, ErrMsg)

         Call Mod1_CopyConstrState (Mod1_ConstraintState, Mod1_ConstraintState_pred, 0, Errstat, ErrMsg)

         Call Mod1_CopyDiscState   (Mod1_DiscreteState,   Mod1_DiscreteState_pred,   0, Errstat, ErrMsg)

         CALL Mod1_UpdateStates( t_global, n_t_global, Mod1_Input, Mod1_InputTimes, Mod1_Parameter, Mod1_ContinuousState_pred, &
                                 Mod1_DiscreteState_pred, Mod1_ConstraintState_pred, &
                                 Mod1_OtherState, ErrStat, ErrMsg )

         !----------------------------------------------------------------------------------------
         ! Module 2
         !----------------------------------------------------------------------------------------

         ! copy ContinuousState to ContinuousState_pred; don't modify ContinuousState until completion of PC iterations

         Call ID_CopyContState   (ID_ContinuousState, ID_ContinuousState_pred, 0, Errstat, ErrMsg)

         Call ID_CopyConstrState (ID_ConstraintState, ID_ConstraintState_pred, 0, Errstat, ErrMsg)

         Call ID_CopyDiscState   (ID_DiscreteState,   ID_DiscreteState_pred,   0, Errstat, ErrMsg)

         CALL ID_UpdateStates( t_global, n_t_global, ID_Input, ID_InputTimes, ID_Parameter, ID_ContinuousState_pred, &
                                 ID_DiscreteState_pred, ID_ConstraintState_pred, &
                                 ID_OtherState, ErrStat, ErrMsg )

         !-----------------------------------------------------------------------------------------
         ! If correction iteration is to be taken, solve intput-output equations; otherwise move on
         !-----------------------------------------------------------------------------------------

         if (pc .lt. pc_max) then

            call Mod1_ID_InputOutputSolve( t_global + dt_global, &
                                             Mod1_Input(1), Mod1_Parameter, Mod1_ContinuousState_pred, Mod1_DiscreteState_pred, &
                                             Mod1_ConstraintState_pred, Mod1_OtherState, Mod1_Output(1), &
                                             ID_Input(1), ID_Parameter, ID_ContinuousState_pred, ID_DiscreteState_pred, &
                                             ID_ConstraintState_pred, ID_OtherState, ID_Output(1),  &
                                             ErrStat, ErrMsg)

         endif

      enddo

      ! Save all final variables

      Call Mod1_CopyContState   (Mod1_ContinuousState_pred,  Mod1_ContinuousState, 0, Errstat, ErrMsg)
      Call Mod1_CopyConstrState (Mod1_ConstraintState_pred,  Mod1_ConstraintState, 0, Errstat, ErrMsg)
      Call Mod1_CopyDiscState   (Mod1_DiscreteState_pred,    Mod1_DiscreteState,   0, Errstat, ErrMsg)

      Call ID_CopyContState   (ID_ContinuousState_pred,  ID_ContinuousState, 0, Errstat, ErrMsg)
      Call ID_CopyConstrState (ID_ConstraintState_pred,  ID_ConstraintState, 0, Errstat, ErrMsg)
      Call ID_CopyDiscState   (ID_DiscreteState_pred,    ID_DiscreteState,   0, Errstat, ErrMsg)

      ! update the global time

      t_global = REAL(n_t_global+1,DbKi) * dt_global + t_initial

      Frmt = '(/ F8.3)'
      WRITE (Un, Frmt, ADVANCE = 'no') t_global

      Frmt = '(A,F10.4,A,F10.4,A,E10.3E2)'
      WRITE (Un, Frmt, ADVANCE = 'no') Dlim, Mod1_ContinuousState%q, Dlim, ID_ContinuousState%q, Dlim, ID_Output(1)%fice

   END DO

   ! -------------------------------------------------------------------------
   ! Ending of modules
   ! -------------------------------------------------------------------------

   CALL Mod1_End(  Mod1_Input(1), Mod1_Parameter, Mod1_ContinuousState, Mod1_DiscreteState, &
                   Mod1_ConstraintState, Mod1_OtherState, Mod1_Output(1), ErrStat, ErrMsg )

   do i = 2, Mod1_interp_order+1
      CALL Mod1_DestroyInput(Mod1_Input(i), ErrStat, ErrMsg )
      CALL Mod1_DestroyOutput(Mod1_Output(i), ErrStat, ErrMsg )
   enddo

   DEALLOCATE(Mod1_InputTimes)
   DEALLOCATE(Mod1_OutputTimes)

   CALL ID_End(  ID_Input(1), ID_Parameter, ID_ContinuousState, ID_DiscreteState, &
                   ID_ConstraintState, ID_OtherState, ID_Output(1), ErrStat, ErrMsg )

   do i = 2, ID_interp_order+1
      CALL ID_DestroyInput(ID_Input(i), ErrStat, ErrMsg )
      CALL ID_DestroyOutput(ID_Output(i), ErrStat, ErrMsg )
   enddo

   DEALLOCATE(ID_InputTimes)
   DEALLOCATE(ID_Output)

END PROGRAM MAIN
!----------------------------------------------------------------------------------------------------------------------------------
SUBROUTINE Mod1_ID_InputOutputSolve(time, &
                   Mod1_Input, Mod1_Parameter, Mod1_ContinuousState, Mod1_DiscreteState, &
                   Mod1_ConstraintState, Mod1_OtherState, Mod1_Output, &
                   ID_Input, ID_Parameter, ID_ContinuousState, ID_DiscreteState, &
                   ID_ConstraintState, ID_OtherState, ID_Output,  &
                   ErrStat, ErrMsg)
!
! Solve input-output relations for Module 1 coupled to Module 2; this section of code corresponds to Eq. (35) in
! Gasmi et al. (2013). This code will be specific to the underlying modules
!...................................................................................................................................

   USE Module1
   USE Module1_Types

   USE IceDyn
   USE IceDyn_Types

   ! Module1 Derived-types variables; see Registry_Module1.txt for details

   TYPE(Mod1_InputType),           INTENT(INOUT) :: Mod1_Input
   TYPE(Mod1_ParameterType),       INTENT(IN   ) :: Mod1_Parameter
   TYPE(Mod1_ContinuousStateType), INTENT(IN   ) :: Mod1_ContinuousState
   TYPE(Mod1_DiscreteStateType),   INTENT(IN   ) :: Mod1_DiscreteState
   TYPE(Mod1_ConstraintStateType), INTENT(INOUT) :: Mod1_ConstraintState
   TYPE(Mod1_OtherStateType),      INTENT(INOUT) :: Mod1_OtherState
   TYPE(Mod1_OutputType),          INTENT(INOUT) :: Mod1_Output

   ! IceLoad Derived-types variables; see Registry_Module2.txt

   TYPE(ID_InputType),           INTENT(INOUT) :: ID_Input
   TYPE(ID_ParameterType),       INTENT(IN   ) :: ID_Parameter
   TYPE(ID_ContinuousStateType), INTENT(IN   ) :: ID_ContinuousState
   TYPE(ID_DiscreteStateType),   INTENT(IN   ) :: ID_DiscreteState
   TYPE(ID_ConstraintStateType), INTENT(INOUT) :: ID_ConstraintState
   TYPE(ID_OtherStateType),      INTENT(INOUT) :: ID_OtherState
   TYPE(ID_OutputType),          INTENT(INOUT) :: ID_Output

   INTEGER(IntKi),                 INTENT(  OUT)  :: ErrStat     ! Error status of the operation
   CHARACTER(*),                   INTENT(  OUT)  :: ErrMsg      ! Error message if ErrStat /= ErrID_None

   REAL(DbKi),                     INTENT(IN   )  :: time        ! Current simulation time in seconds

   ! Solve input-output relations; this section of code corresponds to Eq. (35) in Gasmi et al. (2013)
   ! This code will be specific to the underlying modules; could be placed in a separate routine.
   ! Note that Module2 has direct feedthrough, but Module1 does not. Thus, Module1 should be called first.

   CALL Mod1_CalcOutput( time, Mod1_Input, Mod1_Parameter, Mod1_ContinuousState, Mod1_DiscreteState, &
                Mod1_ConstraintState, Mod1_OtherState, Mod1_Output, ErrStat, ErrMsg )

   call ID_InputSolve( Mod1_Input, Mod1_Output, ID_Input, ID_Output, ErrStat, ErrMsg)

   CALL ID_CalcOutput( time, ID_Input, ID_Parameter, ID_ContinuousState, ID_DiscreteState, &
                ID_ConstraintState, ID_OtherState, ID_Output, ErrStat, ErrMsg )

   call Mod1_InputSolve( Mod1_Input, Mod1_Output, ID_Input, ID_Output, ErrStat, ErrMsg)

END SUBROUTINE Mod1_ID_InputOutputSolve
!----------------------------------------------------------------------------------------------------------------------------------
SUBROUTINE Mod1_InputSolve( Mod1_Input, Mod1_Output,  ID_Input, ID_Output, ErrStat, ErrMsg)

   USE Module1
   USE Module1_Types

   USE IceDyn
   USE IceDyn_Types

   ! Module1 Derived-types variables; see Registry_Module1.txt for details

   TYPE(Mod1_InputType),           INTENT(  OUT) :: Mod1_Input
   TYPE(Mod1_OutputType),          INTENT(IN   ) :: Mod1_Output

   ! Module2 Derived-types variables; see Registry_Module2.txt

   TYPE(ID_InputType),           INTENT(IN   ) :: ID_Input
   TYPE(ID_OutputType),          INTENT(IN   ) :: ID_Output

   INTEGER(IntKi),                 INTENT(  OUT)  :: ErrStat     ! Error status of the operation
   CHARACTER(*),                   INTENT(  OUT)  :: ErrMsg      ! Error message if ErrStat /= ErrID_None

   ErrStat = ErrID_None
   ErrMsg  = ''

   Mod1_Input%fc   = ID_Output%fice

END SUBROUTINE Mod1_InputSolve
!----------------------------------------------------------------------------------------------------------------------------------
SUBROUTINE ID_InputSolve( Mod1_Input,  Mod1_Output, ID_Input,  ID_Output, ErrStat, ErrMsg)

   USE Module1
   USE Module1_Types

   USE IceDyn
   USE IceDyn_Types

   ! Module1 Derived-types variables; see Registry_Module1.txt for details

   TYPE(Mod1_InputType),           INTENT(IN   ) :: Mod1_Input
   TYPE(Mod1_OutputType),          INTENT(IN   ) :: Mod1_Output

   ! Module2 Derived-types variables; see Registry_Module2.txt

   TYPE(ID_InputType),           INTENT(  OUT) :: ID_Input
   TYPE(ID_OutputType),          INTENT(IN   ) :: ID_Output

   INTEGER(IntKi),                 INTENT(  OUT)  :: ErrStat     ! Error status of the operation
   CHARACTER(*),                   INTENT(  OUT)  :: ErrMsg      ! Error message if ErrStat /= ErrID_None

   ErrStat = ErrID_None
   ErrMsg  = ''

   ID_Input%q    = Mod1_Output%q
   ID_Input%dqdt = Mod1_Output%dqdt

END SUBROUTINE ID_InputSolve
!----------------------------------------------------------------------------------------------------------------------------------


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C PATCH1
C
C  It allows the user to replace several circular  patches  in
C  an image with a fitted noisy piece of synthetic data. It is
C  derived from a program, by W.D. Pence (University of Sussex).
C
C  It may be used to remove large defects, bright galaxies  or
C  any other localised unwanted pixels. The result can be very
C  convincing. The input file with the positions and diameters
C  should be of the same format as the one created by REMSTAR (x,y,diam).
C
C Syntax:
C     RUNS PATCH1 input_image output_image [Y/N manual input of the noise?]
C          [[sigma_noise]] input_position_file
C Example:
C    RUNS PATCH1 test test_patched N test.pat
C    RUNS PATCH1 test test_patched Y 12.4 test.pat
C
C JLP
C Version 19-07-90
C--------------------------------------------------------------------------
C  Do not worry if you have arithmetic underflow, just compile it
C  with FORTRAN/CHECK=NOUNDERFLOW
C********************************************************************
	PROGRAM PATCH1
	PARAMETER (NDIMER=200)
	CHARACTER FILE_IN*40,FILE_OUT*40,NAME*40,ANS*1
	CHARACTER COMMENTS*80
	REAL*4 XS,YS,ERR1(NDIMER)
	INTEGER*4 IS,JS,MADRID(1)
	COMMON /VMR/MADRID

10	FORMAT(A)

C INCLUDE 'INTERIM(FMTPAR)'
	CALL JLP_BEGIN

	WRITE(6,11)
11	FORMAT(' PROGRAM PATCH1 ',/,
     1	' Version of 15/04/90 ')
	OPEN(3,FILE='patch1.log',STATUS='unknown')
	WRITE(3,11)

C Input :
	CALL JLP_INQUIFMT
        WRITE(6,*) 'Input image:'
	READ(5,10) FILE_IN
	CALL JLP_VM_READIMAG(IPNT,NX,NY,FILE_IN,COMMENTS)
	WRITE(3,240)FILE_IN
240	FORMAT(' INPUT IMAGE :',A)

	WRITE(6,12) NX,NY
12	FORMAT(' SIZE OF THE FILE : NX =',I5,'  NY =',I5)
	WRITE(3,12) NX,NY

C Output :
	WRITE(6,*) ' OUTPUT IMAGE :'
	READ(5,10) FILE_OUT
	WRITE(3,242)FILE_OUT
242	FORMAT(' OUTPUT IMAGE :',A)

C Get virtual memory:
	I=NX*NY*4
	CALL JLP_GETVM(IOPNT,I)

C Copy the input image on the output image:
	CALL OUTDATA(MADRID(IPNT),MADRID(IOPNT),NX,NY)
C
C SET UP ARRAY OF RANDOM ERRORS WITH GAUSSIAN DISTRIBUTION
C FOR APPROXIMATING THE NOISE WHEN INTERPOLATING
	PRINT *,' DO YOU KNOW THE NOISE OF THE IMAGE ?(N)'
	READ(5,10) ANS
	IF(ANS.NE.'Y'.AND.ANS.NE.'y')THEN
	 CALL AUTO_SKY(MADRID(IOPNT),NX,NY,NX,SKY,SIGMA)
	 WRITE(6,243)SKY,SIGMA
	 WRITE(3,243)SKY,SIGMA
243	 FORMAT(' AUTO-SKY DETERMINATION :',/,
     1	' SKY, SIGMA :',2(G12.5,2X))
	ELSE
	 PRINT *,' NOISE ESTIMATION OF THE IMAGE :'
	 READ(5,*) SIGMA
	 WRITE(3,244)SIGMA
244	 FORMAT(' SIGMA:',G12.5)
	ENDIF

C Use NAG routines G05CBF and G05DDF to generate normal errors, mean=0, sigma=1
C	CALL G05CBF(0)
	CALL JLP_RANDOM_INIT(1)
	  DO 2 I=1,200
C	  ERR1(I)=G05DDF(0.,1.0)
          CALL JLP_RANDOM_GAUSS(ERR1(I))
2	  CONTINUE

	PRINT *,' NAME OF THE FILE CONTAINING THE POSITIONS ?'
	READ(5,10) NAME
	 WRITE(3,245)NAME
245	 FORMAT(' NAME OF THE POSITION FILE :',A)

	OPEN(UNIT=9,STATUS='OLD',FILE=NAME)
	IOBJECT=0

C Loop as long as File 9 contains something :
70	CONTINUE

C Entering centre (IS,JS), and diameter NS
	READ (9,*,END=5) XS,YS,NS
        IS=INT(XS+0.5)
        JS=INT(YS+0.5)
	IOBJECT=IOBJECT+1

C Only even diameters :
	NS=((NS+1)/2)*2

C Going to the next step :
C ORDER OF THE POLYNOMIAL (0, 1, 2, OR 3)'
	NCODE=3
	CALL STRDELT(MADRID(IOPNT),NX,NY,IS,JS,NS,
     1	ERR1,NDIMER,NCODE,SIGMA)
	GO TO 70

C End :
5	 WRITE(6,*) ' END OF FILE :',IOBJECT,'  OBJECTS TREATED'
	 WRITE(3,246) IOBJECT
246	 FORMAT(' NUMBER OF PATCHES : ',I5)

C Writing the data in the output file:
	COMMENTS=' '
	CALL JLP_WRITEIMAG(MADRID(IOPNT),NX,NY,NX,
     1	FILE_OUT,COMMENTS)

	CLOSE(3)
	CLOSE(9)
	CALL JLP_END
	STOP
	END
C----------------------------------------------------------------------
	SUBROUTINE OUTDATA(IN,OUT,N,M)
	REAL IN(N,M),OUT(N,M)
	 DO J=1,M
	  DO I=1,N
	   OUT(I,J)=IN(I,J)
	  END DO
	 END DO
	RETURN
	END
C--------------------------------------------------------------------
	SUBROUTINE STRDELT(ARRAY,NX,NY,IS,JS,
     1	NS,ERR1,NDIMER,NCODE1,SIGMA)
C****************************************************************
C
C Deletes pixels within a circle around point (is,js) and
C interpolates them with a polynomial fitted to an annulus
C of surrounding points.
C
C IS, JS : Position of the centre
C NS : Diameter of the patch
C
C****************************************************************
C	INCLUDE 'INTERIM(FMTPAR)'
	PARAMETER (NDIM=1000)
	REAL*4 ARRAY(NX,NY),ERR1(NDIMER)
	REAL*4 XX(NDIM,2),YY(NDIM)
	REAL*8 ZZ(NDIM),D(30),SE(30),RDOE(30),DUMMY
	REAL*4 XZ,YZ
	DOUBLE PRECISION POLY
	CHARACTER ANS*1
	INTEGER*4 MADRID(1)
	COMMON /VMR/MADRID
	EXTERNAL POLY

	NCODE=NCODE1

C Treating the case when the diameter is 2 (one bad pixel only):
C Linear interpolation between the surrounding pixels
	IF(NS.EQ.2)THEN
	 JM1=MAX0(JS-1,1)
	 JP1=MIN0(JS+1,NY)
	 IM1=MAX0(IS-1,1)
	 IP1=MIN0(IS+1,NY)
	 ARRAY(IS,JS)=(ARRAY(IM1,JS)+ARRAY(IP1,JS)
     1	+ARRAY(IS,JM1)+ARRAY(IS,JP1))/4.0
 	 RETURN
	ENDIF

C Treating the case when the diameter is 4 (two bad pixels):
C Linear interpolation between the surrounding pixels
	IF(NS.EQ.4)THEN
	 JM1=MAX0(JS-1,1)
	 JP1=MIN0(JS+1,NY)
	 JM2=MAX0(JS-2,1)
	 JP2=MIN0(JS+2,NY)
	 IM1=MAX0(IS-1,1)
	 IP1=MIN0(IS+1,NY)
	 IM2=MAX0(IS-2,1)
	 IP2=MIN0(IS+2,NY)
	 ARRAY(IS,JS)=(ARRAY(IM2,JS)+ARRAY(IP2,JS)
     1	+ARRAY(IS,JM2)+ARRAY(IS,JP2))/4.0
	 ARRAY(IM1,JS)=(ARRAY(IM2,JS)+ARRAY(IS,JS)
     1	+ARRAY(IM1,JM1)+ARRAY(IM1,JP1))/4.0
	 ARRAY(IP1,JS)=(ARRAY(IP2,JS)+ARRAY(IS,JS)
     1	+ARRAY(IP1,JP1)+ARRAY(IP1,JP1))/4.0
	 ARRAY(IS,JP1)=(ARRAY(IM1,JP1)+ARRAY(IP1,JP1)
     1	+ARRAY(IS,JS)+ARRAY(IS,JP2))/4.0
	 ARRAY(IS,JM1)=(ARRAY(IM1,JM1)+ARRAY(IP1,JM1)
     1	+ARRAY(IS,JS)+ARRAY(IS,JM2))/4.0
 	 RETURN
	ENDIF

C Limiting the order of the polynomial for small patches :
	IF(NS.EQ.6)NCODE=MIN(1,NCODE)
	IF(NS.EQ.8)NCODE=MIN(2,NCODE)

	IRAD2=(NS/2)**2
C
C DEFINE LIMITS OF AREA TO DELETE
C
	I1=MAX(IS-NS/2,1)
	I2=MIN(IS+NS/2,NX)
	J1=MAX(JS-NS/2,1)
	J2=MIN(JS+NS/2,NY)
C
C TEMPORARILY STORE CURRENT ARRAY CONTENTS
C
	ISIZE=4*(I2-I1+1)*(J2-J1+1)
	CALL JLP_GETVM(IPNT,ISIZE)
	CALL STRCOPY(ARRAY,NY,NX,MADRID(IPNT),ISIZE,I1,I2,J1,J2)
	XOLD=ARRAY(IS,JS)
C
C SET UP ARRAYS FOR NEQSOL
C Fit the background in an annulus between IDIAM AND FACTOR*IDIAM
	IF (NCODE .EQ. 0)THEN
	  FACTOR=1.5
	ELSE
	  FACTOR=2.
	ENDIF
	NWIDE=NS*FACTOR
	NWIDE2=(NWIDE+1)/2
	NWIDE2S=NWIDE2*NWIDE2
	NINC=(NWIDE-1)/30+1
	I11=MAX(IS-NWIDE2,1)
	I22=MIN(IS+NWIDE2,NX)
	J11=MAX(JS-NWIDE2,1)
	J22=MIN(JS+NWIDE2,NY)
C
C Define normalizing factors such that the coords. of
C all the points are between (-1,-1) and (1,1).

	DX=2./(I22-I11)
	DY=2./(J22-J11)
	NPTS=0
	DO 20 J=J11,J22,NINC
	DO 20 I=I11,I22,NINC
C
C CALC RADIUS, AND REJECT IF TOO CLOSE TO STAR CENTRE
	  KRAD2=(J-JS)*(J-JS)+(I-IS)*(I-IS)
	  IF (KRAD2 .GT. IRAD2 .AND. KRAD2 .LE. NWIDE2S)THEN
	    NPTS=NPTS+1
	    XX(NPTS,1)=(I-I11)*DX-1.
	    XX(NPTS,2)=(J-J11)*DY-1.
	    YY(NPTS)=ARRAY(I,J)
          ENDIF
20 	CONTINUE

30	IF (NCODE .EQ. 3)THEN
	  NTERM=10
	ELSE IF (NCODE .EQ. 2)THEN
	  NTERM=6
	ELSE IF (NCODE .EQ. 1)THEN
	  NTERM=3
	ELSE
	  NTERM=1
	END IF
C
	IF (NPTS.LE.NTERM)THEN
	  WRITE(6,122) NPTS
122	  FORMAT('ERROR: Too few points to fit background, npts=',I5)
	  GO TO 200
	END IF
C
C ERASE ANY PREVIOUS SOLUTION
C
	DO I=1,30
	  D(I)=0.
	END DO

	DO 40 KQ=1,2
C FIT THE POLYNOMIAL
C
	  CALL NEQSOL(XX,YY,ZZ,NDIM,NPTS,NTERM,1,0,D,SE,RDOE,SDEV)
C
C DO A 2 SIGMA REJECTION
C
	  TEST=2.*SDEV
	  CALL REJECT(XX,YY,NDIM,D,NPTS,NTERM,TEST,NR,1)
 	  NPTS=NR
	  IF (NPTS .LE. NTERM)THEN
	    WRITE(6,123) NPTS
123	    FORMAT('ERROR: Too few points after rejection, npts=',I5)
	    GO TO 200
	  END IF
C
40	CONTINUE

C REFIT POLYNOMIAL : (Coeff in D)
C
	  CALL NEQSOL(XX,YY,ZZ,NDIM,NPTS,NTERM,1,0,D,SE,RDOE,SD)
C
C EVALUATE POLYNOMIAL AT EACH POINT WITHIN CIRCLE
C
C@	  PRINT *,' IX,IY,NS(DIAM),SDEV(FIT)',IS,JS,NS,SDEV
	DO 60 J=J1,J2
C
C FIND A RANDOM STARTING POINTS IN THE SEQUENCE OF NOISE POINTS
C
C	  XK=G05CAF(DUMMY)
	  CALL JLP_RANDOM(XK)
	  K=XK*199.
C
	  YZ=(J-J11)*DY-1.

	DO 50 I=I1,I2
	  IF ((J-JS)*(J-JS)+(I-IS)*(I-IS) .LE. IRAD2)THEN
	  XZ=(I-I11)*DX-1.
	  K=K+1
	  IF (K .GT. 200)K=1
C	  ZNOISE=ERR1(K)*SIGMA
C	  PRINT *,' ERR1(K),SIGMA',ERR1(K),SIGMA
C	  PRINT *,' POLY, ARRAY_old',POLY(XZ,YZ,D),ARRAY(I,J)
	  ARRAY(I,J)=POLY(XZ,YZ,D)+ERR1(K)*SIGMA
          ENDIF
50	CONTINUE

C PLOT NEW LINE ON ARGS
C LOGICAL TRIM,LLOG
c@	  CALL ARGSROW(ARRAY,NX,NY,I1,I2,J,
c@     1	TRIM,LLOG,VLO,VHI,IXOR,IYOR)

60	CONTINUE

200	CONTINUE

	CALL JLP_FREEVM(IPNT,ISIZE)

300	CONTINUE
	END
C-------------------------------------------------------------------
	SUBROUTINE STRCOPY(ARRAY,NY,NX,TEMP,ISIZE,I1,I2,J1,J2)
C
C STORE CURRENT STAR IMAGE IN TEMPORARY ARRAY
C
	REAL ARRAY(NX,NY),TEMP(ISIZE)
C
	N=0
	DO 11 J=J1,J2
	  DO 11 I=I1,I2
	   N=N+1
	   TEMP(N)=ARRAY(I,J)
11	CONTINUE
	RETURN
C
C
	ENTRY STRRSTR(ARRAY,NY,NX,ITEMP,ISIZE,I1,I2,J1,J2)
C RESTORE ARRAY TO PREVIOUS STATE
C
	N=0
	DO 21 J=J1,J2
	  DO 21 I=I1,I2
	    N=N+1
	    ARRAY(I,J)=TEMP(N)
21	CONTINUE
	END
C--------------------------------------------------------------
	include 'jlpsub:auto_sky.for'
	include 'jlpsub:patch_set.for'


MODULE TNO

   use NWTC_Library  ! ReKi, DBKi, R8Ki
   use NWTC_SLATEC   ! slatec_qk61 -- which is all that is in that library right now.

   implicit none
   PUBLIC :: SPL_integrate

   INTEGER,       PARAMETER :: TNOKi = ReKi

   REAL (TNOKi),  PARAMETER :: Cnuk = 5.5
   REAL (TNOKi),  PARAMETER :: kappa = 0.41
   REAL (TNOKi),  PARAMETER :: Cmu = 0.09
!   INTEGER(IntKi),PARAMETER :: limit = 5000

   !TNO variables
   REAL (TNOKi) :: Omega_TNO ! NOTE: not a constant and used by function f_int1 and f_int2

   !atmosphere variables
   REAL (TNOKi)  :: nu
   REAL (TNOKi)  :: co
   REAL (TNOKi)  :: rho

   ! Wavenumber variables
   REAL (TNOKi)  :: k
   REAL (TNOKi)  :: k1
   REAL (TNOKi)  :: k3

   ! Blade params
   REAL (TNOKi)  :: d99(2)
   REAL (TNOKi)  :: Cf(2)
   REAL (TNOKi)  :: edgevel(2)

   ! Airfoil
    REAL(TNOKi)  :: Mach_TNO
    LOGICAL      :: ISSUCTION_TNO

contains

!> Solve the spl generated at this location and frequency
function SPL_integrate(Omega,limits,ISSUCTION,   &
               Mach,SpdSound,AirDens,KinVisc,      &
               Cfall,d99all,EdgeVelAll) result(integrand)
   real(ReKi), intent(in   ) :: Omega              !< frequency
   real(ReKi), intent(in   ) :: limits(2)          !< integration limits
   logical,    intent(in   ) :: ISSUCTION          !< Is it the suction edge
   real(ReKi), intent(in   ) :: Mach               !< Mach number
   real(ReKi), intent(in   ) :: SpdSound           !< Speed of sound
   real(ReKi), intent(in   ) :: AirDens            !< Air density
   real(ReKi), intent(in   ) :: KinVisc            !< Kinetic air viscosity
   real(ReKi), intent(in   ) :: Cfall(2)           !< Skin friction coefficient   (-)
   real(ReKi), intent(in   ) :: d99all(2)          !<
   real(ReKi), intent(in   ) :: EdgeVelAll(2)      !<
   real(ReKi)                :: integrand          !< integrand result

   real(TNOKi)               :: answer             !< value returned from qk61, NOTE the typing

   ! local variables that are ignored
   real(TNOKi) :: abserr,resabs,resasc             !< accuracy estimates and residuals. Currently ignored

   ! Set module values from input
   ISSUCTION_TNO  = ISSUCTION
   Omega_TNO      = real(Omega,TNOKi)
   ! Mach number of segment
   Mach_TNO       = real(Mach,TNOKi)
   ! Atmospheric values
   co       = real(SpdSound,  TNOKi)
   rho      = real(AirDens,   TNOKi)
   nu       = real(KinVisc,   TNOKi)
   ! Blade node values
   Cf       = real(Cfall,     TNOKi)
   d99      = real(d99all,    TNOKi)
   edgevel  = real(ABS(EdgeVelAll),TNOKi)

   call slatec_qk61(f_int2,limits(1),limits(2),answer,abserr,resabs,resasc)
   integrand = real( answer, ReKi )

end function SPL_integrate

FUNCTION f_int1(x2)
   REAL(TNOKi):: alpha
   REAL(TNOKi):: alpha_gauss
   REAL(TNOKi):: Cfin
   REAL(TNOKi):: delta
   REAL(TNOKi):: dudx
   REAL(TNOKi):: ke
   REAL(TNOKi):: k1_hat
   REAL(TNOKi):: k3_hat
   REAL(TNOKi):: kT
   REAL(TNOKi):: L
   REAL(TNOKi):: Nut
   REAL(TNOKi):: phi22
   REAL(TNOKi):: phim
   REAL(TNOKi):: ums
   REAL(TNOKi):: u_star
   REAL(TNOKi):: U
   REAL(TNOKi):: Uc
   REAL(TNOKi):: Uo
   REAL(TNOKi):: W
   REAL(TNOKi), intent(in) :: x2
   REAL(TNOKi):: f_int1

   ! changed and being multiplied with edge velocity taken from xfoil output
   ! Uo=Mach_TNO*co ISSUCTION_TNO use edgevel(1)

   !constants from xfoil
   if (ISSUCTION_TNO) then
      alpha = 0.45 ! = 0.3 pressure, = 0.45 suction
      Cfin = Cf(1)
      delta = d99(1)
      Uo=Mach_TNO*co*edgevel(1)
   else
      alpha = 0.30
      Cfin = Cf(2)
      delta = d99(2)
      Uo=Mach_TNO*co*edgevel(2)
   endif
   if (Cfin .le. 0.) then
      write(*,*) 'Cf is less than zero, Cf = ',Cfin
      stop
   endif
   u_star = Uo*sqrt(Cfin/2.)

   L = 0.085*delta*tanh(kappa*x2/(0.085*delta))

   if (x2 .gt. delta)then
      U = Uo
      dudx = 0.
      f_int1 = 0.
      RETURN
   else
      W = 1.-cos(pi*x2/delta);
      U = u_star*(1./kappa*log(u_star*x2/nu) +Cnuk+ (Uo/u_star-1./kappa*log(u_star*delta/nu)-Cnuk)*0.5*W)
      dudx = u_star*(1./(kappa*x2)+(Uo/u_star-1./kappa*log(u_star*delta/nu)-Cnuk)* &
             0.5*(pi/delta)*sin(pi*x2/delta))
   endif

   ke=sqrt(pi)/L*0.4213560764 !gamma(5./6.)/gamma(1./3.)
   k1_hat = k1/ke
   k3_hat = k3/ke

   Nut = (L*kappa)**2.*abs(dudx)
   kT = sqrt((Nut*dudx)**2./Cmu)
   ums = alpha*kT

   Uc = 0.7*U
   alpha_gauss = 0.05*Uc/L

   phim = 1./(alpha_gauss*sqrt(pi))*exp(-((Omega_TNO-Uc*k1)/alpha_gauss)**2.)
   phi22 = 4./9./pi*1/ke**2.*(k1_hat**2.+k3_hat**2.)/(1.+k1_hat**2.+k3_hat**2.)**(7./3.)
   f_int1 = L*ums*(dudx)**2*phi22*phim*exp(-2*abs(k)*x2)

   RETURN
END FUNCTION f_int1

FUNCTION f_int2(k1)  ! changed name from 'int2' to avoid conflicts with intrinsic of same name
   REAL (TNOKi), intent(in)  :: k1
   REAL (TNOKi) :: f_int2
   f_int2 = Omega_TNO/co/k1*Pressure(k1)
   RETURN
END FUNCTION f_int2

FUNCTION Pressure(k1_in)
    ! Variables
   REAL(TNOKi)  :: a,b,answer
   REAL(TNOKi)  :: omega
   REAL(TNOKi)  :: abserr,resabs,resasc
   REAL(TNOKi)  :: k1_in
   real(TNOKi)  :: Pressure

   ! Set variables used in f_int1
   k1 = k1_in

    a = 0.0_TNOKi !1e-4*d99(1)
    IF (ISSUCTION_TNO)THEN
        b = d99(1)
    ELSE
        b = d99(2)
    ENDIF

    k3 = 0.
    k= sqrt(k1**2+k3**2)

    CALL slatec_qk61(f_int1,a,b,answer,abserr,resabs,resasc)

    Pressure = 4.*rho**2*k1**2./(k1**2.+k3**2.)*answer

   RETURN
END FUNCTION Pressure

END MODULE TNO


*----------------------------------------------------------------------*
      logical function next_part_number(init,restrict,ipart,
     &     inum,nsum,inummin,inummax)
*----------------------------------------------------------------------*
*     create next partitioning of an integer number inum into nsum
*     summands (inummin.le.value.le.inummax) -- returned on ipart(nsum)
*     the numbers are ordered in increasing sequence
*     if init==.true. the first possible partitioning is created
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00

      logical, intent(in) ::
     &     init, restrict
      integer, intent(in) ::
     &     inum, nsum, inummin, inummax
      integer, intent(inout) ::
     &     ipart(nsum)

      logical ::
     &     succ
      integer ::
     &     ipscr(nsum), idx, isum

      logical, external ::
     &     nxtptn_rc
      integer, external ::
     &     ifndmax

      if (ntest.ge.100) then
        write(lulog,*) '=========================='
        write(lulog,*) ' this is next_part_number'
        write(lulog,*) '=========================='
        write(lulog,*) '  inum,nsum,inummin,inummax: ',
     &                inum,nsum,inummin,inummax
        if (init) then
          write(lulog,*) 'initiating ...'
        else
          write(lulog,*) 'partitioning on entry: '
          write(lulog,'(2x,">",10i4)') ipart(1:nsum)
        end if
      end if

      if (nsum.lt.1) then
        call quit(1,'next_part_number','called with nsum < 1')
      end if

      ! special case: nsum = 1
      if (nsum.eq.1) then
        ipart(1) = inum
        next_part_number = init
        return
      end if

      ! start out: nsum-1 times the minimum, rest in last entry
      if (init) then
        ipscr(1:nsum-1)=inummin
        ipscr(nsum)=inum-(nsum-1)*inummin
        succ = .true.
      else
        ipscr(1:nsum)=ipart(1:nsum)
        succ = .false.
      end if

      if (ipscr(nsum).ge.inummin) then
        ip_loop: do
          ! check upper bounds:
          if (succ.and.ifndmax(ipscr,1,nsum,1).le.inummax) then
            ! return current partitioning ...
            ipart(1:nsum) = ipscr(1:nsum)
            exit ip_loop
          end if

          succ = nxtptn_rc(restrict,ipscr,inum,nsum,inummin)
          if (.not.succ) exit ip_loop

        end do ip_loop
      else
        ! no partitionings possible
        succ = .false.
      end if

      if (ntest.ge.100) then
        if (succ) then
          write(lulog,*) '  created partitioning: '
          write(lulog,'(2x,">",10i4)') ipart(1:nsum)
        else
          write(lulog,*) ' no (further) partitioning possible'
        end if
      end if

      next_part_number = succ

      return
      end

*----------------------------------------------------------------------*
      logical recursive function nxtptn_rc(restrict,
     &     ipart,inum,nsum,inummin) result(lres)
*----------------------------------------------------------------------*
*     recursive slave function for generating next partitioning of inum
*----------------------------------------------------------------------*

      implicit none

      logical, intent(in) ::
     &     restrict
      integer, intent(in) ::
     &     inum, nsum, inummin
      integer, intent(inout) ::
     &     ipart(nsum)

      logical ::
     &     succ
      integer ::
     &     isumm1

      if (nsum.eq.2) then

        ! n.eq.2 is easy:
        succ = ((.not.restrict.and.ipart(2)-1.ge.inummin).or.
     &       (ipart(1)+1).le.(ipart(2)-1))
        if (succ) then
          ipart(1) = (ipart(1)+1)
          ipart(2) = (ipart(2)-1)
        end if

      else if (nsum.gt.2) then

        ! sum of first n-1 elements:
        isumm1 = sum(ipart(1:nsum-1))
        ! get next partitioning for these elements
        succ = nxtptn_rc(restrict,ipart,isumm1,nsum-1,inummin)
        ! if unsuccessful ...
        if (.not.succ) then
          ! ... increase sum of first n-1 elements:
          ipart(1:nsum-2) = inummin
          ipart(nsum-1) = isumm1+1-(nsum-2)*inummin
          ! ... and decrease last element
          ipart(nsum) = ipart(nsum)-1
          succ = ipart(nsum).ge.inummin
          ! check, whether all ordering conditions can be satisfied:
          if (restrict) then
            do while (ipart(nsum-1).gt.ipart(nsum))
              ! another recursive call
              succ = nxtptn_rc(restrict,ipart,isumm1+1,nsum-1,inummin)
              if (.not.succ) exit
            end do
          end if
        end if

      else
        call quit(1,'next_part_number','illegal value of nsum')
      end if

      !nxtptn_rc = succ
      lres = succ

      return
      end


      program invrw

C     Check the computation of invariant r+w==0

      integer r, w

      r = 0
      w = 0

      do i = 1, l
         if(x.gt.0) then
            r = r + 1
            w = w - 1
         else
            r = r - 1
            w = w + 1
         endif
      enddo

      print *, i, l, r, w

      end


program static_arrays

    implicit none
    real(kind=4), dimension(10)       :: array
    real(kind=4), dimension(10)       :: array1D
    real(kind=4), dimension(10,12)    :: array2D
    real(kind=4), dimension(10,12,15) :: array3D
    integer                           :: i, j, k

    interface
        subroutine setArray1D(array1D)
            real(kind=4), dimension(:), intent(inout) :: array1D
            integer                                   :: i
        end subroutine setArray1D

        subroutine setArray2D(array2D)
            real(kind=4), dimension(:,:), intent(inout) :: array2D
            integer                                     :: i, j
        end subroutine setArray2D

        subroutine setArray3D(array3D)
            real(kind=4), dimension(:,:,:), intent(inout) :: array3D
            integer                                       :: i, j, k
        end subroutine setArray3D
    end interface

    array(1:5)  = 3.0
    array(6:10) = 6.0
    print *, "array = ["
    do i = 1, size(array(:))
        print *, array(i)
    end do
    print *, "]"

    call setArray1D(array1D)
    call setArray2D(array2D)
    call setArray3D(array3D)

    print *, "array1D = [ "
    do i = 1, size(array1D(:))
        print *, array1D(i)
    end do
    print *, " ]"

    print *, "Dimensions array2D = ", &
        size(array2D(:,1)), trim("x"), &
        size(array2D(1,:))

    print *, "array2D = [ "
    do i = j, size(array2D(1,:))
        print *, array2D(1:10,j)
    end do
    print *, " ]"

    print *, "Dimensions array3D = ", &
        size(array3D(:,1,1)), trim("x"), &
        size(array3D(1,:,1)), trim("x"), &
        size(array3D(1,1,:))

    do k = 1, size(array3D(1,1,:))
        print *, "array3D(",k,") = [ "
        do j = 1, size(array3D(1,:,k))
            print *, array3D(1:10,j,k)
        end do
        print *, " ]"
    end do

    ! Memory requirements
    print *, "Memory occupied array   = ", sizeof(array)  , " bytes"
    print *, "Memory occupied array1D = ", sizeof(array1D), " bytes"
    print *, "Memory occupied array2D = ", sizeof(array2D), " bytes"
    print *, "Memory occupied array3D = ", sizeof(array3D), " bytes"

end program static_arrays

subroutine setArray1D(array1D)
    implicit none
    real(kind=4), dimension(:), intent(inout) :: array1D
    integer                                   :: i

    do i = 1, size(array1D)
        array1D(i) = i
    end do

end subroutine setArray1D

subroutine setArray2D(array2D)
    implicit none
    real(kind=4), dimension(:,:), intent(inout) :: array2D
    integer                                     :: i, j

    do i = 1, size(array2D(:,1))
        do j = 1, size(array2D(1,:))
            array2D(i,j) = i
        end do
    end do

end subroutine setArray2D

subroutine setArray3D(array3D)
    implicit none
    real(kind=4), dimension(:,:,:), intent(inout) :: array3D
    integer                                       :: i, j, k

    do i = 1, size(array3D(:,1,1))
        do j = 1, size(array3D(1,:,1))
            do k = 1, size(array3D(1,1,:))
                array3D(i,j,k) = i
            end do
        end do
    end do

end subroutine setArray3D


program fortran_test
use dump_hdf5
implicit none

integer, parameter :: dp = kind(1.0d0)
real(dp) x, y, z
integer :: i, count
character(len=32) :: argbuf

count = command_argument_count()

!Reading the command line argument
do i = 1, count-1, 2

	call get_command_argument(i, argbuf)
	! print *, argbuf

	select case(argbuf)
		case('-x')
			call get_command_argument(i+1, argbuf)
			read(argbuf,'(F20.0)') x
			! write(*,*) 'x=',x

		case('-y')
			call get_command_argument(i+1, argbuf)
			read(argbuf,'(F20.0)') y
			! write(*,*) 'y=', y

	end select
end do

! Rosenbrock function
z = 100.0 * (y - x**2)**2 + (1.0 - x)**2

! dump variable. Description is optional.
call dump_hdf5_d("z", z, "The value of the Rosenbrock function")

end program fortran_test


!/*-----------------------------------------------------------------------------
! *  put_snapshot  --  writes a single snapshot on the output stream cout.
! *
! *  note: unlike get_snapshot(), put_snapshot handles particle number and time
! *-----------------------------------------------------------------------------
! */
!
subroutine put_snapshot(mass, pos, vel, n, t)
 	use numz
	use dim
	implicit none
    real(b8) mass(0:), pos(0:,0:)
    real(b8) vel(0:,0:)
    integer  n
    real(b8) t
    integer i,k

                               ! form1 = full double precision

    write(*,*)n                         ! N, total particle number
    write(*,form1) t                                  ! current time
    do i=0,n-1
      write(*,form1,advance="no")mass(i)              ! mass of particle i
      do k=0,ndim-1
            write(*,form1,advance="no") pos(i,k)      ! position of particle i
      enddo
      do k=0,ndim-1
            write(*,form1,advance="no") vel(i,k)      ! velocity of particle i
      enddo
     write(*,*)
    enddo

end subroutine put_snapshot

!/*-----------------------------------------------------------------------------
! *  write_diagnostics  --  writes diagnostics on the error stream cerr:
! *                         current time; number of integration steps so far;
! *                         kinetic, potential, and total energy; absolute and
! *                         relative energy errors since the start of the run.
! *                         If x_flag (x for eXtra data) is true, all internal
! *                         data are dumped for each particle (mass, position,
! *                         velocity, acceleration, and jerk).
! *
! *  note: the kinetic energy is calculated here, while the potential energy is
! *        calculated in the function get_acc_jerk_pot_coll().
! *-----------------------------------------------------------------------------
! */
!
    subroutine write_diagnostics(mass, pos, &
                       vel, acc, &
                       jerk, n, t, epot, &
                       nsteps, einit,init_flag, &
                       x_flag)
	use numz
	use dim
	implicit none
    real(b8) mass(0:), pos(0:,0:)
    real(b8) vel(0:,0:),  acc(0:,0:)
    real(b8) jerk(0:,0:)
    integer  n
    real(b8) t
    real(b8) epot
    integer nsteps
    real(b8) einit
    logical init_flag,x_flag
    real(b8) ekin                        ! kinetic energy of the n-body system
    real(b8) etot
    integer i,k
    ekin = 0.0_b8
                           ! form1 =full double precision

    do i=0,n-1
       do k=0,ndim-1
            ekin = ekin+ 0.5 * mass(i) * vel(i,k) * vel(i,k)
       enddo
    enddo
    etot = ekin + epot                  ! total energy of the n-body system

    if (init_flag) then                 ! at first pass, pass the initial
        einit = etot                    ! energy back to the calling function
    endif

    write(cerr,1)t,nsteps
 1  format("at time t = " ,f10.5, " , after " ,i6," steps:")
    write(cerr,2)ekin,epot,etot
 2  format("E_kin = " ,f10.5, " , E_pot = " ,f10.5," , E_tot = ",f10.5)
    write(cerr,3)etot - einit
 3  format(10x,"absolute energy error: E_tot - E_init = ",es13.5)
    write(cerr,4)(etot - einit) / einit
 4  format(10x,"relative energy error: (E_tot - E_init) / E_init = ",es13.5)

    if (x_flag)then
         write(cerr,*)"for debugging purposes, here is",&
                      " the internal data representation:\n"
        do i=0,n-1
            write(cerr,*)"   internal data for particle ", i+1 ," : "
            write(cerr,form1,advance="no")mass(i)
            do k=0,ndim-1
              write(*,form1,advance="no") pos(i,k)
            enddo
            do k=0,ndim-1
              write(*,form1,advance="no") vel(i,k)
            enddo
            do k=0,ndim-1
              write(*,form1,advance="no") acc(i,k)
            enddo
            do k=0,ndim-1
              write(*,form1,advance="no") jerk(i,k)
            enddo
            write(cerr,*)
        enddo
    endif
end subroutine write_diagnostics


module matrix_mult_mod
implicit none
contains
subroutine mmult_1(a,b,c) ! set ierr with if-elseif: 8 lines
real   , intent(in)  :: a(:,:) ! (m,n) = shape
real   , intent(in)  :: b(:,:) ! (n,p)
real   , intent(out) :: c(:,:) ! (m,p)
integer              :: ierr
ierr = 0
if (size(a,1) /= size(c,1)) then
   ierr = 1
else if (size(a,2) /= size(b,1)) then
   ierr = 2
else if (size(b,2) /= size(c,2)) then
   ierr = 3
end if
if (ierr /= 0) then
   print*,"in mmult_1, ierr =",ierr," returning"
   return
else
   print*,"in mmult_1, ierr = 0, continuing" ! would not appear in a real code
end if
c = matmul(a,b)
end subroutine mmult_1
!
subroutine mmult_2(a,b,c) ! set ierr with findloc: 1 line
! matrix multiplication
real   , intent(in)  :: a(:,:) ! (m,n) = shape
real   , intent(in)  :: b(:,:) ! (n,p)
real   , intent(out) :: c(:,:) ! (m,p)
integer              :: ierr
! set ierr to the position of the first false element if any, otherwise 0
ierr = findloc([size(a,1)==size(c,1),size(a,2)==size(b,1),size(b,2)==size(c,2)],.false.,dim=1)
if (ierr /= 0) then
   print*,"in mmult_2, ierr =",ierr," returning"
   return
else
   print*,"in mmult_2, ierr = 0, continuing" ! would not appear in a real code
end if
c = matmul(a,b)
end subroutine mmult_2
end module matrix_mult_mod
!
program main
use matrix_mult_mod, only: mmult_1, mmult_2
implicit none
integer, parameter :: m = 3, n = 5, p = 10
real :: a(m,n),b(n,p),c(m,p)
call mmult_1(a(2:,:),b,c)
call mmult_2(a(2:,:),b,c)
call mmult_1(a(:,2:),b,c)
call mmult_2(a(:,2:),b,c)
call mmult_1(a,b(:,2:),c)
call mmult_2(a,b(:,2:),c)
call mmult_1(a,b,c)
call mmult_2(a,b,c)
end program main


C     ******************************************************************
C     * ROUTINES TO CONVERT FROM MACH NUMBER TO OTHER NON-DIMENSIONAL  *
C     * COMPRESSIBLE FLOW QUANTITIES. USE F2PY TO COMPILE INTO A       *
C     * PYTHON MODULE.                                                 *
C     *                                                                *
C     * ALL ACCEPT THE SAME PARAMETERS,                                *
C     * Y, DOUBLE 1-D ARRAY : OUTPUT QUANTITY;                         *
C     * M, DOUBLE 1-D ARRAY : INPUT MACH NUMBER;                       *
C     * G, DOUBLE SCALAR : INPUT SPECIFIC HEAT RATIO;                  *
C     * N, INTEGER SCALAR : LENGTH OF ARRAYS (HIDDEN BY F2PY).         *
C     *                                                                *
C     * JAMES BRIND, DECEMBER 2020                                     *
C     ******************************************************************
C
      SUBROUTINE TO_T(Y,M,G,N)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1
      GM1 = G-1.0D0
C     MAIN LOOP
      DO I=1,N
            Y(I) = GM1*M(I)
      ENDDO
      END
C
      SUBROUTINE PO_P(Y,M,G,N)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 RECIP_GM1
      GM1_2 = (G-1.0D0)*0.5D0
      RECIP_GM1 = 1.0D0/(G-1.0D0)
C     MAIN LOOP
      DO I=1,N
            Y(I) = G * M(I) *(1.0D0 + GM1_2 *M(I)*M(I) )**RECIP_GM1
      ENDDO
      END
C
      SUBROUTINE RHOO_RHO(Y,M,G,N)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 M_GM1
      GM1_2 = (G-1.0D0)*0.5D0
      M_GM1 = -1.0D0/(G-1.0D0)
C     MAIN LOOP
      DO I=1,N
            Y(I) = M(I)*(1.0D0 + GM1_2*M(I)*M(I))**M_GM1
      ENDDO
      END
C
      SUBROUTINE V_CPTO(Y,M,G,N)
C     sqrt( (G-1)*M^2 / (1-(G-1)/2*M^2) )
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 GM1
      REAL*8 SQRT_GM1
      REAL*8 RECIP_SQRT_TO_T
      GM1_2 = (G-1.0D0)*0.5D0
      GM1 = G-1.0D0
      SQRT_GM1 = SQRT(GM1)
C     MAIN LOOP
      DO I=1,N
          RECIP_SQRT_TO_T = 1.0D0/SQRT(1.0D0+GM1_2*M(I)*M(I))
          Y(I)=SQRT_GM1*RECIP_SQRT_TO_T*RECIP_SQRT_TO_T*RECIP_SQRT_TO_T
      ENDDO
      END
C
      SUBROUTINE MCPTO_APO(Y,M,G,N)
C     G/SQRT(G-1)*M*(1+(G-1)/2*M^2)^(-(G+1)/(G-1)/2)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 M_GP1_GM1_2
      REAL*8 GM1_2
      REAL*8 GP1_2
      REAL*8 G_SQ_GM1
      REAL*8 TO_T
      REAL*8 F
      GM1_2 = (G-1.0D0)/2.0D0
      GP1_2 = (G+1.0D0)/2.0D0
      M_GP1_GM1_2 = (G+1.0D0)/(G-1.0D0)/(-2.0D0)
      G_SQ_GM1 = G / SQRT(G-1.0D0)
C     MAIN LOOP
      DO I=1,N
        TO_T = (1.0D0 + GM1_2 * M(I)*M(I))
        F = G_SQ_GM1 * TO_T**M_GP1_GM1_2
        Y(I) = F *(1.0D0 - GP1_2*M(I)*M(I)/TO_T)
      ENDDO
      END
C
      SUBROUTINE MCPTO_AP(Y,M,G,N)
C     G/SQRT(G-1)*M*SQRT(1+(G-1)/2*M^2)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 G_SQ_GM1
      REAL*8 SQRT_TO_T
      GM1_2 = (G-1.0D0)/2.0D0
      G_SQ_GM1 = G / SQRT(G-1.0D0)
C     MAIN LOOP
      DO I=1,N
        SQRT_TO_T = SQRT(1.0D0 + GM1_2 * M(I) * M(I) )
        Y(I) = G_SQ_GM1* ( SQRT_TO_T + GM1_2 *M(I)*M(I) / SQRT_TO_T)
      ENDDO
      END
C
      SUBROUTINE A_ACRIT(Y,M,G,N)
C     (2/(G+1)*(1+(G-1)/2*M^2))^((G+1)/(G-1)/2)/M
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GP1_GM1_2
      REAL*8 GM1_2
      REAL*8 GP1_2
      REAL*8 TO_T
      REAL*8 MSQ
      GM1_2 = (G-1.0D0)/2.0D0
      GP1_GM1_2 = (G+1.0D0)/(G-1.0D0)/2.0D0
      GP1_2 = (G+1.0D0)/2.0D0
C     MAIN LOOP
      DO I=1,N
        MSQ = M(I)*M(I)
        TO_T = 1.0D0 + GM1_2 * MSQ
        Y(I) = ((TO_T/GP1_2)**GP1_GM1_2)/MSQ*(-1.0D0/MSQ+GP1_2/TO_T)
      ENDDO
      END
C
      SUBROUTINE MASH(Y,M,G,N)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 GP1
      REAL*8 MSQ
      REAL*8 SQRT_TO_T
      REAL*8 C
      GM1_2 = (G-1.0D0)/2.0D0
      GP1 = G+1.0D0
C     MAIN LOOP
      DO I=1,N
        MSQ = M(I)*M(I)
        SQRT_TO_T = SQRT(1.0D0 + GM1_2*MSQ)
        C = G * (2.0D0*MSQ - 1.0D0) + 1.0D0
        Y(I)= -GP1**2.0D0 * M(I) / SQRT(2.0D0)/SQRT_TO_T  / C / SQRT(C)
      ENDDO
      END
C
      SUBROUTINE POSH_PO(Y,M,G,N)
C     ARGUMENTS
      INTEGER N
      REAL*8 G
      REAL*8 M(N)
      REAL*8 Y(N)
Cf2py intent(in) m
Cf2py intent(in) g
Cf2py intent(out) y
Cf2py intent(hide) n
C     INTERMEDIATE VARS
      REAL*8 GM1_2
      REAL*8 G_GM1
      REAL*8 M_GM1
      REAL*8 P_GM1
      REAL*8 GP1_2
      REAL*8 G_GP1
      REAL*8 GM1_GP1
      REAL*8 MSQ
      REAL*8 A
      REAL*8 B
      REAL*8 C
      REAL*8 TO_T
      GM1_2 = (G-1.0D0)/2.0D0
      G_GM1 = G/(G-1.0D0)
      G_GP1 = 2.0D0*G/(G+1.0D0)
      M_GM1 = (-1.0D0)/(G-1.0D0)
      p_gm1 = (1.0D0)/(G-1.0D0)
      GP1_2 = (G+1.0D0)/2.0D0
      GM1_GP1 = (G-1.0D0)/(G+1.0D0)
C     MAIN LOOP
      DO I=1,N
        MSQ = M(I)*M(I)
        TO_T = (1.0D0 + GM1_2*MSQ)
        A = GP1_2*MSQ/TO_T
        B = 1.0D0/(G/GP1_2*MSQ - GM1_GP1)
        C = -G*M(I)*(MSQ-1.0D0)*(MSQ-1.0D0)/TO_T/TO_T
        Y(I) = C *(A**P_GM1) *(B**G_GM1)
      ENDDO
      END


c     program DRSWCOM2
c>> 1996-05-28 DRSWCOM2 Krogh Removed implicit statement.
c>> 1996-05-28 DRSWCOM2 Krogh Added external statement.
c>> 1995-10-24 DRSWCOM2 Krogh Changed misleading message.
c>> 1994-11-02 DRSWCOM2 Krogh Changes to use M77CON
c>> 1992-05-15 DRSWCOM2 CLL Removed "stop '... finished'"
c>> 1992-03-24 CLL Add parameter MXCASE.
c>> 1992-03-12 CLL
c>> 1987-10-28 Original time stamp
c  Demo driver for the SWCOMP package.  This code was adapted from the
c  test driver to reduce the number of tests and the amount of output.
c  Here we have NCASES = 1 and NN(1) = 6, whereas the test driver had
c  NCASES = 7 and NN(1) = 0.
c     The package SWCOMP computes values and derivatives using the
c     approach described by Wengert.
c     C. L. Lawson, JPL, 1971.  Revised for Fortran77, Jan 1987.
c     CLL 8/18/87. Added SWASIN & SWACOS to package.
c     CLL 8/31/87. Added SWRCHN and changed order of args in SWCHN.
c     CLL 9/1/87.  Added SWSINH, SWCOSH, SWTANH.
c     1992-05-15 CLL Removed "stop '... finished'" to simplify
c     comparison of output from different systems.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c--S replaces "?": DR?WCOM2, ?WCOMP
c--&    ?COPY, ?MXDIF, ?PASCL, ?VECP, ?WACOS, ?WASIN
c--&    ?WATAN, ?WATN2, ?WCHN, ?WCOS, ?WCOSH, ?WDIF, ?WDIF1, ?WEXP
c--&    ?WLOG, ?WPRO, ?WPRO1, ?WPWRI, ?WQUO, ?WQUO1, ?WRCHN, ?WSET
c--&    ?WSIN, ?WSINH, ?WSQRT, ?WSUM, ?WSUM1, ?WTAN, ?WTANH
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer I, IA, ICASE, ICOUNT, II, J, MXCASE, N, NCASES, NMAX,
     1   NDIM, NP1, NW, NA, NX
      parameter(MXCASE = 7)
      parameter(NCASES = 1, NMAX = 6, NDIM = NMAX+1, NW = 20)
      parameter(NA = 4, NX = 10)
      external SMXDIF
      real             SMXDIF
      real             S(295),W(NDIM, NW), TEMP(NDIM), X(NDIM,NX)
      real             SAVE1(NDIM), SAVE2(NDIM), XEXP(NDIM), XLOG(NDIM)
      real             A(NA), FIX3(NA)
      real             ZERO, ONE, TWO, HALF, FOUR, PI, C9, C8, C7
      parameter(ZERO = 0.0e0, ONE = 1.0e0, TWO = 2.0e0, HALF = 0.50e0)
      parameter(FOUR = 4.0e0, C9 = 0.9e0, C8 = 0.8e0, C7 = 0.7e0)
      logical DETAIL, AS(NA), AC(NA)
      integer          NN(MXCASE), IPWR
      data NN/6,1,2,3,4,5,6/
      data A    / -2.0e0, -1.0e0, 0.75e0, 2.5e0/
      data FIX3 /  4*0.0e0 /
      data AS   /  .false., .true., .true., .false. /
      data AC   /  .false., .false., .true., .true. /
      data DETAIL / .false. /
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      print'(a)',
     *   ' DRSWCOM2..  Demo driver for the whole SWCOMP package.',
     *   ' Will print the numerical error in various calculations.'
      PI = ATAN(ONE) * FOUR
      FIX3(1) =  PI
      FIX3(4) = -PI
c
      if(DETAIL) then
      do 20 I=1,6
         do 10 J=1,40
            S(J)=ZERO
   10    continue
         call SPASCL(I-1,S)
         II=((I-1)*I)/2 + 1
         call SVECP  (S,II,  '0DPASCL')
   20    continue
      endif
c                                   Set X(*,1) and X(*,2)
      X(1,1) = C8
      X(1,2) = C7
      do 30 I = 2,NDIM
         X(I,1) = C8 * X(I-1,1)
         X(I,2) = -C7 * X(I-1,2)
   30 continue
c                              Loop through different values of N
      do 500 ICASE= 1, NCASES
         N=NN(ICASE)
         write(*,'(1x/1x,a,i3/1X)') '>>>>>> Tests with Nderiv = ', N
         NP1=N+1
c                                   Set W(*,1) and W(*,2)
            W(1,1) = C9
            W(1,2) = C9
            W(2,1) = C9*C9
            W(2,2) = -C9
            do 40 I = 3,NDIM
               W(I,1) = -C9*W(I-1,1)
               W(I,2) = ZERO
   40       continue
c                                                     Test SWSET
         call  SWSET  (N, C9, -C9, W(1,3))
         write(*,'(1x,a,g11.3)')
     *         'Error in SET                           =',
     *      SMXDIF(NP1,W(1,2),1, W(1,3),1)
c
c                             Test SWSUM, SWSUM1, SWDIF, SWDIF1, SWPRO1
c
      call SWSUM1(N, FOUR, X(1,1), X(1,3))
      call SWSUM (N, X(1,3), X(1,2), X(1,3))
      call SWDIF (N, X(1,3), X(1,1), X(1,3))
      call SWDIF1(N, FOUR, X(1,3), X(1,3))
      call SWPRO1(N, -ONE, X(1,3), X(1,3))
            write(*,'(1x,a,g11.3)')
     *         'Error in -(4-(((4+x)+y))-x) - y        =',
     *         SMXDIF(NP1,X(1,3),1, X(1,2),1)
c
c                                   Test SWQUO1, SWPRO1, and SWPWRI
c
      call SWQUO1(N,TWO, X(1,1), X(1,3))
      call SWPWRI(N,-1, X(1,3), X(1,4))
      call SWPRO1(N,TWO, X(1,4), X(1,5))
            write(*,'(1x,a,g11.3)')
     *         'Error in 2*((2/x)**-1) - x             =',
     *         SMXDIF(NP1,X(1,5),1, X(1,1),1)
c                                                 Test SWPRO and SWQUO
      call SWPRO(N, X(1,1), X(1,2), X(1,3))
      call SWQUO(N, X(1,3), X(1,2), X(1,4))
            write(*,'(1x,a,g11.3)')
     *         'Error in (X1*X2)/X2 - X1               =',
     *         SMXDIF(NP1,X(1,4),1, X(1,1),1)
      if(DETAIL) then
         print*,'X1, X2, X3 = X1 * X2, X4 = X3/X2'
         do 50 J = 1,4
            write(*,'(1x,I3,4g15.7/(4x,4g15.7))') J,(X(I,J),I=1,NP1)
   50    continue
      endif
      call SWQUO(N, X(1,3), X(1,2), X(1,3))
            write(*,'(1x,a,g11.3)')
     *         'Error in (X1*X2)/X2 - X1               =',
     *         SMXDIF(NP1,X(1,3),1, X(1,1),1)
      if(DETAIL) then
         print*,' '
         print*,'X3 = X3/X2'
         write(*,'(1x,I3,4g15.7)') 3,(X(I,3),I=1,NDIM)
      endif
c
c                             Test SWLOG and SWEXP, uses SWCHN
c
          call  SWLOG  (N,W(1,1),W(1,2))
          call  SWEXP (N,W(1,2),W(1,3))
         write(*,'(1x,a,g11.3)')
     *      'Error in Exp(Log(2)) - 2               =',
     *      SMXDIF(NP1,W(1,3),1, W(1,1),1)
         if(DETAIL) then
          call  SVECP(W(1,1),NP1,   '0W1 = T = 2.')
          call  SVECP (W(1,2),NP1,   '0W2 = LOG(W1)')
          call  SVECP (W(1,3),NP1,   '0W3 = EXP(W2). SHOULD MATCH W1.')
          call  SVECP (W(1,4),NP1,   '0W4 = 0.+W1. SCALAR ADD.')
         endif
c
c                                               Test SWCHN and SWRCHN
      call SWSET(N, HALF, ONE, X(1,8))
      call SWEXP(N, X(1,8), XEXP)
      call SWSET(N, HALF, ONE, X(1,3))
      call SWRCHN(N, XEXP, X(1,3))
      if(DETAIL) then
      print*,' '
      print*,'X1, X2 = EXP(X1), X3 = Reversion to Log'
      do 60 J = 1,3
         write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
   60 continue
      endif
c
      call SWSET(N, XEXP(1), ONE, X(1,4))
      call SWLOG(N, X(1,4), XLOG)
      call SWSET(N, X(1,4), ONE, X(1,6))
      call SWRCHN(N, XLOG, X(1,6))
      if(DETAIL) then
         print*,' '
         print*,'X4, X5 = LOG(X4), X6 = Reversion to Exp'
         do 70 J = 4,6
            write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
   70    continue
      endif
            write(*,'(1x,a,g11.3)')
     *         'Error in Log(x) - Rev. of Exp(x)       =',
     *         SMXDIF(NP1,XLOG,1, X(1,3),1)
            write(*,'(1x,a,g11.3)')
     *         'Error in Exp(x) - Rev. of Log(x)       =',
     *         SMXDIF(NP1,XEXP,1, X(1,6),1)
c
      call SCOPY(NP1, X(1,1),1, X(1,7),1)
      call SCOPY(NP1, X(1,7),1, SAVE1,1)
      call SWCHN (N, XEXP, X(1,7))
      call SCOPY(NP1, X(1,7),1, SAVE2,1)
      call SWRCHN(N, XEXP, X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in X7;CHN(XEXP,X7);RCHN(XEXP,X7) =',
     *         SMXDIF(NP1,SAVE1,1, X(1,7),1)
      if(DETAIL) then
         print*,' '
         print*,'X7 ='
         J = 7
         write(*,'(1x,I3,4g15.7)') J,(SAVE1(I),I=1,NDIM)
         print*,'call SWCHN ( N, X2, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(SAVE2(I),I=1,NDIM)
         print*,'call SWRCHN ( N, X2, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
      endif
c
c
      call SCOPY(NP1, X(1,1),1, X(1,7),1)
      call SCOPY(NP1, X(1,7),1, SAVE1,1)
      call SWCHN (N, XEXP, X(1,7))
      call SCOPY(NP1, X(1,7),1, SAVE2,1)
      call SWCHN(N, XLOG, X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in X7;CHN(XEXP,X7);CHN(XLOG,X7)  =',
     *         SMXDIF(NP1,SAVE1,1, X(1,7),1)
      if(DETAIL) then
         print*,' '
         print*,'X7 ='
         J = 7
         write(*,'(1x,I3,4g15.7)') J,(SAVE1(I),I=1,NDIM)
         print*,'call SWCHN ( N, X2, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(SAVE2(I),I=1,NDIM)
         print*,'call SWCHN ( N, X5, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
      endif
c
      call SCOPY(NP1, X(1,1),1, X(1,7),1)
      call SCOPY(NP1, X(1,7),1, SAVE1,1)
      call SWRCHN (N, XEXP, X(1,7))
      call SCOPY(NP1, X(1,7),1, SAVE2,1)
      call SWRCHN(N, XLOG, X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in X7;RCHN(XEXP,X7);RCHN(XLOG,X7)=',
     *         SMXDIF(NP1,SAVE1,1, X(1,7),1)
      if(DETAIL) then
         print*,' '
         print*,'X7 ='
         J = 7
         write(*,'(1x,I3,4g15.7)') J,(SAVE1(I),I=1,NDIM)
         print*,'call SWRCHN ( N, X2, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(SAVE2(I),I=1,NDIM)
         print*,'call SWRCHN ( N, X5, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
      endif
c                                         Test SWPRO and SWSQRT
c
         call  SCOPY (NP1, W(1,1),1, W(1,4),1)
         do 80 I=1,3
            call SWPRO (N,W(1,4),W(1,4),W(1,4))
            if(I .eq. 2) call SCOPY(NP1, W(1,4),1, TEMP,1)
            if(DETAIL) call SVECP  (W(1,4),NP1,   '0W4 = W4*W4')
   80    continue
c
          call SWSQRT (N, W(1,4), W(1,5) )
         write(*,'(1x,a,g11.3)')
     *         'Error in Sqrt(x*x) - x                 =',
     *      SMXDIF(NP1,TEMP,1, W(1,5),1)
         if(DETAIL) call SVECP  (W(1,5), NP1,     '0W5=SQRT(W4)')
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                           Test of SWPWRI( ,0, , )
c
         call SWPWRI(N, 0, X(1,1), X(1,3))
         call SWSET (N, ONE, ZERO, X(1,4))
         write(*,'(1x,a,g11.3)')
     *         'Error in x**0 - 1                      =',
     *      SMXDIF(NP1,X(1,3),1, X(1,4),1)
c
c                                     Loop through tests of SWPWRI
         do 100 IPWR = 1,3
            write(*,'(1x/1x,a,i3)') 'Test SWPWRI using I = ',IPWR
            call SWPWRI(N, IPWR, X(1,1), X(1,3))
            call SCOPY(NP1, X(1,1),1, X(1,4),1)
            do 90 ICOUNT = 2,IPWR
               call SWPRO(N, X(1,1), X(1,4), X(1,4))
   90       continue
            write(*,'(1x,a,g11.3)')
     *         'Error in x**I - x * x * ... * x        =',
     *      SMXDIF(NP1,X(1,3),1, X(1,4),1)
            call SWPWRI(N, -IPWR, X(1,1), X(1,5))
            call SWPRO(N, X(1,5), X(1,4), X(1,6))
            call SWSET (N, ONE, ZERO, X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in x**(-I) * x**I - 1            =',
     *      SMXDIF(NP1,X(1,6),1, X(1,7),1)
  100    continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                        Loop through quadrants to test trig functions.
c
         do 110 IA=1,NA
            write(*,'(1x/1x,a,f11.4)') 'Using angle argument,',A(IA)
            call SCOPY (NP1, W(1,1),1, W(1,5),1)
            W(1,5) = A(IA)
c                                              Test SWSIN and SWASIN
            call SWSIN  (N,W(1,5),W(1,6))
            if(AS(IA)) then
            call SWASIN  (N,W(1,6),W(1,13))
            write(*,'(1x,a,g11.3)')
     *         'Error in Asin(Sin(x)) - x              =',
     *         SMXDIF(NP1,W(1,5),1, W(1,13),1)
            endif
c                                              Test SWCOS and SWACOS
            call SWCOS  (N,W(1,5),W(1,7))
            if(AC(IA)) then
            call SWACOS  (N,W(1,7),W(1,14))
            write(*,'(1x,a,g11.3)')
     *         'Error in Acos(Cos(x)) - x              =',
     *         SMXDIF(NP1,W(1,5),1, W(1,14),1)
            endif
c                                               Test SWTAN
            call SWTAN(N, W(1,5), W(1,8))
            call SWQUO (N,W(1,6),W(1,7),W(1,9))
            write(*,'(1x,a,g11.3)')
     *         'Error in Tan(x) - Sin(x)/Cos(x)        =',
     *         SMXDIF(NP1,W(1,8),1, W(1,9),1)
c                                                Test SWATN2, SWATAN
            call SWATN2(N,W(1,6),W(1,7),W(1,9))
            call SWATAN (N,W(1,8),W(1,10))
            call SCOPY(NP1,W(1,9),1, TEMP,1)
            TEMP(1) = TEMP(1) + FIX3(IA)
            write(*,'(1x,a,g11.3)')
     *         'Error in FIX + Atan2(y,x) - Atan(y/x)  =',
     *         SMXDIF(NP1,TEMP,1, W(1,10),1)
            call SWSET(N,ONE,ZERO,W(1,11) )
            call SWATN2(N,W(1,8), W(1,11), W(1,12))
            write(*,'(1x,a,g11.3)')
     *         'Error in Atan2(y/x, 1) - Atan(y/x)     =',
     *         SMXDIF(NP1,W(1,12),1, W(1,10),1)

         if(DETAIL) then
            call SVECP  (W(1,5),NP1,   '0W5 = ANGLE(IA)')
            call SVECP  (W(1,6),NP1,   '0W6 = SIN(W5)')
            call SVECP  (W(1,13),NP1,
     *                     '0W13 = ASIN(W6).  Compare with W5.')
            call SVECP  (W(1,7),NP1,   '0W7 = COS(W5)')
            call SVECP  (W(1,14),NP1,
     *                  '0W13 = Acos(W7).  Compare with W5.')
            call SVECP  (W(1,8),NP1,   '0W8 = W6/W7')
            call SVECP  (W(1,9),NP1,
     *              '0W9 = ATAN2(W6,W7).   SHOULD MATCH W5')
            call SVECP  (W(1,10),NP1,
     *  '0W10 = ATAN(W8).     SHOULD MATCH W5 OR DIFFER BY 3.14159265')
            call SVECP(W(1,12),NP1,   '0W12=ATAN2(W8,1.)' )
         endif
  110    continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c                                    Test SWSINH, SWCOSH,  TANH
c     First check identity: cosh**2 = sinh**2 + 1
c
      call SWSINH(N, X(1,1), X(1,3))
      call SWPRO(N, X(1,3), X(1,3), X(1,6))
      call SWSUM1(N, ONE, X(1,6), X(1,8))
      call SWCOSH(N, X(1,1), X(1,4))
      call SWPRO(N, X(1,4), X(1,4), X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in cosh**2 - sinh**2 - 1         =',
     *         SMXDIF(NP1,X(1,7),1, X(1,8),1)
c
c                                 Check identity: Tanh = Sinh/Cosh
c
      call SWQUO(N, X(1,3), X(1,4), X(1,9))
      call SWTANH(N, X(1,1), X(1,5))
            write(*,'(1x,a,g11.3)')
     *         'Error in tanh - sinh/cosh              =',
     *         SMXDIF(NP1,X(1,5),1, X(1,9),1)
  500 continue
      end
c     ==================================================================
      real             function SMXDIF(N,X,INCX, Y,INCY)
c
c     Compute max norm of difference between the N-vectors x and y.
c     The vectors are stored with a storage increment of INCX and INCY
c     between successive components.
c     C. L. Lawson, JPL, Sept 1987.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer I, INCX, INCY, IX, IY, N
      real             X(*), Y(*), ZERO, TEMP
      parameter(ZERO = 0.0e0)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      TEMP = ZERO
      IX = 1 - INCX
      IY = 1 - INCY
      do 10 I = 1,N
         IX = IX + INCX
         IY = IY + INCY
         TEMP = max(TEMP, abs(X(IX) - Y(IY)))
   10 continue
      SMXDIF = TEMP
      return
      end


! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
! HOHQMesh contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
!    https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
! * `fmin`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `spline`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `seval`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
!
! --- End License
!
!////////////////////////////////////////////////////////////////////////
!
!      TransfiniteMapClass.f
!      Created: 2007-06-21 11:19:33 -0400
!      By: David Kopriva
!
!      Unlike the text, this is wrapped in a class form.
!
!      Contains:
!                       TYPE(TransfiniteQuadMap) FUNCTION NewTransfiniteQuadMap( boundaryCurves, ownership )
!         ALGORITHM 98: SUBROUTINE EvaluateTransfiniteMapAt( this, xi, eta, res )
!
!      This version is modified so that the curves are in (x,y,z). 6/5/15, 3:44 PM
!      It also remove the derivative routines, since they are not needed in this project.
!
!////////////////////////////////////////////////////////////////////////
!
      MODULE TransfiniteMapClass
      USE CurveInterpolantClass
      IMPLICIT NONE
!
!-------------------------------------------------------------------
! Defines data and methods for a transfinite interpolant
!-------------------------------------------------------------------
!
      TYPE TransfiniteQuadMap
         TYPE(CurveInterpolant), DIMENSION(:), POINTER :: boundaryCurves
         INTEGER                                       :: ownership
      END TYPE TransfiniteQuadMap

      INTERFACE Destruct
         MODULE PROCEDURE DestructTransfiniteQuadMap
      END INTERFACE Destruct

      INTEGER, PARAMETER :: MAP_OWNS_CURVES = 0, MAP_DOESNT_OWN_CURVES = 1
!
!     ========
      CONTAINS
!     ========
!
!////////////////////////////////////////////////////////////////////////
!
      TYPE(TransfiniteQuadMap) FUNCTION NewTransfiniteQuadMap( boundaryCurves, ownership )
!
!-------------------------------------------------------------------
! Constructor for the transfinite map. Reads in and saves the four
! boundary curves.
!-------------------------------------------------------------------
!
         TYPE(CurveInterpolant), DIMENSION(:), POINTER :: boundaryCurves
         INTEGER, OPTIONAL                             :: ownership

         NewTransfiniteQuadMap%boundaryCurves => boundaryCurves

         IF( PRESENT(ownership) ) THEN
            NewTransfiniteQuadMap%ownership = ownership
         ELSE
            NewTransfiniteQuadMap%ownership = MAP_DOESNT_OWN_CURVES
         END IF
      END FUNCTION NewTransfiniteQuadMap
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE DestructTransfiniteQuadMap(this)
         TYPE(TransfiniteQuadMap) :: this
         INTEGER                  :: k

         IF( this%ownership == MAP_OWNS_CURVES ) THEN
            DO k = 1, 4
               CALL Destruct( this%boundaryCurves(k) )
            END DO
            DEALLOCATE( this%boundaryCurves )
         END IF

         NULLIFY(this%boundaryCurves)
      END SUBROUTINE DestructTransfiniteQuadMap
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE EvaluateTransfiniteMapAt( this, xi, eta, res )
!
         TYPE(TransfiniteQuadMap)   :: this
         REAL(KIND=RP), INTENT(IN)  :: xi, eta
         REAL(KIND=RP), INTENT(OUT) :: res(3)

         REAL(KIND=RP) :: x(3,4), cX(3,4)
         INTEGER       :: k
!
!        -------------------------------
!        Evaluate positions along curves
!        -------------------------------
!
         CALL EvaluateAt( this%boundaryCurves(1), atLocation = -1.0_RP, givingResult = x(:,1) )
         CALL EvaluateAt( this%boundaryCurves(1), atLocation =  1.0_RP, givingResult = x(:,2) )
         CALL EvaluateAt( this%boundaryCurves(3), atLocation =  1.0_RP, givingResult = x(:,3) )
         CALL EvaluateAt( this%boundaryCurves(3), atLocation = -1.0_RP, givingResult = x(:,4) )

         CALL EvaluateAt( this%boundaryCurves(1), atLocation = xi , givingResult = cX(:,1) )
         CALL EvaluateAt( this%boundaryCurves(2), atLocation = eta, givingResult = cX(:,2) )
         CALL EvaluateAt( this%boundaryCurves(3), atLocation = xi , givingResult = cX(:,3) )
         CALL EvaluateAt( this%boundaryCurves(4), atLocation = eta, givingResult = cX(:,4) )
!
!        ----------------------------
!        Evaluate on reference square
!        ----------------------------
!
         DO k = 1, 3
            res(k) = 0.5_RP*( (1.0_RP-xi)*cX(k,4) + (1+xi)*cX(k,2) + (1.0_RP-eta)*cX(k,1) + (1+eta)*cX(k,3) ) &
                   - 0.25_RP*( (1.0_RP-xi)*( (1.0_RP-eta)*x(k,1) + (1+eta)*x(k,4) ) &
                   + (1+xi)*( (1.0_RP-eta)*x(k,2) + (1+eta)*x(k,3) ))
         END DO

      END SUBROUTINE EvaluateTransfiniteMapAt

      END MODULE TransfiniteMapClass


      subroutine compute_phi2(n_iPHI,n_rPHI,Nx,res)
      implicit none
      integer i
      integer Nx
      real*8 n_iPHI(Nx)
      real*8 n_rPHI(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = n_rPHI(i) ** 2 + n_iPHI(i) ** 2
      res(i)=qb
      end do
      END


subroutine driver(im,jm,km,dt,Rd,Rv,Cpd,Cpv,g,p_,z0_,u_,t_,q_,udot_,tdot_,qdot_,z0dot_,w_)

implicit none

! In
integer, intent(in) :: im,jm,km
!f2py intent(in,hide) im,jm,km
real(8), intent(in) :: dt,Rd,Rv,Cpd,Cpv,g
real(8), intent(in), dimension(km,jm,im) :: p_,u_,t_,q_
real(8), intent(in), dimension(jm,im) :: z0_

! Out
real(8), intent(out), dimension(km,jm,im) :: udot_,tdot_,qdot_,w_
real(8), intent(out), dimension(jm,im) :: z0dot_

! Local
real(8), dimension(jm) :: z0,z0dot
real(8), dimension(jm,km) :: u,t,q,p
real(8), dimension(jm,km) :: udot,tdot,qdot
real(8), dimension(jm,km+1) :: w

p = transpose(p_(:,:,1)) * 100. ! mb -> Pa
u = transpose(u_(:,:,1))
t = transpose(t_(:,:,1))
q = transpose(q_(:,:,1)) * 1.e-3 ! g/kg -> kg/kg
z0 = z0_(:,1)

call tend(jm,km,Rd,Rv,Cpd,Cpv,g,p,u,t,q,z0,udot,tdot,qdot,z0dot,w)

udot_(:,:,1) = transpose(udot)*2.*dt
tdot_(:,:,1) = transpose(tdot)*2.*dt
qdot_(:,:,1) = transpose(qdot)*2.*dt *1.e3
z0dot_(:,1) = z0dot *2.*dt
w_(:,:,1) = transpose(w(:,1:km)+w(:,2:km+1))/2.

end subroutine driver


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief calculate buoyancy for head equation
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] ismpl local sample index
!>    @return buoyancy
!>    @details
!>calculate buoyancy for head equation\n
!>sign convention: negative for positive buoyancy\n
      DOUBLE PRECISION FUNCTION buoy(i,j,k,ismpl)
        use arrays
        use mod_genrl
        use mod_flow
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, j, k

        DOUBLE PRECISION rhor, rhav, hh, h0, h1, prod, summ
        DOUBLE PRECISION rhof, kz, visf
        EXTERNAL rhof, kz, visf

        rhav = 0.5D0*(rhof(i,j,k+1,ismpl)+rhof(i,j,k,ismpl))
        rhor = (rhav-rref)/rref

        hh = 0.D0
        h0 = kz(i,j,k,ismpl)*rhof(i,j,k,ismpl)*grav/visf(i,j,k,ismpl)
        h1 = kz(i,j,k+1,ismpl)*rhof(i,j,k+1,ismpl)*grav/ &
          visf(i,j,k+1,ismpl)
        summ = h0 + h1
        prod = h0*h1
        IF (summ>0.D0) hh = 2.0D0*prod/summ

        buoy = hh*rhor

        RETURN
      END


program main

  use mo_kind, only: i4, i8, dp
  use mo_dds,  only: dds, mdds
  use mo_opt_functions, only: griewank
  use mo_ansi_colors, only: color, c_red, c_green

  implicit none

  integer(i4), parameter :: np = 10

  ! Input to DDS
  real(dp),    dimension(np)   :: dv_ini   ! inital value of decision variables
  real(dp),    dimension(np,2) :: dv_range ! Min/max values of decision variables

  ! Optional Input to DDS
  real(dp)                     :: r_val    ! DDS perturbation parameter (-> 0.2 by default)
  integer(i8) :: seed                      ! User seed to initialise the random number generator
  integer(i8) :: nIterMax                  ! Maximum number of iteration or function evaluation
  logical     :: to_max                    ! Maximization or minimization of function

  ! Output of DDS
  real(dp), dimension(np) :: dv_opt        ! Best value of decision variables

  ! Test
  logical :: isgood

  write(*,*) '--------------------------------------------------'
  write(*,*) '  Dynamically Dimensioned Search (DDS) Algorithm  '
  write(*,*) '         version 1.1 - by Bryan Tolson            '
  write(*,*) '--------------------------------------------------'

  dv_ini        = (/ -.226265E+01, -.130187E+01, -.151219E+01, 0.133983E+00, 0.988159E+00, &
                     -.495074E+01, -.126574E+02, 0.572684E+00, 0.303864E+01, 0.343031E+01 /)
  dv_range(:,1) = (/ -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0 /)
  dv_range(:,2) = (/ 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0 /)
  r_val    = 0.20_dp
  nIterMax = 100000_i8
  to_max   = .False.
  seed     = 123456789_i8
  dv_opt   = DDS(griewank, dv_ini, dv_range, r=r_val, seed=seed, maxiter=nIterMax, maxit=to_max)

  write(*,*) ''
  write(*,*) 'DDS'
  write(*,'(A,10F9.4)') 'Should be    3.0825   0.0629   0.0362  -0.0063   0.0026  -7.6358   0.0718  -0.0528  -0.1008   0.0037'
  write(*,'(A,10F9.4)') 'Output is ', dv_opt

  isgood = .true.
  isgood = isgood .and. (nint(10000._dp*dv_opt(1))  ==  30825)
  isgood = isgood .and. (nint(10000._dp*dv_opt(2))  ==    629)
  isgood = isgood .and. (nint(10000._dp*dv_opt(3))  ==    362)
  isgood = isgood .and. (nint(10000._dp*dv_opt(4))  ==    -63)
  isgood = isgood .and. (nint(10000._dp*dv_opt(5))  ==     26)
  isgood = isgood .and. (nint(10000._dp*dv_opt(6))  == -76358)
  isgood = isgood .and. (nint(10000._dp*dv_opt(7))  ==    718)
  isgood = isgood .and. (nint(10000._dp*dv_opt(8))  ==   -528)
  isgood = isgood .and. (nint(10000._dp*dv_opt(9))  ==  -1008)
  isgood = isgood .and. (nint(10000._dp*dv_opt(10)) ==     37)

  dv_ini        = (/ -.226265E+01, -.130187E+01, -.151219E+01, 0.133983E+00, 0.988159E+00, &
                     -.495074E+01, -.126574E+02, 0.572684E+00, 0.303864E+01, 0.343031E+01 /)
  dv_range(:,1) = (/ -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0, -600.0 /)
  dv_range(:,2) = (/ 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0, 600.0 /)
  r_val    = 0.20_dp
  nIterMax = 100000_i8
  to_max   = .False.
  seed     = 123456789_i8
  dv_opt   = MDDS(griewank, dv_ini, dv_range, seed=seed, maxiter=nIterMax, maxit=to_max)

  write(*,*) ''
  write(*,*) 'MDDS'
  write(*,'(A,10F9.4)') 'Should be    3.1209   0.0577  -0.0168  -6.3592  -0.0393   0.0191  -8.2359   0.0158  -9.4605  -0.0736'
  write(*,'(A,10F9.4)') 'Output is ', dv_opt

  isgood = isgood .and. (nint(10000._dp*dv_opt(1))  ==  31209)
  isgood = isgood .and. (nint(10000._dp*dv_opt(2))  ==    577)
  isgood = isgood .and. (nint(10000._dp*dv_opt(3))  ==   -168)
  isgood = isgood .and. (nint(10000._dp*dv_opt(4))  == -63592)
  isgood = isgood .and. (nint(10000._dp*dv_opt(5))  ==   -393)
  isgood = isgood .and. (nint(10000._dp*dv_opt(6))  ==    191)
  isgood = isgood .and. (nint(10000._dp*dv_opt(7))  == -82359)
  isgood = isgood .and. (nint(10000._dp*dv_opt(8))  ==    158)
  isgood = isgood .and. (nint(10000._dp*dv_opt(9))  == -94605)
  isgood = isgood .and. (nint(10000._dp*dv_opt(10)) ==   -736)

  write(*,*) ''
  if (isgood) then
     write(*,*) 'mo_dds double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_dds double precision ', color('failed!', c_red)
  endif

end program main