!------------------------------------------------------------------------------
!
! ODX
!
! The program ODX calculates the optimal DELTA_X for the simulation according
! to the physiographic characteristics obtained from the application of the
! hydraulic geometry theory.
!
!------------------------------------------------------------------------------

program odx

use mpar
use mbbio

implicit none

integer(kind=ISP) :: i,j,i_basin,nsc,ncc

real(kind=REP) :: A_cell,A_1,A_2,Q_1,Q_2
real(kind=REP) :: G,beta_1,beta_2,u,w,alpha
real(kind=REP) :: ck_1,ck_2,dh_1,dh_2
real(kind=REP) :: wsum_Q,wsum_ck,wsum_dh
real(kind=REP) :: sumlog_ck,sumlog_dh
real(kind=REP) :: avg_ck,avg_dh,optimal_dx
real(kind=REP) :: avglog_ck,avglog_dh,optimallog_dx
real(kind=REP) :: adopted_dx,r1,r2
real(kind=REP) :: min_A,min_kS,min_Ws,min_S0,min_Q,min_ck,min_Dh
real(kind=REP) :: max_A,max_kS,max_Ws,max_S0,max_Q,max_ck,max_Dh
real(kind=REP) :: sum_A,sum_kS,sum_Ws,sum_S0,sum_Q,sum_ck,sum_Dh

real(kind=RSP) :: sumnrc

call rparfile('hap.in')
call load_dtm("basin_b","basin_i")

A_cell=delta_x*delta_y

write(6,*)
write(6,'(1x,a)') 'Select the Qf = u A**w relationship parameters: '
write(6,*)
write(6,'(1x,a,$)') 'coefficient u -> '
read(5,*) u
write(6,'(1x,a,$)') 'exponent w -> '
read(5,*) w

write(6,*)
write(6,'(1x,a)') 'Select the exponent alpha of the Q**alpha weights: '
write(6,*)
write(6,'(1x,a,$)') 'alpha (0 to weight slope flows, 1 to weight channel flows) -> '
read(5,*) alpha

nsc=0
ncc=0
sumnrc=0.0E+00
min_A=1.0D+10
min_kS=1.0D+10
min_Ws=1.0D+10
min_S0=1.0D+10
min_Q=1.0D+10
min_ck=1.0D+10
min_Dh=1.0D+10
max_A=-1.0D+10
max_kS=-1.0D+10
max_Ws=-1.0D+10
max_S0=-1.0D+10
max_Q=-1.0D+10
max_ck=-1.0D+10
max_Dh=-1.0D+10
sum_A=0.0D+00
sum_kS=0.0D+00
sum_Ws=0.0D+00
sum_S0=0.0D+00
sum_Q=0.0D+00
sum_ck=0.0D+00
sum_Dh=0.0D+00
wsum_Q=0.0D+00
wsum_ck=0.0D+00
wsum_dh=0.0D+00
sumlog_ck=0.0D+00
sumlog_dh=0.0D+00

do i=1,N
   do j=1,M
      i_basin=(i-1)*M+j
      if (dtm_index_pr(i_basin) == 0) cycle
      if (dtm_hcID(i_basin).eq.0) then
         nsc=nsc+1
      else if (dtm_hcID(i_basin).eq.1) then
         ncc=ncc+1
      else
         write(6,*) 'unexpected case!'
         stop
      end if
      A_1=dtm_w_1(i_basin)*(dtm_A_inflow(i_basin)+A_cell)/dtm_nrc(i_basin)
      A_2=dtm_w_2(i_basin)*(dtm_A_inflow(i_basin)+A_cell)/dtm_nrc(i_basin)
      Q_1=u*A_1**w
      Q_2=u*A_2**w
      G=1-dtm_y1_sf(i_basin)+2.0d0/3.0d0*dtm_b1_sf(i_basin)
      beta_1=atan(max(dtm_local_slope_1(i_basin),local_slope_t))
      beta_2=atan(max(dtm_local_slope_2(i_basin),local_slope_t))
      if (dtm_w_1(i_basin) > 0.0_RSP) then
         ! write(6,*) 'i_basin = ',i_basin
         ! write(6,*) 'w1 = ',dtm_w_1(i_basin)
         ! write(6,*) 'A1 = ',A_1
         ! write(6,*) 'Q1 = ',Q_1
         ! write(6,*) 'W1 = ',dtm_Ws1_sf_1(i_basin)
         ck_1=5.0d0/(3.0d0*G)*dtm_kSs1_sf_1(i_basin)**(3.0d0/5.0d0)* &
              dtm_Ws1_sf_1(i_basin)**(-2.0d0/5.0d0)* &
              sin(beta_1)**(3.0d0/10.0d0)*Q_1**(1.0d0-3.0d0/5.0d0*G)
         dh_1=Q_1**(1-dtm_b1_sf(i_basin))/ &
              (2*G*dtm_Ws1_sf_1(i_basin)*tan(beta_1))
         sumnrc=sumnrc+dtm_nrc(i_basin)
         min_A=min(min_A,A_1)
         min_kS=min(min_kS,dtm_kSs1_sf_1(i_basin))
         min_Ws=min(min_Ws,dtm_Ws1_sf_1(i_basin))
         min_S0=min(min_S0,sin(beta_1))
         min_Q=min(min_Q,Q_1)
         min_ck=min(min_ck,ck_1)
         min_Dh=min(min_Dh,dh_1)
         max_A=max(max_A,A_1)
         max_kS=max(max_kS,dtm_kSs1_sf_1(i_basin))
         max_Ws=max(max_Ws,dtm_Ws1_sf_1(i_basin))
         max_S0=max(max_S0,sin(beta_1))
         max_Q=max(max_Q,Q_1)
         max_ck=max(max_ck,ck_1)
         max_Dh=max(max_Dh,dh_1)
         sum_A=sum_A+dtm_nrc(i_basin)*A_1
         sum_kS=sum_kS+dtm_nrc(i_basin)*dtm_kSs1_sf_1(i_basin)
         sum_Ws=sum_Ws+dtm_nrc(i_basin)*dtm_Ws1_sf_1(i_basin)
         sum_S0=sum_S0+dtm_nrc(i_basin)*sin(beta_1)
         sum_Q=sum_Q+dtm_nrc(i_basin)*Q_1
         sum_ck=sum_ck+dtm_nrc(i_basin)*ck_1
         sum_Dh=sum_Dh+dtm_nrc(i_basin)*dh_1
         wsum_Q=wsum_Q+dtm_nrc(i_basin)*Q_1**alpha
         wsum_ck=wsum_ck+dtm_nrc(i_basin)*ck_1*Q_1**alpha
         wsum_dh=wsum_dh+dtm_nrc(i_basin)*dh_1*Q_1**alpha
         sumlog_ck=sumlog_ck+dtm_nrc(i_basin)*log10(ck_1)
         sumlog_dh=sumlog_dh+dtm_nrc(i_basin)*log10(dh_1)
      end if
      if (dtm_w_2(i_basin) > 0.0_RSP) then
         ! write(6,*) 'i_basin = ',i_basin
         ! write(6,*) 'w2 = ',dtm_w_2(i_basin)
         ! write(6,*) 'A2 = ',A_2
         ! write(6,*) 'Q2 = ',Q_2
         ! write(6,*) 'W2 = ',dtm_Ws1_sf_2(i_basin)
         ck_2=5.0d0/(3.0d0*G)*dtm_kSs1_sf_2(i_basin)**(3.0d0/5.0d0)* &
              dtm_Ws1_sf_2(i_basin)**(-2.0d0/5.0d0)* &
              sin(beta_2)**(3.0d0/10.0d0)*Q_2**(1.0d0-3.0d0/5.0d0*G)
         dh_2=Q_2**(1-dtm_b1_sf(i_basin))/ &
              (2*G*dtm_Ws1_sf_2(i_basin)*tan(beta_2))
         sumnrc=sumnrc+dtm_nrc(i_basin)
         min_A=min(min_A,A_2)
         min_kS=min(min_kS,dtm_kSs1_sf_2(i_basin))
         min_Ws=min(min_Ws,dtm_Ws1_sf_2(i_basin))
         min_S0=min(min_S0,sin(beta_2))
         min_Q=min(min_Q,Q_2)
         min_ck=min(min_ck,ck_2)
         min_Dh=min(min_Dh,dh_2)
         max_A=max(max_A,A_2)
         max_kS=max(max_kS,dtm_kSs1_sf_2(i_basin))
         max_Ws=max(max_Ws,dtm_Ws1_sf_2(i_basin))
         max_S0=max(max_S0,sin(beta_2))
         max_Q=max(max_Q,Q_2)
         max_ck=max(max_ck,ck_2)
         max_Dh=max(max_Dh,dh_2)
         sum_A=sum_A+dtm_nrc(i_basin)*A_2
         sum_kS=sum_kS+dtm_nrc(i_basin)*dtm_kSs1_sf_2(i_basin)
         sum_Ws=sum_Ws+dtm_nrc(i_basin)*dtm_Ws1_sf_2(i_basin)
         sum_S0=sum_S0+dtm_nrc(i_basin)*sin(beta_2)
         sum_Q=sum_Q+dtm_nrc(i_basin)*Q_2
         sum_ck=sum_ck+dtm_nrc(i_basin)*ck_2
         sum_Dh=sum_Dh+dtm_nrc(i_basin)*dh_2
         wsum_Q=wsum_Q+dtm_nrc(i_basin)*Q_2**alpha
         wsum_ck=wsum_ck+dtm_nrc(i_basin)*ck_2*Q_2**alpha
         wsum_dh=wsum_dh+dtm_nrc(i_basin)*dh_2*Q_2**alpha
         sumlog_ck=sumlog_ck+dtm_nrc(i_basin)*log10(ck_2)
         sumlog_dh=sumlog_dh+dtm_nrc(i_basin)*log10(dh_2)
      end if
  end do
end do

avg_ck=wsum_ck/wsum_Q
avg_dh=wsum_dh/wsum_Q

avglog_ck=10**(sumlog_ck/sumnrc)
avglog_dh=10**(sumlog_dh/sumnrc)

optimal_dx=2*avg_dh/avg_ck
optimallog_dx=2*avglog_dh/avglog_ck

write(6,*)
write(6,'(1x,a,i8,a,i8,a,i8,a)') &
'MEAN (MIN,MAX) OVER',nint(sumnrc),' PATHS,', &
nsc,' SLOPE CELLS,',ncc,' CHANNEL CELLS'
write(6,'(1x,a,f20.6,1x,a1,f20.6,a1,f20.6,a1)') &
'<A> =       ',sum_A/sumnrc,'(',min_A,',',max_A,')'
write(6,'(1x,a,f20.6,1x,a1,f20.6,a1,f20.6,a1)') &
'<kS(A,1)> = ',sum_kS/sumnrc,'(',min_kS,',',max_kS,')'
write(6,'(1x,a,f20.6,1x,a1,f20.6,a1,f20.6,a1)') &
'<W(A,1)> =  ',sum_Ws/sumnrc,'(',min_Ws,',',max_Ws,')'
write(6,'(1x,a,f20.6,1x,a1,f20.6,a1,f20.6,a1)') &
'<S0> =      ',sum_S0/sumnrc,'(',min_S0,',',max_S0,')'
write(6,'(1x,a,f20.6,1x,a1,f20.6,a1,f20.6,a1)') &
'<Q>  =      ',sum_Q/sumnrc,'(',min_Q,',',max_Q,')'
write(6,'(1x,a,f20.6,1x,a1,f20.6,a1,f20.6,a1)') &
'<ck> =      ',sum_ck/sumnrc,'(',min_ck,',',max_ck,')'
write(6,'(1x,a,f20.6,1x,a1,f20.6,a1,f20.6,a1)') &
'<Dh> =      ',sum_Dh/sumnrc,'(',min_Dh,',',max_Dh,')'
write(6,*)
write(6,'(1x,a)') 'Q**ALPHA-WEIGHTED ARITMETIC AVERAGES'
write(6,'(1x,a,f13.6)') 'average kinematic celerity =    ',avg_ck
write(6,'(1x,a,f13.6)') 'average hydraulic diffusivity = ',avg_dh
write(6,'(1x,a,f13.6)') 'optimal space interval =        ',optimal_dx
write(6,*)
! write(6,'(1x,a,f13.6)') 'AVERAGES ON LOG VALUES'
! write(6,'(1x,a,f13.6)') 'average kinematic celerity =    ',avglog_ck
! write(6,'(1x,a,f13.6)') 'average hydraulic diffusivity = ',avglog_dh
! write(6,'(1x,a,f13.6)') 'optimal space interval =        ',optimallog_dx
! write(6,*)
write(6,'(1x,a,$)') 'adopted space interval -> '
read(5,*) adopted_dx
r1=adopted_dx/avg_ck
r2=2*avg_dh/avg_ck**2
if (adopted_dx.ge.2*avg_dh/avg_ck) then
   write(6,*)
   write(6,'(1x,a,f13.6,1x,a1,f13.6,a1,f13.6,a1)') &
   'optimal time interval = ',r1,'(',r1-r2,',',r1+r2,')'
   write(6,*)
else
   write(6,*)
   write(6,'(1x,a,f13.6,1x,a1,f13.6,1x,a1,f13.6,a1)') &
   'optimal time interval = ',r2,'(',r2-r1,',',r2+r1,')'
   write(6,*)
end if

end program odx


!***********************************/
!	Name:内挿targetセルをドナー候補の座標系に変換する
!	Alias:CellTransformationIntoDonor
!	Description:iTime=0でドナー格子のN+1座標系へ写す，iTime=1でN座標系へ
!	Type:
!	Input:
!	Output:
!	Note:1~3次元すべてに対応済み
!	Author:Akitaka Toyota
!	Date:2017.12.05
!	Update:
!	Other:
!***********************************/
    subroutine CellTransformationIntoDonor(iTime,CUV,Global2Donor)
    use StructVar_Mod
    implicit none
    type(CountUpVertex), intent(inout) :: CUV
    type(TransformationMatrix), intent(in) :: Global2Donor
    integer, intent(in) :: iTime

    if(iTime == 0) then
        CUV%TargetCoords(0,:) = matmul(Global2Donor%Top2Next,CUV%TargetCoords(0,:))
        CUV%TargetCoords(1,:) = matmul(Global2Donor%Top2Next,CUV%TargetCoords(1,:))
        CUV%TargetCoords(2,:) = matmul(Global2Donor%Top2Next,CUV%TargetCoords(2,:))
        CUV%TargetCoords(3,:) = matmul(Global2Donor%Top2Next,CUV%TargetCoords(3,:))
    else
        CUV%TargetCoords(0,:) = matmul(Global2Donor%Top2Current,CUV%TargetCoords(0,:))
        CUV%TargetCoords(1,:) = matmul(Global2Donor%Top2Current,CUV%TargetCoords(1,:))
        CUV%TargetCoords(2,:) = matmul(Global2Donor%Top2Current,CUV%TargetCoords(2,:))
        CUV%TargetCoords(3,:) = matmul(Global2Donor%Top2Current,CUV%TargetCoords(3,:))
    end if

    return
    end subroutine CellTransformationIntoDonor


C$Procedure      TWOVEC ( Two vectors defining an orthonormal frame )

      SUBROUTINE TWOVEC ( AXDEF, INDEXA, PLNDEF, INDEXP, MOUT )

C$ Abstract
C
C     Find the transformation to the right-handed frame having a
C     given vector as a specified axis and having a second given
C     vector lying in a specified coordinate plane.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     AXES,  FRAME,  ROTATION,  TRANSFORMATION
C
C$ Declarations

      DOUBLE PRECISION   AXDEF  (   3 )
      INTEGER            INDEXA
      DOUBLE PRECISION   PLNDEF (   3 )
      INTEGER            INDEXP
      DOUBLE PRECISION   MOUT   ( 3,3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  -------------------------------------------------
C     AXDEF      I   Vector defining a principal axis.
C     INDEXA     I   Principal axis number of AXDEF (X=1, Y=2, Z=3).
C     PLNDEF     I   Vector defining (with AXDEF) a principal plane.
C     INDEXP     I   Second axis number (with INDEXA) of principal
C                     plane.
C     MOUT       O   Output rotation matrix.
C
C$ Detailed_Input
C
C     AXDEF      is a vector defining one of the priciple axes of a
C                coordinate frame.
C
C     INDEXA     is a number that determines which of the three
C                coordinate axes contains AXDEF.
C
C                If INDEXA is 1 then AXDEF defines the X axis of the
C                coordinate frame.
C
C                If INDEXA is 2 then AXDEF defines the Y axis of the
C                coordinate frame.
C
C                If INDEXA is 3 then AXDEF defines the Z axis of the
C                coordinate frame
C
C     PLNDEF     is a vector defining (with AXDEF) a principal plane of
C                the coordinate frame. AXDEF and PLNDEF must be
C                linearly independent.
C
C     INDEXP     is the second axis of the principal frame determined
C                by AXDEF and PLNDEF.  INDEXA, INDEXP must be different
C                and be integers from 1 to 3.
C
C                If INDEXP is 1, the second axis of the principal
C                plane is the X-axis.
C
C                If INDEXP is 2, the second axis of the principal
C                plane is the Y-axis.
C
C                If INDEXP is 3, the second axis of the principal plane
C                is the Z-axis.
C
C
C$ Detailed_Output
C
C     MOUT       is a rotation matrix that transforms coordinates given
C                in the input frame to the frame determined by AXDEF,
C                PLNDEF, INDEXA and INDEXP.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If INDEXA or INDEXP is not in the set {1,2,3} the error
C        SPICE(BADINDEX) will be signaled.
C
C     2) If INDEXA and INDEXP are the same the error
C        SPICE(UNDEFINEDFRAME) will be signaled.
C
C     3) If the cross product of the vectors AXDEF and PLNDEF is zero,
C        the error SPICE(DEPENDENTVECTORS) will be signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Given two linearly independent vectors there is a unique
C     right-handed coordinate frame having:
C
C        AXDEF lying along the INDEXA axis.
C
C        PLNDEF lying in the INDEXA-INDEXP coordinate plane.
C
C     This routine determines the transformation matrix that transforms
C     from coordinates used to represent the input vectors to the
C     the system determined by AXDEF and PLNDEF.  Thus a vector
C     (x,y,z) in the input coordinate system will have coordinates
C
C                     t
C        MOUT* (x,y,z)
C
C     in the frame determined by AXDEF and PLNDEF.
C
C$ Examples
C
C     The rotation matrix TICC from inertial to Sun-Canopus
C     (celestial) coordinates is found by the call
C
C        CALL TWOVEC (Sun vector, 3, Canopus vector, 1, TICC)
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.M. Owen       (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 31-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL call.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0,  31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     define an orthonormal frame from two vectors
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 31-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL call.
C
C-    Beta Version 2.0.0, 10-JAN-1989 (WLT)
C
C     Error checking was added and the algorithm somewhat redesigned.
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      MTEMP  ( 3, 3 )

      INTEGER               I1
      INTEGER               I2
      INTEGER               I3
      INTEGER               SEQNCE ( 5 )

C
C     Saved variables
C
      SAVE                  SEQNCE

C
C     Initial values
C
      DATA                  SEQNCE  / 1, 2, 3, 1, 2 /

C
C     Standard SPICE error handling
C
      IF ( RETURN() ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'TWOVEC' )
      END IF

C
C     Check for obvious bad inputs.
C
      IF (      ( MAX(INDEXP,INDEXA) .GT. 3 )
     .     .OR. ( MIN(INDEXP,INDEXA) .LT. 1 ) ) THEN

         CALL SETMSG ( 'The definition indexs must lie in the range ' //
     .                 'from 1 to 3.  The value of INDEXA was #. '    //
     .                 'The value of INDEXP was #. '                  )

         CALL ERRINT ( '#', INDEXA  )
         CALL ERRINT ( '#', INDEXP  )
         CALL SIGERR ( 'SPICE(BADINDEX)' )
         CALL CHKOUT (     'TWOVEC' )
         RETURN

      ELSE IF   ( INDEXA .EQ. INDEXP )  THEN

         CALL SETMSG ( 'The values of INDEXA and INDEXP were the '    //
     .                 'same, namely #.  They are required to be '    //
     .                 'different.'                                   )

         CALL ERRINT ( '#', INDEXA  )
         CALL SIGERR ( 'SPICE(UNDEFINEDFRAME)' )
         CALL CHKOUT (     'TWOVEC' )
         RETURN

      END IF

C
C     Get indices for right-handed axes
C
C     First AXDEF ...
C
      I1 = INDEXA
C
C     ... then the other two.
C
      I2 = SEQNCE ( INDEXA + 1 )
      I3 = SEQNCE ( INDEXA + 2 )

C
C     Row I1 contains normalized AXDEF (store in columns for now)
C
      CALL VHAT ( AXDEF, MOUT(1,I1) )

C
C     Obtain rows I2 and I3 using cross products.  Which order to use
C     depends on whether INDEXP = I2 (next axis in right-handed order)
C     or INDEXP = I3 (previous axis in right-handed order).
C
      IF ( INDEXP .EQ. I2 ) THEN

         CALL UCRSS ( AXDEF,      PLNDEF,        MOUT(1,I3) )
         CALL UCRSS ( MOUT(1,I3), AXDEF,         MOUT(1,I2) )

      ELSE

         CALL UCRSS ( PLNDEF,     AXDEF,         MOUT(1,I2) )
         CALL UCRSS ( AXDEF,      MOUT(1,I2),    MOUT(1,I3) )

      END IF

C
C     Finally, check to see that we actually got something non-zero
C     in one of the one columns of MOUT(1,I2) and MOUT(1,I3) (we need
C     only check one of them since they are related by a cross product).
C
      IF (       ( MOUT(1,I2) .EQ. 0.0D0 )
     .     .AND. ( MOUT(2,I2) .EQ. 0.0D0 )
     .     .AND. ( MOUT(3,I2) .EQ. 0.0D0 ) ) THEN

         CALL SETMSG ( 'The input vectors AXDEF and PLNDEF are '      //
     .                 'linearly dependent.'                          )
         CALL SIGERR ( 'SPICE(DEPENDENTVECTORS)' )

      END IF
C
C     Transpose MOUT.
C
      CALL XPOSE ( MOUT,     MTEMP )
      CALL MOVED ( MTEMP, 9, MOUT  )

      CALL CHKOUT ( 'TWOVEC' )
      RETURN
      END


program problem33
  use euler
  implicit none
  integer   :: a1,a2,b1,b2
  integer*8 :: a=1,b=1
  real      :: temp1,temp2

  do b1=0,9
     do b2=0,9
        if (b1==0 .and. b2==0) cycle ! undefined
        do a2=0,9
           if (a2==0 .and. b2==0) cycle ! "trivial"
           do a1=0,9
              if (a1==0 .and. b1==0) cycle ! "trivial"
              temp1=float(a1*10+a2)/(b1*10+b2)
              if (temp1 >= 1.0 .or. temp1 <= 0) cycle ! must be positive fraction less than one
              if (a1==b1 .and. (float(a2)/b2)==temp1) then
                 a=a*a2
                 b=b*b2
              end if
              if (a2==b2 .and. (float(a1)/b1)==temp1) then
                 a=a*a1
                 b=b*b1
              end if
              if (a2==b1 .and. (float(a1)/b2)==temp1) then
                 a=a*a1
                 b=b*b2
              end if
              if (a1==b2 .and. (float(a2)/b1)==temp1) then
                 a=a*a2
                 b=b*b1
              end if
           end do
        end do
     end do
  end do

  print *, b/(gcd(a,b))

end program problem33


module Mod_HeightGauge
   use typre
   use Mod_CutMesh
   use MOd_MPIObject
   use MPI
   implicit none

   type, extends(MPIObject) :: HeightGauge
      integer(ip) :: ndime
      real(rp) :: Origin(3), DirectionVector(3)
      real(rp) :: height = -1e12
contains
      procedure :: ResetGauge
      procedure :: SetNdime
      procedure :: CheckHeight
      procedure :: CollectHeight
   end type

contains

   subroutine ResetGauge(a)
      class(HeightGauge) :: a

      a%height = -1e12
   end subroutine

   subroutine SetNdime(a,ndime)
      class(HeightGauge) :: a
      integer(ip) :: ndime

      a%ndime = ndime
   end subroutine

   subroutine CheckHeight(a,ninters,xglob)
      class(HeightGauge) :: a
      integer(ip) :: ninters
      real(rp) :: xglob(a%ndime,ninters)

      real(rp) :: auxxglob(3,3),distance
      logical :: isfound

      real(rp) :: lambda2

      if (a%ndime == 3) then
         if (ninters == 3) then

            call MollerTrumbore(a%DirectionVector,a%Origin,xglob,isfound,distance)
            if (isfound) a%height = distance

         elseif (ninters == 4) then
            !We just check the 4 possible triangles
            !Not efficient (twice the real effort) but only in the surface elements

            auxxglob(1:3,1) = xglob(1:3,1)
            auxxglob(1:3,2) = xglob(1:3,2)
            auxxglob(1:3,3) = xglob(1:3,3)
            call MollerTrumbore(a%DirectionVector,a%Origin,auxxglob,isfound,distance)
            if (isfound) a%height = distance

            auxxglob(1:3,1) = xglob(1:3,1)
            auxxglob(1:3,2) = xglob(1:3,2)
            auxxglob(1:3,3) = xglob(1:3,4)
            call MollerTrumbore(a%DirectionVector,a%Origin,auxxglob,isfound,distance)
            if (isfound) a%height = distance

            auxxglob(1:3,1) = xglob(1:3,2)
            auxxglob(1:3,2) = xglob(1:3,3)
            auxxglob(1:3,3) = xglob(1:3,4)
            call MollerTrumbore(a%DirectionVector,a%Origin,auxxglob,isfound,distance)
            if (isfound) a%height = distance

            auxxglob(1:3,1) = xglob(1:3,1)
            auxxglob(1:3,2) = xglob(1:3,3)
            auxxglob(1:3,3) = xglob(1:3,4)
            call MollerTrumbore(a%DirectionVector,a%Origin,auxxglob,isfound,distance)
            if (isfound) a%height = distance
         else
            call runend('CheckHeight: Wrong number of intersections')
         endif

      else
         if (ninters == 2) then
            lambda2 = ( xglob(2,2)*a%DirectionVector(1) - xglob(1,1)*a%DirectionVector(2) + a%Origin(1)*a%DirectionVector(2) - a%Origin(2)*a%DirectionVector(1))/ &
            (xglob(2,1)*a%DirectionVector(1) - xglob(2,2)*a%DirectionVector(1) - xglob(1,1)*a%DirectionVector(2) + xglob(1,2)*a%DirectionVector(2))

            if (lambda2 >= -1e-6 .and. lambda2 <= 1.000001) then
               if (a%DirectionVector(1) /= 0.0_rp) then
                  distance = (xglob(1,1)-a%Origin(1) - xglob(1,1)*lambda2 + xglob(1,2)*lambda2) / a%DirectionVector(1)
               else
                  distance = (xglob(2,1)-a%Origin(2) - xglob(2,1)*lambda2 + xglob(2,2)*lambda2) / a%DirectionVector(2)
               endif
               a%Height = distance
            endif

         else
            call runend('CheckHeight: Wrong number of intersections')
         endif
      endif

   end subroutine

   subroutine MollerTrumbore(DirectionVector,Origin,xglob,isfound,distance)
      implicit none
      real(rp) :: DirectionVector(3), Origin(3), xglob(3,3)
      logical  :: isfound
      real(rp) :: distance

      real(rp) :: sysmat(3,3), sysrhs(3), syssol(3)

      isfound = .false.
      !Moller Trumbore algorithm
      sysmat(1:3,1) = -DirectionVector(1:3)
      sysmat(1:3,2) = xglob(1:3,2)-xglob(1:3,1)
      sysmat(1:3,3) = xglob(1:3,3)-xglob(1:3,1)

      sysrhs(1:3) = Origin(1:3)-xglob(1:3,1)
      call SolveSystem(3,sysmat,sysrhs,syssol)

      if ((syssol(2) >= 0) .and.(syssol(3) >= 0) .and. (syssol(2)+syssol(3) <= 1) ) then
         isfound = .true.
         distance = syssol(1)
      endif
   end subroutine

   subroutine CollectHeight(a)
      class(HeightGauge) :: a

      integer(ip) :: ierr
      real(rp) :: height

      call MPI_REDUCE(a%height, height, 1, MPI_REAL8, MPI_MAX, a%MPIroot,a%MPIcomm, ierr )
      if (a%MPIrank == a%MPIroot) a%height = height

   end subroutine

end module


FUNCTION INTIND(lam,func,lo,hi)

  !perform integral over spectrum for index computation

  USE sps_vars
  USE sps_utils, ONLY : tsum, locate
  IMPLICIT NONE

  INTEGER :: l1,l2,i
  REAL(SP), INTENT(in), DIMENSION(nspec) :: lam, func
  REAL(SP), INTENT(in) :: lo,hi
  REAL(SP) :: f1,f2,intind

  !---------------------------------------------------------------!
  !---------------------------------------------------------------!

  !take care of the ends
  l1 = MAX(MIN(locate(lam,lo),nspec-1),1)
  l2 = MAX(MIN(locate(lam,hi),nspec-1),2)
  f1 = (func(l1+1)-func(l1))/(lam(l1+1)-lam(l1))*&
       (lo-lam(l1))+func(l1)
  f2 = (func(l2+1)-func(l2))/(lam(l2+1)-lam(l2))*&
       (hi-lam(l2))+func(l2)

  IF (l1.EQ.l2) THEN
     intind = (f2+f1)/2.*(hi-lo)
  ELSE
     intind = TSUM(lam(l1+1:l2),func(l1+1:l2))
     intind = intind + (lam(l1+1)-lo)*(f1+func(l1+1))/2.
     intind = intind + (hi-lam(l2))*(f2+func(l2))/2.
  ENDIF

END FUNCTION INTIND

!------------------------------------------------------------!
!------------------------------------------------------------!
!------------------------------------------------------------!

SUBROUTINE GETINDX(lambda,spec,indices)

  !routine to calculate indices from an input spectrum
  !indices are defined in fsps/data/allindices.dat

  USE sps_vars
  USE sps_utils, ONLY : intind, locate
  IMPLICIT NONE

  INTEGER :: j
  REAL(SP), INTENT(in), DIMENSION(nspec) :: spec,lambda
  REAL(SP), INTENT(inout), DIMENSION(nindx) :: indices
  REAL(SP) :: intfifc,cb,cr,lr,lb

  !---------------------------------------------------------------!
  !---------------------------------------------------------------!

  indices = 999.

  DO j=1,nindx

     !blue continuum
     cb = intind(lambda,spec,indexdefined(3,j),indexdefined(4,j))
     cb = cb / (indexdefined(4,j)-indexdefined(3,j))
     lb = (indexdefined(3,j)+indexdefined(4,j))/2.

     IF (indexdefined(7,j).NE.4) THEN

        !red continuum
        cr = intind(lambda,spec,indexdefined(5,j),indexdefined(6,j))
        cr = cr / (indexdefined(6,j)-indexdefined(5,j))
        lr = (indexdefined(5,j)+indexdefined(6,j))/2.

        !compute integral(fi/fc)
        !NB: fc here is a linear interpolation between the red and blue.
        intfifc = intind(lambda,spec/((cr-cb)/(lr-lb)*(lambda-lb) + cb),&
             indexdefined(1,j),indexdefined(2,j))

     ELSE
        intfifc = intind(lambda,spec,indexdefined(1,j),indexdefined(2,j))
        intfifc = intfifc/(indexdefined(2,j)-indexdefined(1,j))
     ENDIF

     IF (indexdefined(7,j).EQ.1.) THEN
        !compute magnitude
        indices(j) = &
             -2.5*LOG10(intfifc/(indexdefined(2,j)-indexdefined(1,j)))
     ELSE IF (indexdefined(7,j).EQ.2.) THEN
        !compute EW (in Ang)
        indices(j) = (indexdefined(2,j)-indexdefined(1,j)) - intfifc
     ELSE IF (indexdefined(7,j).EQ.3.) THEN
        !compute Dn4000
        !NB: this only works with cr and cb computed above b/c
        !the wavelength intervals for blue and red are the
        !same for these indices, otherwise a slightly
        !different cr and cb would have to be computed
        indices(j) = cr/cb
     ELSE IF (indexdefined(7,j).EQ.4.) THEN
        !compute magnitude from a flux ratio
        indices(j) = -2.5*LOG10(intfifc/cb)
     ENDIF

     !set dummy values for indices defined off of the wavelength grid
     IF (indexdefined(6,j).GT.lambda(nspec)) indices(j) = 999.0
     IF (indexdefined(3,j).LT.lambda(1)) indices(j) = 999.0

  ENDDO

END SUBROUTINE GETINDX


      SUBROUTINE FOURN(DATA,NN,NDIM,ISIGN)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION NN(NDIM),DATA(*)
      NTOT=1
      DO 11 IDIM=1,NDIM
        NTOT=NTOT*NN(IDIM)
11    CONTINUE
      NPREV=1
      DO 18 IDIM=1,NDIM
        N=NN(IDIM)
        NREM=NTOT/(N*NPREV)
        IP1=2*NPREV
        IP2=IP1*N
        IP3=IP2*NREM
        I2REV=1
        DO 14 I2=1,IP2,IP1
          IF(I2.LT.I2REV)THEN
            DO 13 I1=I2,I2+IP1-2,2
              DO 12 I3=I1,IP3,IP2
                I3REV=I2REV+I3-I2
                TEMPR=DATA(I3)
                TEMPI=DATA(I3+1)
                DATA(I3)=DATA(I3REV)
                DATA(I3+1)=DATA(I3REV+1)
                DATA(I3REV)=TEMPR
                DATA(I3REV+1)=TEMPI
12            CONTINUE
13          CONTINUE
          ENDIF
          IBIT=IP2/2
1         IF ((IBIT.GE.IP1).AND.(I2REV.GT.IBIT)) THEN
            I2REV=I2REV-IBIT
            IBIT=IBIT/2
          GO TO 1
          ENDIF
          I2REV=I2REV+IBIT
14      CONTINUE
        IFP1=IP1
2       IF(IFP1.LT.IP2)THEN
          IFP2=2*IFP1
          THETA=ISIGN*6.28318530717959D0/(IFP2/IP1)
          WPR=-2.D0*DSIN(0.5D0*THETA)**2
          WPI=DSIN(THETA)
          WR=1.D0
          WI=0.D0
          DO 17 I3=1,IFP1,IP1
            DO 16 I1=I3,I3+IP1-2,2
              DO 15 I2=I1,IP3,IFP2
                K1=I2
                K2=K1+IFP1
                TEMPR=SNGL(WR)*DATA(K2)-SNGL(WI)*DATA(K2+1)
                TEMPI=SNGL(WR)*DATA(K2+1)+SNGL(WI)*DATA(K2)
                DATA(K2)=DATA(K1)-TEMPR
                DATA(K2+1)=DATA(K1+1)-TEMPI
                DATA(K1)=DATA(K1)+TEMPR
                DATA(K1+1)=DATA(K1+1)+TEMPI
15            CONTINUE
16          CONTINUE
            WTEMP=WR
            WR=WR*WPR-WI*WPI+WR
            WI=WI*WPR+WTEMP*WPI+WI
17        CONTINUE
          IFP1=IFP2
        GO TO 2
        ENDIF
        NPREV=N*NPREV
18    CONTINUE
      RETURN
      END


C    @(#)gtpieqiv.f	20.3 2/13/96
c
c This routine is part of IPFDAT
c This is a modified version of "pieqiv" and is used only by IPFDAT
c
      integer function gtpieqiv (numtext, text, newtext)
      character text(*)*(*), newtext*(*)
C                                                                      *
C     This program calculates pi-equivalent data from branch sections  *
C                                                                      *
      complex * 8 y(2,2), ex
      character code * 10

      logical debug

      gtpieqiv = 0               ! Set return status = "successful"
      debug = .false.
      ksect = 0

      do 220 i = 1, numtext
         ksect = ksect + 1

         read (text(i), 100, err=200 ) r, x
  100    format (t39, 2f6.5)

         z = r ** 2 + x ** 2
         if (z .eq. 0.0) then
            write (*, 120) text(i)(1:33)
  120       format (' Branch record ', a,
     &              ' has zero transfer impedance.')
            z = 1.0
         endif

         if (text(i)(1:2) .eq. 'L ') then
C                                                                      *
C           "L" DATA                                                      *
C                                                                      *
            read (text(i), 130, err=200 ) g, b
  130       format (t51, 2f6.5)

            y(1,2) = -cmplx (r/z, -x/z)
            y(2,1) = y(1,2)
            y(1,1) = cmplx (g,b) - y(1,2)
            y(2,2) = y(1,1)

         else if (text(i)(1:2) .eq. 'T ') then
C                                                                      *
C           "T" DATA                                                   *
C                                                                      *
            read (text(i), 140, err=200 ) base1, base2, g, b, tap1, tap2
  140       format (t15, f4.0, t28, f4.0, t51, 2f6.5, 2f5.2)

            t1 = tap1 / base1
            t2 = tap2 / base2
            if (amin1 (t1,t2) .lt. 0.667 .or. amax1 (t1,t2) .gt. 1.333)
     1         then
               write (*, 150) text(i)(1:33)
  150          format ('0 Transformer ', a,
     1            ' has taps which are beyond 33% of base kv.')
            endif
            t12 = 1.0 / (t1 * t2)
            y(1,1) = cmplx (0.5 * t12 * g, -0.5 * t12 * abs(b))
            y(2,2) = y(1,1)
            y(1,2) = -cmplx (r / (z * t1 * t2), -x / (z * t1 * t2))
            y(2,1) = y(1,2)
            y(1,1) = y(1,1)
     &             + cmplx (r / (z * t1 ** 2), -x / (z * t1 ** 2))
            y(2,2) = y(2,2)
     &             + cmplx (r / (z * t2 ** 2), -x / (z * t2 ** 2))

         else if (text(i)(1:2) .eq. 'TP') then
C                                                                      *
C           "TP" DATA                                                  *
C                                                                      *
            read (text(i),190,err=200 ) g, b, tap1, tap2

            t2 = tap2 / base2
            if (t2 .eq. 0.0) t2 = 1.0
            if (t2 .lt. 0.667 .or. t2 .gt. 1.333) then
               write (*, 160) text(i)(1:33)
  160          format ('0 Transformer ', a,
     1            ' has taps which are beyond 33% ofbase kv.')
               t2 = 1.0
            endif
            angle = 0.0174532925 * t1
            if (t1 .lt. -120.1 .or. t1 .gt. 120.1) then
               write (*, 170) text(i)(1:33)
  170          format ('0 Transformer ', a,
     1            ' has excessive phase shift (120.0) degrees).')
            endif

            y(1,2) = cmplx (0.5 * g, -0.5 * abs(b))
            y(1,1) = y(1,2) + cmplx (r/z, -x/z)
            y(2,2) = y(1,2)
     &             + cmplx (r/z, -x/z) / cmplx (t2 ** 2,0.0)
            ex = cmplx (cos (angle), sin (angle))
            y(1,2) = -ex * cmplx (r / (z * t2), -x / (z * t2))
            ex = cmplx (cos (angle), -sin (angle))
            y(2,1) = -ex * cmplx (r / (z * t2), -x / (z * t2))

         else if (text(i)(1:1) .eq. 'E') then
C                                                                      *
C           "E" DATA                                                   *
C                                                                      *
            read (text(i), 180, err=200 ) g1, b1, g2, b2
  180       format (t51, 4f6.5)

            y(1,2)= -cmplx (r/z, -x/z)
            y(2,1) = y(1,2)
            y(1,1) = cmplx(g1,b1) - y(1,2)
            y(2,2) = cmplx(g2,b2) - y(2,1)

         else

            write (*, 190) text(i)(1:33)
  190       format (' Illegal branch type ', a)
            gtpieqiv = 1
            go to 220
         endif

         if (ksect .eq. 1) then
            call first_sect (y)
         else
            call next_sect (y)
         endif
         go to 220

  200    write (*, 210 ) text(i)(1:33)
  210    format (' Illegal data in field ', a)
         gtpieqiv = 1

  220 continue

      if (gtpieqiv .eq. 0) then
         call final_sect (y)

         if (debug) then
            write (*, 230) y(1,1), y(1,2), y(2,1), y(2,2)
  230       format ( /, ' Y(1,1) = (', e12.5, ',', e12.5, ') ',
     1               /, ' Y(1,2) = (', e12.5, ',', e12.5, ') ',
     2               /, ' Y(2,1) = (', e12.5, ',', e12.5, ') ',
     3               /, ' Y(2,2) = (', e12.5, ',', e12.5, ') ',
     4               /)
         endif
         r = -real (cmplx (1.0,0.0) / y(1,2))
         x = -aimag (cmplx (1.0,0.0) / y(1,2))
         g1 = real (y(1,1) + y(1,2))
         b1 = aimag (y(1,1) + y(1,2))
         g2 = real (y(2,2) + y(2,1))
         b2 = aimag (y(2,2) + y(2,1))

         newtext = text(1)(1:33)
         newtext(1:2) = 'E '
         newtext(39:44) = code (r, 6, 5)
         newtext(45:50) = code (x, 6, 5)
         newtext(51:56) = code (g1, 6, 5)
         newtext(57:62) = code (b1, 6, 5)
         newtext(63:68) = code (g2, 6, 5)
         newtext(69:74) = code (b2, 6, 5)

         write (*, 240) newtext(1:80)
  240    format (' Consolidated branch (', a, ')')

      endif
      return
      end


! Set auxiliary arrays
!
! Routine that sets the values found in the aux array including topography and
! other fields that are used in the source terms and other things.
!
! In the default routine sets the following fields depending on the input
! parameters present:
!  (1) topography
!  (2) capacity (set if coordinate_system == 2)
!  (3) length ratio of edge (set if coordinate_system == 2)
!  (frition_index). Location of manning's N (variable_friction)
!  (wind_index, wind_index + 1).  Location of x and y wind speeds (wind_forcing)
!  (pressure_index).  Location of pressure field (pressure_forcing)
!
! There are a couple of additional things of note:
!
!  - This routine is called anytime a grid is created during re-gridding to fill
!    in the aux arrays.
!  - Built-in to this routine is an ability to copy aux values from grids from
!    the same level.  If you do not want this behavior you will need to modify
!    this routine.
!  - If you are using periodic BCs then you must handle this here.  Look to the
!    setting of topography for an example of how this may need to be done.
!  - If your aux arrays are time dependent and set somewhere else it may be
!    prudent to set a default value here as is done with the wind and pressure.
!
subroutine setaux(mbc,mx,my,xlow,ylow,dx,dy,maux,aux)

    use amr_module, only: mcapa, xupper, yupper, xlower, ylower, NEEDS_TO_BE_SET
    use amr_module, only: xperdom, yperdom

    use geoclaw_module, only: coordinate_system, earth_radius, deg2rad
    use geoclaw_module, only: sea_level, ambient_pressure

    use storm_module, only: wind_forcing, pressure_forcing
    use storm_module, only: wind_index, pressure_index, set_storm_fields

    use friction_module, only: variable_friction, friction_index
    use friction_module, only: set_friction_field

    use topo_module

    implicit none

    ! Arguments
    integer, intent(in) :: mbc,mx,my,maux
    real(kind=8), intent(in) :: xlow,ylow,dx,dy
    real(kind=8), intent(inout) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Locals
    integer :: ii,jj,m, iint,jint
    real(kind=8) :: x,y,xm,ym,xp,yp,topo_integral
    real(kind=8) :: xper,yper,xperm,yperm,xperp,yperp
    character(len=*), parameter :: aux_format = "(2i4,4d15.3)"
    integer :: skipcount,iaux,ilo,jlo

    ! Lat-Long coordinate system in use, check input variables
    if (coordinate_system == 2) then
        if (mcapa /= 2 .or. maux < 3) then
            print *,'ERROR in setaux:  for coordinate_system==2'
            print *,'     need mcapa == 2 and maux >= 3'
            print *,'     have mcapa = ',mcapa,'  maux = ',maux
            stop
        endif
    endif

    ! Compute integer indices based off same corner of domain to reduce round
    ! off discrepancies
    ilo = floor((xlow - xlower + .05d0*dx)/dx)
    jlo = floor((ylow - ylower + .05d0*dy)/dy)

    ! Set geometry values
    if (coordinate_system == 1) then
        if (maux == 0 .and. mcapa > 0) then
            print *, "ERROR:  Capacity array requested but number of aux"
            print *, "variables is set to 0."
            stop
        end if
    else if (coordinate_system == 2) then
        do jj = 1 - mbc, my + mbc
            do ii = 1 - mbc, mx + mbc
                ym = ylower + (jlo+jj-1.d0) * dy
                yp = ylower + (jlo+jj) * dy
                aux(2,ii,jj) = deg2rad * earth_radius**2                      &
                                * (sin(yp * deg2rad) - sin(ym * deg2rad)) / dy
                aux(3,ii,jj) = ym * deg2rad
            end do
        end do
    end if

    ! If using a variable friction field initialize the coefficients to 0
    if (variable_friction) then
        call set_friction_field(mx, my, mbc, maux, xlow, ylow, dx, dy, aux)
    endif

    ! Storm fields if used
    if (wind_forcing) then
        aux(wind_index, :, :) = 0.d0
        aux(wind_index + 1, :, :) = 0.d0
    endif
    if (pressure_forcing) then
        aux(pressure_index, :, :) = ambient_pressure
    endif

    ! ==========================================================================
    !  Set Bathymetry
    ! Set analytical bathymetry here if requested
    if (test_topography > 0) then
        do jj = 1 - mbc, my + mbc
            ym = ylower + (jlo+jj-1.d0) * dy
            yp = ylower + (jlo+jj) * dy
            y = 0.5d0*(ym+yp)
            do ii = 1 - mbc, mx + mbc
                xm = xlower + (ilo+ii-1.d0) * dx
                xp = xlower + (ilo+ii) * dx
                x = 0.5d0*(xm+xp)
                aux(1,ii,jj) = test_topo(x, y)
            end do
        end do

    ! Set bathymetry based on input files
    else if (mtopofiles > 0) then

        do jj=1-mbc,my+mbc
            ym = ylower + (jlo+jj-1.d0) * dy
            yp = ylower + (jlo+jj) * dy
            y = 0.5d0*(ym+yp)

            do ii=1-mbc,mx+mbc
                xm = xlower + (ilo+ii-1.d0) * dx
                xp = xlower + (ilo+ii) * dx
                x = 0.5d0*(xm+xp)

                ! Parameter NEEDS_TO_BE_SET initialized in amr_module.f90
                ! saves time by otherwise copying instead of reinitializing
                if (aux(1,ii,jj) .ne. NEEDS_TO_BE_SET) then
                    cycle
                endif

                topo_integral = 0.d0
                if ((y>yupper).or.(y<ylower).or.(x>xupper).or.(x<xlower)) then
                    if (.not.(xperdom .or. yperdom)) then
                        ! Skip setting as this cell sticks out of the physical
                        ! domain and we are not setting periodic BCs
                        cycle

                    else
                        ! We evaluate the periodic BC topography by computing
                        ! the appropriate periodic grid cell coordinates and
                        ! again calling cellgridintegrate
                        call wrap_coords(x,y,xperm,xper,xperp,yperm,yper, &
                                         yperp,dx,dy)
                        call cellgridintegrate(topo_integral,  &
                            xperm,xper,xperp,yperm,yper,yperp, &
                            xlowtopo,ylowtopo,xhitopo,yhitopo,dxtopo,dytopo, &
                            mxtopo,mytopo,mtopo,i0topo,mtopoorder, &
                            mtopofiles,mtoposize,topowork)
                    endif
                else
                    ! Cell does not extend outside of physical domain
                    call cellgridintegrate(topo_integral,xm,x,xp,ym,y,yp, &
                            xlowtopo,ylowtopo,xhitopo,yhitopo,dxtopo,dytopo, &
                            mxtopo,mytopo,mtopo,i0topo,mtopoorder, &
                            mtopofiles,mtoposize,topowork)
                endif

                ! Correct for geometry
                if (coordinate_system == 2) then
                    aux(1,ii,jj) = topo_integral / (dx * dy * aux(2,ii,jj))
                else
                    aux(1,ii,jj) = topo_integral / (dx * dy)
                endif
            enddo
        enddo
    else
        print *, "ERROR:  There is no way to set bathymetry!  Either "
        print *, "        provide topography files or request topography "
        print*,  "        defined by a function."
        stop
    end if

    ! Copy topo to ghost cells if outside physical domain and not periodic
    if (.not. yperdom) then
        do jj=1-mbc,my+mbc
            y = ylower + (jlo+jj-.5d0) * dy
            if ((y < ylower) .or. (y>yupper)) then
                do ii=1-mbc,mx+mbc
                    x = xlower + (ilo+ii-.5d0) * dx
                    iint = ii + max(0, ceiling((xlower-x)/dx)) &
                         - max(0, ceiling((x-xupper)/dx))
                    jint = jj + max(0, ceiling((ylower-y)/dy)) &
                         - max(0, ceiling((y-yupper)/dy))
                    aux(1,ii,jj) = aux(1,iint,jint)
                enddo
            endif
        enddo
    endif
    if (.not. xperdom) then
        do ii=1-mbc,mx+mbc
            x =  xlower + (ilo+ii-.5d0) * dx
            if ((x < xlower) .or. (x > xupper)) then
                do jj=1-mbc,my+mbc
                    y = ylower + (jlo+jj-.5d0) * dy
                    iint = ii + max(0, ceiling((xlower-x)/dx)) &
                         - max(0, ceiling((x-xupper)/dx))
                    jint = jj + max(0, ceiling((ylower-y)/dy)) &
                         - max(0, ceiling((y-yupper)/dy))
                    aux(1,ii,jj) = aux(1,iint,jint)
                enddo
            endif
        enddo
    endif

contains

    ! Provide wrapper function for providing periodic coordinates
    subroutine wrap_coords(x,y,xperm,xper,xperp,yperm,yper,yperp,dx,dy)

        use amr_module, only: xperdom, yperdom, xupper, yupper, xlower, ylower

        implicit none

        ! Arguments
        real(kind=8), intent(in) :: x,y,dx,dy
        real(kind=8), intent(out) :: xperm,xper,xperp,yperm,yper,yperp
        real(kind=8) :: xdomain, ydomain

        ! need size of domain for wrapping
        xdomain = xupper - xlower
        ydomain = yupper - ylower
        xper = x
        yper = y

        ! test for wrapping of coordinates
        if (x > xupper .and. xperdom) xper = xper - xdomain
        if (x < xlower .and. xperdom) xper = xper + xdomain
        if (y > yupper .and. yperdom) yper = yper - ydomain
        if (y < ylower .and. yperdom) yper = yper + ydomain

        ! adjust rest of variables
        xperm = xper - 0.5d0 * dx
        xperp = xper + 0.5d0 * dx
        yperm = yper - 0.5d0 * dy
        yperp = yper + 0.5d0 * dy

    end subroutine wrap_coords

end subroutine setaux


!
!********************************************************************
!

      subroutine znew_integral1(zetai, dKdL, z0, z1, z2)

      implicit none

      real dz, zmax
      integer j, npts, nmaxdim, j_filt

      parameter (nmaxdim = 10000)

      real z(nmaxdim), dKdL, zetai, mult
      complex z0, z1, z2, zi, f2(nmaxdim), beta, cexpx
      complex f1(nmaxdim), f0(nmaxdim)

      zi = cmplx(0.,1.)

      npts = nmaxdim
c      zmax = 10000.
c      dz = zmax / (npts - 1)
      dz = 0.0628
      if(dz .gt. 1.0 / (5. * abs(zetai))) dz = 1.0 / (5. * abs(zetai))
      mult = 1.0

*     --------------------
*     calculate Z0, Z1, Z2
*     --------------------
      j_filt = npts / 2

      f0 = 0.0
      f1 = 0.0
      f2 = 0.0

      do  j = 1, npts
         z(j) = (j - 1) * dz
         beta = 1. / sqrt(1. - 0.5 * zi * dKdL * z(j)**2 )
         if (j .ge. npts - j_filt) then
             mult = cos((float(j - j_filt) / float(j_filt))
     .            * 2.0 * atan(1.0))
         end if
	 cexpx = exp(zi * z(j) - 0.25 * (z(j) * beta * zetai)**2) * mult
         f0(j) = zi * zetai * beta * cexpx

         f1(j) = 0.5 * zetai**2 * beta**3 * z(j) * cexpx

         f2(j) = 0.5 * zi * zetai * beta**3
     .      * (1.0 -  0.5 * (beta * zetai * z(j))**2) * cexpx

      end do

      z0 = sum(f0) * dz
      z1 = sum(f1) * dz
      z2 = sum(f2) * dz

      return
      end

c
c*******************************************************************************
c

      subroutine z_approx_e(sgn_kprl, zeta, gamma,
     .   z0, z1, z2, zetai_table,
     .   dKdL_table, z0_table, z1_table, z2_table,
     .   dKdL_giv, nmax, mmax, ntable, mtable)

      use z_erfc
c      use zfun_hilbert
      implicit none

*     ------------------
*     Finite k_parallel:
*     ------------------
      real gamma, fgam, y0, y, sgn_kprl, descrim
      complex zeta, z0, z1, z2, zfunct, zetat, fzeta
      complex z0_out, z1_out, z2_out
      logical :: flag
      integer :: ieer ! fft error flag
      integer nmax, mmax, ntable, mtable

      complex z0_table(ntable, mtable)
      complex z1_table(ntable, mtable)
      complex z2_table(ntable, mtable)

      real zetai_table(ntable), zetai_giv
      real dKdL_table(mtable), dKdL_giv

      y0 = 1.5
      y = y0

      if(sgn_kprl .ge. 0.0)then
         fgam = 1.0

         if(gamma .gt. 1.0e-05)then
            y = y0
            fgam = (sqrt(1. +  4. * gamma * y) - 1.)
     .         / (2. * gamma * y)
         endif

         zetat = fgam * zeta

c        zfunct = fzeta(zetat)
         call zfun (zetat, zfunct)
c        call zfun_erfc (zetat, zfunct)
c	 call zfun_hil(zetat, zfunct, flag)

         z0 = fgam * zfunct
         z1 = fgam * (1.0 + fgam * zeta * zfunct)
         z2 =  fgam**2 * zeta * (1.0 + fgam * zeta * zfunct)

      end if

      if(sgn_kprl .lt. 0.0)then
         fgam = 1.0

         if(gamma .gt. 1.0e-05)then
            descrim = 1. - 4. * gamma * y0
            if (descrim .ge. 0.0) y =   y0
            if (descrim .lt. 0.0) y = - y0
            fgam = (1. - sqrt(1. -  4. * gamma * y) )
     .         / (2. * gamma * y)
         endif

         zetat = - fgam * zeta

c         zfunct = fzeta( zetat)
         call zfun (zetat, zfunct)
c        call zfun_erfc (zetat, zfunct)
c	 call zfun_hil(zetat, zfunct, flag)

         z0 = - fgam * zfunct
         z1 = y / abs(y) * fgam * (1.0 - fgam * zeta * zfunct)
         z2 =  fgam**2 * zeta * (1.0 - fgam * zeta * zfunct)

      end if

      zetai_giv = 1.0 / real(zeta)

      call intplt_z(zetai_giv, dKdL_giv, z0_out, nmax, mmax, z0_table,
     .   ntable, mtable, zetai_table, dKdL_table)

      call intplt_z(zetai_giv, dKdL_giv, z1_out, nmax, mmax, z1_table,
     .   ntable, mtable, zetai_table, dKdL_table)

      call intplt_z(zetai_giv, dKdL_giv, z2_out, nmax, mmax, z2_table,
     .   ntable, mtable, zetai_table, dKdL_table)

      if (z0_out .ne. 0.0) z0 = z0_out
      if (z1_out .ne. 0.0) z1 = z1_out
      if (z2_out .ne. 0.0) z2 = z2_out

      return
      end

!
!********************************************************************
!

      subroutine z_approx_i(sgn_kprl, zeta, gamma,
     .   z0, z1, z2, zetai_table,
     .   dKdL_table, z0_table, z1_table, z2_table,
     .   dKdL_giv, nmax, mmax, ntable, mtable)

      use z_erfc
c      use zfun_hilbert
      implicit none

*     ------------------
*     Finite k_parallel:
*     ------------------
      real gamma, fgam, y0, y, sgn_kprl, descrim, gammad
      complex zeta, z0, z1, z2, zfunct, zetat, fzeta
      complex z0_out, z1_out, z2_out
      logical :: flag
      integer :: ieer ! fft error flag
      integer nmax, mmax, ntable, mtable

      complex z0_table(ntable, mtable)
      complex z1_table(ntable, mtable)
      complex z2_table(ntable, mtable)

      real zetai_table(ntable), zetai_giv
      real dKdL_table(mtable), dKdL_giv

      y0 = 1.5
      y = y0

      if(sgn_kprl .ge. 0.0)then
         fgam = 1.0

         if(gamma .gt. 1.0e-05)then
            y = y0
            fgam = (sqrt(1. +  4. * gamma * y) - 1.)
     .         / (2. * gamma * y)
         endif

         zetat = fgam * zeta

c        zfunct = fzeta(zetat)
         call zfun (zetat, zfunct)
c        call zfun_erfc (zetat, zfunct)
c	 call zfun_hil(zetat, zfunct, flag)

         z0 = fgam * zfunct
         z1 = fgam * (1.0 + fgam * zeta * zfunct)
         z2 =  fgam**2 * zeta * (1.0 + fgam * zeta * zfunct)

      end if

      if(sgn_kprl .lt. 0.0)then
         fgam = 1.0

         if(gamma .gt. 1.0e-05)then
            descrim = 1. - 4. * gamma * y0
            if (descrim .ge. 0.0) y =   y0
            if (descrim .lt. 0.0) y = - y0
            fgam = (1. - sqrt(1. -  4. * gamma * y) )
     .         / (2. * gamma * y)
         endif

         zetat = - fgam * zeta

c         zfunct = fzeta( zetat)
         call zfun (zetat, zfunct)
c        call zfun_erfc (zetat, zfunct)
c	 call zfun_hil(zetat, zfunct, flag)

         z0 = - fgam * zfunct
         z1 = y / abs(y) * fgam * (1.0 - fgam * zeta * zfunct)
         z2 =  fgam**2 * zeta * (1.0 - fgam * zeta * zfunct)

      end if

      return

      zetai_giv = 1.0 / real(zeta)

      call intplt_z(zetai_giv, dKdL_giv, z0_out, nmax, mmax, z0_table,
     .   ntable, mtable, zetai_table, dKdL_table)

      call intplt_z(zetai_giv, dKdL_giv, z1_out, nmax, mmax, z1_table,
     .   ntable, mtable, zetai_table, dKdL_table)

      call intplt_z(zetai_giv, dKdL_giv, z2_out, nmax, mmax, z2_table,
     .   ntable, mtable, zetai_table, dKdL_table)

      if (z0_out .ne. 0.0) z0 = z0_out
      if (z1_out .ne. 0.0) z1 = z1_out
      if (z2_out .ne. 0.0) z2 = z2_out

      return
      end

!
!********************************************************************
!
      subroutine z_integral(sgn_kprl, zeta, delta, z2)

      implicit none

      real dx, xmax, xnueff, sgn_kprl, xmax0
      integer j, npts, nmaxdim
      real x(10000), zeta_mod, delta
      complex z0, z1, z2, zi, f(10000), zeta, beta
      complex cexpx(10000)

      parameter (nmaxdim = 10000)

      zi = cmplx(0.,1.)
      xnueff = 0.0
      zeta_mod = sqrt(conjg(zeta) * zeta)

      if(zeta_mod .gt. 1.0e+03)then
         z2 = - 0.5 / zeta - 0.75 / zeta**3
         return
      else

         xmax0 = 7.0
         npts = 10000
         xmax = sgn_kprl * xmax0
         dx = xmax / (npts - 1)

*        ------------
*        calculate Z2
*        ------------

         do  j = 1, npts
            x(j) = (j-1) * dx
            beta = 1. / sqrt(1. - zi * delta * x(j)**2 )
	    cexpx(j) = exp(zi * zeta * x(j) - x(j)**2 / 4. * beta**2)
            f(j) = zi / 2.0 * (1.0 -  x(j)**2 / 2. * beta**2)
     .           * cexpx(j) * beta**3

         end do

         call dgrat1(x, f, 1, npts, z2, nmaxdim)

         return

      end if

      end

c
c*******************************************************************************
c

      subroutine z_table(sgn_kprl, zeta, gamma, xnu, z0, z1, z2)

*     ----------------------------------------------------
*     z_table is a wrapper routine for David Smithe's table
*     lookup Z function
*     ----------------------------------------------------

      implicit none

      complex, intent(inout)   :: z0, z1, z2
      complex, intent(in)    :: zeta
      real, intent(in)       :: sgn_kprl, gamma, xnu
      complex, dimension(0:4)  :: zfunc

      real alpha_s
      complex zi

      zi = cmplx(0.0, 1.0)

      alpha_s = -2.0 * gamma

      if (sgn_kprl .ge. 0.0) then

         call ztable_zfunc( real(zeta), alpha_s, xnu, zfunc )
         z0 = zfunc(0)
         z1 = - 0.5 * zfunc(1) - gamma / (2.0 * zi) * zfunc(2)
         z2 = 0.5 * zfunc(0) + 0.25 * zfunc(2)
     .      + gamma / (2.0 * zi) * zfunc(3)
     .      - gamma**2 / 4. * zfunc(4)

      else if (sgn_kprl .lt. 0.0) then

         call ztable_zfunc( - real(zeta), - alpha_s, - xnu, zfunc )
         z0 = - zfunc(0)
         z1 = - 0.5 * zfunc(1) + gamma / (2.0 * zi) * zfunc(2)
         z2 = - 0.5 * zfunc(0) - 0.25 * zfunc(2)
     .      + gamma / (2.0 * zi) * zfunc(3)
     .      + gamma**2 / 4. * zfunc(4)

      end if

      return

      end subroutine z_table

c
c*******************************************************************************
c

      subroutine z_exact(sgn_kprl, zeta, gamma, xnu, z0, z1, z2,
     .   dz0, dz1, dz2)

*     ----------------------------------------------------
*     z_exact is a wrapper routine for David Smithe's own
*     version of "z_smithe"
*     ----------------------------------------------------

      implicit none

      complex, intent(inout)   :: z0, z1, z2, dz0, dz1, dz2
      complex, intent(in)    :: zeta
      real, intent(in)       :: sgn_kprl, gamma, xnu
      complex, dimension(0:4)  :: zfunc

      real alpha_s
      complex zi

      zi = cmplx(0.0, 1.0)

      alpha_s = -2.0 * gamma

      if ( sgn_kprl .ge. 0.0 ) then

         call ztable_zfunc( real(zeta), alpha_s, xnu, zfunc )
         z0 = zfunc(0)
         z1 = - 0.5 * zfunc(1) - gamma / (2.0 * zi) * zfunc(2)
         z2 = 0.5 * zfunc(0) + 0.25 * zfunc(2)
     .      + gamma / (2.0 * zi) * zfunc(3)
     .      - gamma**2 / 4. * zfunc(4)

         dz0 = zfunc(1)
         dz1 = - 0.5 * zfunc(2) - gamma / (2.0 * zi) * zfunc(3)
c         dz2 = 0.5 * zfunc(1) + 0.25 * zfunc(3)
c     .      + gamma / (2.0 * zi) * zfunc(4)

      else if ( sgn_kprl .lt. 0.0 ) then

         call ztable_zfunc( - real(zeta), - alpha_s, - xnu, zfunc )
         z0 = - zfunc(0)
         z1 = - 0.5 * zfunc(1) + gamma / (2.0 * zi) * zfunc(2)
         z2 = - 0.5 * zfunc(0) - 0.25 * zfunc(2)
     .      + gamma / (2.0 * zi) * zfunc(3)
     .      + gamma**2 / 4. * zfunc(4)

         dz0 =  zfunc(1)
         dz1 =  0.5 * zfunc(2) - gamma / (2.0 * zi) * zfunc(3)
c         dz2 =  0.5 * zfunc(1) + 0.25 * zfunc(3)
c     .      - gamma / (2.0 * zi) * zfunc(4)

      end if

      return

      end subroutine z_exact

c
c***************************************************************************
c

      subroutine z_approx(sgn_kprl, zeta, gamma, z0, z1, z2)
      use z_erfc
c      use zfun_hilbert
      implicit none

*     ------------------
*     Finite k_parallel:
*     ------------------
      real gamma, fgam, y0, y, sgn_kprl, descrim
      complex zeta, z0, z1, z2, zfunct, zetat, fzeta
      logical :: flag
      integer :: ieer ! fft error flag

      y0 = 1.5
      y = y0

      if(sgn_kprl .ge. 0.0)then
         fgam = 1.0

         if(gamma .gt. 1.0e-05)then
            y = y0
            fgam = (sqrt(1. +  4. * gamma * y) - 1.)
     .         / (2. * gamma * y)
         endif

         zetat = fgam * zeta

c        zfunct = fzeta(zetat)
         call zfun (zetat, zfunct)
c        call zfun_erfc (zetat, zfunct)
c	 call zfun_hil(zetat, zfunct, flag)

         z0 = fgam * zfunct
         z1 = fgam * (1.0 + fgam * zeta * zfunct)
         z2 =  fgam**2 * zeta * (1.0 + fgam * zeta * zfunct)
      end if

      if(sgn_kprl .lt. 0.0)then
         fgam = 1.0

         if(gamma .gt. 1.0e-05)then
            descrim = 1. - 4. * gamma * y0
            if (descrim .ge. 0.0) y =   y0
            if (descrim .lt. 0.0) y = - y0
            fgam = (1. - sqrt(1. -  4. * gamma * y) )
     .         / (2. * gamma * y)
         endif

         zetat = - fgam * zeta

c         zfunct = fzeta( zetat)
         call zfun (zetat, zfunct)
c        call zfun_erfc (zetat, zfunct)
c	 call zfun_hil(zetat, zfunct, flag)

         z0 = - fgam * zfunct
         z1 = y / abs(y) * fgam * (1.0 - fgam * zeta * zfunct)
         z2 =  fgam**2 * zeta * (1.0 - fgam * zeta * zfunct)
      end if

      return
      end

c
c***************************************************************************
c
      subroutine z2pole(zeta, zfunct)

      complex zeta, zfunct, zi, znum
      data pi/3.141592654/
      data zi/(0.0,1.0)/
      data g/1.141592654/
      data sqpi/1.772453851/
      znum = zi*sqpi + g*zeta
      zfunct = znum/(1.0 - zeta*znum)
      return
      end
c
c******************************************************************************
c

      subroutine z_smithe(sgn_kprl, zeta, gamma, z0, z1, z2)

      implicit none

      real dx, xmax, xnueff, gamma, sgn_kprl, xmax0
      integer j, npts, nmaxdim
      real x(10000), zeta_mod
      complex z0, z1, z2, zi, f(10000), zeta
      complex cexpx(10000)

      parameter (nmaxdim = 10000)

      zi = cmplx(0.,1.)
      xnueff = 0.0
      zeta_mod = sqrt(conjg(zeta) * zeta)

      if(zeta_mod .gt. 1.0e+02)then

         z0 = - 1.0 / zeta - 0.5 / zeta**3
     .                          + 3.0 * gamma / (zi * zeta**4)
         z1 = - 0.5 / zeta**2 + gamma / (zi * zeta**3)
     .                                       - 0.75 / zeta**4
         z2 = - 0.5 / zeta - 0.75 / zeta**3
     .                          + 4.5 * gamma / (zi * zeta**4)
         return

      else

         xmax0 = 7.0
         npts = 10000
         xmax = sgn_kprl * xmax0
         dx = xmax / (npts - 1)

*        ------------
*        calculate Z0
*        ------------
         do  j = 1, npts

            x(j) = (j-1) * dx
            cexpx(j) = exp(zi * zeta * x(j)
     .         - x(j)**2 / 4. * (1. + gamma * x(j))**2
     .         - xnueff / 8. * x(j)**3   )

            f(j) = zi * cexpx(j)
         end do

         call dgrat1(x, f, 1, npts, z0, nmaxdim)

*        ------------
*        calculate Z1
*        ------------
         do  j = 1, npts
            f(j) = 0.5 * x(j)* (1.0 + gamma * x(j)) * cexpx(j)
         end do

         call dgrat1(x, f, 1, npts, z1, nmaxdim)

*        ------------
*        calculate Z2
*        ------------
         do  j = 1, npts
            f(j) = zi / 2.0 * (1.0 -  x(j)**2 / 2.
     .           * (1. + gamma * x(j))**2) * cexpx(j)
         end do

         call dgrat1(x, f, 1, npts, z2, nmaxdim)

         return

      end if

      end

c
c*******************************************************************************
c

      subroutine dgrat1(x, f, nx1, nx2, ans, nmaxdim)

      implicit none

      integer n, nx1, nx2, nmaxdim
      real x(nmaxdim), dx
      complex f(nmaxdim), ans

      ans = 0.0

      do n = nx1, nx2 - 1
         dx = x(n+1) - x(n)
         ans = ans + dx * (f(n) + f(n+1)) / 2.0
      end do

      return
      end


MODULE interp_der
!==================================================================
!Evaluate derivatives is not used any more because of the log grid
!==================================================================
     USE def_constants, ONLY: ord_spline, pr
     IMPLICIT NONE
     PRIVATE
     PUBLIC :: Lin_der, Lin_der_Log10
!
!
     CONTAINS
! ===================================================================
!
!
! ===================================================================
SUBROUTINE Lin_der(dT_dv_u, dT_du_v, dp_dv_u, dp_du_v,&
&          NNN, MMM, x_mesh,y_mesh, spline_pmin, spline_Vsat, u_in, v_in,TTT,ppp,vvv)
!
IMPLICIT NONE
!
!
REAL(pr), INTENT(OUT) :: dT_dv_u, dT_du_v, dp_dv_u, dp_du_v
REAL(pr), INTENT(IN)  :: u_in, v_in
INTEGER, INTENT(IN)  :: NNN, MMM
REAL(pr), DIMENSION(NNN), INTENT(IN)  :: y_mesh
REAL(pr), DIMENSION(MMM), INTENT(IN)  :: x_mesh
REAL(pr), DIMENSION(ord_spline+1,NNN-1), INTENT(IN) :: spline_pmin, spline_Vsat
REAL(pr), DIMENSION(NNN,MMM), INTENT(IN) :: TTT, ppp, vvv
!
!
INTEGER :: i, j
REAL(8) :: x_mesh_test, delta_u, delta_v, v_min_li, v_max_li,    &
&           T_down_left, T_down_right, T_up_left, T_up_right,    &
&           p_down_left, p_down_right, p_up_left, p_up_right,    &
&           v1, v2, v3, v4, u1, u2, a2, a3, a4, b3,              &
&  dX_dv_u, dX_du_v, dY_du_v, dT_dX_Y, dT_dY_X, dp_dX_Y, dp_dY_X
!
!
!
delta_u = y_mesh(2) - y_mesh(1)
i       = INT((u_in - y_mesh(1))/delta_u) + 1
!
IF(( i .LE. 0) .OR. (i .GE. NNN)) THEN
  print*,'In Lin_der'
  print*,'i lower than 0 or greater then NNN',i, u_in
  stop
ENDIF
!
!
v_min_li = 0_pr
v_max_li = 0_pr
!
DO j = 1, ord_spline + 1
   v_min_li =v_min_li + spline_Vsat(ord_spline+2-j,i)*u_in**(j-1)
   v_max_li =v_max_li + spline_pmin(ord_spline+2-j,i)*u_in**(j-1)
ENDDO
!
! Evaluation of x_mesh_test:
!
delta_v     = x_mesh(2) - x_mesh(1)
x_mesh_test = ((x_mesh(MMM) - x_mesh(1)) / (v_max_li - &
&                v_min_li)) * (v_in - v_min_li) + x_mesh(1)
!
j = INT((x_mesh_test - x_mesh(1))/delta_v) + 1
!
IF ((j .LT. 1) .OR. (j .GE. MMM)) THEN
   print*,'In Lin_der'
   print*, 'Error in index determination j',j
   stop
ENDIF
!
T_down_left  = TTT(i,j)
T_down_right = TTT(i,j+1)
T_up_left    = TTT(i+1,j)
T_up_right   = TTT(i+1,j+1)
!
p_down_left  = ppp(i,j)
p_down_right = ppp(i,j+1)
p_up_left    = ppp(i+1,j)
p_up_right   = ppp(i+1,j+1)
!
! Derivatives in transformed space:
!
dT_dX_Y =((T_down_right - T_down_left) +&
&         (T_up_right   + T_down_left  - T_down_right - T_up_left)*&
&         (u_in - y_mesh(i)) / delta_u )/delta_v
!
dT_dY_X =((T_up_left    - T_down_left) + &
&         (T_up_right   + T_down_left  - T_down_right - T_up_left)*&
&         (x_mesh_test - x_mesh(j)) / delta_v)/delta_u
!
dp_dX_Y =((p_down_right - p_down_left) + &
&         (p_up_right   + p_down_left  - p_down_right - p_up_left)*&
&         (u_in - y_mesh(i)) / delta_u )/delta_v
!
dp_dY_X =((p_up_left    - p_down_left) + &
&         (p_up_right   + p_down_left  - p_down_right - p_up_left)*&
&         (x_mesh_test - x_mesh(j)) / delta_v)/delta_u
!
! TRANSFORMED SPACE
!
v1 = vvv(i,   j  )
v2 = vvv(i+1, j  )
v3 = vvv(i+1, j+1)
v4 = vvv(i,   j+1)
!
u1 = y_mesh(i)
u2 = y_mesh(i+1)
!
a2 = v4-v1;  a3 = v2-v1;  a4 = v1+v3-v2-v4
b3 = u2-u1
!
dX_dv_u = delta_v / ( a2 + a4*(u_in - y_mesh(i))/delta_u )
dX_du_v =-dX_dv_u * ( a3 + a4*(x_mesh_test-x_mesh(j))/delta_v ) / b3
dY_du_v = delta_u / b3
!
! Derivatives in physical space:
!
dT_dv_u = dX_dv_u * dT_dX_Y
dT_du_v = dX_du_v * dT_dX_Y + dY_du_v * dT_dY_X
!
dp_dv_u = dX_dv_u * dp_dX_Y
dp_du_v = dX_du_v * dp_dX_Y + dY_du_v * dp_dY_X
print*, dX_du_v * dp_dX_Y , dY_du_v * dp_dY_X, dp_du_v
!
IF ( (dT_dv_u /= dT_dv_u) .OR.&
&    (dT_du_v /= dT_du_v) .OR.&
&    (dp_dv_u /= dp_dv_u) .OR.&
&    (dp_du_v /= dp_du_v) )THEN
   print*, 'dT_dv_u',dT_dv_u
   print*, 'dT_du_v',dT_du_v
   print*, 'dp_dv_u',dp_dv_u
   print*, 'dp_du_v',dp_du_v
   STOP
ENDIF
!
END SUBROUTINE Lin_der
!
!
! ===================================================================
!
!
! ===================================================================
!
SUBROUTINE Lin_der_Log10(dT_dv_u, dT_du_v, dp_dv_u, dp_du_v,&
&          NNN, MMM, x_mesh,y_mesh, spline_pmin, spline_Vsat, u_in, v_in,TTT,ppp,vvv)
!
IMPLICIT NONE
!
!
REAL(pr), INTENT(OUT) :: dT_dv_u, dT_du_v, dp_dv_u, dp_du_v
REAL(pr), INTENT(IN)  :: u_in, v_in
INTEGER, INTENT(IN)  :: NNN, MMM
REAL(pr), DIMENSION(NNN), INTENT(IN)  :: y_mesh
REAL(pr), DIMENSION(MMM), INTENT(IN)  :: x_mesh
REAL(pr), DIMENSION(MMM)  :: vlog
REAL(pr), DIMENSION(ord_spline+1,NNN-1), INTENT(IN) :: spline_pmin, spline_Vsat
REAL(pr), DIMENSION(NNN,MMM), INTENT(IN) :: TTT, ppp, vvv
!
!
INTEGER :: i, j
REAL(8) :: x_mesh_test, delta_u, delta_v, v_min_li, v_max_li,    &
&           T_down_left, T_down_right, T_up_left, T_up_right,    &
&           p_down_left, p_down_right, p_up_left, p_up_right,    &
&           v1, v2, v3, v4, u1, u2, a2, a3, a4, b3,              &
&  dX_dv_u, dX_du_v, dY_du_v, dT_dX_Y, dT_dY_X, dp_dX_Y, dp_dY_X
!
!
!
delta_u = y_mesh(2) - y_mesh(1)
i       = INT((u_in - y_mesh(1))/delta_u) + 1
!
IF(( i .LE. 0) .OR. (i .GE. NNN)) THEN
  print*,'In Lin_der'
  print*,'i lower than 0 or greater then NNN',i, u_in
  stop
ENDIF
!
!
v_min_li = 0_pr
v_max_li = 0_pr
!
DO j = 1, ord_spline + 1
   v_min_li =v_min_li + spline_Vsat(ord_spline+2-j,i)*u_in**(j-1)
   v_max_li =v_max_li + spline_pmin(ord_spline+2-j,i)*u_in**(j-1)
ENDDO
!
! Evaluation of x_mesh_test:
!
delta_v     = x_mesh(2) - x_mesh(1)
x_mesh_test = ((x_mesh(MMM) - x_mesh(1)) / (LOG10(v_max_li) - LOG10(v_min_li)))&
&* (LOG10(v_in) - LOG10(v_min_li)) +  x_mesh(1)
!

j = INT((x_mesh_test - x_mesh(1))/delta_v) + 1
!
IF ((j .LT. 1) .OR. (j .GE. MMM)) THEN
   print*,'In Lin_der'
   print*, 'Error in index determination j',j
   stop
ENDIF
!
T_down_left  = TTT(i,j)
T_down_right = TTT(i,j+1)
T_up_left    = TTT(i+1,j)
T_up_right   = TTT(i+1,j+1)
!
p_down_left  = ppp(i,j)
p_down_right = ppp(i,j+1)
p_up_left    = ppp(i+1,j)
p_up_right   = ppp(i+1,j+1)
!
! Derivatives in transformed space:
!
dT_dX_Y =((T_down_right - T_down_left) +&
&         (T_up_right   + T_down_left  - T_down_right - T_up_left)*&
&         (u_in - y_mesh(i)) / delta_u )/delta_v
!
dT_dY_X =((T_up_left    - T_down_left) + &
&         (T_up_right   + T_down_left  - T_down_right - T_up_left)*&
&         (x_mesh_test - x_mesh(j)) / delta_v)/delta_u
!
dp_dX_Y =((p_down_right - p_down_left) + &
&         (p_up_right   + p_down_left  - p_down_right - p_up_left)*&
&         (u_in - y_mesh(i)) / delta_u )/delta_v
!
dp_dY_X =((p_up_left    - p_down_left) + &
&         (p_up_right   + p_down_left  - p_down_right - p_up_left)*&
&         (x_mesh_test - x_mesh(j)) / delta_v)/delta_u
!
! TRANSFORMED SPACE
!
v1 = LOG10(vvv(i,   j  ))
v2 = LOG10(vvv(i+1, j  ))
v3 = LOG10(vvv(i+1, j+1))
v4 = LOG10(vvv(i,   j+1))
!
u1 = y_mesh(i)
u2 = y_mesh(i+1)
!
a2 = v4-v1;  a3 = v2-v1;  a4 = v1+v3-v2-v4
b3 = u2-u1
!
!dX_dv_u = delta_v / ( a2 + a4*(u_in - y_mesh(i))/delta_u )
dX_dv_u = delta_v / ( a2 + a4*(u_in - y_mesh(i))/delta_u ) / (vvv(i,j)*2.302585)
dX_du_v =-dX_dv_u * ( a3 + a4*(x_mesh_test-x_mesh(j))/delta_v ) / b3
dY_du_v = delta_u / b3
!
! Derivatives in physical space:
!
dT_dv_u = dX_dv_u * dT_dX_Y
dT_du_v = dX_du_v * dT_dX_Y + dY_du_v * dT_dY_X
dp_dv_u = dX_dv_u * dp_dX_Y
dp_du_v = dX_du_v * dp_dX_Y + dY_du_v * dp_dY_X
!
print*, dX_du_v * dp_dX_Y , dY_du_v * dp_dY_X, dp_du_v
IF ( (dT_dv_u /= dT_dv_u) .OR.&
&    (dT_du_v /= dT_du_v) .OR.&
&    (dp_dv_u /= dp_dv_u) .OR.&
&    (dp_du_v /= dp_du_v) )THEN
   print*, 'dT_dv_u',dT_dv_u
   print*, 'dT_du_v',dT_du_v
   print*, 'dp_dv_u',dp_dv_u
   print*, 'dp_du_v',dp_du_v
   STOP
ENDIF
!
END SUBROUTINE Lin_der_Log10
!
END MODULE interp_der


!	Obtain mean item scale parameters for an observation.
!	numcat is a vector with the number of
!		underlying categories per item.
!	The items presented are indicated by mask.
!	The underlying item probabilities are in probcat.
!	scales contains the scale parameters.
function mean(numcat,mask,probcat,scales)
implicit none
integer,intent(in)::numcat(:)
logical,intent(in)::mask(:)
real(kind=8),intent(in)::probcat(:),scales(:,:)
real(kind=8)::mean(size(scales,1),size(mask))
!	item is the item number. nloc points to the item probability.
integer::item,nloc

nloc=1
do item=1,size(mask)
	if(mask(item))then
		mean(:,item)=matmul(scales(:,nloc:nloc+numcat(item)-1),probcat(nloc:nloc+numcat(item)-1))
	end if
	nloc=nloc+numcat(item)
end do
return
end function mean


        program test_nint
          integer, dimension(5,5) :: arr
          integer :: i, j
          do i = 1, 5
            do j = 1, 5
              arr(i,j) = i+j     ! initialize the array
            end do
          end do
          print *, nint(arr)
        end program test_nint


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc               mnpasu : parsur test program                         cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real u(21),v(11),f(693),tu(27),tv(17),c(900),wrk(2000),z(693),
     * wk(128)
      integer iwrk(80),iw(32),ipar(2)
      real ai,fp,s
      integer kwrk,lwrk,m,mu,mv,j0,j1,j2,j3,nc,nu,nuest,nv,nvest,
     * i,idim,ier,is,iopt,j,l
c  we generate the u-coordinates of the grid.
      mu = 21
      do 10 i=1,mu
        u(i) = i-1
  10  continue
c  we generate the v-coordinates of the grid.
      mv = 11
      do 20 i=1,mv
        v(i) = u(2*i-1)
  20  continue
c  the dimension of the surface
      idim = 3
c  we fetch and print the surface co-ordinates at the grid points
      write(6,900)
      write(6,905) (v(i),i=1,mv)
      write(6,910)
      m = mu*mv
      j0 = 0
      do 40 i=1,mu
        write(6,915) u(i)
        j1 = j0
        do 30 l=1,idim
          j2 = j1+1
          j3 = j1+mv
          read(5,920) (f(j),j=j2,j3)
          write(6,925) (f(j),j=j2,j3)
          j1 = j1+m
  30    continue
        j0 = j0+mv
  40  continue
c  we set up the dimension information
      nuest = 27
      nvest = 17
      lwrk = 2000
      kwrk = 80
c  main loop for the different spline approximations
      do 300 is=1,4
        go to (110,120,130,140),is
c  a smoothing surface with no periodicity conditions
 110    iopt = 0
        s = 0.07
        ipar(1) = 0
        ipar(2) = 0
        go to 200
c  a smoothing surface periodic in the v-variable
 120    ipar(2) = 1
        go to 200
c  a smoothing surface periodic in both variables
 130    ipar(1) = 1
        go to 200
c  finally we also calculate a least-squares spline surface
c  with specified knots.
 140    iopt = -1
        nu = 11
        nv = 11
        j = 5
        do 150 i=1,3
          ai = 5*i
          tu(j) = ai
          tv(j) = tu(j)
          j = j+1
 150    continue
c  determination of the spline surface.
 200    call parsur(iopt,ipar,idim,mu,u,mv,v,f,s,nuest,
     *   nvest,nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c  printing of the fitting results.
        if(iopt.ge.0) go to 210
        write(6,935) ipar(1),ipar(2)
        go to 220
 210    write(6,940) ipar(1),ipar(2)
        write(6,945) s
 220    write(6,950) fp,ier
        write(6,955) nu
        write(6,960)
        write(6,965) (tu(i),i=1,nu)
        write(6,970) nv
        write(6,960)
        write(6,965) (tv(i),i=1,nv)
        nc = (nu-4)*(nv-4)
        write(6,975)
        j1 = 0
        do 230 l=1,idim
          j0 = j1+1
          j1 = j1+nc
          write(6,980) (c(j),j=j0,j1)
 230    continue
c  evaluation of the spline surface.
        call surev(idim,tu,nu,tv,nv,c,u,mu,v,mv,z,693,
     *   wk,128,iw,32,ier)
        write(6,985)
        write(6,905) (v(i),i=1,mv,2)
        write(6,910)
        j0 = 0
        do 250 i=1,mu,4
          write(6,915) u(i)
          j1 = j0
          do 240 l=1,idim
            j2 = j1+1
            j3 = j1+mv
            write(6,925) (z(j),j=j2,j3,2)
            j1 = j1+m
 240      continue
          j0 = j0+mv*4
 250    continue
 300  continue
      stop
c  format statements.
 900  format(15h1the input data)
 905  format(1h0,2x,1hv,11(3x,f4.1))
 910  format(1h ,1x,1hu)
 915  format(1h ,f4.1)
 920  format(11f7.3)
 925  format(5x,11f7.3)
 935  format(37h0least-squares surface of periodicity,2i3)
 940  format(33h0smoothing surface of periodicity,2i3)
 945  format(20h smoothing factor s=,f8.2)
 950  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i3)
 955  format(1x,42htotal number of knots in the u-direction =,i3)
 960  format(1x,22hposition of the knots )
 965  format(5x,10f6.2)
 970  format(1x,42htotal number of knots in the v-direction =,i3)
 975  format(23h0b-spline coefficients )
 980  format(5x,8f9.4)
 985  format(1h0,37hspline values at selected grid points)
      end


subroutine area_ave (nlat_i , nlon_i , numlon_i, fld_i , &
                     nlat_o , nlon_o , numlon_o, fld_o , &
                     i_ovr  , j_ovr  , w_ovr   , nmax  )

  use precision

  implicit none
! ------------------------ code history ---------------------------
! source file:       area_ave.F
! purpose:           area averaging of field from input to output grids
! date last revised: November 1996
! author:            Gordon Bonan
! standardized:
! reviewed:
! -----------------------------------------------------------------

! ------------------- input variables -----------------------------
  integer nlat_i   ! number of latitude points for input grid
  integer nlat_o   ! number of latitude points for output grid
  integer nlon_i   ! maximum number of longitude points for input grid
  integer nlon_o   ! maximum number of longitude points for output grid
  integer nmax     ! maximum number of overlapping cells
  integer numlon_i(nlat_i)  ! input grid number of lon points at each lat
  integer numlon_o(nlat_o)  ! input grid number of lon points at each lat
  integer i_ovr(nlon_o,nlat_o,nmax)  ! lon index, overlapping input cell
  integer j_ovr(nlon_o,nlat_o,nmax)  ! lat index, overlapping input cell

  real(r8) fld_i(nlon_i,nlat_i) !field for input grid
  real(r8) w_ovr(nlon_o,nlat_o,nmax)  ! overlap weights for input cells
! -----------------------------------------------------------------

! ------------------- output variables ----------------------------
  real(r8) fld_o(nlon_o,nlat_o) !field for output grid
! -----------------------------------------------------------------

! ------------------- local variables -----------------------------
  integer jo,ji             !latitude index for output,input grids
  integer io,ii             !longitude index for output,input grids
  integer n                 !overlapping cell index
! -----------------------------------------------------------------

  do jo = 1, nlat_o
    do io =1, numlon_o(jo)
      fld_o(io,jo) = 0.
    end do
  end do

  do n = 1, nmax
    do jo = 1, nlat_o
      do io =1, numlon_o(jo)
        ii = i_ovr(io,jo,n)
        ji = j_ovr(io,jo,n)
        fld_o(io,jo) = fld_o(io,jo) + w_ovr(io,jo,n)*fld_i(ii,ji)
      end do
    end do
  end do

  return
end subroutine area_ave


#include "scalar.fpp"
!=====================================================================!
! Backward Difference Formula Integration Module for first and second
! order systems with adjoint derivative capabilities.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module bdf_integrator

  use integrator_class, only : integrator
  use physics_class,    only : physics

  implicit none

  private
  public :: BDF

  !===================================================================!
  ! A derived type for the bdf coefficients
  !===================================================================!

  type :: bdf_coeff

     ! Information
     integer                               :: max_order = 3

     ! Coeff values
     type(scalar)                              :: alpha
     type(scalar), dimension(:,:), allocatable :: beta
     type(scalar), dimension(:,:), allocatable :: gamma

   contains

     private

     procedure :: destruct
     procedure :: getOrder

  end type bdf_coeff

  ! Interface for the constructor of bdf_coeff type
  interface bdf_coeff
     module procedure construct_bdf_coeff
  end interface bdf_coeff

  !===================================================================!
  ! BDF Integrator type
  !===================================================================!

  type, extends(integrator) :: BDF

     ! BDF variables
     integer            :: max_bdf_order = 3
     type(bdf_coeff)    :: coeff

     type(scalar), dimension(:,:), allocatable :: rhsbin

   contains

     ! Destructor
     procedure, public  :: finalize

     ! Routines for integration
     procedure, private :: approximateStates
     procedure, private :: getLinearCoeff

     ! Routines for adjoint gradient

     procedure, public  :: marchBackwards
     procedure, private :: evaluate_adjoint
     procedure, private :: distribute_contributions

     procedure, private :: assembleRHS
     procedure          :: computeTotalDerivative

  end type BDF

  ! Constructor for BDF type
  interface BDF
     module procedure initialize
  end interface BDF

contains

  !===================================================================!
  ! Constructor for BDF coeff object
  !===================================================================!

  type(bdf_coeff) function construct_bdf_coeff( max_order ) result( this )

    integer, intent(in), OPTIONAL :: max_order

    if( present(max_order) ) then
       this % max_order = max_order
    end if

    allocate( this % beta (0:this % max_order, this % max_order + 1) )
    this % beta = 0.0d0

    allocate( this % gamma (0:this % max_order, 2*this % max_order + 1) ) ! 2m + 1
    this % gamma = 0.0d0

    ! Set the coefficients

    this % alpha = 1.0d0
    this % gamma(0, 1:1) = 1.0d0

    if (this % max_order .eq. 3) then

       this % beta (1, 1:2) = (/ 1.0, -1.0 /)
       this % beta (2, 1:3) = (/ 1.5d0, -2.0d0, 0.5d0 /)
       this % beta (3, 1:4) = (/ 35.d0/24.0d0, -15.d0/8.0d0, 3.0d0/8.0d0, 1.0d0/24.0d0 /)

       this % gamma(1, 1:3) = (/ 1.0d0, -2.0d0, 1.0d0 /)
       this % gamma(2, 1:5) = (/ 2.25d0, -6.0d0, 5.5d0, -2.0d0, 0.25d0 /)
       this % gamma(3, 1:7) = (/ 2.126736d0, -5.468750d0, 4.609375d0, &
            & -1.284722d0, -0.015625d0, 0.031250d0, 0.001736d0 /)

    else if (this % max_order .eq. 2) then

       this % beta (1, 1:2) = (/ 1.0, -1.0 /)
       this % beta (2, 1:3) = (/ 1.5d0, -2.0d0, 0.5d0 /)

       this % gamma(1, 1:3) = (/ 1.0d0, -2.0d0, 1.0d0 /)
       this % gamma(2, 1:5) = (/ 2.25d0, -6.0d0, 5.5d0, -2.0d0, 0.25d0 /)

    else if (this % max_order .eq. 1) then

       this % beta (1, 1:2) = (/ 1.0, -1.0 /)
       this % gamma(1, 1:3) = (/ 1.0d0, -2.0d0, 1.0d0 /)
    else
       print *,  "Wrong max_bdf_order:", this % max_order
       stop
    end if

  end function construct_bdf_coeff

  !===================================================================!
  ! Destructor for BDF coeff object
  !===================================================================!

  subroutine destruct( this )

    class(bdf_coeff) :: this

    if ( allocated(this % beta) ) deallocate(this % beta)
    if ( allocated(this % gamma) ) deallocate(this % gamma)

  end subroutine destruct

  !===================================================================!
  ! Returns the linearization scalar coefficients: alpha, beta, gamma
  !===================================================================!

  subroutine getLinearCoeff( this, alpha, beta, gamma )

    class(BDF) :: this
    type(scalar), intent(out)   :: alpha, beta, gamma
    integer :: k

    k = this % current_step

    if ( this % second_order ) then
       gamma = this % coeff % gamma(this % coeff % getOrder(k, 2), 1)/this % h/this % h
    else
       gamma = 0.0d0
    end if
    beta  = this % coeff % beta(this % coeff % getOrder(k,1), 1)/this % h
    alpha = this % coeff % alpha

  end subroutine getLinearCoeff

  !===================================================================!
  ! Approximate the state variables at each step using BDF formulae
  !===================================================================!

  subroutine approximateStates( this )

    class(BDF) :: this
    integer    :: k, m, i

    k = this % current_step

    !-----------------------------------------------------------------!
    ! Extrapolate U to next time step
    !-----------------------------------------------------------------!

    this % u(k,:) = this % u(k-1,:) + this % udot(k-1,:)*this % h &
         & + this % uddot(k-1,:)*this % h*this % h/2.0d0

    !-----------------------------------------------------------------!
    ! Approximate UDOT using BDF
    !-----------------------------------------------------------------!

    m = this % coeff % getOrder(k, 1)

    do i = 1, m + 1
       this % udot(k,:) = this % udot(k,:) &
            & + this % coeff % beta(m, i)*this % u(k-i+1,:)/this % h
    end do

    !-----------------------------------------------------------------!
    ! Approximate UDDOT using BDF
    !-----------------------------------------------------------------!

    m = this % coeff % getOrder(k, 2)

    if ( m .eq. 0) then

       ! We dont have enought points yet
       this % uddot(k,:) = (this % udot(k,:) - this % udot(k-1,:))/this % h

    else

       do i = 1, 2*m + 1
          this % uddot(k,:) = this % uddot(k,:) &
               & + this % coeff % gamma(m, i)*this % u(k-i+1,:)/this % h/this % h
       end do

    end if

  end subroutine approximateStates

  !===================================================================!
  ! Returns the order of approximation for the given time step k and
  ! degree d
  !===================================================================!

  pure integer function getOrder(this, k, d )

    class(bdf_coeff), intent(in)    :: this
    integer, intent(in)             :: k, d

    ! find the order of approximation
    getOrder = (k-1)/d  ! k = md + 1

    ! Do not let exceed the max order sought
    if ( getOrder .gt. this % max_order ) getOrder = this % max_order

  end function getOrder

  !===================================================================!
  ! Compute the total derivative of the function with respect to the
  ! design variables and return the gradient
  !===================================================================!

  subroutine computeTotalDerivative( this, dfdx )

    class(BDF)                                 :: this
    type(scalar) , dimension(:), intent(inout) :: dfdx
    type(scalar) , allocatable, dimension(:,:) :: dRdX
    type(scalar)                               :: scale = 1.0d0
    integer                                    :: k

    if (.not.allocated(dRdX)) allocate(dRdX(this % nSVars, this % nDVars))

    dRdX = 0.0d0
    dfdx = 0.0d0

    !-----------------------------------------------------------------!
    ! Compute dfdx
    !-----------------------------------------------------------------!

    do k = 2, this % num_steps
       call this % system % func % addFuncDVSens(dfdx, scale, this % time(k), &
            & this % system % x, this % u(k,:), this % udot(k,:), this % uddot(k,:) )
    end do

    ! Initial condition
!!$    call this % system % func % addFuncDVSens(dfdx, scale, this % time(1), &
!!$         & this % system % x, this % u(1,:), this % udot(1,:), this % uddot(1,:) )

    !-----------------------------------------------------------------!
    ! Compute the total derivative
    !-----------------------------------------------------------------!

    do k = 2, this % num_steps
       call this % system % getResidualDVSens(dRdX, scale, this % time(k), &
            & this % system % x, this % u(k,:), this % udot(k,:), this % uddot(k,:))
       dfdx = dfdx + matmul(transpose(dRdX),this % mu(k,:)) ! same as {mu}, [dRdX]
    end do

!!$    ! Add constraint contribution
!!$    call this % system % getResidualDVSens(dRdX, scale, this % time(1), &
!!$         & this % system % x, this % u(1,:), this % udot(1,:), this % uddot(1,:))
!!$    dfdx = dfdx + matmul(this % psi(2,:), dRdX)

    ! Finally multiply by the scalar
    dfdx = this % h * dfdx

    if (allocated(dRdX)) deallocate(dRdX)

  end subroutine computeTotalDerivative

  !===================================================================!
  ! Initialize the BDF datatype and allocate required variables
  !===================================================================!

  type(bdf) function initialize( system, tinit, tfinal, h, second_order, max_bdf_order )  result (this)

    class(physics), target          :: system
    integer  , OPTIONAL, intent(in) :: max_bdf_order
    real(dp) , OPTIONAL, intent(in) :: tinit, tfinal
    real(dp) , OPTIONAL, intent(in) :: h
    logical  , OPTIONAL, intent(in) :: second_order

    print *, "======================================"
    print *, ">>   Backward Difference Formula    << "
    print *, "======================================"

    call this % construct(system, tinit, tfinal, h, second_order)

    !-----------------------------------------------------------------!
    ! Set the order of integration
    !-----------------------------------------------------------------!

    if (present(max_bdf_order)) then
       this % max_bdf_order = max_bdf_order
    end if
    print '("  >> Max BDF Order          : ",i4)', this % max_bdf_order

    !-----------------------------------------------------------------!
    ! Create the BDF-coeff object
    !-----------------------------------------------------------------!

    this % coeff = bdf_coeff(this % max_bdf_order)

    !-----------------------------------------------------------------!
    ! Setup adjoint RHS
    !-----------------------------------------------------------------!

    allocate(this % rhs(this % nsvars))
    this % rhs = 0.0d0

    allocate(this % rhsbin(this % num_steps, this % nsvars))
    this % rhsbin = 0.0d0

  end function initialize

  !===================================================================!
  ! Deallocate the allocated variables
  !===================================================================!

  subroutine finalize( this )

    class(BDF) :: this

    call this % destruct()

    ! call the BDF coeff destructor
    call this % coeff % destruct()

    if (allocated(this % rhs)) deallocate(this % rhs)
    if (allocated(this % rhsbin)) deallocate(this % rhsbin)

  end subroutine finalize

  !===================================================================!
  ! Subroutine that marches backwards in time to compute the Lagrange
  ! multipliers (adjoint variables for the function)
  !===================================================================!

  subroutine marchBackwards( this )

    class(BDF)    :: this
    type(integer) :: k

    time: do k = this % num_steps, 2, -1

       this % current_step = k

       !--------------------------------------------------------------!
       ! Solve the adjoint equation at each step
       !--------------------------------------------------------------!

       call this % evaluate_adjoint(this % mu, this % psi, this % phi)

       !--------------------------------------------------------------!
       ! Drop the contributions from this step to corresponding bins
       !--------------------------------------------------------------!

       call this % distribute_contributions(this % rhsbin)

    end do time

  end subroutine marchBackwards

  !===================================================================!
  ! Function that puts together the right hand side of the adjoint
  ! equation into the supplied rhs vector.
  !===================================================================!

  subroutine assembleRHS( this, rhs )

    class(BDF)                                :: this
    type(scalar), dimension(:), intent(inout) :: rhs
    type(scalar), dimension(:,:), allocatable :: jac
    type(scalar)                              :: scale
    integer                                   :: k, i, m1, m2, idx
    type(scalar)                              :: alpha, beta, gamma

    ! Retrieve the current time index
    k = this % current_step

    ! Replace from rhsbin for this step (contains k+ terms)
    rhs = this % rhsbin(k,:)

    ! Coefficients
    call this % getLinearCoeff(alpha, beta, gamma)

    ! Add the state variable sensitivity from the previous step
    call this % system % func % addFuncSVSens(rhs, &
         & alpha, beta, gamma, &
         & this % time(k), &
         & this % system % X, &
         & this % u(k,:), &
         & this % udot(k,:), &
         & this % uddot(k,:))

    ! Negate the RHS
    rhs = - rhs

  end subroutine assembleRHS

  !===================================================================!
  ! Evaluates the adjoint variable values at the current step
  !===================================================================!

  subroutine evaluate_adjoint(this, mu, psi, phi)

    class(BDF)                   :: this
    type(integer)                :: k
    type(scalar)                 :: alpha, beta, gamma
    type(scalar), dimension(:,:) :: mu, psi, phi

    ! Retrive the current step number
    k = this % current_step

    ! Evaluate PHI (no linear solution necessary)
    phi(k,:) = 0.0d0

    ! Evaluate PSI (no linear solution necessary)
    psi(k,:) = 0.0d0

    ! Evaluate MU
    call this % getLinearCoeff(alpha, beta, gamma)

    call this % adjointSolve(mu(k,:), &
         & alpha, beta, gamma, &
         & this % time(k), &
         & this % u(k,:), this % udot(k,:), this % uddot(k,:))

  end subroutine evaluate_adjoint

  !===================================================================!
  ! Add contributions from kth step to k- steps
  !===================================================================!

  subroutine distribute_contributions(this, rhsbin)

    class(BDF)                   :: this
    type(integer)                :: k, p1, p2, i
    type(scalar)                 :: alpha, beta, gamma
    type(scalar), dimension(:,:) :: rhsbin

    ! Retrive the current step number
    k = this % current_step

    ! Determine the order of approximation of differential states
    p1 = this % coeff % getOrder(k, 1)
    p2 = this % coeff % getOrder(k, 2)

    !-----------------------------------------------------------------!
    ! Add contributions from k to k- RHSBIN
    !-----------------------------------------------------------------!

    do i = 2, p1+1

       ! Coefficients
       alpha = 0.0d0
       beta  = this % coeff % beta(p1, i)/this % h
       gamma = 0.0d0

       call this % addFuncResAdjPdt(rhsbin(k-i+1,:), &
            & alpha, beta, gamma, this % time(k), &
            & this % u(k,:), this % udot(k,:), this % uddot(k,:), &
            & this % mu(k,:))

    end do

    do i = 2, 2*p2+1

       ! Coefficients
       alpha = 0.0d0
       beta  = 0.0d0
       gamma = this % coeff % gamma(p2, i)/this % h/this % h

       call this % addFuncResAdjPdt(rhsbin(k-i+1,:), &
            & alpha, beta, gamma, this % time(k), &
            & this % u(k,:), this % udot(k,:), this % uddot(k,:), &
            & this % mu(k,:))

    end do

  end subroutine distribute_contributions

end module bdf_integrator


!!The model here is V=lambda/4 phi^4 + 1/2 g^2 phi^2 chi^2 (default model in LatticeEasy and DEFROST, see hep-ph 9705347)

module model
  use define_fields
  implicit none

#include "configure.h"
!!*******************define the couplings etc. for your model *************
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!!the predefined constants that you can use: GeV, MPl (the reduced Planck Mass), PlanckMass (the Planck Mass), Mplsq (square of the reduced Planck Mass)
  real(dl):: lambda = 7.18d-14
  real(dl):: kappa = MPl * 1.94d-12
  real(dl):: m = MPl * 6.82d-6
  real(dl):: j = 47998.
!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

!!***************define macros here;************************
!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
#define PHI f(1)
#define CHI f(2)
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

!!***************** define initial conditions ******************************
!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!!HLattice always treat the first field as the inflaton \phi.
!!To be self consistent you may want to get the background \phi and \dot\phi by solving the background equations from inflation. HLattice will do that for you.
!!Just define where you want to start the background evolution. Note this is NOT where you start the lattice simulation, which is defined in a subroutine "start_box_simulation" in this file.
 !!initial field values
  real(dl),dimension(ns)::init_fields=(/ &
       1.358d0 * MPl, 0._dl &
       /)

!!Initial field momenta
 !! if set to be greater than or equal to Mplsq (square of reduced Planck Mass), the initial field momenta will be determined by slow-roll inflationary attractor
  !! Note again these are NOT the initial field momenta where you start the lattice simulation, the are the initial values that HLattice take to evolve the inflaton.
  real(dl),dimension(ns):: init_momenta = Mplsq

!!put initial random Gaussian perturbations in the fields when you starts lattice simulation;
!!the amplitude of fluctuations are defined in subroutine model_Power
  logical,dimension(ns)::do_init = (/ .true., .true. /)

!!Important note: init_fields and init_momenta will be changed after the initialization. After the subroutine init() is called, they will equal to the the fields and field momenta AT THE BEGINNING OF LATTICE SIMULATION. In addition, the Hubble parameter at the beginning of lattice simulation will be saved to a global variable "init_Hubble".
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

contains

!! the potential of the scalar fields
  function potential(f)
    real(dl) f(ns)
    real(dl) potential
    potential = (lambda/4.d0) * PHI**4 - (2.d0 * kappa/3.d0) * PHI**3 + ((m**2)/2.d0) * PHI**2 + ((lambda/4.d0) * (j + 2.d0) * (j + 3.d0) * PHI**2 - kappa * (j + 2.d0) * PHI + (m**2)/2.d0) * CHI**2
  end function potential

!! the derivative of pential w.r.t. to the fields
!! return an array (dV/df1, dV/df2, ...)
  function dVdf(f)
    real(dl) f(ns)
    real(dl),dimension(ns):: dVdf
    dVdf = (/ &
         lambda * PHI**3 - (2.d0 * kappa) * PHI**2 + (m**2) * PHI + ((lambda/2.d0) * (j + 2.d0) * (j + 3.d0) * PHI - kappa * (j + 2.d0)) * CHI**2 ,   &
         2.d0 * ((lambda/4.d0) * (j + 2.d0) * (j + 3.d0) * PHI**2 - kappa * (j + 2.d0) * PHI + (m**2)/2.d0) * CHI &
         /)
  end function dVdf

!!d^2 V / d f_{fld}^2,, here fld can be 1,2,..., ns
  function mass_sq(f,fld)
    real(dl) f(ns)
    real(dl):: mass_sq
    integer fld
    select case(fld)
    case(1)
       mass_sq = 3.d0 * lambda * PHI**2 - (4.d0 * kappa) * PHI + m**2 + ((lambda/2.d0) * (j + 2.d0) * (j + 3.d0)) * CHI**2
    case(2)
       mass_sq = 2.d0 * ((lambda/4.d0) * (j + 2.d0) * (j + 3.d0) * PHI**2 - kappa * (j + 2.d0) * PHI + (m**2)/2.d0)
    case default
       stop "wrong argument fld in mass_sq"
    end select
  end function mass_sq

!!define the condition to start box simulation
  function start_box_simulation(f,p)
    logical start_box_simulation
    real(dl),dimension(ns)::f,p
    start_box_simulation = mass_sq(f, 2) .lt. 1.e-8*Mplsq
    !!start_box_simulation = (p(1) + sqrt((sum(p**2)/2.+potential(f))/3.)/Mpl*f(1) .lt. 0.)
    !!LATTICEEASY initial condition

    !!start_box_simulation = (sum(p**2) .ge. potential(f) )
    !!i.e. epsilon = 1 (the end of inflation)

    !! or starting much later is actually ok, you can still catch the main dynamics
    !!    start_box_simulation = (sum(p**2) / 2. + potential(f) .lt. (0.35e-9_dl*Mplsq)**2)
  end function start_box_simulation

!!define the time step; you will get significant error if you use physical time and 2nd order integrator (the integrator is chosen in configure.h)
!!I strongly recommend you use conformal time for this model, for which a second order integrator will do ok (if metric perturbs are off)
  function model_dt_per_step()
    real(dl) model_dt_per_step
!!to capture the rapid oscillations of the chi field
    model_dt_per_step = metric%dx/2048._dl
  end function model_dt_per_step

!!return an array (|f_k|^2, |f'_k|^2) for fields initialization.
!!remember always set them to be zero for k=0.
  function model_Power(fld,k)
    real(dl),dimension(2):: model_Power
    real(dl) k,omega
    integer(IB) fld
    omega=k**2+mass_sq(init_fields,fld)
    if(n*k*metric%dx .lt. const_pi .or. omega.lt.0.) then
       model_Power =0._dl
       return
    endif
    omega=sqrt(omega)
    if(omega.gt.Init_Hubble)then
       !!put in 1/2 particle per phase space volume
       !!note this is just an approximation. If you care about time scale of one or two oscillations. The quantum->classical transition should be calculated analytically.
       model_Power(1) = 0.5_dl/omega
       model_Power(2) = 0.5_dl*omega
       return
    endif
    model_Power = 0._dl
    return
  end function model_Power

!!model outputs
  subroutine model_output(i)
    !! i = 1; called before initialization
    !! i = 2; called after initialization
    !! i = 3; called in output_to_screen()
    !! i = 4; called at the end of simulation
    integer(IB) i
    type(file_pointer) fp
    select case(i)
    case(1)
    case(2)
       fp = open_file("data/"//trim(run_name)//"_model.info", "w")
       write(fp%unit,*) "V = lambda/4 phi^4 + g^2/2 chi^2 phi^2"
       write(fp%unit,*) "reduced Planck Mass M_p = ", Mpl
       !!write(fp%unit,*) "lambda = ",lambda
       !!write(fp%unit,*) "g^2 = ", g2l*lambda
       write(fp%unit,*) "n = ",n
       write(fp%unit,*) "dx=",metric%dx
       write(fp%unit,*) "Initial fields values:", Init_fields
       write(fp%unit,*) "Initial momenta:", Init_momenta
       write(fp%unit,*) "Initial mass (/M_p):", sqrt(mass_sq(init_fields, 1))/Mpl, sqrt(mass_sq(init_fields, 2))/Mpl
       write(fp%unit,*) "effective k_min / Hubble = ", k_unit/metric%physdx/Init_Hubble
       write(fp%unit,*) "effective k_max / Hubble = ", fft_numk*k_unit/metric%physdx/Init_Hubble
       call close_file(fp)
       write(*,*) "effective k_min / Hubble = ", k_unit/metric%physdx/Init_Hubble
       write(*,*) "effective k_max / Hubble = ", fft_numk*k_unit/metric%physdx/Init_Hubble
    case(3)
    case(4)
    case default
       write(*,*) "Unknow option in model_output"
       stop
    end select
  end subroutine model_output

end module model