program Faddeeva_w_test
    use faddeeva_fortran_interface, only: Faddeeva_w, find_relerr, dp
    ! -----------------------------------------------------------------------
    implicit none
    complex(dp), allocatable :: res(:)
    real(dp), allocatable :: re_err(:), im_err(:)
    real(dp) :: relerr, errmax
    integer :: i, num_args
    include '/references/reference_data.f90'
    ! -----------------------------------------------------------------------
    num_args = size(Faddeeva_w_args)
    allocate(res(1:num_args))
    allocate(re_err(1:num_args))
    allocate(im_err(1:num_args))
    relerr = 0.0_dp
    errmax = 0.0_dp
    do i = 1, num_args
        res(i) = Faddeeva_w(Faddeeva_w_args(i), relerr)
        re_err(i) = find_relerr(real(res(i)), real(Faddeeva_w_wolfram_refs(i)))
        im_err(i) = find_relerr(aimag(res(i)), aimag(Faddeeva_w_wolfram_refs(i)))
        print *, "w(", real(Faddeeva_w_args(i)),"+i*", aimag(Faddeeva_w_args(i)),") = ", real(res(i)),"+i*", &
                aimag(res(i)), " (vs.", real(Faddeeva_w_wolfram_refs(i)),"+i*", aimag(Faddeeva_w_wolfram_refs(i)),"), &
                re/im rel. err. = ", re_err(i),"/", im_err(i)
        if (re_err(i) > errmax) errmax = re_err(i)
        if (im_err(i) > errmax) errmax = im_err(i)
        if (errmax > 1e-13) then
            print *, "FAILURE -- relative error", errmax, "is too large!"
            stop 1
        end if
    end do
    print *, "SUCCESS (max relative error = ", errmax
end program Faddeeva_w_test


      SUBROUTINE DSPLINE(X,Y,A,B,C,N)                ! Double Precision
      IMPLICIT REAL*8 (A-H),REAL*8 (O-Z)
      DIMENSION X(N),Y(N),A(N),B(N),C(N)
C
C-----COMPUTATION OF CUBIC SPLINE COEFFICIENTS A,B,C
C-----FOR APPROXIMATION OF A DATA ARRAY (X,Y) SUCH THAT
C-----F(X)=Y(I)+DEL*[A(I)+DEL*(B(I)+C(I)*DEL)] IN THE
C-----INTERVAL X(I)<X<X(I+1), WHERE DEL=X-X(I).
C-----VANISHING CURVATURE AT THE BOUNDARIES IS ASSUMED:
C-----F"[X(1)]=F"[X(N)]=0
      X1=X(1)
      DO 10 I=2,N
      Z1=X(I)
      X(I)=Z1-X1
   10 X1=Z1
C
      DO 20 I=2,N-1
      A(I)=X(I+1)/(X(I)+X(I+1))
      B(I)=1.-A(I)
      C(I)=6.*((Y(I+1)-Y(I))/X(I+1)-(Y(I)-Y(I-1))/X(I))
     *  /(X(I)+X(I+1))
   20 CONTINUE
C
      B(2)=2.
      DO 30 I=3,N-1
      X1=B(I)/B(I-1)
      B(I)=2.-X1*A(I-1)
   30 C(I)=C(I)-X1*C(I-1)
      C(N-1)=C(N-1)/B(N-1)
C
      DO 40 I=N-2,2,-1
   40 C(I)=(C(I)-A(I)*C(I+1))/B(I)
      C(1)=.0
      C(N)=.0
C
      DO 50 I=1,N-1
      A(I)=(Y(I+1)-Y(I))/X(I+1)-X(I+1)*(2.*C(I)+C(I+1))/6.
      B(I)=.5*C(I)
   50 C(I)=(C(I+1)-C(I))/X(I+1)/6.
      DO 60 I=2,N
   60 X(I)=X(I-1)+X(I)
C
      RETURN
      END


module cosmo_params
  use precision1, only : dp
  use constants
  implicit none

  type FLRW_pars
      real(dp) :: h
      real(dp) :: Om
      real(dp) :: Ok
      real(dp) :: Ol
  end type FLRW_pars

! Planck 2013 parameters
  real(dp), parameter :: h_plk  = 0.673_dp
  real(dp), parameter :: Om_plk = 0.315_dp
  real(dp), parameter :: Ok_plk = 0._dp
  real(dp), parameter :: Ol_plk = 0.685_dp

! Background model parameters
  type(FLRW_pars), parameter :: &
          FLRW=FLRW_pars(h_plk,Om_plk,Ok_plk,Ol_plk)

  real(dp), parameter ::                        &
       H0    = 1.e5_dp * FLRW%h * TU / LU / CS, & !1/Mpc
       rho_c = 3._dp * H0**2 / KAPPA_C2,        &
       lb    = 3._dp * FLRW%Ol * H0**2,         &
       gkr   = KAPPA_C2 * rho_c * FLRW%Om,      &
       M0    = 0.5_dp * FLRW%Om * H0**2,        &
       T0CMB = 2.7255_dp,                       &
       q0    = -0.55_dp,                        &
       j0    = 1.0_dp

  real(dp), parameter :: ldipole  = 276.4_dp
  real(dp), parameter :: bdipole  = 29.3_dp

  real(dp), pointer :: ct2 => null() !age of universe in Mpc

! Model specific parameters
  character(len=8), save :: model
  real(dp), save :: alpha,amp,r0,dlr

! Observer position
  real(dp), save :: r_obs,theta_obs

contains

  subroutine get_age
    implicit none
    real(dp) :: q
    if (.not. associated(ct2)) then
        allocate(ct2)
        if (abs(FLRW%Ok) < 1.e-8_dp) then
            q=sqrt(abs(FLRW%Ol))
            ct2=log((1._dp+q)/(1._dp-q))/(3._dp*q*H0)
        else
            STOP 'Hardcoded to work for Ok=0 only!'
        end if
    else
        return
    end if
  end subroutine get_age

end module cosmo_params


! ----------------------------------------------------------------------
      subroutine regint(f,a,b,c,n)
! ----------------------------------------------------------------------
      use stel_kinds
      implicit none
      integer :: i, n
      real(rprec), dimension(n) :: f, a, b, c
      real(rprec) :: sqp, sqm, sqa, sqc, top, tom
c ----------------------------------------------------------------------
      do  i=1,n
         sqp    = sqrt(a(i)+2._dp*b(i)+c(i))
         sqm    = sqrt(a(i)-2._dp*b(i)+c(i))
         sqa    = sqrt(a(i))
         sqc    = sqrt(c(i))
         top    = log((sqc*sqp+c(i)+b(i))/(sqa*sqp-a(i)-b(i)))/sqp
         tom    = log((sqc*sqm+c(i)-b(i))/(sqa*sqm-a(i)+b(i)))/sqm
         f(i)   = top + tom
      enddo

      end subroutine regint


!***********************************/
!	Name:FluxDifferenceSplitting法で用いる左右の固有行列を計算するためのプログラム
!	Alias:GetEigenMatrix
!	Description:特性速度の絶対値を成分に持つ対角行列に左右の固有行列を作用させるといわゆる|A|が得られ，特性速度がどちらに向いていても風上法で扱えるようになる
!	Type:FDSMatrix
!	Input:Geometory,RoeAverage,FDSMatrix
!	Output:FDSMatrix
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.09
!	Other:1次元と2次元に対応
!***********************************/
    subroutine GetEigenMatrix(Geom,RA,FM,SP4O)
    use StructVar_Mod
    !use LoopVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio, Epsilon => EntropyCorrection
    implicit none
    type(Geometry), intent(in) :: Geom
    type(RoeAverage), intent(in) :: RA
    type(FDSMatrix), intent(inout) :: FM
    type(PrivateVar4OMP), intent(inout) :: SP4O

    if(Geom%Dimension == 1) then
        FM%RightEigenMatrix(1,1) = 1.0d0
        FM%RightEigenMatrix(1,2) = 1.0d0
        FM%RightEigenMatrix(1,3) = 1.0d0
        FM%RightEigenMatrix(2,1) = RA%RoeAverage(2) - RA%RoeAverage(1)
        FM%RightEigenMatrix(2,2) = RA%RoeAverage(2)
        FM%RightEigenMatrix(2,3) = RA%RoeAverage(2) + RA%RoeAverage(1)
        FM%RightEigenMatrix(3,1) = RA%RoeAverage(3) - RA%RoeAverage(2)*RA%RoeAverage(1)
        FM%RightEigenMatrix(3,2) = 0.5d0 * RA%RoeAverage(2)**2
        FM%RightEigenMatrix(3,3) = RA%RoeAverage(3) + RA%RoeAverage(2)*RA%RoeAverage(1)

        SP4O%GEM%CalcAssistB2 = Gmin1/RA%RoeAverage(1)**2
        SP4O%GEM%CalcAssistB1 = 0.5d0*RA%RoeAverage(2)**2 * SP4O%GEM%CalcAssistB2

        FM%LeftEigenMatrix(1,1) = 0.5d0*(SP4O%GEM%CalcAssistB1 + RA%RoeAverage(2)/RA%RoeAverage(1))
        FM%LeftEigenMatrix(1,2) = -0.5d0*(1.0d0/RA%RoeAverage(1) + SP4O%GEM%CalcAssistB2*RA%RoeAverage(2))
        FM%LeftEigenMatrix(1,3) = 0.5d0*(SP4O%GEM%CalcAssistB2)
        FM%LeftEigenMatrix(2,1) = 1.0d0 - SP4O%GEM%CalcAssistB1
        FM%LeftEigenMatrix(2,2) = SP4O%GEM%CalcAssistB2 * RA%RoeAverage(2)
        FM%LeftEigenMatrix(2,3) = -SP4O%GEM%CalcAssistB2
        FM%LeftEigenMatrix(3,1) = 0.5d0*(SP4O%GEM%CalcAssistB1 - RA%RoeAverage(2)/RA%RoeAverage(1))
        FM%LeftEigenMatrix(3,2) = 0.5d0*(1.0d0/RA%RoeAverage(1) - SP4O%GEM%CalcAssistB2*RA%RoeAverage(2))
        FM%LeftEigenMatrix(3,3) = 0.5d0*(SP4O%GEM%CalcAssistB2)

        FM%AbsEigenValues = 0.0d0
        FM%AbsEigenValues(1,1) = dabs(RA%RoeAverage(2) - RA%RoeAverage(1))
        FM%AbsEigenValues(2,2) = dabs(RA%RoeAverage(2))
        FM%AbsEigenValues(3,3) = dabs(RA%RoeAverage(2) + RA%RoeAverage(1))

    else if(Geom%Dimension == 2) then
        if(RA%Direction == 1) then
            FM%RightEigenMatrix(1,1) = 1.0d0
            FM%RightEigenMatrix(1,2) = 1.0d0
            FM%RightEigenMatrix(1,3) = 1.0d0
            FM%RightEigenMatrix(1,4) = 0.0d0
            FM%RightEigenMatrix(2,1) = RA%RoeAverage(2) - RA%RoeAverage(1)
            FM%RightEigenMatrix(2,2) = RA%RoeAverage(2)
            FM%RightEigenMatrix(2,3) = RA%RoeAverage(2) + RA%RoeAverage(1)
            FM%RightEigenMatrix(2,4) = 0.0d0
            FM%RightEigenMatrix(3,1) = RA%RoeAverage(3)
            FM%RightEigenMatrix(3,2) = RA%RoeAverage(3)
            FM%RightEigenMatrix(3,3) = RA%RoeAverage(3)
            FM%RightEigenMatrix(3,4) = 1.0d0
            FM%RightEigenMatrix(4,1) = RA%RoeAverage(4) - RA%RoeAverage(2)*RA%RoeAverage(1)
            FM%RightEigenMatrix(4,2) = 0.5d0 * (RA%RoeAverage(2)**2 + RA%RoeAverage(3)**2)
            FM%RightEigenMatrix(4,3) = RA%RoeAverage(4) + RA%RoeAverage(2)*RA%RoeAverage(1)
            FM%RightEigenMatrix(4,4) = RA%RoeAverage(3)

            SP4O%GEM%CalcAssistB2 = Gmin1/RA%RoeAverage(1)**2
            SP4O%GEM%CalcAssistB1 = 0.5d0*(RA%RoeAverage(2)**2 + RA%RoeAverage(3)**2) * SP4O%GEM%CalcAssistB2

            FM%LeftEigenMatrix(1,1) = 0.5d0*(SP4O%GEM%CalcAssistB1 + RA%RoeAverage(2)/RA%RoeAverage(1))
            FM%LeftEigenMatrix(1,2) = -0.5d0*(1.0d0/RA%RoeAverage(1) + SP4O%GEM%CalcAssistB2*RA%RoeAverage(2))
            FM%LeftEigenMatrix(1,3) = -0.5d0*(SP4O%GEM%CalcAssistB2*RA%RoeAverage(3))
            FM%LeftEigenMatrix(1,4) = 0.5d0*(SP4O%GEM%CalcAssistB2)
            FM%LeftEigenMatrix(2,1) = 1.0d0 - SP4O%GEM%CalcAssistB1
            FM%LeftEigenMatrix(2,2) = SP4O%GEM%CalcAssistB2 * RA%RoeAverage(2)
            FM%LeftEigenMatrix(2,3) = SP4O%GEM%CalcAssistB2 * RA%RoeAverage(3)
            FM%LeftEigenMatrix(2,4) = - SP4O%GEM%CalcAssistB2
            FM%LeftEigenMatrix(3,1) = 0.5d0*(SP4O%GEM%CalcAssistB1 - RA%RoeAverage(2)/RA%RoeAverage(1))
            FM%LeftEigenMatrix(3,2) = 0.5d0*(1.0d0/RA%RoeAverage(1) - SP4O%GEM%CalcAssistB2*RA%RoeAverage(2))
            FM%LeftEigenMatrix(3,3) = -0.5d0*(SP4O%GEM%CalcAssistB2*RA%RoeAverage(3))
            FM%LeftEigenMatrix(3,4) = 0.5d0*(SP4O%GEM%CalcAssistB2)
            FM%LeftEigenMatrix(4,1) = -RA%RoeAverage(3)
            FM%LeftEigenMatrix(4,2) = 0.0d0
            FM%LeftEigenMatrix(4,3) = 1.0d0
            FM%LeftEigenMatrix(4,4) = 0.0d0

            FM%AbsEigenValues = 0.0d0
            FM%AbsEigenValues(1,1) = dabs(RA%RoeAverage(2) - RA%RoeAverage(1))
            FM%AbsEigenValues(2,2) = dabs(RA%RoeAverage(2))
            FM%AbsEigenValues(3,3) = dabs(RA%RoeAverage(2) + RA%RoeAverage(1))
            FM%AbsEigenValues(4,4) = dabs(RA%RoeAverage(2))

        else if(RA%Direction == 2) then
            FM%RightEigenMatrix(1,1) = 1.0d0
            FM%RightEigenMatrix(1,2) = 1.0d0
            FM%RightEigenMatrix(1,3) = 1.0d0
            FM%RightEigenMatrix(1,4) = 0.0d0
            FM%RightEigenMatrix(2,1) = RA%RoeAverage(2)
            FM%RightEigenMatrix(2,2) = RA%RoeAverage(2)
            FM%RightEigenMatrix(2,3) = RA%RoeAverage(2)
            FM%RightEigenMatrix(2,4) = 1.0d0
            FM%RightEigenMatrix(3,1) = RA%RoeAverage(3) - RA%RoeAverage(1)
            FM%RightEigenMatrix(3,2) = RA%RoeAverage(3)
            FM%RightEigenMatrix(3,3) = RA%RoeAverage(3) + RA%RoeAverage(1)
            FM%RightEigenMatrix(3,4) = 0.0d0
            FM%RightEigenMatrix(4,1) = RA%RoeAverage(4) - RA%RoeAverage(3)*RA%RoeAverage(1)
            FM%RightEigenMatrix(4,2) = 0.5d0 * (RA%RoeAverage(2)**2 + RA%RoeAverage(3)**2)
            FM%RightEigenMatrix(4,3) = RA%RoeAverage(4) + RA%RoeAverage(3)*RA%RoeAverage(1)
            FM%RightEigenMatrix(4,4) = RA%RoeAverage(2)

            SP4O%GEM%CalcAssistB2 = Gmin1/RA%RoeAverage(1)**2
            SP4O%GEM%CalcAssistB1 = 0.5d0*(RA%RoeAverage(2)**2 + RA%RoeAverage(3)**2) * SP4O%GEM%CalcAssistB2

            FM%LeftEigenMatrix(1,1) = 0.5d0*(SP4O%GEM%CalcAssistB1 + RA%RoeAverage(3)/RA%RoeAverage(1))
            FM%LeftEigenMatrix(1,2) = -0.5d0*(SP4O%GEM%CalcAssistB2*RA%RoeAverage(2))
            FM%LeftEigenMatrix(1,3) = -0.5d0*(1.0d0/RA%RoeAverage(1) + SP4O%GEM%CalcAssistB2*RA%RoeAverage(3))
            FM%LeftEigenMatrix(1,4) = 0.5d0*(SP4O%GEM%CalcAssistB2)
            FM%LeftEigenMatrix(2,1) = 1.0d0 - SP4O%GEM%CalcAssistB1
            FM%LeftEigenMatrix(2,2) = SP4O%GEM%CalcAssistB2 * RA%RoeAverage(2)
            FM%LeftEigenMatrix(2,3) = SP4O%GEM%CalcAssistB2 * RA%RoeAverage(3)
            FM%LeftEigenMatrix(2,4) = - SP4O%GEM%CalcAssistB2
            FM%LeftEigenMatrix(3,1) = 0.5d0*(SP4O%GEM%CalcAssistB1 - RA%RoeAverage(3)/RA%RoeAverage(1))
            FM%LeftEigenMatrix(3,2) = -0.5d0*(SP4O%GEM%CalcAssistB2*RA%RoeAverage(2))
            FM%LeftEigenMatrix(3,3) = 0.5d0*(1.0d0/RA%RoeAverage(1) - SP4O%GEM%CalcAssistB2*RA%RoeAverage(3))
            FM%LeftEigenMatrix(3,4) = 0.5d0*(SP4O%GEM%CalcAssistB2)
            FM%LeftEigenMatrix(4,1) = -RA%RoeAverage(2)
            FM%LeftEigenMatrix(4,2) = 1.0d0
            FM%LeftEigenMatrix(4,3) = 0.0d0
            FM%LeftEigenMatrix(4,4) = 0.0d0

            FM%AbsEigenValues = 0.0d0
            FM%AbsEigenValues(1,1) = dabs(RA%RoeAverage(3) - RA%RoeAverage(1))
            FM%AbsEigenValues(2,2) = dabs(RA%RoeAverage(3))
            FM%AbsEigenValues(3,3) = dabs(RA%RoeAverage(3) + RA%RoeAverage(1))
            FM%AbsEigenValues(4,4) = dabs(RA%RoeAverage(3))
        end if
    end if
    return
end subroutine GetEigenMatrix


module lib_constants

  implicit none
  save

  integer,parameter,private :: sp = selected_real_kind(p=6,r=37)
  integer,parameter,private :: dp = selected_real_kind(p=15,r=307)

  real(sp),parameter :: zero_sp = 0._sp
  real(dp),parameter :: zero_dp = 0._dp

  real(dp),parameter :: zero = 0._dp
  real(dp),parameter :: half = 0.5_dp
  real(dp),parameter :: one = 1._dp
  real(dp),parameter :: two = 2._dp

  ! Physical constants

  real(dp),parameter :: G_cgs = 6.67300d-08
  real(dp),parameter :: G_si  = 6.67300d-11

  !  N = kg.m/s^2 = [G]*kg^2/m**2
  !  [G] = m^3/s^2/kg

  real(dp),parameter :: k_cgs = 1.380650424d-16 ! erg/K
  real(dp),parameter :: k_si  = 1.380650424d-23 !   J/K

  real(dp),parameter :: h_cgs = 6.6260689633d-27   ! ergs.s
  real(dp),parameter :: h_si  = 6.6260689633e-34_dp !    J.s

  real(dp),parameter :: c_si  = 2.99792458e08_dp ! m / s
  real(dp),parameter :: c_cgs = 2.99792458e10_dp ! cm / s
  ! speed of light

  real(dp),parameter :: kpc_si  = 3.08568025e19_dp ! m
  real(dp),parameter :: kpc_cgs = 3.08568025e21_dp ! cm
  ! kiloparsec

  real(dp),parameter :: pi = 3.14159265358979323846_dp
  real(sp),parameter :: pi_sp = 3.14159265358979323846_sp
  real(dp),parameter :: pi_dp = 3.14159265358979323846_dp

  real(dp),parameter :: twopi = pi + pi
  real(sp),parameter :: twopi_sp = pi_sp + pi_sp
  real(dp),parameter :: twopi_dp = pi_dp + pi_dp

  real(dp),parameter  :: deg2rad = pi / 180._dp
  real(dp),parameter  :: rad2deg = 180._dp / pi
  real(sp),parameter :: deg2rad_sp = pi_sp / 180._sp
  real(sp),parameter :: rad2deg_sp = 180._sp / pi_sp
  real(dp),parameter :: deg2rad_dp = pi_dp / 180._dp
  real(dp),parameter :: rad2deg_dp = 180._dp / pi_dp

  real(dp),parameter :: lsun_cgs = 3.846e33_dp ! erg/s

  real(dp),parameter :: rsun_cgs = 6.95508e10_dp ! cm

  real(dp),parameter :: au_cgs = 1.49598e13_dp ! cm

  real(dp),parameter :: year_cgs = 3600._dp * 24._dp * 365.25_dp

  real(dp),parameter :: msun_cgs = 1.989e33_dp ! g
  ! Conversions

  real(dp),parameter :: ergs2mJy = 1.e26_dp
  real(dp),parameter :: microns2cm = 1.e-4_dp
  real(dp),parameter :: microns2m  = 1.e-6_dp

  real(dp),parameter :: stef_boltz = 5.670400e-5_dp

contains

  real(sp) function infinity_sp()
    implicit none
    real(sp) :: x
    x = huge(1._sp)
    infinity_sp = x + x
  end function infinity_sp

  real(dp) function infinity_dp()
    implicit none
    real(dp) :: x
    x = huge(1._dp)
    infinity_dp = x + x
  end function infinity_dp

end module lib_constants


      subroutine tag4refinement(mx,my,mbc,
     &      meqn, xlower,ylower,dx,dy,blockno,
     &      q, tag_threshold, init_flag,tag_patch)
      implicit none

      integer mx,my, mbc, meqn, tag_patch, init_flag
      integer blockno
      double precision xlower, ylower, dx, dy
      double precision tag_threshold
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer i,j, mq
      double precision qvec(3), dmax, heat_eval_refinement

      tag_patch = 0
c     # Refine based only on first variable in system.
      mq = 1
      do j = 1,my+1
         do i = 1,mx+1
            qvec(1) = q(i,j,1)
            qvec(2) = q(i-1,j,1)
            qvec(3) = q(i,j-1,1)

            dmax = heat_eval_refinement(qvec,dx,dy)

            if (abs(dmax) .gt. tag_threshold) then
               tag_patch = 1
               return
            endif
         enddo
      enddo

      end

      double precision function heat_eval_refinement(q,dx,dy)
          implicit none

          double precision q(3), dx,dy

          double precision qij, qimj, qijm
          double precision qxm, qym, dmax

          qij = q(1)
          qimj = q(2)
          qijm = q(3)
          qxm = (qij - qimj)/dx
          qym = (qij - qijm)/dy

          dmax = max(abs(qxm),abs(qym))

          heat_eval_refinement = dmax

          return

      end function heat_eval_refinement


program test_stats_rand
    use forlab_stats, only: rng, randu, randn
    use forlab_io, only: disp
    implicit none
    integer(kind=4) :: iX(5)
    real(kind=8) :: rX(5)

    call rng()
    call randu(iX)
    call disp(iX, 'RANDU(iX(5)) : ')
    call randu(iX, from=-10_4, to=10_4)
    call disp(iX, 'RANDU(iX, from=-10_4, to=10_4) : ')

    call randu(rX)
    call disp(rX, 'RANDU(rX(5)) : ')
    call randu(rX, from=-10.d0, to=10.d0)
    call disp(rX, 'RANDU(rX, from=-10.d0, to=10.d0) : ')

    call randn(rX)
    call disp(rX, 'RANDN(rX(5)) : ')
    call randn(rX, mean=0.d0, std=10.d0)
    call disp(rX, 'RANDN(rX, mean=0.d0, std=10.d0) : ')

end program test_stats_rand


    module numz
! module defines the basic real type and pi
!      integer, parameter :: b8 = selected_real_kind(14)
      integer, parameter :: b8 = selected_real_kind(4)
      real(b8), parameter :: pi  = 4.0_b8*(atan(1.0_b8))
      real(b8), parameter :: pi2 = 8.0_b8*(atan(1.0_b8))
      integer, parameter :: nsig = 100
    end module
    program signal
    use numz
    real(b8) :: tmin(nsig),tmax(nsig),amp(nsig),f(nsig)
    real(b8) :: dt,maxt
    real(b8), allocatable :: sig(:)
    real(b8) sval,t,y
    integer :: nc(nsig),num,msig
    integer :: i,j
    read(*,*)num
! subsignals are nonzero between tmin and tmax
! tmin can be < 0.0
! tmax can be > maxt
! with a given max amplitude and frequency (hz)
! nc =  0 constant amplitude between tmin and tmax
! nc = -1 amplitude decreases between tmin and tmax
! nc = +1 amplitude increases between tmin and tmax
    do i=1,num
      read(*,*)tmin(i),tmax(i),amp(i),f(i),nc(i)
    end do
    write(*,*)
    read(*,*)dt,maxt
    msig=maxt/dt
    msig=msig+1
    allocate(sig(msig))
    do j=1,msig
      t=dt*(j-1)
      sig(j)=0.0_b8
      do i=1,num
        y=sval(t,tmin(i),tmax(i),amp(i),f(i),nc(i))
!       write(*,*)i,t,y
        sig(j)=sig(j)+y
      enddo
    enddo
 !   do i=1,msig
 !     write(*,*)sig(i)
 !   enddo
    open(unit=18,file="test.dat",access="stream",status="replace")
    write(18)sig
    end program
    function sval(t,tmin,tmax,amp,f,nc)
    use numz
    real(b8) :: t,tmin,tmax,amp,f,sval
    integer nc
    real(b8) cur
    sval=0.0_b8
    if(t .lt. tmin)return
    if(t .gt. tmax)return
    cur=t-tmin
    sval=amp*sin(pi2*cur*f)
    if(nc .eq.  0)then
      return
    endif
    if(nc .eq. -1)then
      sval=sval*(1.0_b8-cur/(tmax-tmin))
      return
    endif
    if(nc .eq.  1)then
      sval=sval*(cur/(tmax-tmin))
      return
    endif
    write(*,*)"invalid nc:",nc
    end function


PROGRAM FU_example2
   ! Example program for FU_Prec and FU_Statistics modules of ecasglez's FortranUtilities,
   ! showing how to apply FU_Statistics functions to an array with rank larger than 1.
   ! It shows 3 examples on how to calculate the mean value of a rank 3 array.
   ! compile using: gfortran example2.f90 -o example2 -I/path/to/include/ -lFortranUtilities -L/path/to/lib/ -O2
   ! before running: export LD_LIBRARY_PATH=/path/to/lib:${LD_LIBRARY_PATH}
   ! run using: ./example2
   ! license: MIT.

   USE FU_Prec      , ONLY: dp
   USE FU_statistics, ONLY: mean

   IMPLICIT NONE

   INTEGER, PARAMETER :: n = 100
   REAL(KIND=8),DIMENSION(:,:,:),ALLOCATABLE :: matrix
   REAL(KIND=8) :: media

   ALLOCATE(matrix(n,n,n))
   CALL random_number(matrix(:,:,:))

   !First method. Use RESHAPE.
   media = mean(RESHAPE(matrix,([SIZE(matrix)])))
   WRITE(*,'(A,F9.5,A)') 'Mean value: ', media, '.'

   !Second method. Use an array constructor.
   media = mean([matrix])
   WRITE(*,'(A,F9.5,A)') 'Mean value: ', media, '.'

   !Third method. Use sequence association. Use auxiliary function mean3D (see below)
   media = mean3D(matrix,SIZE(matrix))
   WRITE(*,'(A,F9.5,A)') 'Mean value: ', media, '.'

   DEALLOCATE(matrix)

   CONTAINS

      FUNCTION mean3D(a,n) RESULT(res)
         USE FU_statistics, ONLY: mean
         IMPLICIT NONE
         REAL(KIND=dp),DIMENSION(n), INTENT(IN) :: a
         INTEGER, INTENT(IN) :: n
         REAL(KIND=dp) :: res
         res = mean(a)
      END FUNCTION mean3D

END PROGRAM FU_example2


module m
implicit none
private
public :: square_cube,powers,powers_dt,powers_2_3
type square_cube
   integer :: isquare,icube
end type square_cube
contains
! subroutine with multiple intent(out) arguments
subroutine powers(i,isquare,icube)
integer, intent(in)  :: i
integer, intent(out) :: isquare,icube
isquare = i**2
icube   = i*isquare
end subroutine powers
! function returning derived type with multple components
function powers_dt(i) result(res)
integer, intent(in) :: i
type(square_cube)   :: res
res%isquare = i**2
res%icube   = i*res%isquare
end function powers_dt
! function returning an array. This approach is arguably worse
! because it's not clear from the name what
! p_2_3(1) and p_2_3(2) refer to. It's also restricted to
! returning values of the same type.
function powers_2_3(i) result(p_2_3)
integer, intent(in) :: i
integer             :: p_2_3(2)
p_2_3(1) = i**2
p_2_3(2) = p_2_3(1)*i
end function powers_2_3
!
end module m

program main
use m, only: powers,powers_dt,square_cube,powers_2_3
implicit none
integer, parameter :: i = 4
integer            :: isquare,icube,pow(2)
type(square_cube)  :: dt
call powers(i,isquare,icube) ! return results in isquare and icube
dt = powers_dt(i) ! return a derived type with components isquare and icube
pow = powers_2_3(i)
print*,isquare,icube ! 16 64
print*,dt%isquare,dt%icube ! 16 64
print*,dt ! 16 64
! can print a whole derived type when it has scalar components
print*,pow ! 16 64
end program main


program pi_main

  use timer

  ! Local variables
  integer, parameter :: num_steps = 100000000 ! number of steps over which to estimate pi
  real(kind=8) :: step                        ! the step size
  integer :: ii                               ! genereric counter
  real(kind=8) :: x, x2                       ! intermediate value
  real(kind=8) :: pi = 0.0_8                  ! overall estimate
  real(kind=8) :: sum = 0.0_8                 ! variable to store partial sum
  real(kind=8) :: start, end                  ! timers

  real(kind=8), parameter :: PI_8 = 4.0_8 * atan(1.0_8)

  ! step size is dependent upon the number of steps
  step = 1.0_8/num_steps

  ! Start timer
  call wtime(start)

  ! main loop
  !$omp parallel do private(x,x2)
  do ii = 1, num_steps
    x = (ii-0.5_8)*step
    x2 = 4.0_8/(1.0_8+x*x)
    !$omp critical
    sum = sum + x2
    !$omp end critical
  end do
  !$omp end parallel do

  pi = step * sum

  ! Stop timer
  call wtime(end)

  ! Print result
  write(*,"(A)")         "------------------------------------"
  write(*,"(A,F19.16)") "pi is:    ", pi
  write(*,"(A,F19.16)") "error is: ", abs(pi - PI_8)
  write(*,"(A,F10.3)")   "runtime:  ", end-start
  write(*,"(A)")         "------------------------------------"

end program pi_main


module poisbinom

  use types, only: dp

  implicit none

contains

  function cdf(p, x)
    use logspace, only: logadd, log1p

    real(dp), dimension(:), intent(in) :: p
    integer, intent(in) :: x
    real(dp) :: cdf

    real(dp), dimension(size(p)) :: logp, lognotp
    real(dp), dimension(2, size(p)) :: memory

    integer :: j, k, n, prev, curr, tmp

    n = size(p)

    if (x > n) then
      cdf = 1
    else if (x < 0) then
      cdf = 0
    else
      logp = log(p)
      lognotp = log1p(-p)

      memory(1, 1) = lognotp(1)
      do j = 2, size(p)
        memory(1, j) = lognotp(j) + memory(1, j - 1)
      end do

      prev = 1
      curr = 2

      cdf = memory(1, n)

      do k = 1, x
         if (k > 1) then
            memory(curr, k) = logp(k) + memory(prev, k - 1)
         else
            memory(curr, k) = logp(k)
         end if

         do j = k + 1, n
            memory(curr, j) = logadd(lognotp(j) + memory(curr, j - 1), &
                                     logp(j) + memory(prev, j - 1))
         end do

         cdf = logadd(cdf, memory(curr, n))

         tmp = curr
         curr = prev
         prev = tmp
      end do

      cdf = exp(cdf)
    end if
  end function cdf

  function fullCdf(p, x) result (cdf)
    use logspace, only: logadd, log1p

    real(dp), dimension(:), intent(in) :: p
    integer, intent(in) :: x
    real(dp), dimension(0:x) :: cdf

    real(dp), dimension(size(p)) :: logp, lognotp
    real(dp), dimension(2, size(p)) :: memory

    integer :: j, k, n, prev, curr, tmp

    n = size(p)

    if (x > n) then
      cdf = 1.0
    else
      logp = log(p)
      lognotp = log1p(-p)

      memory(1, 1) = lognotp(1)
      do j = 2, size(p)
        memory(1, j) = lognotp(j) + memory(1, j - 1)
      end do

      prev = 1
      curr = 2

      cdf(0) = memory(1, n)

      do k = 1, x
         if (k > 1) then
            memory(curr, k) = logp(k) + memory(prev, k - 1)
         else
            memory(curr, k) = logp(k)
         end if

         do j = k + 1, n
            memory(curr, j) = logadd(lognotp(j) + memory(curr, j - 1), &
                                     logp(j) + memory(prev, j - 1))
         end do

         cdf(k) = logadd(cdf(k - 1), memory(curr, n))

         tmp = curr
         curr = prev
         prev = tmp
      end do

      cdf = exp(cdf)
    end if
  end function fullCdf

end module poisbinom


!===============================================================================
program thompson_parameter
!===============================================================================
!  Program form of the CIJ_thom routine in anisotropy_ajn module

   use anisotropy_ajn

   implicit none

   real(8) :: ecs(6,6)
   real(8) :: vp,vs,rho,del,eps,gam
   integer :: i
   character(len=250) :: arg

   if (command_argument_count() /= 6) then
      write(0,'(a)') 'Usage:  CIJ_thom [vp] [vs] [rho] [delta] [epsilon] [gamma]',&
                     '  Rotationally symmetric about 3-axis (vertical)'
      write(0,'(a)') '  Sends 36 elastic constants to stdout (density-normalised).'
      stop
   endif

   call get_command_argument(1,arg) ;  read(arg,*) vp
   call get_command_argument(2,arg) ;  read(arg,*) vs
   call get_command_argument(3,arg) ;  read(arg,*) rho
   call get_command_argument(4,arg) ;  read(arg,*) del
   call get_command_argument(5,arg) ;  read(arg,*) eps
   call get_command_argument(6,arg) ;  read(arg,*) gam

   ecs = CIJ_thom(vp,vs,rho,eps,gam,del)

   write(*,*) ecs/rho

end program thompson_parameter
!-------------------------------------------------------------------------------


      subroutine interpolate_q2n_3r(val, f, k)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Extrapolates a variable defined at the gausspoints to the nodes
!
! Author : Sai Rapaka
!

      use comfem

      implicit none
      real*8,  dimension(8)        :: f
      real*8                       :: val
      integer                      :: k

      real*8                       :: sq3, zeta, eta, mu
      real*8,  dimension(8)        :: N
      integer                      :: i

      sq3 = sqrt(3.0d0)

      zeta = gpcord(k,1)*sq3*sq3
      eta  = gpcord(k,2)*sq3*sq3
      mu   = gpcord(k,3)*sq3*sq3

      N(1) = 0.125d0*(1 - zeta)*(1 - eta)*(1 - mu)
      N(2) = 0.125d0*(1 + zeta)*(1 - eta)*(1 - mu)
      N(3) = 0.125d0*(1 + zeta)*(1 + eta)*(1 - mu)
      N(4) = 0.125d0*(1 - zeta)*(1 + eta)*(1 - mu)
      N(5) = 0.125d0*(1 - zeta)*(1 - eta)*(1 + mu)
      N(6) = 0.125d0*(1 + zeta)*(1 - eta)*(1 + mu)
      N(7) = 0.125d0*(1 + zeta)*(1 + eta)*(1 + mu)
      N(8) = 0.125d0*(1 - zeta)*(1 + eta)*(1 + mu)

      val = 0.0d0
      do i=1,8
        val = val + N(i)*f(i)
      enddo

      end subroutine interpolate_q2n_3r


SUBROUTINE mapc2m_cylinder(xc,yc,xp,yp,zp)
    IMPLICIT NONE

    DOUBLE PRECISION xc,yc,xp,yp,zp

    DOUBLE PRECISION pi, pi2
    COMMON /compi/ pi, pi2

    DOUBLE PRECISION R_cyl, h_cyl
    COMMON /cylinder_comm/ r_cyl, h_cyl

    DOUBLE PRECISION r1, R, theta, z, yc1

    !! finite cylinder :
    if (yc .lt. 0 .or. yc .gt. 1) then
!!        write(6,*) 'yc not in [0,1];  yc = ', yc
    endif

    !!yc1 = mod(yc,1.0)

    CALL map_comp2cylinder(xc,yc,theta,z)

    xp = R_cyl*cos(theta)
    yp = R_cyl*sin(theta)
    zp = z

END SUBROUTINE MAPC2M_CYLINDER


program main
    use plantFEM
    implicit none

    real(real64) :: OA(2),OB(2),OC(2)
    real(real64) :: AB(2),CA(2),AC(2),BA(2)

    OA(1)=3.0d0; OA(2)=8.0d0
    OB(1)=-1.0d0; OB(2)=2.0d0
    OC(1)=3.00d0; OC(2)=-20.0d0
    AB = OB - OA
    BA = OA - OB
    CA = OA - OC
    AC = OC - OA
    print *, 1, 2.0d0/3.0d0*OA + 2.0d0*BA
    print *, 2,CA + 2.0d0*OB
    print *, 3,5.0d0*CA + 2.0d0*AB
    print *, 4,5.0d0*CA + 2.0d0*AB + 2.0d0*AC
    print *, 5,AB + 2.0d0*OB
    print *, 6,OA + 2.0d0*OB + 2.0d0*OC
    print *, 7,2.0d0*OA + 2.0d0*AB
    print *, "Student's answers"

    print *, 56.00d0/19.0d0*OA+ 46.0d0/19.0d0*OB !+ 1.0d0*OC

end program main


: CR 10 EMIT ;
: PUTS 48 + EMIT CR ;

1 2 <  PUTS
1 2 <= PUTS
1 2 =  PUTS
1 2 >= PUTS
1 2 >  PUTS
CR
1 2 <> PUTS
CR
CR
2 2 <  PUTS
2 2 <= PUTS
2 2 =  PUTS
2 2 >= PUTS
2 2 >  PUTS
CR
2 2 <> PUTS
CR
CR
3 2 <  PUTS
3 2 <= PUTS
3 2 =  PUTS
3 2 >= PUTS
3 2 >  PUTS
CR
3 2 <> PUTS


! These routines evaluate 1-dimensional derivatives at an interface by using
! 4-cell centered stencils.  Mostly intended to use arbitrary boundary
! conditions when a true solution is available.
!
! They will work in a pinch anywhere you need a derivative, but performance
! takes a big hit if you make pointwise function calls at every grid cell.

double precision function derivative0(q)
    implicit none
    double precision, dimension(4), intent(in) :: q
    derivative0 = -0.0625d0 * q(1) + 0.5625d0 * q(2)  &
        + 0.5625d0 * q(3) - 0.0625d0 * q(4)
end function derivative0

double precision function derivative1(q, dx)
    implicit none
    double precision, dimension(4), intent(in) :: q
    double precision, intent(in) :: dx
    derivative1 = (4.166666666666667d-2 * q(1) - 1.125d0 * q(2)  &
        + 1.125d0 * q(3) - 4.166666666666667d-2 * q(4)) / dx
end function derivative1

double precision function derivative2(q, dx)
    implicit none
    double precision, dimension(4), intent(in) :: q
    double precision, intent(in) :: dx
    derivative2 = (.5d0 * q(1) - .5d0 * q(2) - .5d0 * q(3) + .5d0 * q(4)) / dx**2
end function derivative2

double precision function derivative3(q, dx)
    implicit none
    double precision, dimension(4), intent(in) :: q
    double precision, intent(in) :: dx
    derivative3 = (-q(1) + 3.d0 * q(2) - 3.d0 * q(3) + q(4)) / dx**3
end function derivative3

double precision function gen_derivative(i, q, dx)
    implicit none
    integer, intent(in) :: i
    double precision, dimension(4), intent(in) :: q
    double precision, intent(in) :: dx
    double precision, external :: derivative0, derivative1, derivative2, derivative3

    if (i == 0) then
        gen_derivative = derivative0(q)
    else if (i == 1) then
        gen_derivative = derivative1(q, dx)
    else if (i == 2) then
        gen_derivative = derivative2(q, dx)
    else if (i == 3) then
        gen_derivative = derivative3(q, dx)
    end if

end function gen_derivative


	FUNCTION PR_MHKN  ( smph )
C************************************************************************
C* PR_MHKN								*
C*									*
C* This function computes SKNT from SMPH.  The following equation is	*
C* used:								*
C*									*
C*      SKNT = SMPH * 0.868976						*
C*									*
C* REAL PR_MHKN  ( SMPH )						*
C*									*
C* Input parameters:							*
C*	SMPH		REAL		Speed in miles/hour		*
C*									*
C* Output parameters:							*
C*	PR_MHKN		REAL		Speed in knots			*
C**									*
C* T. Lee/SAIC		 9/01						*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing data.
C
	IF  ( ERMISS ( smph ) )  THEN
	    PR_MHKN = RMISSD
	  ELSE
	    PR_MHKN = smph * 0.868976
	END IF
C*
	RETURN
	END


      subroutine project(v,n1v,nrow,nv,x,work)
c---------------------------------------------------------------
c        projects vector x onto subspace spanned by the columns of
c   the array v by forming the matrix product v*v(trans)x.
c  (note   remember to be a projector the columns of v must
c  be orthonormal.)
c
c  arguments-
c    v - array of containing the basis vectors defining the
c        subspace x is to be projected onto.
c        these vectors are assumed to be stored in the columns of v.
c    n1v-first dimension of v in calling program.
c    nrow-number of elements in the rows of v and x.
c    nv-number of vectors in v.  (i.e. number of columns in v)
c    x-vector to be projected.  it is overwritten on return by
c      the requested projection.
c    work - work vector of length at least nv.
c
c  author   gary l. pavlis
c           geophysics program ak-50
c           university of washington
c           seattle, wa  98195
c
c  written   march 1983
c---------------------------------------------------------------------
      integer n1v,nrow,nv
      real v(n1v,nv),x(nrow),work(nv)
      integer j
      do 100 j=1,nv
           work(j) = sdot(nrow,v(1,j),1,x,1)
  100 continue
      do 150 j=1,nrow
           x(j) = 0.0
  150 continue
      do 200 j=1,nv
           call saxpy(nrow,work(j),v(1,j),1,x,1)
  200 continue
      return
      end

c $Id$


!=============================================================================!
	subroutine grad( ndof, nx, ny, v, g1v, g2v, dx, dy, optx, opty, &
	                 xper, yper, lsym, rsym, bsym, tsym, carp)
!
!  Take the gradient of a 2-D field.
!  Updated to sixth-order accurate differencing on the interior with
!  the option for optimized fourth-order differencing.
!
!  Revised: 6-28-95
!
!=============================================================================!
	use stencil
	implicit none

	integer :: ndof, nx, ny, optx, opty
	logical :: xper, yper
	logical :: lsym, rsym, bsym, tsym, carp
	real    :: v(ndof,nx,ny), g1v(ndof,nx,ny), g2v(ndof,nx,ny)
        !$sgi distribute v(*,*,block), g1v(*,*,block), g2v(*,*,block)

	real    :: dx, dy

	real, parameter :: zero = 0.0, one = 1.0, pt5 = 0.5
	real dxinv, dyinv
	real a, b, c, w
	real gx1, gx2, gx3, gx4, gx5, gx6
	real gy1, gy2, gy3, gy4, gy5, gy6

	integer :: i, j, idof
	real, parameter :: eps = 1.0e-12
	real :: isign
!=============================================================================!

	dxinv  = one / dx
	dyinv  = one / dy

!.... seven point stencil in x

	if (optx.eq.0) then
	  c = 1.0 / 60.0
	else if (optx.eq.-1) then
	  c = 0.0
	else
	  w = 2.0 * 3.1415926535897932385e+0 / 12.0
	  c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
	      (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
	end if

	a = (2.0 + 15.0 * c) / 3.0
	b = -(1.0 + 48.0 * c) / 12.0

	gx1 =  -c * dxinv
	gx2 =  -b * dxinv
	gx3 =  -a * dxinv
	gx4 =   a * dxinv
	gx5 =   b * dxinv
	gx6 =   c * dxinv

!.... seven point stencil in y

	if (opty.eq.0) then
	  c = 1.0 / 60.0
	else if (opty.eq.-1) then
	  c = 0.0
	else
	  w = 2.0 * 3.1415926535897932385e+0 / 12.0
	  c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
	      (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
	end if

	a = (2.0 + 15.0 * c) / 3.0
	b = -(1.0 + 48.0 * c) / 12.0

	gy1 =  -c * dyinv
	gy2 =  -b * dyinv
	gy3 =  -a * dyinv
	gy4 =   a * dyinv
	gy5 =   b * dyinv
	gy6 =   c * dyinv

!=============================================================================!
!.... compute the gradient in x
!=============================================================================!

	if (xper) then

!$doacross
!$omp parallel do
          do j = 1, ny

	  g1v(:,1,j)        = ( gx1 * v(:,nx-3,j)	+ &
				gx2 * v(:,nx-2,j)	+ &
				gx3 * v(:,nx-1,j)	+ &
				gx4 * v(:,2,j)		+ &
				gx5 * v(:,3,j)		+ &
				gx6 * v(:,4,j)	)

	  g1v(:,2,j)        = ( gx1 * v(:,nx-2,j)	+ &
				gx2 * v(:,nx-1,j)	+ &
				gx3 * v(:,1,j)		+ &
				gx4 * v(:,3,j)		+ &
				gx5 * v(:,4,j)		+ &
				gx6 * v(:,5,j)	)

	  g1v(:,3,j)        = ( gx1 * v(:,nx-1,j)	+ &
				gx2 * v(:,1,j)		+ &
				gx3 * v(:,2,j)		+ &
				gx4 * v(:,4,j)		+ &
				gx5 * v(:,5,j)		+ &
				gx6 * v(:,6,j)	)

	  g1v(:,nx-2,j)     = ( gx1 * v(:,nx-5,j)	+ &
				gx2 * v(:,nx-4,j)	+ &
				gx3 * v(:,nx-3,j)	+ &
				gx4 * v(:,nx-1,j)	+ &
				gx5 * v(:,1,j)		+ &
				gx6 * v(:,2,j)	)

	  g1v(:,nx-1,j)     = ( gx1 * v(:,nx-4,j)	+ &
				gx2 * v(:,nx-3,j)	+ &
				gx3 * v(:,nx-2,j)	+ &
				gx4 * v(:,1,j)		+ &
				gx5 * v(:,2,j)		+ &
				gx6 * v(:,3,j)	)

	  g1v(:,nx,j) = g1v(:,1,j)

          end do
!$omp end parallel do

	else  if (carp ) then       !  Implement Carpenter's boundary stencil

!$doacross
!$omp parallel do
          do j = 1, ny

	  g1v(:,1,j)     = ( gg1 * v(:,1,j)	+ &
			     gg2 * v(:,2,j)  	+ &
			     gg3 * v(:,3,j)  	+ &
			     gg4 * v(:,4,j)  	+ &
			     gg5 * v(:,5,j)  	+ &
			     gg6 * v(:,6,j)  ) * dxinv

	  g1v(:,2,j)     = ( gh1 * v(:,1,j)  	+ &
			     gh2 * v(:,2,j)  	+ &
			     gh3 * v(:,3,j)  	+ &
			     gh4 * v(:,4,j)  	+ &
			     gh5 * v(:,5,j)  	+ &
			     gh6 * v(:,6,j)  ) * dxinv

	  g1v(:,3,j)     = ( gi1 * v(:,1,j)  	+ &
			     gi2 * v(:,2,j)  	+ &
			     gi3 * v(:,3,j)  	+ &
			     gi4 * v(:,4,j)  	+ &
			     gi5 * v(:,5,j)  	+ &
			     gi6 * v(:,6,j)  ) * dxinv

	  g1v(:,4,j)     = ( gj1 * v(:,1,j)  	+ &
			     gj2 * v(:,2,j)  	+ &
			     gj3 * v(:,3,j)  	+ &
			     gj4 * v(:,4,j)  	+ &
			     gj5 * v(:,5,j)  	+ &
			     gj6 * v(:,6,j)  ) * dxinv

	  g1v(:,nx-3,j) = -( gj1 * v(:,nx,j)  	+ &
			     gj2 * v(:,nx-1,j)  + &
			     gj3 * v(:,nx-2,j)  + &
			     gj4 * v(:,nx-3,j)  + &
			     gj5 * v(:,nx-4,j)  + &
			     gj6 * v(:,nx-5,j)  ) * dxinv

	  g1v(:,nx-2,j) = -( gi1 * v(:,nx,j)  	+ &
			     gi2 * v(:,nx-1,j)  + &
			     gi3 * v(:,nx-2,j)  + &
			     gi4 * v(:,nx-3,j)  + &
			     gi5 * v(:,nx-4,j)  + &
			     gi6 * v(:,nx-5,j)  ) * dxinv

	  g1v(:,nx-1,j) = -( gh1 * v(:,nx,j)  	+ &
			     gh2 * v(:,nx-1,j)  + &
			     gh3 * v(:,nx-2,j)  + &
			     gh4 * v(:,nx-3,j)  + &
			     gh5 * v(:,nx-4,j)  + &
			     gh6 * v(:,nx-5,j)  ) * dxinv

	  g1v(:,nx,j)   = -( gg1 * v(:,nx,j)  	+ &
			     gg2 * v(:,nx-1,j)  + &
			     gg3 * v(:,nx-2,j)  + &
			     gg4 * v(:,nx-3,j)  + &
			     gg5 * v(:,nx-4,j)  + &
			     gg6 * v(:,nx-5,j)  ) * dxinv
	  end do
!$omp end parallel do

	else                  ! boundary differences

!$doacross
!$omp parallel do
	  do j = 1, ny

!	  g1v(:,1,j)      = ( v(:,2,j) - v(:,1,j) ) * dxinv
	  g1v(:,1,j)      = ( gc1 * v(:,1,j)  + &
			      gc2 * v(:,2,j)  + &
			      gc3 * v(:,3,j)  + &
			      gc4 * v(:,4,j)  + &
			      gc5 * v(:,5,j)  ) * dxinv
!	  g1v(:,1,j)      = ( ge1 * v(:,1,j)  + &
!			      ge2 * v(:,2,j)  + &
!			      ge3 * v(:,3,j)  + &
!			      ge4 * v(:,4,j)  + &
!			      ge5 * v(:,5,j)  + &
!			      ge6 * v(:,6,j)  + &
!			      ge7 * v(:,7,j)  ) * dxinv

!	  g1v(:,2,j)      = ( v(:,3,j) - v(:,1,j) ) * pt5 * dxinv
	  g1v(:,2,j)      = ( gb1 * v(:,1,j)  + &
			      gb2 * v(:,2,j)  + &
			      gb3 * v(:,3,j)  + &
			      gb4 * v(:,4,j)  + &
			      gb5 * v(:,5,j)  ) * dxinv
!	  g1v(:,2,j)      = ( gf1 * v(:,1,j)  + &
!			      gf2 * v(:,2,j)  + &
!			      gf3 * v(:,3,j)  + &
!			      gf4 * v(:,4,j)  + &
!			      gf5 * v(:,5,j)  + &
!			      gf6 * v(:,6,j)  + &
!			      gf7 * v(:,7,j)  ) * dxinv

	  g1v(:,3,j)      = ( ga1 * v(:,1,j)  + &
			      ga2 * v(:,2,j)  + &
			      ga3 * v(:,4,j)  + &
			      ga4 * v(:,5,j)  ) * dxinv

	  g1v(:,nx-2,j)   = ( ga1 * v(:,nx-4,j)  + &
			      ga2 * v(:,nx-3,j)  + &
			      ga3 * v(:,nx-1,j)  + &
			      ga4 * v(:,nx  ,j)  ) * dxinv

	  g1v(:,nx-1,j)  = -( gb1 * v(:,nx  ,j)  + &
			      gb2 * v(:,nx-1,j)  + &
			      gb3 * v(:,nx-2,j)  + &
			      gb4 * v(:,nx-3,j)  + &
			      gb5 * v(:,nx-4,j)  ) * dxinv

	  g1v(:,nx,j)    = -( gc1 * v(:,nx  ,j)  + &
			      gc2 * v(:,nx-1,j)  + &
			      gc3 * v(:,nx-2,j)  + &
			      gc4 * v(:,nx-3,j)  + &
			      gc5 * v(:,nx-4,j)  ) * dxinv

	  end do
!$omp end parallel do

	end if

!.... implement the symmetric conditions

	if (lsym) then
!$doacross local( idof, isign )
!$omp parallel do private(idof, isign)
          do j = 1, ny
	  do idof = 1, ndof
	    if (idof .eq. 3) then
	      isign = -one
	    else
	      isign = one
	    end if

	    g1v(idof,1,j)     = ( isign * gx1 * v(idof,4,j)	+ &
				  isign * gx2 * v(idof,3,j)	+ &
				  isign * gx3 * v(idof,2,j)	+ &
				  gx4 * v(idof,2,j)		+ &
				  gx5 * v(idof,3,j)		+ &
				  gx6 * v(idof,4,j)		)

	    g1v(idof,2,j)     = ( isign * gx1 * v(idof,3,j)	+ &
				  isign * gx2 * v(idof,2,j)	+ &
				  gx3 * v(idof,1,j)		+ &
				  gx4 * v(idof,3,j)		+ &
				  gx5 * v(idof,4,j)		+ &
				  gx6 * v(idof,5,j)		)

	    g1v(idof,3,j)     = ( isign * gx1 * v(idof,2,j)	+ &
				  gx2 * v(idof,1,j)		+ &
				  gx3 * v(idof,2,j)		+ &
				  gx4 * v(idof,4,j)		+ &
				  gx5 * v(idof,5,j)		+ &
				  gx6 * v(idof,6,j)		)
	  end do
	  end do
!$omp end parallel do

	end if

	if (rsym) then
!$doacross local( idof, isign )
!$omp parallel do private(idof, isign)
          do j = 1, ny
	  do idof = 1, ndof
	    if (idof .eq. 3) then
	      isign = -one
	    else
	      isign = one
	    end if

	    g1v(idof,nx-2,j)  = ( gx1 * v(idof,nx-5,j)	        + &
				  gx2 * v(idof,nx-4,j)	        + &
				  gx3 * v(idof,nx-3,j)	        + &
				  gx4 * v(idof,nx-1,j)		+ &
				  gx5 * v(idof,nx,  j)		+ &
				  isign * gx6 * v(idof,nx-1,j)	)

	    g1v(idof,nx-1,j)  = ( gx1 * v(idof,nx-4,j)	        + &
				  gx2 * v(idof,nx-3,j)	        + &
				  gx3 * v(idof,nx-2,j)		+ &
				  gx4 * v(idof,nx,  j)		+ &
				  isign * gx5 * v(idof,nx-1,j)	+ &
				  isign * gx6 * v(idof,nx-2,j)	)

	    g1v(idof,nx,j)    = ( gx1 * v(idof,nx-3,j)	        + &
				  gx2 * v(idof,nx-2,j)		+ &
				  gx3 * v(idof,nx-1,j)		+ &
				  isign * gx4 * v(idof,nx-1,j)	+ &
				  isign * gx5 * v(idof,nx-2,j)	+ &
				  isign * gx6 * v(idof,nx-3,j)	)
	  end do
	  end do
!$omp end parallel do

	end if

!.... interior

!$doacross local(i,idof)
!$omp parallel do private(i,idof)
        do j = 1, ny
          do i = 4, nx-3
            do idof = 1, ndof
	      g1v(idof,i,j)  = ( gx1 * v(idof,i-3,j)	+ &
	                         gx2 * v(idof,i-2,j)	+ &
	                         gx3 * v(idof,i-1,j)	+ &
			         gx4 * v(idof,i+1,j)	+ &
			         gx5 * v(idof,i+2,j)	+ &
			         gx6 * v(idof,i+3,j)	)
	    end do
	  end do
	end do
!$omp end parallel do

!=============================================================================!
!.... compute the gradient in y
!=============================================================================!

	if (yper) then

!$doacross
!$omp parallel do
          do i = 1, nx

	  g2v(:,i,1)        = ( gy1 * v(:,i,ny-3)	+ &
				gy2 * v(:,i,ny-2)	+ &
				gy3 * v(:,i,ny-1)	+ &
				gy4 * v(:,i,2)		+ &
				gy5 * v(:,i,3)		+ &
				gy6 * v(:,i,4)  	)

	  g2v(:,i,2)        = ( gy1 * v(:,i,ny-2)	+ &
				gy2 * v(:,i,ny-1)	+ &
				gy3 * v(:,i,1)		+ &
				gy4 * v(:,i,3)		+ &
				gy5 * v(:,i,4)		+ &
				gy6 * v(:,i,5)	)

	  g2v(:,i,3)        = ( gy1 * v(:,i,ny-1)	+ &
				gy2 * v(:,i,1)		+ &
				gy3 * v(:,i,2)		+ &
				gy4 * v(:,i,4)		+ &
				gy5 * v(:,i,5)		+ &
				gy6 * v(:,i,6)	)

	  g2v(:,i,ny-2)     = ( gy1 * v(:,i,ny-5)	+ &
				gy2 * v(:,i,ny-4)	+ &
				gy3 * v(:,i,ny-3)	+ &
				gy4 * v(:,i,ny-1)	+ &
				gy5 * v(:,i,1)		+ &
				gy6 * v(:,i,2)	)

	  g2v(:,i,ny-1)     = ( gy1 * v(:,i,ny-4)	+ &
				gy2 * v(:,i,ny-3)	+ &
				gy3 * v(:,i,ny-2)	+ &
				gy4 * v(:,i,1)		+ &
				gy5 * v(:,i,2)		+ &
				gy6 * v(:,i,3)	)

	  g2v(:,i,ny) = g2v(:,i,1)

          end do
!$omp end parallel do

	else  if (carp ) then       !  Implement Carpenter's boundary stencil

!$doacross
!$omp parallel do
          do i = 1, nx

	  g2v(:,i,1)     = ( gg1 * v(:,i,1)	+ &
			     gg2 * v(:,i,2)  	+ &
			     gg3 * v(:,i,3)  	+ &
			     gg4 * v(:,i,4)  	+ &
			     gg5 * v(:,i,5)  	+ &
			     gg6 * v(:,i,6)  ) * dyinv

	  g2v(:,i,2)     = ( gh1 * v(:,i,1)  	+ &
			     gh2 * v(:,i,2)  	+ &
			     gh3 * v(:,i,3)  	+ &
			     gh4 * v(:,i,4)  	+ &
			     gh5 * v(:,i,5)  	+ &
			     gh6 * v(:,i,6)  ) * dyinv

	  g2v(:,i,3)     = ( gi1 * v(:,i,1)  	+ &
			     gi2 * v(:,i,2)  	+ &
			     gi3 * v(:,i,3)  	+ &
			     gi4 * v(:,i,4)  	+ &
			     gi5 * v(:,i,5)  	+ &
			     gi6 * v(:,i,6)  ) * dyinv

	  g2v(:,i,4)     = ( gj1 * v(:,i,1)  	+ &
			     gj2 * v(:,i,2)  	+ &
			     gj3 * v(:,i,3)  	+ &
			     gj4 * v(:,i,4)  	+ &
			     gj5 * v(:,i,5)  	+ &
			     gj6 * v(:,i,6)  ) * dyinv

	  g2v(:,i,ny-3) = -( gj1 * v(:,i,ny)  	+ &
			     gj2 * v(:,i,ny-1)  + &
			     gj3 * v(:,i,ny-2)  + &
			     gj4 * v(:,i,ny-3)  + &
			     gj5 * v(:,i,ny-4)  + &
			     gj6 * v(:,i,ny-5)  ) * dyinv

	  g2v(:,i,ny-2) = -( gi1 * v(:,i,ny)  	+ &
			     gi2 * v(:,i,ny-1)  + &
			     gi3 * v(:,i,ny-2)  + &
			     gi4 * v(:,i,ny-3)  + &
			     gi5 * v(:,i,ny-4)  + &
			     gi6 * v(:,i,ny-5)  ) * dyinv

	  g2v(:,i,ny-1) = -( gh1 * v(:,i,ny)  	+ &
			     gh2 * v(:,i,ny-1)  + &
			     gh3 * v(:,i,ny-2)  + &
			     gh4 * v(:,i,ny-3)  + &
			     gh5 * v(:,i,ny-4)  + &
			     gh6 * v(:,i,ny-5)  ) * dyinv

	  g2v(:,i,ny)   = -( gg1 * v(:,i,ny)  	+ &
			     gg2 * v(:,i,ny-1)  + &
			     gg3 * v(:,i,ny-2)  + &
			     gg4 * v(:,i,ny-3)  + &
			     gg5 * v(:,i,ny-4)  + &
			     gg6 * v(:,i,ny-5)  ) * dyinv
	  end do
!$omp end parallel do

	else     ! normal boundary differences (must use for implicit)

!$doacross
!$omp parallel do
          do i = 1, nx

	  g2v(:,i,1)     = ( gc1 * v(:,i,1)	+ &
			     gc2 * v(:,i,2)  	+ &
			     gc3 * v(:,i,3)  	+ &
			     gc4 * v(:,i,4)  	+ &
			     gc5 * v(:,i,5)     ) * dyinv

	  g2v(:,i,2)     = ( gb1 * v(:,i,1)  	+ &
			     gb2 * v(:,i,2)  	+ &
			     gb3 * v(:,i,3)  	+ &
			     gb4 * v(:,i,4)  	+ &
			     gb5 * v(:,i,5)     ) * dyinv

	  g2v(:,i,3)     = ( ga1 * v(:,i,1)  	+ &
			     ga2 * v(:,i,2)  	+ &
			     ga3 * v(:,i,4)  	+ &
			     ga4 * v(:,i,5)     ) * dyinv

	  g2v(:,i,ny-2)  = ( ga1 * v(:,i,ny-4)  + &
			     ga2 * v(:,i,ny-3)  + &
			     ga3 * v(:,i,ny-1)  + &
			     ga4 * v(:,i,ny  )  ) * dyinv

	  g2v(:,i,ny-1) = -( gb1 * v(:,i,ny  )  + &
			     gb2 * v(:,i,ny-1)  + &
			     gb3 * v(:,i,ny-2) 	+ &
			     gb4 * v(:,i,ny-3)  + &
			     gb5 * v(:,i,ny-4)  ) * dyinv

	  g2v(:,i,ny)   = -( gc1 * v(:,i,ny  )  + &
			     gc2 * v(:,i,ny-1)  + &
			     gc3 * v(:,i,ny-2)  + &
			     gc4 * v(:,i,ny-3)  + &
			     gc5 * v(:,i,ny-4)  ) * dyinv

	  end do
!$omp end parallel do

	end if

!.... interior

!$doacross local(j,idof)
!$omp parallel do private(j,idof)
        do i = 1, nx
          do j = 4, ny-3
            do idof = 1, ndof
	      g2v(idof,i,j) = ( gy1 * v(idof,i,j-3)	+ &
			        gy2 * v(idof,i,j-2)	+ &
			        gy3 * v(idof,i,j-1)	+ &
			        gy4 * v(idof,i,j+1)	+ &
			        gy5 * v(idof,i,j+2)	+ &
			        gy6 * v(idof,i,j+3)	)
	    end do
	  end do
	end do
!$omp end parallel do

!.... implement a filter of roundoff noise

	if (.false.) then

!$omp parallel do private(i,idof)
	  do j = 1, ny
	    do i = 1, nx
	      do idof = 1, ndof
		if ( abs(g1v(idof,i,j)) .lt. eps ) g1v(idof,i,j) = zero
		if ( abs(g2v(idof,i,j)) .lt. eps ) g2v(idof,i,j) = zero
	      end do
	    end do
	  end do

	end if

	return
	end


!NCLFORTSTART
SUBROUTINE ROTATECOORDS(ilat, ilon, olat, olon, lat_np, lon_np, lon_0, direction)
    USE wrf_constants, ONLY : PI, RAD_PER_DEG, DEG_PER_RAD

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: olat, olon

    REAL(KIND=8), INTENT(IN) :: ilat, ilon
    REAL(KIND=8), INTENT(OUT) :: olat, olon
    REAL(KIND=8), INTENT(IN) :: lat_np, lon_np, lon_0
    INTEGER, INTENT(IN) :: direction

! NCLFORTEND

    !  >=0, default : computational -> geographical
    !  < 0          : geographical  -> computational

    REAL(KIND=8) :: rlat, rlon
    REAL(KIND=8) :: phi_np, lam_np, lam_0, dlam
    REAL(KIND=8) :: sinphi, cosphi, coslam, sinlam
    !REAL(KIND=8), PARAMETER :: PI=3.141592653589793D0
    !REAL(KIND=8), PARAMETER :: RAD_PER_DEG=PI/180.D0
    !REAL(KIND=8), PARAMETER :: DEG_PER_RAD=180.D0/PI

    !convert all angles to radians
    phi_np = lat_np*RAD_PER_DEG
    lam_np = lon_np*RAD_PER_DEG
    lam_0 = lon_0*RAD_PER_DEG
    rlat = ilat*RAD_PER_DEG
    rlon = ilon*RAD_PER_DEG

    IF (direction .LT. 0) THEN
    ! the equations are exactly the same except for one
    ! small difference with respect to longitude ...
        dlam = pi - lam_0
    ELSE
        dlam = lam_np
    END IF

    sinphi = COS(phi_np)*COS(rlat)*COS(rlon - dlam) + SIN(phi_np)*SIN(rlat)
    cosphi = SQRT(1.D0 - sinphi*sinphi)
    coslam = SIN(phi_np)*COS(rlat)*COS(rlon - dlam) - COS(phi_np)*SIN(rlat)
    sinlam = COS(rlat)*SIN(rlon - dlam)

    IF (cosphi.NE.0.D0) THEN
        coslam = coslam/cosphi
        sinlam = sinlam/cosphi
    END IF

    olat = DEG_PER_RAD*ASIN(sinphi)
    olon = DEG_PER_RAD*(ATAN2(sinlam,coslam) - dlam - lam_0 + lam_np)

    RETURN

END SUBROUTINE ROTATECOORDS

!NCLFORTSTART
SUBROUTINE DLLTOIJ(map_proj, truelat1, truelat2, stdlon, lat1, lon1,&
                   pole_lat, pole_lon, knowni, knownj, dx, dy, latinc,&
                   loninc, lat, lon, loc, errstat, errmsg)
    USE wrf_constants, ONLY : ALGERR, PI, RAD_PER_DEG, DEG_PER_RAD, WRF_EARTH_RADIUS

    ! Converts input lat/lon values to the cartesian (i,j) value
    ! for the given projection.

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: loc

    INTEGER, INTENT(IN) :: map_proj
    REAL(KIND=8), INTENT(IN) :: stdlon
    REAL(KIND=8), INTENT(IN) ::lat1, lon1, pole_lat, pole_lon, knowni, knownj
    REAL(KIND=8), INTENT(IN) ::dx, dy, latinc, loninc
    REAL(KIND=8), INTENT(INOUT) :: lat, lon, truelat1, truelat2 ! these might get modified
    REAL(KIND=8), DIMENSION(2), INTENT(OUT) :: loc
    INTEGER, INTENT(INOUT) :: errstat
    CHARACTER(LEN=*), INTENT(INOUT) :: errmsg

!NCLEND

    REAL(KIND=8) :: deltalon1
    REAL(KIND=8) :: tl1r
    REAL(KIND=8) :: clain, dlon, rsw, deltalon, deltalat
    REAL(KIND=8) :: reflon, scale_top, ala1, alo1, ala, alo, rm, polei, polej
    ! earth radius divided by dx
    REAL(KIND=8) :: rebydx
    REAL(KIND=8) :: ctl1r, arg, cone, hemi
    REAL(KIND=8) :: i, j
    REAL(KIND=8) :: lat1n, lon1n, olat, olon

    ! Contants
    !REAL(KIND=8),PARAMETER :: PI=3.141592653589793D0
    !REAL(KIND=8),PARAMETER :: RAD_PER_DEG=PI/180.D0
    !REAL(KIND=8),PARAMETER :: DEG_PER_RAD=180.D0/PI
    !REAL(KIND=8),PARAMETER :: RE_M=6370000.D0 ! radius of earth in meters

    !      lat1     ! sw latitude (1,1) in degrees (-90->90n)
    !      lon1     ! sw longitude (1,1) in degrees (-180->180e)
    !      dx       ! grid spacing in meters at truelats
    !      dlat     ! lat increment for lat/lon grids
    !      dlon     ! lon increment for lat/lon grids
    !      stdlon   ! longitude parallel to y-axis (-180->180e)
    !      truelat1 ! first true latitude (all projections)
    !      truelat2 ! second true lat (lc only)
    !      hemi     ! 1 for nh, -1 for sh
    !      cone     ! cone factor for lc projections
    !      polei    ! computed i-location of pole point
    !      polej    ! computed j-location of pole point
    !      rsw      ! computed radius to sw corner
    !      knowni   ! x-location of known lat/lon
    !      knownj   ! y-location of known lat/lon
    !      re_m     ! radius of spherical earth, meters
    !      rebydx   ! earth radius divided by dx

    errstat = INT(dy) ! remove compiler warning since dy not used
    errstat = 0

    rebydx = WRF_EARTH_RADIUS/dx

    ! Get rid of compiler warnings
    i=0
    j=0

    hemi = 1.0D0
    IF (truelat1 .LT. 0.0D0) THEN
        hemi = -1.0D0
    END IF

    ! mercator
    IF (map_proj.EQ.3) THEN

        ! preliminary variables
        clain = COS(RAD_PER_DEG*truelat1)
        dlon = dx/(WRF_EARTH_RADIUS*clain)

        ! compute distance from equator to origin, and store in
        ! the rsw tag.
        rsw = 0.D0
        IF (lat1 .NE. 0.D0) THEN
            rsw = (LOG(TAN(0.5D0*((lat1 + 90.D0)*RAD_PER_DEG))))/dlon
        END IF

        deltalon = lon - lon1
        IF (deltalon .LT. -180.D0) deltalon = deltalon + 360.D0
        IF (deltalon .GT. 180.D0) deltalon = deltalon - 360.D0
        i = knowni + (deltalon/(dlon*DEG_PER_RAD))
        j = knownj + (LOG(TAN(0.5D0*((lat + 90.D0)*RAD_PER_DEG))))/dlon - rsw

    ! ps
    ELSE IF (map_proj .EQ. 2) THEN

        reflon = stdlon + 90.D0

        ! compute numerator term of map scale factor
        scale_top = 1.D0 + hemi*SIN(truelat1*RAD_PER_DEG)

        ! compute radius to lower-left (sw) corner
        ala1 = lat1*RAD_PER_DEG
        rsw = rebydx*COS(ala1)*scale_top/(1.D0 + hemi*SIN(ala1))

        ! find the pole point
        alo1 = (lon1 - reflon)*RAD_PER_DEG
        polei = knowni - rsw*COS(alo1)
        polej = knownj - hemi*rsw*SIN(alo1)

        ! find radius to desired point
        ala = lat*RAD_PER_DEG
        rm = rebydx*COS(ala)*scale_top/(1.D0 + hemi*SIN(ala))
        alo = (lon - reflon)*RAD_PER_DEG
        i = polei + rm*COS(alo)
        j = polej + hemi*rm*SIN(alo)

    ! lambert
    ELSE IF (map_proj .EQ. 1) THEN

        IF (ABS(truelat2) .GT. 90.D0) THEN
            truelat2 = truelat1
        END IF

        IF (ABS(truelat1 - truelat2) .GT. 0.1D0) THEN
            cone = (LOG(COS(truelat1*RAD_PER_DEG))-LOG(COS(truelat2*RAD_PER_DEG)))/&
                 (LOG(TAN((90.D0 - ABS(truelat1))*RAD_PER_DEG*0.5D0))-&
                 LOG(TAN((90.D0 - ABS(truelat2))*RAD_PER_DEG*0.5D0)))
        ELSE
            cone = SIN(ABS(truelat1)*RAD_PER_DEG)
        END IF

        ! compute longitude differences and ensure we stay
        ! out of the forbidden "cut zone"
        deltalon1 = lon1 - stdlon
        IF (deltalon1 .GT. +180.D0) deltalon1 = deltalon1 - 360.D0
        IF (deltalon1 .LT. -180.D0) deltalon1 = deltalon1 + 360.D0

        ! convert truelat1 to radian and compute cos for later use
        tl1r = truelat1*RAD_PER_DEG
        ctl1r = COS(tl1r)

        ! compute the radius to our known lower-left (sw) corner
        rsw = rebydx*ctl1r/cone*(TAN((90.D0*hemi - lat1)*RAD_PER_DEG/2.D0)/&
            TAN((90.D0*hemi - truelat1)*RAD_PER_DEG/2.D0))**cone

        ! find pole point
        arg = cone*(deltalon1*RAD_PER_DEG)
        polei = hemi*knowni - hemi*rsw*SIN(arg)
        polej = hemi*knownj + rsw*COS(arg)

        ! compute deltalon between known longitude and standard
        ! lon and ensure it is not in the cut zone
        deltalon = lon - stdlon
        IF (deltalon .GT. +180.D0) deltalon = deltalon - 360.D0
        IF (deltalon .LT. -180.D0) deltalon = deltalon + 360.D0

        ! radius to desired point
        rm = rebydx*ctl1r/cone*(TAN((90.D0*hemi - lat)*RAD_PER_DEG/2.D0)/&
                  TAN((90.D0*hemi - truelat1)*RAD_PER_DEG/2.D0))**cone

        arg = cone*(deltalon*RAD_PER_DEG)
        i = polei + hemi*rm*SIN(arg)
        j = polej - rm*COS(arg)

        ! finally, if we are in the southern hemisphere, flip the
        ! i/j values to a coordinate system where (1,1) is the sw
        ! corner (what we assume) which is different than the
        ! original ncep algorithms which used the ne corner as
        ! the origin in the southern hemisphere (left-hand vs.
        ! right-hand coordinate?)
        i = hemi*i
        j = hemi*j

    ! lat-lon
    ELSE IF (map_proj .EQ. 6) THEN

        IF (pole_lat .NE. 90.D0) THEN
            CALL ROTATECOORDS(lat, lon, olat, olon, pole_lat, pole_lon, stdlon, -1)
            lat = olat
            lon = olon + stdlon
        END IF

        ! make sure center lat/lon is good
        IF (pole_lat .NE. 90.D0) THEN
            CALL ROTATECOORDS(lat1, lon1, olat, olon, pole_lat, pole_lon, stdlon, -1)
            lat1n = olat
            lon1n = olon + stdlon
            deltalat = lat - lat1n
            deltalon = lon - lon1n
        ELSE
            deltalat = lat - lat1
            deltalon = lon - lon1
        END IF

        ! compute i/j
        i = deltalon/loninc
        j = deltalat/latinc

        i = i + knowni
        j = j + knownj

    ELSE
        errstat = ALGERR
        WRITE(errmsg, *) "Do not know map projection ", map_proj
        RETURN
    END IF

    loc(1) = j
    loc(2) = i

    RETURN

END SUBROUTINE DLLTOIJ

!NCLFORTSTART
SUBROUTINE DIJTOLL(map_proj, truelat1, truelat2, stdlon, lat1, lon1,&
                   pole_lat, pole_lon, knowni, knownj, dx, dy, latinc,&
                   loninc, ai, aj, loc, errstat, errmsg)
    USE wrf_constants, ONLY : ALGERR, PI, RAD_PER_DEG, DEG_PER_RAD, WRF_EARTH_RADIUS

    ! converts input lat/lon values to the cartesian (i,j) value
    ! for the given projection.
    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: loc

    INTEGER, INTENT(IN) :: map_proj
    REAL(KIND=8), INTENT(IN) :: stdlon
    REAL(KIND=8), INTENT(IN) :: lat1, lon1, pole_lat, pole_lon, knowni, knownj
    REAL(KIND=8), INTENT(IN) :: dx, dy, latinc, loninc, ai, aj
    REAL(KIND=8), INTENT(INOUT) :: truelat1, truelat2
    REAL(KIND=8), DIMENSION(2), INTENT(OUT) :: loc
    INTEGER, INTENT(INOUT) :: errstat
    CHARACTER(LEN=*), INTENT(INOUT) :: errmsg

!NCLEND

    REAL(KIND=8) :: gi2
    REAL(KIND=8) :: arccos
    REAL(KIND=8) :: deltalon1
    REAL(KIND=8) :: tl1r
    REAL(KIND=8) :: clain, dlon, rsw, deltalon, deltalat
    REAL(KIND=8) :: reflon, scale_top, ala1, alo1, polei, polej
    ! earth radius divided by dx
    REAL(KIND=8) :: rebydx
    REAL(KIND=8) :: ctl1r, cone, hemi

    !REAL(KIND=8),PARAMETER :: PI = 3.141592653589793D0
    !REAL(KIND=8),PARAMETER :: RAD_PER_DEG = PI/180.D0
    !REAL(KIND=8),PARAMETER :: DEG_PER_RAD = 180.D0/PI
    !REAL(KIND=8),PARAMETER :: RE_M = 6370000.D0 ! radius of sperical earth

    REAL(KIND=8) :: inew, jnew, r, r2
    REAL(KIND=8) :: chi, chi1, chi2
    REAL(KIND=8) :: xx, yy, lat, lon

    REAL(KIND=8) :: olat, olon, lat1n, lon1n

    !     lat1     ! sw latitude (1,1) in degrees (-90->90n)
    !     lon1     ! sw longitude (1,1) in degrees (-180->180e)
    !     dx       ! grid spacing in meters at truelats
    !     dlat     ! lat increment for lat/lon grids
    !     dlon     ! lon increment for lat/lon grids
    !     stdlon   ! longitude parallel to y-axis (-180->180e)
    !     truelat1 ! first true latitude (all projections)
    !     truelat2 ! second true lat (lc only)
    !     hemi     ! 1 for nh, -1 for sh
    !     cone     ! cone factor for lc projections
    !     polei    ! computed i-location of pole point
    !     polej    ! computed j-location of pole point
    !     rsw      ! computed radius to sw corner
    !     knowni   ! x-location of known lat/lon
    !     knownj   ! y-location of known lat/lon
    !     re_m     ! radius of spherical earth, meters
    !     rebydx   ! earth radius divided by dx

    errstat = INT(dy) ! Remove compiler warning since dy not used
    errstat = 0

    rebydx = WRF_EARTH_RADIUS/dx

    hemi = 1.0D0
    IF (truelat1 .LT. 0.0D0) THEN
        hemi = -1.0D0
    END IF

    ! mercator
    IF (map_proj .EQ. 3) THEN
        ! preliminary variables
        clain = COS(RAD_PER_DEG*truelat1)
        dlon = dx/(WRF_EARTH_RADIUS*clain)

        ! compute distance from equator to origin, and store in
        ! the rsw tag.
        rsw = 0.D0
        IF (lat1 .NE. 0.D0) THEN
            rsw = (LOG(TAN(0.5D0*((lat1 + 90.D0)*RAD_PER_DEG))))/dlon
        END IF

        lat = 2.0D0*ATAN(EXP(dlon*(rsw + aj - knownj)))*DEG_PER_RAD - 90.D0
        lon = (ai - knowni)*dlon*DEG_PER_RAD + lon1
        IF (lon .GT. 180.D0) lon = lon - 360.D0
        IF (lon .LT. -180.D0) lon = lon + 360.D0

        ! ps
    ELSE IF (map_proj .EQ. 2) THEN

        ! compute the reference longitude by rotating 90 degrees to
        ! the east to find the longitude line parallel to the
        ! positive x-axis.
        reflon = stdlon + 90.D0

        ! compute numerator term of map scale factor
        scale_top = 1.D0 + hemi*SIN(truelat1*RAD_PER_DEG)

        ! compute radius to known point
        ala1 = lat1*RAD_PER_DEG
        rsw = rebydx*COS(ala1)*scale_top/(1.D0 + hemi*SIN(ala1))

        ! find the pole point
        alo1 = (lon1 - reflon)*RAD_PER_DEG
        polei = knowni - rsw*COS(alo1)
        polej = knownj - hemi*rsw*SIN(alo1)

        ! compute radius to point of interest
        xx = ai - polei
        yy = (aj - polej)*hemi
        r2 = xx**2 + yy**2

        ! now the magic code
        IF (r2 .EQ. 0.D0) THEN
            lat = hemi*90.D0
            lon = reflon
        ELSE
            gi2 = (rebydx*scale_top)**2.D0
            lat = DEG_PER_RAD*hemi*ASIN((gi2 - r2)/(gi2 + r2))
            arccos = ACOS(xx/SQRT(r2))
            IF (yy .GT. 0) THEN
                lon = reflon + DEG_PER_RAD*arccos
            ELSE
                lon = reflon - DEG_PER_RAD*arccos
            END IF
      END IF

        ! convert to a -180 -> 180 east convention
        IF (lon .GT. 180.D0) lon = lon - 360.D0
        IF (lon .LT. -180.D0) lon = lon + 360.D0

    !     !lambert
    ELSE IF (map_proj .EQ. 1) THEN

        IF (ABS(truelat2) .GT. 90.D0) THEN
            truelat2 = truelat1
        END IF

        IF (ABS(truelat1 - truelat2) .GT. 0.1D0) THEN
            cone = (LOG(COS(truelat1*RAD_PER_DEG)) - LOG(COS(truelat2*RAD_PER_DEG)))/&
                 (LOG(TAN((90.D0 - ABS(truelat1))*RAD_PER_DEG*0.5D0)) - &
                  LOG(TAN((90.D0 - ABS(truelat2))*RAD_PER_DEG*0.5D0)))
        ELSE
            cone = SIN(ABS(truelat1)*RAD_PER_DEG)
        END IF

        ! compute longitude differences and ensure we stay out of the
        ! forbidden "cut zone"
        deltalon1 = lon1 - stdlon
        IF (deltalon1 .GT. +180.D0) deltalon1 = deltalon1 - 360.D0
        IF (deltalon1 .LT. -180.D0) deltalon1 = deltalon1 + 360.D0

        ! convert truelat1 to radian and compute cos for later use
        tl1r = truelat1*RAD_PER_DEG
        ctl1r = COS(tl1r)

        ! compute the radius to our known point
        rsw = rebydx*ctl1r/cone*(TAN((90.D0*hemi - lat1)*RAD_PER_DEG/2.D0)/&
                         TAN((90.D0*hemi - truelat1)*RAD_PER_DEG/2.D0))**cone

        ! find pole point
        alo1 = cone*(deltalon1*RAD_PER_DEG)
        polei = hemi*knowni - hemi*rsw*SIN(alo1)
        polej = hemi*knownj + rsw*COS(alo1)

        chi1 = (90.D0 - hemi*truelat1)*RAD_PER_DEG
        chi2 = (90.D0 - hemi*truelat2)*RAD_PER_DEG

        ! see if we are in the southern hemispere and flip the
        ! indices if we are.
        inew = hemi*ai
        jnew = hemi*aj

        ! compute radius**2 to i/j location
        reflon = stdlon + 90.D0
        xx = inew - polei
        yy = polej - jnew
        r2 = (xx*xx + yy*yy)
        r = sqrt(r2)/rebydx

        ! convert to lat/lon
        IF (r2 .EQ. 0.D0) THEN
            lat = hemi*90.D0
            lon = stdlon
        ELSE
            lon = stdlon + DEG_PER_RAD*ATAN2(hemi*xx,yy)/cone
            lon = dmod(lon + 360.D0, 360.D0)
            IF (chi1 .EQ. chi2) THEN
                chi = 2.0D0*ATAN((r/TAN(chi1))**(1.D0/cone)*TAN(chi1*0.5D0))
            ELSE
                chi = 2.0D0*ATAN((r*cone/SIN(chi1))**(1.D0/cone)*TAN(chi1*0.5D0))
            END IF
            lat = (90.0D0 - chi*DEG_PER_RAD)*hemi
        END IF

        IF (lon .GT. +180.D0) lon = lon - 360.D0
        IF (lon .LT. -180.D0) lon = lon + 360.D0

    !     !lat-lon
    ELSE IF (map_proj .EQ. 6) THEN
        inew = ai - knowni
        jnew = aj - knownj

        IF (inew .LT. 0.D0) inew = inew + 360.D0/loninc
        IF (inew .GE. 360.D0/dx) inew = inew - 360.D0/loninc

        ! compute deltalat and deltalon
        deltalat = jnew*latinc
        deltalon = inew*loninc

        IF (pole_lat .NE. 90.D0) THEN
            CALL ROTATECOORDS(lat1, lon1, olat, olon, pole_lat, pole_lon, stdlon, -1)
            lat1n = olat
            lon1n = olon + stdlon
            lat = deltalat + lat1n
            lon = deltalon + lon1n
        ELSE
            lat = deltalat + lat1
            lon = deltalon + lon1
        END IF

        IF (pole_lat .NE. 90.D0) THEN
            lon = lon - stdlon
            CALL ROTATECOORDS(lat, lon, olat, olon, pole_lat, pole_lon, stdlon, 1)
            lat = olat
            lon = olon
        END IF

        IF (lon .LT. -180.D0) lon = lon + 360.D0
        IF (lon .GT. 180.D0) lon = lon - 360.D0

    ELSE
        errstat = ALGERR
        WRITE(errmsg, *) "Do not know map projection ", map_proj
        RETURN
    END IF

    loc(1) = lat
    loc(2) = lon

    RETURN

END SUBROUTINE DIJTOLL