program test
  !  This program test the change of basis code.

  use precision
  use globals
  use basis_change
  use operators

  implicit none
  type(wave_fn) :: y1, y2, y1back
  integer(idp) ::  loop
  complex(cdp) :: alpha

  alpha=cmplx(2,2)
  y1%in_basis%n=500
  y2%in_basis%n=500
  y1back%in_basis%n=500
  allocate(y1%co_eff(0:y1%in_basis%n), y2%co_eff(0:y2%in_basis%n), y1back%co_eff(0:y1%in_basis%n))

  y1%in_basis%alpha=cmplx(0)
  y1%co_eff=cmplx(1.0d0)
  y1back%in_basis=y1%in_basis
  y1back%co_eff=cmplx(0)
  y2%co_eff=cmplx(0.0d0)

  do loop=1,y1%in_basis%n

     y1%co_eff(loop)=alpha/sqrt(dble(loop))*y1%co_eff(loop-1)

  end do
  y1%co_eff=y1%co_eff / normalisation(y1)
  y2%in_basis%alpha=y1.a.y1
  write(*,*) 'expectation y1 ',y1.a.y1
  call change_basis(y1,y2)
  write(*,*) 'expectation y2 ',y2.a.y2
  call change_basis(y2,y1back)
  write(*,*) 'expectation y1back ',y1back.a.y1back
  write(*,*) 'error in change ',sum(abs(y1%co_eff-y1back%co_eff))/sum(abs(y1%co_eff))
  open(unit=1, file="y1.dat")
  write(1,'(e15.7,e15.7)') y1%co_eff
  close(1)
  open(unit=1, file="y2.dat")
  write(1,'(e15.7,e15.7)') y2%co_eff
  close(1)
  open(unit=1, file="y1back.dat")
  write(1,'(e15.7,e15.7)') y1back%co_eff
  close(1)
  deallocate(y1%co_eff, y2%co_eff, y1back%co_eff)

end program test


// cosine based palette, 4 vec3 params
vec3 palette( in float t, in vec3 a, in vec3 b, in vec3 c, in vec3 d )
{
    return a + b*cos( 6.28318*(c*t+d) );
}
void mainImage( out vec4 fragColor, in vec2 fragCoord )
{
    // Normalized pixel coordinates (from 0 to 1)
    vec2 uv = fragCoord/iResolution.xy;

    float time = iTime*0.2;

    // Calculate two points on screen.

    vec2 c1 = vec2(sin(time)*0.5, cos(iTime)*0.7);
    vec2 c2 = vec2(sin(time*0.7)*0.9, cos(iTime*0.65)*0.6);

    //Determine length to point 1 & calculate color.
    float d1 = length( uv - c1);
    vec3 col1 = palette( d1+time,vec3(0.5,0.5,0.5),vec3(0.5,0.5,0.5),vec3(1.0,1.0,1.0),vec3(0.0,0.10,0.20));

    //Determine length to point 2 & calculate color.
    float d2 = length( uv - c2);
    vec3 col2 = palette( d2+time,vec3(0.5,0.5,0.5),vec3(0.5,0.5,0.5),vec3(1.0,1.0,1.0),vec3(0.0,0.10,0.20));

    // Output to screen
    fragColor = vec4( (col1+col2) / 2.0 ,1.0);
}


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE CALDIS (NNENUM, NENUM, XNE, YNE, ZNE, SDISTS)
C=======================================================================

C   --*** CALDIS *** (SPLOT) Calculate node/element distances
C   --   Written by Amy Gilkey - revised 02/14/86
C   --
C   --CALDIS calculates the distances between selected nodes or elements.
C   --
C   --Parameters:
C   --   NNENUM - IN  - the number of selected node/element numbers
C   --   NENUM  - IN  - the selected node/element numbers
C   --   XNE,
C   --   YNE,
C   --   ZNE    - IN  - the coordinates of the nodes (if nodes)
C   --                  or element centroids (if elements)
C   --   SDISTS - OUT - the calculated distances
C   --
C   --Common Variables:
C   --   Uses NDIM of /DBNUMS/

      include 'dbnums.blk'

      INTEGER NENUM(NNENUM)
      REAL XNE(*), YNE(*), ZNE(*)
      REAL SDISTS(NNENUM)

      SDISTS(1) = 0.0
      INE = NENUM(1)
      XTHIS = XNE(INE)
      YTHIS = YNE(INE)
      IF (NDIM .EQ. 3) ZTHIS = ZNE(INE)

      DO 100 NUM = 2, NNENUM
         INE = NENUM(NUM)
         XLAST = XTHIS
         XTHIS = XNE(INE)
         YLAST = YTHIS
         YTHIS = YNE(INE)
         IF (NDIM .EQ. 2) THEN
            SDISTS(NUM) = SDISTS(NUM-1) +
     &         SQRT ((XTHIS-XLAST)**2 + (YTHIS-YLAST)**2)
         ELSE IF (NDIM .EQ. 3) THEN
            ZLAST = ZTHIS
            ZTHIS = ZNE(INE)
            SDISTS(NUM) = SDISTS(NUM-1) +
     &         SQRT ((XTHIS-XLAST)**2 + (YTHIS-YLAST)**2
     &         + (ZTHIS-ZLAST)**2)
         END IF
  100 CONTINUE

      RETURN
      END


      subroutine runCY_i1i2(i,j,i1,i2,f,Xtwiddle,Gtt,Gtwiddle,Shat3,
     . Bzero2,N0)
      implicit none
C---  Expression for Eq. 5.59
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,i,j,i1,i2,n,m,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np),f(np),
     . Gtt(np,np,np,np)
      double complex Shat3(np,z2max,-2:0),Bzero2(z2max,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)
     . *(Shat3(m,z2(i1,i2),ep)
     . -2d0*delta(m,i1)*Cv(czzi(i2)+N0,ep)
     . -2d0*delta(m,i2)*Cv(czzi(i1)+N0,ep))
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4*Cv(czzii(z2(i1,i2))+N0,ep-1)

      Cv(cii(z2(i1,i2))+N0,ep)=
     .  (Gtwiddle(i,j)
     . *(8d0*Cv(czzii(z2(i1,i2))+N0,ep)+pole-Bzero2(z2(i1,i2),ep))
     . +bit+Xtwiddle(0,j)*Cv(ciii(z3(i,i1,i2))+N0,ep))/Xtwiddle(i,j)

      enddo
      return
      end


!***********************************/
!	Name:頻繁に使うわりに組込関数が存在しないうえ毎回書くのが面倒な計算を1行で実行するためのサブルーチン・関数集
!	Alias:FrequentOperation
!	Description:
!	Type:double precision, allocatable(3)
!	Input:double precision, allocatable(3)
!	Output:double precision, allocatable(3) or double precision
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.11.10
!	Update:-
!	Other:
!***********************************/
module FrequentOperation
implicit none

public CrossProduct
public AbsCrossProduct
public CheckPointInternalTriangle
public CheckEdgeIntersect
public GetEdgeIntersectionCoords
public GetEdgeIntersectionCoordsWithTriangle
public AbsVector
public CheckBackOrFront
public GetLengthBetweenEdge
public SaveLog

contains
    subroutine CrossProduct(A,B,C) !外積計算
    implicit none
        double precision, intent(in) :: A(:), B(:) !入力：3次元列ベクトル2組
        double precision, intent(out) :: C(:)       !出力：3次元列ベクトル
            C(1) = A(2)*B(3) - A(3)*B(2)
            C(2) = A(3)*B(1) - A(1)*B(3)
            C(3) = A(1)*B(2) - A(2)*B(1)
    return
    end subroutine CrossProduct

    function AbsCrossProduct(A,B) result(R) !外積の絶対値
    implicit none
        double precision, intent(in) :: A(:), B(:) !入力：3次元列ベクトル2組
        double precision :: R                       !出力：スカラー倍精度実数
        double precision, dimension(3) :: C

        call CrossProduct(A,B,C)
        R = sqrt(C(1)**2 + C(2)**2 + C(3)**2)
    return
    end function AbsCrossProduct

    subroutine GetCellCenterCoords(LocalNumX,LocalNumY,Bound,Width,Point)
    implicit none
    integer, intent(in) :: LocalNumX, LocalNumY !局所点番号
    double precision, intent(in) :: Bound(:) !座標下端
    double precision, intent(in) :: Width(:) !界面幅Δx,Δy
    double precision, intent(out) :: Point(:) !セル中心端点座標

        Point(1) = Bound(1) + Width(1)*dble(LocalNumX-0.5d0)
        Point(2) = Bound(2) + Width(2)*dble(LocalNumY-0.5d0)

    return
    end subroutine GetCellCenterCoords

    subroutine GetEdgeEndPoint(LocalNumX,LocalNumY,Bound,Width,Point)
    implicit none
    integer, intent(in) :: LocalNumX, LocalNumY !局所点番号
    double precision, intent(in) :: Bound(:) !座標下端
    double precision, intent(in) :: Width(:) !界面幅Δx,Δy
    double precision, intent(out) :: Point(:) !界面端点座標

        Point(1) = Bound(1) + Width(1)*dble(LocalNumX-1)
        Point(2) = Bound(2) + Width(2)*dble(LocalNumY-1)

    return
    end subroutine GetEdgeEndPoint

    subroutine GetLocalNumber2D(Coords,Width,Bound,LocalNum)
    use StructVar_Mod
    implicit none

    double precision, intent(in) :: Coords(:), Width(:), Bound(:)
    integer, intent(out) :: LocalNum(:)

        LocalNum(1:2) = int((Coords(1:2) - Bound(1:2))/(Width(1:2)))+1 !補助格子におけるセル中心位置

    return
    end subroutine GetLocalNumber2D

    subroutine SwapInteger(A,B)
    implicit none
    integer, intent(inout) :: A,B
    integer :: Tmp
        Tmp = A
        A = B
        B = Tmp
        return
    end subroutine SwapInteger

    subroutine SwapDoublePrecision(A,B)
    implicit none
    double precision, intent(inout) :: A,B
    double precision :: Tmp
        Tmp = A
        A = B
        B = Tmp
        return
    end subroutine SwapDoublePrecision

    subroutine SwapDbleArray(A,B)
    implicit none
    double precision, intent(inout) :: A(:),B(:)
    double precision, allocatable :: Tmp(:)
        allocate(Tmp(ubound(A,1)))
        Tmp = A
        A = B
        B = Tmp
        return
    end subroutine SwapDbleArray

    subroutine GetPointCoordsFromCellCoords(Corner,CellCoords,HalfWidth,PointCoords)
    implicit none
        integer, intent(in) :: Corner
        double precision, intent(in) :: CellCoords(:), HalfWidth(:)
        double precision, intent(out) :: PointCoords(:)

        if(Corner == 1) then !Left Top
            PointCoords(1) = CellCoords(1) - HalfWidth(1)
            PointCoords(2) = CellCoords(2) + HalfWidth(2)

        else if(Corner == 2) then !Right Top
            PointCoords(1) = CellCoords(1) + HalfWidth(1)
            PointCoords(2) = CellCoords(2) + HalfWidth(2)

        else if(Corner == 3) then !Right Bottom
            PointCoords(1) = CellCoords(1) + HalfWidth(1)
            PointCoords(2) = CellCoords(2) - HalfWidth(2)

        else if(Corner == 4) then !Left Bottom
            PointCoords(1) = CellCoords(1) - HalfWidth(1)
            PointCoords(2) = CellCoords(2) - HalfWidth(2)

        end if

        return
    end subroutine GetPointCoordsFromCellCoords

    subroutine Global2Local(GlobalNumber,ixCellNumber,LocalNum) !グローバル番号，X方向の分割数，局所番号を返す
    implicit none

        integer, intent(in) :: GlobalNumber,ixCellNumber
        integer, intent(out) :: LocalNum(:)

        LocalNum(1) = GlobalNumber - int(GlobalNumber/ixCellNumber)*ixCellNumber
        if(LocalNum(1) /= 0) then
            LocalNum(2) = int(GlobalNumber/ixCellNumber) + 1
        else
            LocalNum(1) = ixCellNumber
            LocalNum(2) = int(GlobalNumber/ixCellNumber)
        end if

    return
    end subroutine Global2Local

    function Local2Global(iLocalX,iLocalY,ixCellNumber) result(iGlobalNumber)
    implicit none
        integer, intent(in) :: iLocalX, iLocalY, ixCellNumber
        integer :: iGlobalNumber

            iGlobalNumber = ixCellNumber*(iLocalY-1)+iLocalX

    return
    end function

    function CheckPointInternalTriangle(Point,Vertex1, Vertex2, Vertex3) result(TorF)
    implicit none
        double precision, intent(in) :: Point(:), Vertex1(:), Vertex2(:), Vertex3(:)
        integer :: TorF
        double precision, dimension(3,3) :: VertexOnRelatedCoords
        double precision :: AB, BC, CA, AA, BB

        VertexOnRelatedCoords(1,:) = Vertex1(:) - Point(:)
        VertexOnRelatedCoords(2,:) = Vertex2(:) - Point(:)
        VertexOnRelatedCoords(3,:) = Vertex3(:) - Point(:)

        AB = dot_product(VertexOnRelatedCoords(1,:),VertexOnRelatedCoords(2,:))
        BC = dot_product(VertexOnRelatedCoords(2,:),VertexOnRelatedCoords(3,:))
        CA = dot_product(VertexOnRelatedCoords(3,:),VertexOnRelatedCoords(1,:))
        AA = dot_product(VertexOnRelatedCoords(1,:),VertexOnRelatedCoords(1,:))

        if(AB*BC-AA*BC < 0.0d0) then
            TorF = 0
        else
            BB = dot_product(VertexOnRelatedCoords(2,:),VertexOnRelatedCoords(2,:))
            if(AB*BC-CA*BB < 0.0d0) then
                TorF = 0
            else
                TorF = 1
            end if
        end if

        return
    end function CheckPointInternalTriangle

    subroutine GetEdgeIntersectionCoords(Vertex11,Vertex12, Vertex21, Vertex22, IntersectCoords)
    implicit none
        double precision, intent(in) :: Vertex11(:), Vertex12(:), Vertex21(:), Vertex22(:)
        double precision, intent(out) :: IntersectCoords(:)

        double precision :: Ksi, Eta, Delta
        double precision :: Lambda, Mu !Coefficient of Line's Gradient

            !Check Intersect
            Ksi = (Vertex22(2)-Vertex21(2))*(Vertex22(1)-Vertex11(1)) - (Vertex22(1)-Vertex21(1))*(Vertex22(2)-Vertex11(2))
            Eta = (Vertex12(1)-Vertex11(1))*(Vertex22(2)-Vertex11(2)) - (Vertex12(2)-Vertex11(2))*(Vertex22(1)-Vertex11(1))
            Delta = (Vertex12(1)-Vertex11(1))*(Vertex22(2)-Vertex21(2)) - (Vertex12(2)-Vertex11(2))*(Vertex22(1)-Vertex21(1))
            if(Delta == 0.0d0) then
                write(6,*) Ksi,Eta,Delta
                stop
            end if
            Lambda = Ksi / Delta
            Mu = Eta / Delta

            IntersectCoords(1:2) = Vertex11(1:2) + Lambda*(Vertex12(1:2)-Vertex11(1:2))
            IntersectCoords(3) = 0.0d0

        return
    end subroutine GetEdgeIntersectionCoords

    function CheckEdgeIntersect(Vertex11,Vertex12, Vertex21, Vertex22) result(TorF)
    implicit none
        double precision, intent(in) :: Vertex11(:), Vertex12(:), Vertex21(:), Vertex22(:)
        integer :: TorF

        double precision :: Ksi, Eta

        !Check Intersect
        TorF = 0 !初期化
        Ksi = (Vertex11(1) - Vertex12(1))*(Vertex21(2)-Vertex11(2)) + (Vertex11(2)-Vertex12(2))*(Vertex11(1)-Vertex21(1))
        Eta = (Vertex11(1) - Vertex12(1))*(Vertex22(2)-Vertex11(2)) + (Vertex11(2)-Vertex12(2))*(Vertex11(1)-Vertex22(1))
        if(Ksi*Eta < 0.0d0) TorF = 1

        return
    end function CheckEdgeIntersect

    subroutine GetEdgeIntersectionCoordsWithTriangle(EdgeVertex1,EdgeVertex2,TriVertex1,TriVertex2,TriVertex3,IntersectCoords)
    implicit none
        double precision, intent(in) :: EdgeVertex1(:), EdgeVertex2(:)
        double precision, intent(in) :: TriVertex1(:), TriVertex2(:), TriVertex3(:)
        double precision, intent(out) :: IntersectCoords(:)
        integer :: iEndFlag

        iEndFlag = 0
        iEndFlag = CheckEdgeIntersect(EdgeVertex1,EdgeVertex2,TriVertex1,TriVertex2)
        if(iEndFlag == 1) then
            call GetEdgeIntersectionCoords(EdgeVertex1,EdgeVertex2,TriVertex1,TriVertex2,IntersectCoords)
        end if

        if(iEndFlag == 0) then
            iEndFlag = CheckEdgeIntersect(EdgeVertex1,EdgeVertex2,TriVertex2,TriVertex3)
            if(iEndFlag == 1) then
                call GetEdgeIntersectionCoords(EdgeVertex1,EdgeVertex2,TriVertex2,TriVertex3,IntersectCoords)
            end if
        end if

        if(iEndFlag == 0) then
            iEndFlag = CheckEdgeIntersect(EdgeVertex1,EdgeVertex2,TriVertex1,TriVertex3)
            if(iEndFlag == 1) then
                call GetEdgeIntersectionCoords(EdgeVertex1,EdgeVertex2,TriVertex1,TriVertex3,IntersectCoords)
            else  !Not intersect
                write(6,*) "Error Occured"
                stop
            end if
        end if

        return
    end subroutine GetEdgeIntersectionCoordsWithTriangle

    function AbsVector(vector) result(length)
        double precision, intent(in) :: vector(:)
        double precision :: length
        length = sqrt(dot_product(vector, vector))
        return
    end function AbsVector

    subroutine CheckBackOrFront(iMainCell, iAdjCell, iBackOrFront12, iBackOrFrontm11)
        implicit none
        integer, intent(in) :: iMainCell, iAdjCell
        integer, intent(out) :: iBackOrFront12
        double precision, intent(out) :: iBackOrFrontm11

        if(iMainCell > iAdjCell) then ! Main側の数字が大きい = Main側が表
            iBackOrFront12 = 1  ! GM%Width用
            iBackOrFrontm11 = -1.0d0    ! GM%Normalの向き調整用
        else    ! Main側の数字が小さい = Main側が裏
            iBackOrFront12 = 2
            iBackOrFrontm11 = 1.0d0
        end if
        return
    end subroutine CheckBackOrFront

    subroutine GetLengthBetweenEdge(UG, iEdge, iFrontCell, iBackCell,FrontLength, BackLength)
        use StructVar_Mod
        implicit none
        type(UnstructuredGrid), intent(in) :: UG
        integer, intent(in) :: iEdge
        integer, intent(out) :: iFrontCell, iBackCell
        double precision, intent(out) :: FrontLength, BackLength
            iFrontCell = UG%Line%Cell(iEdge,1,1)
            iBackCell =  UG%Line%Cell(iEdge,2,1)

            FrontLength = AbsVector(UG%GM%Width(iFrontCell, UG%Line%Cell(iEdge,1,2), :))
            BackLength = AbsVector(UG%GM%Width(iBackCell, UG%Line%Cell(iEdge,2,2), :))
        return
    end subroutine GetLengthBetweenEdge

    subroutine SaveLog(logMessage, UConf)
        use StructVar_Mod
        implicit none
        character(len=256), intent(in) :: logMessage
        type(Configulation), intent(in) :: UConf

        open(9999, file=UConf%cLogName, status="unknown", position="append")
            write(9999,*) trim(adjustl(logMessage))
        close(9999)

        return
    end subroutine SaveLog
end module FrequentOperation


module mo_map_functions

  use mo_kind, only: int8=>i1, int16=>i2, int32=>i4, int64=>i8, real32=>sp, real64=>dp
#if defined (__pgiFortran__) || defined (__NAGf90Fortran__) || defined (__NAG__)
  use mo_kind, only: real128=>dp
#else
  use mo_kind, only: real128=>qp
#endif

  implicit none

  public

contains

  pure integer(kind=int8) function xpowx_i1(x) result(res)
    integer(kind=int8),intent(in) :: x
    res = x**x
  end function xpowx_i1

  pure integer(kind=int16) function xpowx_i2(x) result(res)
    integer(kind=int16),intent(in) :: x
    res = x**x
  end function xpowx_i2

  pure integer(kind=int32) function xpowx_i4(x) result(res)
    integer(kind=int32),intent(in) :: x
    res = x**x
  end function xpowx_i4

  pure integer(kind=int64) function xpowx_i8(x) result(res)
    integer(kind=int64),intent(in) :: x
    res = x**x
  end function xpowx_i8

  pure real(kind=real32) function xpowx_r4(x) result(res)
    real(kind=real32),intent(in) :: x
    res = x**x
  end function xpowx_r4

  pure real(kind=real64) function xpowx_r8(x) result(res)
    real(kind=real64),intent(in) :: x
    res = x**x
  end function xpowx_r8

  pure real(kind=real128) function xpowx_r16(x) result(res)
    real(kind=real128),intent(in) :: x
    res = x**x
  end function xpowx_r16

  pure complex(kind=real32) function xpowx_c4(x) result(res)
    complex(kind=real32),intent(in) :: x
    res = x**x
  end function xpowx_c4

  pure complex(kind=real64) function xpowx_c8(x) result(res)
    complex(kind=real64),intent(in) :: x
    res = x**x
  end function xpowx_c8

  pure complex(kind=real128) function xpowx_c16(x) result(res)
    complex(kind=real128),intent(in) :: x
    res = x**x
  end function xpowx_c16

end module mo_map_functions


*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZBDT05( M, N, A, LDA, S, NS, U, LDU,
*                          VT, LDVT, WORK, RESID )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, LDU, LDVT, N, NS
*       DOUBLE PRECISION   RESID
*       ..
*       .. Array Arguments ..
*      DOUBLE PRECISION   S( * )
*      COMPLEX*16         A( LDA, * ), U( * ), VT( LDVT, * ), WORK( * )
*       ..
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZBDT05 reconstructs a bidiagonal matrix B from its (partial) SVD:
*>    S = U' * B * V
*> where U and V are orthogonal matrices and S is diagonal.
*>
*> The test ratio to test the singular value decomposition is
*>    RESID = norm( S - U' * B * V ) / ( n * norm(B) * EPS )
*> where VT = V' and EPS is the machine precision.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrices A and U.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrices A and VT.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          The m by n matrix A.
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*>          S is DOUBLE PRECISION array, dimension (NS)
*>          The singular values from the (partial) SVD of B, sorted in
*>          decreasing order.
*> \endverbatim
*>
*> \param[in] NS
*> \verbatim
*>          NS is INTEGER
*>          The number of singular values/vectors from the (partial)
*>          SVD of B.
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is COMPLEX*16 array, dimension (LDU,NS)
*>          The n by ns orthogonal matrix U in S = U' * B * V.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of the array U.  LDU >= max(1,N)
*> \endverbatim
*>
*> \param[in] VT
*> \verbatim
*>          VT is COMPLEX*16 array, dimension (LDVT,N)
*>          The n by ns orthogonal matrix V in S = U' * B * V.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*>          LDVT is INTEGER
*>          The leading dimension of the array VT.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (M,N)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is DOUBLE PRECISION
*>          The test ratio:  norm(S - U' * A * V) / ( n * norm(A) * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE ZBDT05( M, N, A, LDA, S, NS, U, LDU,
     $                    VT, LDVT, WORK, RESID )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDU, LDVT, M, N, NS
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   S( * )
      COMPLEX*16         A( LDA, * ), U( * ), VT( LDVT, * ), WORK( * )
*     ..
*
* ======================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   ANORM, EPS
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM, DLAMCH, ZLANGE
      EXTERNAL           LSAME, IDAMAX, DASUM, DLAMCH, ZLANGE
      DOUBLE PRECISION   DZASUM
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZGEMM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible.
*
      RESID = ZERO
      IF( MIN( M, N ).LE.0 .OR. NS.LE.0 )
     $   RETURN
*
      EPS = DLAMCH( 'Precision' )
      ANORM = ZLANGE( 'M', M, N, A, LDA, DUM )
*
*     Compute U' * A * V.
*
      CALL ZGEMM( 'N', 'C', M, NS, N, CONE, A, LDA, VT,
     $            LDVT, CZERO, WORK( 1+NS*NS ), M )
      CALL ZGEMM( 'C', 'N', NS, NS, M, -CONE, U, LDU, WORK( 1+NS*NS ),
     $            M, CZERO, WORK, NS )
*
*     norm(S - U' * B * V)
*
      J = 0
      DO 10 I = 1, NS
         WORK( J+I ) =  WORK( J+I ) + DCMPLX( S( I ), ZERO )
         RESID = MAX( RESID, DZASUM( NS, WORK( J+1 ), 1 ) )
         J = J + NS
   10 CONTINUE
*
      IF( ANORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         IF( ANORM.GE.RESID ) THEN
            RESID = ( RESID / ANORM ) / ( DBLE( N )*EPS )
         ELSE
            IF( ANORM.LT.ONE ) THEN
               RESID = ( MIN( RESID, DBLE( N )*ANORM ) / ANORM ) /
     $                 ( DBLE( N )*EPS )
            ELSE
               RESID = MIN( RESID / ANORM, DBLE( N ) ) /
     $                 ( DBLE( N )*EPS )
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of ZBDT05
*
      END


!> Author:   Jabir Ali Ouassou
!> Category: Foundation
!>
!> This module defines the data type 'spin', which represents 2×2 complex matrices in spin space. The module overloads
!> common arithmetic operators to work with the new data type, and defines and exports the Pauli matrices as constants.
!> To make it easier to interact with common differential equation solvers, which often operate on real state vectors,
!> the assignment operator is overloaded in such a way that 'spin' can be easily imported/exported to a real vector(8).

module spin_m
  use :: math_m
  private

  ! Public interface
  public spin
  public inverse, trace, conjg, norm2, sum
  public pauli, pauli0, pauli1, pauli2, pauli3

  ! Type declaration
  type spin
    complex(wp) :: matrix(2,2) = 0.0_wp   !! Encapsulate a spin matrix
  contains
    ! Overload constructors and operators
    generic :: spin          => cons_rscalar, cons_cscalar, cons_cmatrix, cons_rvector, cons_spin
    generic :: assignment(=) => assr_rscalar, assr_cscalar, assr_cmatrix, assr_rvector, assl_cmatrix, assl_rvector
    generic :: operator(+)   => addl_rscalar, addr_rscalar, addl_cscalar, addr_cscalar, addl_cmatrix, addr_cmatrix, add_spin
    generic :: operator(-)   => subl_rscalar, subr_rscalar, subl_cscalar, subr_cscalar, subl_cmatrix, subr_cmatrix, sub_spin
    generic :: operator(*)   => mull_rscalar, mulr_rscalar, mull_cscalar, mulr_cscalar, mull_cmatrix, mulr_cmatrix, mul_spin
    generic :: operator(/)   => divr_rscalar, divr_cscalar
    generic :: operator(**)  => expr_iscalar

    ! Specific methods for construction
    procedure,   nopass,   private :: cons_spin    => spin_cons_spin      !! Construction from a spin object
    procedure,   nopass,   private :: cons_rscalar => spin_cons_rscalar   !! Construction from a real scalar
    procedure,   nopass,   private :: cons_cscalar => spin_cons_cscalar   !! Construction from a complex scalar
    procedure,   nopass,   private :: cons_cmatrix => spin_cons_cmatrix   !! Construction from a complex matrix
    procedure,   nopass,   private :: cons_rvector => spin_cons_rvector   !! Construction from a real vector

    ! Specific methods for importing the object state
    ! Specific implementations of assignments
    procedure, pass(this), private :: assr_rscalar => spin_assr_rscalar   !! Assign data from a real scalar      (right)
    procedure, pass(this), private :: assr_cscalar => spin_assr_cscalar   !! Assign data from a complex scalar   (right)
    procedure, pass(this), private :: assl_cmatrix => spin_assl_cmatrix   !! Assign data into a complex matrix   (left)
    procedure, pass(this), private :: assr_cmatrix => spin_assr_cmatrix   !! Assign data from a complex matrix   (right)
    procedure, pass(this), private :: assl_rvector => spin_assl_rvector   !! Assign data into a real vector      (left)
    procedure, pass(this), private :: assr_rvector => spin_assr_rvector   !! Assign data from a real vector      (right)

    ! Specific implementations of addition
    procedure, pass(this), private :: add_spin     => spin_add_spin       !! Addition with a spin object
    procedure, pass(this), private :: addl_rscalar => spin_addl_rscalar   !! Addition with a real scalar         (left)
    procedure, pass(this), private :: addr_rscalar => spin_addr_rscalar   !! Addition with a real scalar         (right)
    procedure, pass(this), private :: addl_cscalar => spin_addl_cscalar   !! Addition with a complex scalar      (left)
    procedure, pass(this), private :: addr_cscalar => spin_addr_cscalar   !! Addition with a complex scalar      (right)
    procedure, pass(this), private :: addl_cmatrix => spin_addl_cmatrix   !! Addition with a complex matrix      (left)
    procedure, pass(this), private :: addr_cmatrix => spin_addr_cmatrix   !! Addition with a complex matrix      (right)

    ! Specific implementations of subtraction
    procedure, pass(this), private :: sub_spin     => spin_sub_spin       !! Subtraction with a spin object
    procedure, pass(this), private :: subl_rscalar => spin_subl_rscalar   !! Subtraction with a real scalar      (left)
    procedure, pass(this), private :: subr_rscalar => spin_subr_rscalar   !! Subtraction with a real scalar      (right)
    procedure, pass(this), private :: subl_cscalar => spin_subl_cscalar   !! Subtraction with a complex scalar   (left)
    procedure, pass(this), private :: subr_cscalar => spin_subr_cscalar   !! Subtraction with a complex scalar   (right)
    procedure, pass(this), private :: subl_cmatrix => spin_subl_cmatrix   !! Subtraction with a complex matrix   (left)
    procedure, pass(this), private :: subr_cmatrix => spin_subr_cmatrix   !! Subtraction with a complex matrix   (right)

    ! Specific implementations of multiplication
    procedure, pass(this), private :: mul_spin     => spin_mul_spin       !! Multiplication by a spin object
    procedure, pass(this), private :: mull_rscalar => spin_mull_rscalar   !! Multiplication by a real scalar     (left)
    procedure, pass(this), private :: mulr_rscalar => spin_mulr_rscalar   !! Multiplication by a real scalar     (right)
    procedure, pass(this), private :: mull_cscalar => spin_mull_cscalar   !! Multiplication by a complex scalar  (left)
    procedure, pass(this), private :: mulr_cscalar => spin_mulr_cscalar   !! Multiplication by a complex scalar  (right)
    procedure, pass(this), private :: mull_cmatrix => spin_mull_cmatrix   !! Multiplication by a complex matrix  (left)
    procedure, pass(this), private :: mulr_cmatrix => spin_mulr_cmatrix   !! Multiplication by a complex matrix  (right)

    ! Specific implementations of division
    procedure, pass(this), private :: divr_rscalar => spin_divr_rscalar   !! Division by a real scalar           (right)
    procedure, pass(this), private :: divr_cscalar => spin_divr_cscalar   !! Division by a complex scalar        (right)

    ! Specific implementations of exponentiation
    procedure, pass(this), private :: expr_iscalar => spin_expr_iscalar   !! Exponentiation by an integer        (right)
  end type

  ! Public interfaces
  interface inverse
    !! Matrix inverse
    module procedure spin_inv
  end interface

  interface trace
    !! Matrix trace
    module procedure spin_trace
  end interface

  interface sum
    !! Matrix sum
    module procedure spin_sum
  end interface

  interface conjg
    !! Complex conjugation
    module procedure spin_conjg
  end interface

  interface norm2
    !! Matrix norm
    module procedure spin_norm
  end interface

  ! Exported constants
  type(spin), parameter                 :: pauli0 = spin(reshape([ ( 1, 0), ( 0, 0), ( 0, 0), ( 1, 0) ], [2,2], order=[2,1]))
  type(spin), parameter                 :: pauli1 = spin(reshape([ ( 0, 0), ( 1, 0), ( 1, 0), ( 0, 0) ], [2,2], order=[2,1]))
  type(spin), parameter                 :: pauli2 = spin(reshape([ ( 0, 0), ( 0,-1), ( 0, 1), ( 0, 0) ], [2,2], order=[2,1]))
  type(spin), parameter                 :: pauli3 = spin(reshape([ ( 1, 0), ( 0, 0), ( 0, 0), (-1, 0) ], [2,2], order=[2,1]))
  type(spin), parameter, dimension(0:3) :: pauli  = [pauli0, pauli1, pauli2, pauli3]
contains

  !--------------------------------------------------------------------------------!
  !                            SPECIFIC CONSTRUCTORS                               !
  !--------------------------------------------------------------------------------!

  pure function spin_cons_rscalar(other) result(this)
    !! Constructs a spin object from a real scalar.
    real(wp),  intent(in)  :: other
    type(spin)             :: this

    this = other
  end function

  pure function spin_cons_cscalar(other) result(this)
    !! Constructs a spin object from a complex scalar.
    complex(wp), intent(in)  :: other
    type(spin)               :: this

    this = other
  end function

  pure function spin_cons_cmatrix(other) result(this)
    !! Constructs a spin object from a complex matrix.
    complex(wp), intent(in) :: other(2,2)
    type(spin)              :: this

    this = other
  end function

  pure function spin_cons_rvector(other) result(this)
    !! Constructs a spin object from a real vector.
    real(wp), intent(in) :: other(8)
    type(spin)           :: this

    this = other
  end function

  pure function spin_cons_spin(other) result(this)
    !! Constructs a spin object from an existing one.
    type(spin), intent(in) :: other
    type(spin)             :: this

    this = other
  end function

  !--------------------------------------------------------------------------------!
  !                         SPECIFIC IMPORT PROCEDURES                             !
  !--------------------------------------------------------------------------------!

  pure subroutine spin_assr_rscalar(this, other)
    !! Imports data to a spin object from a real scalar.
    class(spin), intent(inout) :: this
    real(wp),    intent(in)    :: other

    this%matrix = other * pauli0%matrix
  end subroutine

  pure subroutine spin_assr_cscalar(this, other)
    !! Imports data to a spin object from a complex scalar.
    class(spin), intent(inout) :: this
    complex(wp), intent(in)    :: other

    this%matrix = other * pauli0%matrix
  end subroutine

  pure subroutine spin_assr_cmatrix(this, other)
    !! Imports data to a spin object from a complex matrix.
    class(spin),  intent(inout) :: this
    complex(wp),  intent(in)    :: other(2,2)

    this%matrix = other
  end subroutine

  pure subroutine spin_assr_rvector(this, other)
    !! Imports data to a spin object from a real vector.
    class(spin), intent(inout) :: this
    real(wp),    intent(in)    :: other(8)

    this%matrix = cx(reshape(other(1:7:2),[2,2],order=[2,1]),&
                     reshape(other(2:8:2),[2,2],order=[2,1]))
  end subroutine

  !--------------------------------------------------------------------------------!
  !                         SPECIFIC EXPORT PROCEDURES                             !
  !--------------------------------------------------------------------------------!

  pure subroutine spin_assl_cmatrix(other, this)
    !! Exports data from a spin object to a complex matrix.
    class(spin), intent(in)  :: this
    complex(wp), intent(out) :: other(2,2)

    other = this%matrix
  end subroutine

  pure subroutine spin_assl_rvector(other, this)
    !! Exports data from a spin object to a real vector.
    class(spin), intent(in)  :: this
    real(wp),    intent(out) :: other(8)

    other(1:7:2) = re([ this%matrix(1,:), this%matrix(2,:) ])
    other(2:8:2) = im([ this%matrix(1,:), this%matrix(2,:) ])
  end subroutine

  !--------------------------------------------------------------------------------!
  !                     SPECIFIC EXPONENTIATION PROCEDURES                         !
  !--------------------------------------------------------------------------------!

  pure function spin_expr_iscalar(this, other) result(r)
    !! Exponentiates the spin object, where the power is a positive integer.
    class(spin), intent(in) :: this
    integer,     intent(in) :: other
    type(spin)              :: r
    integer                 :: n

    r = this
    do n=2,other
      r%matrix = r%matrix * this
    end do
  end function

  !--------------------------------------------------------------------------------!
  !                     SPECIFIC MULTIPLICATION PROCEDURES                         !
  !--------------------------------------------------------------------------------!

  elemental pure function spin_mul_spin(this, other) result(r)
    !! Defines multiplication of two spin matrices.
    class(spin), intent(in) :: this
    class(spin), intent(in) :: other
    type(spin)              :: r

    r%matrix = matmul(this%matrix, other%matrix)
  end function

  pure function spin_mull_rscalar(other, this) result(r)
    !! Defines left multiplication of a spin matrix by a real scalar.
    class(spin), intent(in) :: this
    real(wp),    intent(in) :: other
    type(spin)              :: r

    r%matrix = other * this%matrix
  end function

  pure function spin_mulr_rscalar(this, other) result(r)
    !! Defines right multiplication of a spin matrix by a real scalar.
    class(spin), intent(in) :: this
    real(wp),    intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix * other
  end function

  pure function spin_mull_cscalar(other, this) result(r)
    !! Defines left multiplication of a spin matrix by a complex scalar.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other
    type(spin)              :: r

    r%matrix = other * this%matrix
  end function

  function spin_mulr_cscalar(this, other) result(r)
    !! Defines right multiplication of a spin matrix by a complex scalar.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix * other
  end function

  pure function spin_mull_cmatrix(other, this) result(r)
    !! Defines left multiplication of a spin matrix by a complex matrix.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other(2,2)
    type(spin)              :: r

    r%matrix = matmul(other, this%matrix)
  end function

  pure function spin_mulr_cmatrix(this, other) result(r)
    !! Defines right multiplication of a spin matrix by a complex matrix.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other(2,2)
    type(spin)              :: r

    r%matrix = matmul(this%matrix, other)
  end function

  !--------------------------------------------------------------------------------!
  !                        SPECIFIC DIVISION PROCEDURES                            !
  !--------------------------------------------------------------------------------!

  pure function spin_divr_rscalar(this, other) result(r)
    !! Defines division of a spin matrix by a real scalar.
    class(spin), intent(in) :: this
    real(wp),    intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix / other
  end function

  pure function spin_divr_cscalar(this, other) result(r)
    !! Defines division of a spin matrix by a complex scalar.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix / other
  end function

  !--------------------------------------------------------------------------------!
  !                        SPECIFIC ADDITION PROCEDURES                            !
  !--------------------------------------------------------------------------------!

  elemental pure function spin_add_spin(this, other) result(r)
    !! Defines addition of two spin matrices.
    class(spin), intent(in) :: this
    class(spin), intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix + other%matrix
  end function

  pure function spin_addl_rscalar(other, this) result(r)
    !! Defines left addition of a spin matrix and a real scalar.
    class(spin), intent(in) :: this
    real(wp),    intent(in) :: other
    type(spin)              :: r

    r%matrix = other*pauli0%matrix + this%matrix
  end function

  pure function spin_addr_rscalar(this, other) result(r)
    !! Defines right addition of a spin matrix and a real scalar.
    class(spin), intent(in) :: this
    real(wp),    intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix + other*pauli0%matrix
  end function

  pure function spin_addl_cscalar(other, this) result(r)
    !! Defines left addition of a spin matrix and a complex scalar.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other
    type(spin)              :: r

    r%matrix = other*pauli0%matrix + this%matrix
  end function

  pure function spin_addr_cscalar(this, other) result(r)
    !! Defines right addition of a spin matrix and a complex scalar.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix + other*pauli0%matrix
  end function

  pure function spin_addl_cmatrix(other, this) result(r)
    !! Defines left addition of a spin matrix and a complex matrix.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other(2,2)
    type(spin)              :: r

    r%matrix = other + this%matrix
  end function

  pure function spin_addr_cmatrix(this, other) result(r)
    !! Defines right addition of a spin matrix and a complex matrix.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other(2,2)
    type(spin)              :: r

    r%matrix = this%matrix + other
  end function

  !--------------------------------------------------------------------------------!
  !                       SPECIFIC SUBTRACTION PROCEDURES                          !
  !--------------------------------------------------------------------------------!

  elemental pure function spin_sub_spin(this, other) result(r)
    !! Defines subtraction of two spin matrices.
    class(spin), intent(in) :: this
    class(spin), intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix - other%matrix
  end function

  pure function spin_subl_rscalar(other, this) result(r)
    !! Defines left subtraction of a spin matrix and a real scalar.
    class(spin), intent(in) :: this
    real(wp),    intent(in) :: other
    type(spin)              :: r

    r%matrix = other*pauli0%matrix - this%matrix
  end function

  pure function spin_subr_rscalar(this, other) result(r)
    !! Defines right subtraction of a spin matrix and a real scalar.
    class(spin), intent(in) :: this
    real(wp),    intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix - other*pauli0%matrix
  end function

  pure function spin_subl_cscalar(other, this) result(r)
    !! Defines left subtraction of a spin matrix and a complex scalar.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other
    type(spin)              :: r

    r%matrix = other*pauli0%matrix - this%matrix
  end function

  pure function spin_subr_cscalar(this, other) result(r)
    !! Defines right subtraction of a spin matrix and a complex scalar.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other
    type(spin)              :: r

    r%matrix = this%matrix - other*pauli0%matrix
  end function

  pure function spin_subl_cmatrix(other, this) result(r)
    !! Defines left subtraction of a spin matrix and a complex matrix.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other(2,2)
    type(spin)              :: r

    r%matrix = other - this%matrix
  end function

  pure function spin_subr_cmatrix(this, other) result(r)
    !! Defines right subtraction of a spin matrix and a complex matrix.
    class(spin), intent(in) :: this
    complex(wp), intent(in) :: other(2,2)
    type(spin)              :: r

    r%matrix = this%matrix - other
  end function

  !--------------------------------------------------------------------------------!
  !                                MATRIX ALGEBRA                                  !
  !--------------------------------------------------------------------------------!

  elemental pure function spin_norm(this) result(r)
    !! Calculate the Frobenius norm of the spin matrix.
    class(spin), intent(in) :: this
    real(wp)                :: r, w(8)

    w = this
    r = norm2(w)
  end function

  elemental pure function spin_conjg(this) result(r)
    !! Calculate the complex conjugate of the spin matrix.
    class(spin), intent(in) :: this
    type(spin)              :: r

    r%matrix = conjg(this%matrix)
  end function

  elemental pure function spin_trace(this) result(r)
    !! Calculate the trace of the spin matrix.
    class(spin), intent(in) :: this
    complex(wp)             :: r

    r = this%matrix(1,1) + this%matrix(2,2)
  end function

  pure function spin_inv(this) result(r)
    !! Calculate the inverse of the spin matrix.
    class(spin), intent(in) :: this
    type(spin)              :: r

    r%matrix = inverse(this%matrix)
  end function

  pure function spin_sum(this) result(r)
    !! Calculate the sum of an array of spin matrices.
    class(spin), intent(in) :: this(:)
    type(spin)              :: r
    integer                 :: n

    do n=1,size(this)
      r % matrix = r % matrix + this(n) % matrix
    end do
  end function
end module


    !Purpose: Calcualte N or P flow from Pool A to Pool B, as well as immobilization or mineralization
    SUBROUTINE nut_np_flow (                                           &
        C_A, E_A, CEtoB, C_AtoB, CO2fromA,                                  &   !Input
        E_AtoB, IMM_AtoB, MNR_AtoB)                          !Output

    IMPLICIT NONE

    real, intent(in) :: C_A            !         |Amount of carbon in pool A at the beginning of the time step (kg C ha-1)
    real, intent(in) :: E_A            !         | Amount of N or P in pool A at the beginning of the time step (kg C ha-1)
    real, intent(in) :: CEtoB          !         | C:E ratio (i.e. C:N or C:P) of the material enters pool B (fraction)
    real, intent(in) :: C_AtoB         !         | C flow from pool A to pool B (kg N or P ha-1 day-1)
    real, intent(in) ::  CO2fromA      !         | CO2 emission during the decomposition of pool A (kg C ha-1 day-1)
    real, intent(out) :: E_AtoB        !         | E (i.e. N or P) flow from pool A to B (kg N or P ha-1 day-1)
    real, intent(out) :: IMM_AtoB      !         | Immobilization of E in order to satisfy the CEtoB ratio (kg N or P ha-1 day-1)
    real, intent(out) :: MNR_AtoB      !         | Mineralization of E as the result of pool A to Pool B transformation (kg N or P ha-1 day-1)

    !!Local
    real :: EfromCO2                   !         |
    real :: efco2                      !         |E mineralization resulting from CO2 respiration as result of pool A decomposition (kg N or P ha-1 day-1)

    !Initialize to zero.
    E_AtoB = 0.
    EfromCO2 = 0.
    MNR_AtoB = 0.
    IMM_AtoB = 0.

    ! IF N or P in pool A is zero or no C flows from pool A to B, then skip the rest of the calculationg and return
    IF (E_A .LT. 1.E-6 .OR. C_AtoB .LT. 1.E-6 .OR. C_A .LT. 1.E-6) RETURN

    !Calcualting E (N or P) transformed from pool A to pool B by assuming E flow is proportional to C flow
    E_AtoB = E_A * (C_AtoB / C_A)

    !E supply due to CO2 emission during the transformation of C from Pool A to B.
    IF (CO2fromA .LT. 0.) THEN
        EfromCO2 = 0.
    ELSE
        EfromCO2 = E_A * (CO2fromA / C_A)
    ENDIF

    !If C:E ratio of the material transformed from pool A to B is larger than
    !C:E ratio that is permitted by the receiving pool B, then immobilization of
    !N or P is required to lower C:E ratio of the transformed material to meet
    ! the requirement by pool B.
    IF (C_AtoB / E_AtoB .GT. CEtoB) THEN
        !Potential immobilization is calcualted as:
        IMM_AtoB = C_AtoB / CEtoB - E_AtoB

    ELSE
        !The amount of E that flows from pool A to pool B is enough to
        !satisfy the condition of the C/E ratio that is allowed to enter
        !pool B. The rest of the E coming from pool A is mineralized.
        MNR_AtoB = E_AtoB - C_AtoB / CEtoB

        !Correct the E flow from pool A to pool B for the E
        !mineralization.
        E_AtoB = E_AtoB - MNR_AtoB
    ENDIF

    !Sum the E released due to CO2 respiration with the E release
    !related to the flow from pool A to B.
    MNR_AtoB = MNR_AtoB + EFCO2

    RETURN
    END SUBROUTINE nut_np_flow


*DECK QAGS
      SUBROUTINE QAGS (F, UDATA, A, B, EPSABS, EPSREL, RESULT,
     +   ABSERR, NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C***BEGIN PROLOGUE  QAGS
C***PURPOSE  The routine calculates an approximation result to a given
C            Definite integral  I = Integral of F over (A,B),
C            Hopefully satisfying following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A1A1
C***TYPE      SINGLE PRECISION (QAGS-S, DQAGS-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, END POINT SINGULARITIES,
C             EXTRAPOLATION, GENERAL-PURPOSE, GLOBALLY ADAPTIVE,
C             QUADPACK, QUADRATURE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of a definite integral
C        Standard fortran subroutine
C        Real version
C
C
C        PARAMETERS
C         ON ENTRY
C            F      - Real
C                     Function subprogram defining the integrand
C                     Function F(X). The actual name for F needs to be
C                     Declared E X T E R N A L in the driver program.
C
C            A      - Real
C                     Lower limit of integration
C
C            B      - Real
C                     Upper limit of integration
C
C            EPSABS - Real
C                     Absolute accuracy requested
C            EPSREL - Real
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     And EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     The routine will end with IER = 6.
C
C         ON RETURN
C            RESULT - Real
C                     Approximation to the integral
C
C            ABSERR - Real
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine
C                             The estimates for integral and error are
C                             less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more sub-
C                             divisions by increasing the value of LIMIT
C                             (and taking the according dimension
C                             adjustments into account. However, if
C                             this yields no improvement it is advised
C                             to analyze the integrand in order to
C                             determine the integration difficulties. If
C                             the position of a local difficulty can be
C                             determined (e.g. SINGULARITY,
C                             DISCONTINUITY within the interval) one
C                             will probably gain from splitting up the
C                             interval at this point and calling the
C                             integrator on the subranges. If possible,
C                             an appropriate special-purpose integrator
C                             should be used, which is designed for
C                             handling the type of difficulty involved.
C                         = 2 The occurrence of roundoff error is detec-
C                             ted, which prevents the requested
C                             tolerance from being achieved.
C                             The error may be under-estimated.
C                         = 3 Extremely bad integrand behaviour
C                             occurs at some points of the integration
C                             interval.
C                         = 4 The algorithm does not converge.
C                             Roundoff error is detected in the
C                             Extrapolation table. It is presumed that
C                             the requested tolerance cannot be
C                             achieved, and that the returned result is
C                             the best which can be obtained.
C                         = 5 The integral is probably divergent, or
C                             slowly convergent. It must be noted that
C                             divergence can occur with any other value
C                             of IER.
C                         = 6 The input is invalid, because
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)
C                             OR LIMIT.LT.1 OR LENW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST are set to
C                             zero.  Except when LIMIT or LENW is
C                             invalid, IWORK(1), WORK(LIMIT*2+1) and
C                             WORK(LIMIT*3+1) are set to zero, WORK(1)
C                             is set to A and WORK(LIMIT+1) TO B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - Integer
C                    Dimensioning parameter for IWORK
C                    LIMIT determines the maximum number of subintervals
C                    in the partition of the given integration interval
C                    (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, the routine will end with IER = 6.
C
C            LENW  - Integer
C                    Dimensioning parameter for WORK
C                    LENW must be at least LIMIT*4.
C                    If LENW.LT.LIMIT*4, the routine will end
C                    with IER = 6.
C
C            LAST  - Integer
C                    On return, LAST equals the number of subintervals
C                    produced in the subdivision process, determines the
C                    number of significant elements actually in the WORK
C                    Arrays.
C
C         WORK ARRAYS
C            IWORK - Integer
C                    Vector of dimension at least LIMIT, the first K
C                    elements of which contain pointers
C                    to the error estimates over the subintervals
C                    such that WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) form a decreasing
C                    sequence, with K = LAST IF LAST.LE.(LIMIT/2+2),
C                    and K = LIMIT+1-LAST otherwise
C
C            WORK  - Real
C                    Vector of dimension at least LENW
C                    on return
C                    WORK(1), ..., WORK(LAST) contain the left
C                     end-points of the subintervals in the
C                     partition of (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain
C                     the right end-points,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain
C                     the integral approximations over the subintervals,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     contain the error estimates.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  QAGSE, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  QAGS
C
C
      REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(*),WORK(*)
C
      EXTERNAL F, UDATA
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  QAGS
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10
C
C         PREPARE CALL FOR QAGSE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
C
      CALL QAGSE(F,UDATA,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,
     1  IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAGS',
     +   'ABNORMAL RETURN', IER, LVL)
      RETURN
      END


C * * * * * * * * * * * * * * *
C --- DRIVER FOR RETARD
C * * * * * * * * * * * * * * *
compile retard
cfeh dr_retard retard
        IMPLICIT REAL*8 (A-H,O-Z)
        PARAMETER (NDGL=3,NGRID=11,LWORK=8*NDGL+21+NGRID,LIWORK=20)
        PARAMETER (NRDENS=1,LRCONT=600,LICONT=NRDENS+1)
        DIMENSION Y(NDGL),WORK(LWORK),IWORK(LIWORK)
        COMMON /CORER/RCONT(LRCONT)
        COMMON /COREI/ICONT(LICONT)
        EXTERNAL FCN,SOLOUT
C --- DIMENSION OF THE SYSTEM
        N=NDGL
C --- OUTPUT ROUTINE IS USED DURING INTEGRATION
        IOUT=1
C --- INITIAL VALUES AND ENDPOINT OF INTEGRATION
        RPAR=0.1D0
        X=0.0D0
        Y(1)=5.0D0
        Y(2)=0.1D0
        Y(3)=1.0D0
        XEND=40.D0
C --- REQUIRED (RELATIVE AND ABSOLUTE) TOLERANCE
        ITOL=0
        RTOL=1.0D-5
        ATOL=RTOL
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,20
        IWORK(I)=0
  10    WORK(I)=0.D0
C --- SECOND COMPONENT USES RETARDED ARGUMENT
        IWORK(5)=NRDENS
        ICONT(2)=2
C ---  USE AS GRID-POINTS
        IWORK(6)=NGRID
        DO 12 I=1,NGRID-1
  12    WORK(20+I)=I
        WORK(20+NGRID)=20.D0
C --- CALL OF THE SUBROUTINE RETARD
        CALL RETARD(N,FCN,X,Y,XEND,
     &              RTOL,ATOL,ITOL,
     &              SOLOUT,IOUT,
     &              WORK,LWORK,IWORK,LIWORK,LRCONT,LICONT,
     &              RPAR,IPAR,IDID)
C --- PRINT FINAL SOLUTION
        WRITE (6,99) Y(1),Y(2),Y(3)
 99     FORMAT(1X,'X = XEND     Y =',3E18.10)
C --- PRINT STATISTICS
        WRITE (6,91) RTOL,(IWORK(J),J=17,20)
 91     FORMAT('     tol=',D8.2,'   fcn=',I5,' step=',I4,
     &             ' accpt=',I4,' rejct=',I3)
        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,RPAR,IPAR,IRTRN)
C --- PRINTS SOLUTION AT EQUIDISTANT OUTPUT-POINTS
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N)
        EXTERNAL PHI
        COMMON /INTERN/XOUT
        IF (NR.EQ.1) THEN
           WRITE (6,99) X,Y(1),NR-1
           XOUT=X+5.D0
        ELSE
 10        CONTINUE
           IF (X.GE.XOUT) THEN
              WRITE (6,99) X,Y(1),NR-1
              XOUT=XOUT+5.D0
              GOTO 10
           END IF
        END IF
 99     FORMAT(1X,'X =',F6.2,'    Y =',E18.10,'    NSTEP =',I4)
        RETURN
        END
C
        SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR)
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        EXTERNAL PHI
        Y2L1=YLAG(2,X-1.D0,PHI,RPAR,IPAR)
        Y2L10=YLAG(2,X-10.D0,PHI,RPAR,IPAR)
        F(1)=-Y(1)*Y2L1+Y2L10
        F(2)=Y(1)*Y2L1-Y(2)
        F(3)=Y(2)-Y2L10
        RETURN
        END
C
        FUNCTION PHI(I,X,RPAR,IPAR)
        IMPLICIT REAL*8 (A-H,O-Z)
        IF (I.EQ.2) PHI=RPAR
        RETURN
        END


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, xp, yp, zp, rp
      integer blockno

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

      integer example
      common /example_comm/ example

      double precision r_cyl, h_cyl
      common /cylinder_comm/ r_cyl, h_cyl

      DOUBLE PRECISION xc0, yc0, r0
      COMMON /cylinder_init_comm/ xc0, yc0, r0

      integer*8 cont, get_context
      double precision xp0, yp0, zp0, r

      cont = get_context()

      call fclaw2d_map_c2m(cont, blockno,xc,yc,xp,yp,zp)

      call fclaw2d_map_c2m(cont, blockno,xc0,yc0,xp0,yp0,zp0)

c     # Distance from thc
c      r = sqrt((xp-xp0)**2 + (yp-yp0)**2 + (zp-zp0)**2)

c      fdisc = r - r0

      r = abs(yc - .5d0)
      fdisc = r - 0.25

      end


      SUBROUTINE IDMAT (SZ, MAT)

C General purpose routine to initialize a square matrix to
C the identity matrix.

      INTEGER   SZ, I,J
      REAL      MAT(SZ, SZ)

      DO 100 I = 1,SZ
      DO 200 J = 1,SZ
         IF (I .EQ. J) THEN
            MAT (I,J) = 1.0
         ELSE
            MAT (I,J) = 0.0
         ENDIF
200   CONTINUE
100   CONTINUE

      END


	FUNCTION PR_P03D ( ctend )
C************************************************************************
C* PR_P03D								*
C*									*
C* This subroutine translates a WMO pressure tendency string into the	*
C* pressure tendency code * 1000 + the magnitude of the change in	*
C* tenths of millibars.							*
C*									*
C* REAL PR_P03D ( CTEND )						*
C*									*
C* Input parameters:							*
C*	CTEND		CHAR*		WMO pressure tendency code	*
C*									*
C* Output parameters:							*
C*	PR_P03D		REAL		Pressure change information	*
C**									*
C* Log:									*
C* K. Brill/NMC		11/91						*
C* K. Brill/NMC		02/92	Translate into a 4-digit number		*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	ctend
C*
	CHARACTER*4	cc
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	PR_P03D = RMISSD
C
C*	Get pressure tendency information.
C
	cc = ctend (1:4)
	IF  ( cc (1:1) .ge. '0' .and. cc (1:1) .le. '8' .and.
     +        cc (2:4) .ne. '999' )  THEN
	    CALL ST_CRNM  ( cc, ptend, ier )
	    IF  ( .not. ERMISS ( ptend ) )  THEN
		PR_P03D = ptend
	    END IF
	END IF
C*
	RETURN
	END


Real Function fde(dmass, srt, con)
  Save
  amn = 0.938869
  avpi = 0.13803333
  am0 = 1.232
  fd = 4.*(am0**2)*width(dmass)/((dmass**2-1.232**2)**2+am0**2*width(dmass)**2)
  If (con==1.) Then
     p11 = (srt**2+dmass**2-amn**2)**2/(4.*srt**2) - dmass**2
     If (p11<=0) p11 = 1.E-06
     p1 = sqrt(p11)
  Else
     dmass = amn + avpi
     p11 = (srt**2+dmass**2-amn**2)**2/(4.*srt**2) - dmass**2
     If (p11<=0) p11 = 1.E-06
     p1 = sqrt(p11)
  End If
  fde = fd*p1*dmass
  Return
End Function fde


      double complex function ffDDHK(s12,s34,msq)
      implicit none
C-----Author: R.K.Ellis July 2012
C-----The top loop function taken from
C-----Djouadi,Driesen,Hollik,Kraft arXiv:hep-ph/9701342v1, Eq(4)
      double precision s12,s34,msq
      double complex C0DDHK,C2DDHK
      ffDDHK=C0DDHK(s12,s34,msq)+4d0*C2DDHK(s12,s34,msq)
      return
      end

      double complex function fWDDHK(s12,s34,msq)
      implicit none
C-----Author: R.K.Ellis July 2012
C-----The W-loop function taken from
C-----Djouadi,Driesen,Hollik,Kraft arXiv:hep-ph/9701342v1, Eq(4)
c----- msq here should only be equal to wmass**2
      double precision s12,s34,msq
      double complex C0DDHK,C2DDHK
      fWDDHK=2d0*(s12/msq*(1d0-2d0*msq/s34)
     & +2d0*(1d0-6d0*msq/s34))*C2DDHK(s12,s34,msq)
     & +4d0*(1d0-4d0*msq/s34)*C0DDHK(s12,s34,msq)
      return
      end

      double complex function f0DDHK(s12,s34)
      implicit none
C-----The F0-function taken from
C-----Djouadi,Driesen,Hollik,Kraft arXiv:hep-ph/9701342v1, Eq(2)
C-----suitably generalized to allow off-shell Z-line
      include 'constants.f'
      include 'masses.f'
      include 'ewcouple.f'
      include 'ewcharge.f'
      include 'zcouple.f'
      include 'couple.f'
      include 'part.f'
      include 'first.f'
      include 'msbarmasses.f'
      integer top
      double complex ffDDHK,fWDDHK
      double precision s12,s34,cotw,mtsq,mwsq,mt_eff,massfrun
      parameter(top=2)
      save mt_eff
!$omp threadprivate(mt_eff)

      if (first) then
c--- run mt to appropriate scale
        if (part .eq. 'lord') then
          mt_eff=massfrun(mt_msbar,hmass,amz,1)
        else
          mt_eff=massfrun(mt_msbar,hmass,amz,2)
        endif
        first=.false.
      endif

      cotw=sqrt((1d0-xw)/xw)
      mtsq=mt**2
      mwsq=wmass**2
      f0DDHK=s34*(cotw*fWDDHK(s12,s34,mwsq)
     &+2d0*Q(top)*xn*mt_eff**2/s34*(L(top)+R(top))*ffDDHK(s12,s34,mtsq))
      return
      end

      double complex function qlC2DDHK(s12,s34,msq)
      implicit none
      include 'scale.f'
      double complex qlI2,qlI3
      double precision s12,s34,msq
      qlC2DDHK=-dcmplx(0.5d0/(s12-s34))
     & +0.5d0*s34/(s12-s34)**2
     & *(qlI2(s34,msq,msq,musq,0)-qlI2(s12,msq,msq,musq,0))
     & -msq/(s12-s34)*qlI3(s12,s34,0d0,msq,msq,msq,musq,0)
      return
      end
c       - 1/2*[s12-s34]^-1
c          + 1/2*B0f(p1,mt,mt)*s34*[s12-s34]^-2
c          - 1/2*B0f(p12,mt,mt)*s34*[s12-s34]^-2
c          - C0DDHK(p1,p2,mt,mt,mt)*mt^2*[s12-s34]^-1

      double complex function qlC0DDHK(s12,s34,msq)
      implicit none
      include 'scale.f'
      double complex qlI3
      double precision s12,s34,msq

      qlC0DDHK=qlI3(s12,s34,0d0,msq,msq,msq,musq,0)

      return
      end


       SUBROUTINE W3FB11(ALAT,ELON,ALAT1,ELON1,DX,ELONV,ALATAN,XI,XJ)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM:  W3FB11        LAT/LON TO LAMBERT(I,J) FOR GRIB
C   PRGMMR: STACKPOLE        ORG: NMC42       DATE:88-11-28
C
C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH GIVEN IN
C   THE NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO A GRID
C   COORDINATE SYSTEM OVERLAID ON A LAMBERT CONFORMAL TANGENT CONE
C   PROJECTION TRUE AT A GIVEN N OR S LATITUDE. W3FB11 IS THE REVERSE
C   OF W3FB12. USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID
C
C PROGRAM HISTORY LOG:
C   88-11-25  ORIGINAL AUTHOR:  STACKPOLE, W/NMC42
C   90-04-12  R.E.JONES   CONVERT TO CFT77 FORTRAN
C   94-04-28  R.E.JONES   ADD SAVE STATEMENT
C
C USAGE:  CALL W3FB11 (ALAT,ELON,ALAT1,ELON1,DX,ELONV,ALATAN,XI,XJ)
C   INPUT ARGUMENT LIST:
C     ALAT     - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMIS)
C     ELON     - EAST LONGITUDE IN DEGREES, REAL*4
C     ALAT1    - LATITUDE  OF LOWER LEFT POINT OF GRID (POINT (1,1))
C     ELON1    - LONGITUDE OF LOWER LEFT POINT OF GRID (POINT (1,1))
C                ALL REAL*4
C     DX       - MESH LENGTH OF GRID IN METERS AT TANGENT LATITUDE
C     ELONV    - THE ORIENTATION OF THE GRID.  I.E.,
C                THE EAST LONGITUDE VALUE OF THE VERTICAL MERIDIAN
C                WHICH IS PARALLEL TO THE Y-AXIS (OR COLUMNS OF
C                OF THE GRID) ALONG WHICH LATITUDE INCREASES AS
C                THE Y-COORDINATE INCREASES.  REAL*4
C                THIS IS ALSO THE MERIDIAN (ON THE BACK SIDE OF THE
C                TANGENT CONE) ALONG WHICH THE CUT IS MADE TO LAY
C                THE CONE FLAT.
C     ALATAN   - THE LATITUDE AT WHICH THE LAMBERT CONE IS TANGENT TO
C                (TOUCHING) THE SPHERICAL EARTH.
C                 SET NEGATIVE TO INDICATE A
C                 SOUTHERN HEMISPHERE PROJECTION.
C
C   OUTPUT ARGUMENT LIST:
C     XI       - I COORDINATE OF THE POINT SPECIFIED BY ALAT, ELON
C     XJ       - J COORDINATE OF THE POINT; BOTH REAL*4
C
C   REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES,
C     AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981
C     AFGWC/TN-79/003
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256
C
C$$$
C
         SAVE
C
         DATA  RERTH /6.3712E+6/, PI/3.14159/
C
C        PRELIMINARY VARIABLES AND REDIFINITIONS
C
C        H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
C
         IF (ALATAN.GT.0) THEN
           H = 1.
         ELSE
           H = -1.
         ENDIF
C
         RADPD  = PI    / 180.0
         REBYDX = RERTH / DX
         ALATN1 = ALATAN * RADPD
         AN     = H * SIN(ALATN1)
         COSLTN = COS(ALATN1)
C
C        MAKE SURE THAT INPUT LONGITUDES DO NOT PASS THROUGH
C        THE CUT ZONE (FORBIDDEN TERRITORY) OF THE FLAT MAP
C        AS MEASURED FROM THE VERTICAL (REFERENCE) LONGITUDE.
C
         ELON1L = ELON1
         IF ((ELON1 - ELONV).GT.180.)
     &     ELON1L = ELON1 - 360.
         IF ((ELON1 - ELONV).LT.(-180.))
     &     ELON1L = ELON1 + 360.
C
         ELONL = ELON
         IF ((ELON  - ELONV).GT.180.)
     &     ELONL  = ELON  - 360.
         IF ((ELON - ELONV).LT.(-180.))
     &     ELONL = ELON + 360.
C
         ELONVR = ELONV * RADPD
C
C        RADIUS TO LOWER LEFT HAND (LL) CORNER
C
         ALA1 =  ALAT1 * RADPD
         RMLL = REBYDX * (((COSLTN)**(1.-AN))*(1.+AN)**AN) *
     &           (((COS(ALA1))/(1.+H*SIN(ALA1)))**AN)/AN
C
C        USE LL POINT INFO TO LOCATE POLE POINT
C
         ELO1 = ELON1L * RADPD
         ARG = AN * (ELO1-ELONVR)
         POLEI = 1. - H * RMLL * SIN(ARG)
         POLEJ = 1. + RMLL * COS(ARG)
C
C        RADIUS TO DESIRED POINT AND THE I J TOO
C
         ALA =  ALAT * RADPD
         RM = REBYDX * ((COSLTN**(1.-AN))*(1.+AN)**AN) *
     &           (((COS(ALA))/(1.+H*SIN(ALA)))**AN)/AN
C
         ELO = ELONL * RADPD
         ARG = AN*(ELO-ELONVR)
         XI = POLEI + H * RM * SIN(ARG)
         XJ = POLEJ - RM * COS(ARG)
C
C        IF COORDINATE LESS THAN 1
C        COMPENSATE FOR ORIGIN AT (1,1)
C
         IF (XI.LT.1.)  XI = XI - 1.
         IF (XJ.LT.1.)  XJ = XJ - 1.
C
      RETURN
      END


!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!This file is "Ylm_dYlm.f"
!This file contain two functions.
!Function Ylm
!Function dYlm
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
! This function Ylm is related to the real spherical harmonics Ylm0 by
!c Ylm=sqrt(4*pi/(2l+1))*r**l*Ylm0 and is a monomial of x,y,z
Function Ylm(x,y,z,il,im)
  implicit none
  real(8),intent(IN) :: x,y,z
  integer,intent(IN) :: il,im
  integer :: ilm
  real(8) :: Ylm,r2

  ilm=il*il+il+1+im
  r2=x*x+y*y+z*z
  select case( ilm )
  case(1)  ; Ylm=1.d0                                     ! ilm=1  (0  0)
  case(2)  ; Ylm=-y                                       ! ilm=2  (1 -1)
  case(3)  ; Ylm=z                                        ! ilm=3  (1  0)
  case(4)  ; Ylm=-x                                       ! ilm=4  (1  1)
  case(5)  ; Ylm=sqrt(3.d0)*x*y                           ! ilm=5  (2 -2)
  case(6)  ; Ylm=-sqrt(3.d0)*y*z                          ! ilm=6  (2 -1)
  case(7)  ; Ylm=(3.d0*z*z-r2)/2.d0                       ! ilm=7  (2  0)
  case(8)  ; Ylm=-sqrt(3.d0)*x*z                          ! ilm=8  (2  1)
  case(9)  ; Ylm=sqrt(3.d0/4.d0)*(x*x-y*y)                ! ilm=9  (2  2)
  case(10) ; Ylm=-sqrt(5.d0/8.d0)*y*(3*x*x-y*y)           ! ilm=10 (3 -3)
  case(11) ; Ylm=sqrt(15.d0)*x*y*z                        ! ilm=11 (3 -2)
  case(12) ; Ylm=-sqrt(3.d0/8.d0)*y*(5.d0*z*z-r2)         ! ilm=12 (3 -1)
  case(13) ; Ylm=z*(5.d0*z*z-3*r2)/2.d0                   ! ilm=13 (3  0)
  case(14) ; Ylm=-sqrt(3.d0/8.d0)*x*(5.d0*z*z-r2)         ! ilm=14 (3  1)
  case(15) ; Ylm=sqrt(15.d0/4.d0)*z*(x*x-y*y)             ! ilm=15 (3  2)
  case(16) ; Ylm=-sqrt(5.d0/8.d0)*x*(x*x-3.d0*y*y)        ! ilm=16 (3  3)
  case(17) ; Ylm=sqrt(35.d0)/2.d0*x*y*(x*x-y*y)           ! ilm=17 (4 -4)
  case(18) ; Ylm=-sqrt(35.d0/8.d0)*y*z*(3.d0*x*x-y*y)     ! ilm=18 (4 -3)
  case(19) ; Ylm=sqrt(5.d0)/2.d0*x*y*(7.d0*z*z-r2)        ! ilm=19 (4 -2)
  case(20) ; Ylm=-sqrt(5.d0/8.d0)*y*z*(7.d0*z*z-3.d0*r2)  ! ilm=20 (4 -1)
  case(21) ; Ylm=(35.d0*z**4-30.d0*z*z*r2+3.d0*r2*r2)/8.d0! ilm=21 (4  0)
  case(22) ; Ylm=-sqrt(5.d0/8.d0)*x*z*(7.d0*z**2-3.d0*r2) ! ilm=22 (4  1)
  case(23) ; Ylm=sqrt(5.d0)/4.d0*(7.d0*z*z-r2)*(x*x-y*y)  ! ilm=23 (4  2)
  case(24) ; Ylm=-sqrt(35.d0/8.d0)*x*z*(x*x-3.d0*y*y)     ! ilm=24 (4  3)
  case(25) ; Ylm=sqrt(35.d0)/8.d0*(x**4+y**4-6.d0*x*x*y*y)! ilm=25 (4  4)
  end select

  return
End Function Ylm
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
Function dYlm(x,y,z,il,im,idir)
  implicit none
  real(8),intent(IN) :: x,y,z
  integer,intent(IN) :: il,im,idir
  integer :: ilm
  real(8) :: dYlm

  ilm=il*il+il+1+im
  if ((ilm > 16) .or. (il >= 4)) then
    write(*,*) 'dYlm routine not prepared for il>=4'
    stop
  endif
  if((ilm ==  1 ).and.(idir == 1)) dYlm=0.d0                            ! ilm=1  (0  0)
  if((ilm ==  1 ).and.(idir == 2)) dYlm=0.d0                            ! ilm=1  (0  0)
  if((ilm ==  1 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=1  (0  0)
  if((ilm ==  2 ).and.(idir == 1)) dYlm=0.d0                            ! ilm=2  (1 -1)
  if((ilm ==  2 ).and.(idir == 2)) dYlm=-1.d0                           ! ilm=2  (1 -1)
  if((ilm ==  2 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=2  (1 -1)
  if((ilm ==  3 ).and.(idir == 1)) dYlm=0.d0                            ! ilm=3  (1  0)
  if((ilm ==  3 ).and.(idir == 2)) dYlm=0.d0                            ! ilm=3  (1  0)
  if((ilm ==  3 ).and.(idir == 3)) dYlm=1.d0                            ! ilm=3  (1  0)
  if((ilm ==  4 ).and.(idir == 1)) dYlm=-1.d0                           ! ilm=4  (1  1)
  if((ilm ==  4 ).and.(idir == 2)) dYlm=0.d0                            ! ilm=4  (1  1)
  if((ilm ==  4 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=4  (1  1)
  if((ilm ==  5 ).and.(idir == 1)) dYlm=sqrt(3.d0)*y                    ! ilm=5  (2 -2)
  if((ilm ==  5 ).and.(idir == 2)) dYlm=sqrt(3.d0)*x                    ! ilm=5  (2 -2)
  if((ilm ==  5 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=5  (2 -2)
  if((ilm ==  6 ).and.(idir == 1)) dYlm=0.d0                            ! ilm=6  (2 -1)
  if((ilm ==  6 ).and.(idir == 2)) dYlm=-sqrt(3.d0)*z                   ! ilm=6  (2 -1)
  if((ilm ==  6 ).and.(idir == 3)) dYlm=-sqrt(3.d0)*y                   ! ilm=6  (2 -1)
  if((ilm ==  7 ).and.(idir == 1)) dYlm=-x                              ! ilm=7  (2  0)
  if((ilm ==  7 ).and.(idir == 2)) dYlm=-y                              ! ilm=7  (2  0)
  if((ilm ==  7 ).and.(idir == 3)) dYlm=2.d0*z                          ! ilm=7  (2  0)
  if((ilm ==  8 ).and.(idir == 1)) dYlm=-sqrt(3.d0)*z                   ! ilm=8  (2  1)
  if((ilm ==  8 ).and.(idir == 2)) dYlm=0.d0                            ! ilm=8  (2  1)
  if((ilm ==  8 ).and.(idir == 3)) dYlm=-sqrt(3.d0)*x                   ! ilm=8  (2  1)
  if((ilm ==  9 ).and.(idir == 1)) dYlm=sqrt(3.d0)*x                    ! ilm=9  (2  2)
  if((ilm ==  9 ).and.(idir == 2)) dYlm=-sqrt(3.d0)*y                   ! ilm=9  (2  2)
  if((ilm ==  9 ).and.(idir == 3)) dYlm=0.d0                            ! ilm=9  (2  2)
  if((ilm == 10 ).and.(idir == 1)) dYlm=-3.d0*sqrt(5.d0/2.d0)*x*y                         ! ilm=10 (3 -3)
  if((ilm == 10 ).and.(idir == 2)) dYlm=-3.d0/2.d0*sqrt(5.d0/2.d0)*(x*x-y*y)               ! ilm=10 (3 -3)
  if((ilm == 10 ).and.(idir == 3)) dYlm=0.d0                                              ! ilm=10 (3 -3)
  if((ilm == 11 ).and.(idir == 1)) dYlm=sqrt(15.d0)*y*z                                   ! ilm=11 (3 -2)
  if((ilm == 11 ).and.(idir == 2)) dYlm=sqrt(15.d0)*z*x                                   ! ilm=11 (3 -2)
  if((ilm == 11 ).and.(idir == 3)) dYlm=sqrt(15.d0)*x*y                                   ! ilm=11 (3 -2)
  if((ilm == 12 ).and.(idir == 1)) dYlm=sqrt(3.d0/2.d0)*x*y                               ! ilm=12 (3 -1)
  if((ilm == 12 ).and.(idir == 2)) dYlm=-1.d0/2.d0*sqrt(3.d0/2.d0)*(4.d0*z*z-x*x-3.d0*y*y)! ilm=12 (3 -1)
  if((ilm == 12 ).and.(idir == 3)) dYlm=-4.d0*sqrt(3.d0/2.d0)*y*z                         ! ilm=12 (3 -1)
  if((ilm == 13 ).and.(idir == 1)) dYlm=-3.d0*z*x                                         ! ilm=13 (3  0)
  if((ilm == 13 ).and.(idir == 2)) dYlm=-3.d0*y*z                                         ! ilm=13 (3  0)
  if((ilm == 13 ).and.(idir == 3)) dYlm=3.d0/2.d0*(2.d0*z*z-x*x-y*y)                      ! ilm=13 (3  0)
  if((ilm == 14 ).and.(idir == 1)) dYlm=-1.d0/2.d0*sqrt(3.d0/2.d0)*(4.d0*z*z-3.d0*x*x-y*y)! ilm=14 (3  1)
  if((ilm == 14 ).and.(idir == 2)) dYlm=sqrt(3.d0/2.d0)*x*y                               ! ilm=14 (3  1)
  if((ilm == 14 ).and.(idir == 3)) dYlm=-4.d0*sqrt(3.d0/2.d0)*z*x                         ! ilm=14 (3  1)
  if((ilm == 15 ).and.(idir == 1)) dYlm=sqrt(15.d0)*z*x                                   ! ilm=15 (3  2)
  if((ilm == 15 ).and.(idir == 2)) dYlm=-sqrt(15.d0)*y*z                                  ! ilm=15 (3  2)
  if((ilm == 15 ).and.(idir == 3)) dYlm=1.d0/2.d0*sqrt(15.d0)*(x*x-y*y)                   ! ilm=15 (3  2)
  if((ilm == 16 ).and.(idir == 1)) dYlm=-3.d0/2.d0*sqrt(5.d0/2.d0)*(x*x-y*y)              ! ilm=16 (3  3)
  if((ilm == 16 ).and.(idir == 2)) dYlm=3.d0*sqrt(5.d0/2.d0)*x*y                          ! ilm=16 (3  3)
  if((ilm == 16 ).and.(idir == 3)) dYlm=0.d0                                              ! ilm=16 (3  3)

  return
End Function dYlm
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130


	REAL FUNCTION PFUNC1(P1)
	IMPLICIT NONE
C
C    Arguments
C
	REAL P1
C
C    Functions
C
	REAL ZCRVALUE
C
C    Locals
C
	REAL Q1,Q0,P10,P01,PA,QA,XALPHA,XBETA
C
C    Common from main
C
	REAL ALPHA,BETA,N,P0,PHI_V,ZALPHA,ZBETA
	COMMON/PCOM/ALPHA,BETA,N,P0,PHI_V,ZALPHA,ZBETA
C
C Code:
C
	XALPHA=ALPHA
	XBETA=BETA

	ZALPHA=ZCRVALUE(XALPHA/2.)
	ZBETA=ZCRVALUE(XBETA)
	Q1=1.-P1
	Q0=1.-P0
	P10=P1*Q0 - PHI_V*SQRT(P1*Q1*P0*Q0)
	P01=Q1*P0 - PHI_V*SQRT(P1*Q1*P0*Q0)
	PA=P10/(P01+P10)
	QA=1.-PA
	PFUNC1=((ZALPHA*0.5+ZBETA*SQRT(PA*QA))**2 /
     .		((PA-0.5)**2 * (P01+P10)))-N
C
C    Done.
C
	RETURN
	END


! chk_boz_values --
!     Check: does the compiler support the BOZ values with int/real/dble/cmplx?
!
program chk_boz_values
    implicit none

    integer                :: int_value
    real                   :: real_value
    real(kind=kind(1.0d0)) :: double_value
    complex                :: complex_value

    int_value     = int(z'3f7')
    real_value    = real(z'3f700000')
    double_value  = dble(z'3f70000000000000')
    complex_value = cmplx(z'3f700000',z'3f700000')

    write( *, '(a)'        ) 'Using hexadecimal values:'
    write( *, '(a,i0)'     ) '    Integer:          ', int_value
    write( *, '(a,e14.6)'  ) '    Single precision: ', real_value
    write( *, '(a,e20.12)' ) '    Double precision: ', double_value
    write( *, '(a,2e14.6)' ) '    Complex:          ', complex_value

    write( *, '(a)'        ) 'Using an octal value:'
    write( *, '(a,i0)'     ) '    Integer:          ', int(o'123')
    write( *, '(a)'        ) 'Using a binary value:'
    write( *, '(a,i0)'     ) '    Integer:          ', int(b'110011')

end program chk_boz_values


! Compile and run: make

program phys395_hw3_optimization
  use q1_roots
  use q3_minima
  use q5_fit
  implicit none

  print *
  call q1()
  call q3()
  call q5()
end program phys395_hw3_optimization


program test_union
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

n = 1
ntests = 14
call initialize_tests(tests,ntests)

tests(n) = assert(all(union([1_int8,2_int8],[2_int8,3_int8]) == [1,2,3]),&
                  'union, int8')
n = n + 1

tests(n) = assert(all(union([1_int16,2_int16],[2_int16,3_int16]) == [1,2,3]),&
                  'union, int16')
n = n + 1

tests(n) = assert(all(union([1_int32,2_int32],[2_int32,3_int32]) == [1,2,3]),&
                  'union, int32')
n = n + 1

tests(n) = assert(all(union([1_int64,2_int64],[2_int64,3_int64]) == [1,2,3]),&
                  'union, int64')
n = n + 1

tests(n) = assert(all(union([1._real32,2._real32],[2._real32,3._real32]) == [1,2,3]),&
                  'union, real32')
n = n + 1

tests(n) = assert(all(union([1._real64,2._real64],[2._real64,3._real64]) == [1,2,3]),&
                  'union, real64')
n = n + 1

tests(n) = assert(all(union([1._real128,2._real128],[2._real128,3._real128]) == [1,2,3]),&
                  'union, real128')
n = n + 1

tests(n) = assert(all(union([cmplx(1._real32,0._real32),cmplx(2._real32,0._real32)],&
                            [cmplx(2._real32,0._real32),cmplx(3._real32,0._real32)])&
                      == [cmplx(1._real32,0._real32),&
                          cmplx(2._real32,0._real32),&
                          cmplx(3._real32,0._real32)]),&
                  'union, complex real32')
n = n + 1

tests(n) = assert(all(union([cmplx(1._real64,0._real64),cmplx(2._real64,0._real64)],&
                            [cmplx(2._real64,0._real64),cmplx(3._real64,0._real64)])&
                      == [cmplx(1._real64,0._real64),&
                          cmplx(2._real64,0._real64),&
                          cmplx(3._real64,0._real64)]),&
                  'union, complex real64')
n = n + 1

tests(n) = assert(all(union([cmplx(1._real128,0._real128),cmplx(2._real128,0._real128)],&
                            [cmplx(2._real128,0._real128),cmplx(3._real128,0._real128)])&
                      == [cmplx(1._real128,0._real128),&
                          cmplx(2._real128,0._real128),&
                          cmplx(3._real128,0._real128)]),&
                  'union, complex real128')
n = n + 1

tests(n) = assert(all(union(arange(1,0),arange(1,0)) == arange(1,0)),&
                  'union of empty arrays is an empty array')
n = n + 1

tests(n) = assert(all(union([1,2,2,3],arange(1,0)) == set([1,2,2,3])),&
                  'union(x,[]) == set(x)')
n = n + 1

tests(n) = assert(all(union(arange(1,0),[1,2,2,3]) == set([1,2,2,3])),&
                  'union([],x) == set(x)')
n = n + 1

tests(n) = assert(all(union([1,2],[3,4]) == ([1,2].union.[3,4])),&
                  'union operator, a.union.b')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_union


C     This program is written for testing module TYPING
C
C
      PROGRAM TYPAGE
      LOGICAL L
      INTEGER I
      REAL*4 R
      REAL*8 D
      COMPLEX*8 C
      CHARACTER CH

C     Test for Assignment
C     ===================
      I = L                     !ERROR
      I = I
      I = R
      I = D
      I = C
      I = CH                    !ERROR

      R = L                     !ERROR
      R = I
      R = R
      R = D
      R = C
      R = CH                    !ERROR

      D = L                     !ERROR
      D = I
      D = R
      D = D
      D = C
      D = CH                    !ERROR

      C = L                     !ERROR
      C = I
      C = R
      C = D
      C = C
      C = CH                    !ERROR

      CH = L                    !ERROR
      CH = I                    !ERROR
      CH = R                    !ERROR
      CH = D                    !ERROR
      CH = C                    !ERROR
      CH = CH

      L = L
      L = I                     !ERROR
      L = R                     !ERROR
      L = D                     !ERROR
      L = C                     !ERROR
      L = CH                    !ERROR

C     Test for Arithmetic operators: +, -, *, /
C     =========================================
      I = +5 - I
      I = -I + R
      I = +R / D
      I = C * R

      I = I + R
      I = R + D
      I = D + C                 !ERR - PROBIHITED
      I = R + C
      I = C + R

      I = I + R + D + C         !ERR - PROBIHITED
      I = C + D + R + I         !ERR - PROBIHITED

C     Test for power operator: **
C     Somes cases are prohibited by FORTRAN itself (just for checking errors)
C     =======================================================================
      I = I**I
      I = I**R
      I = I**D
      I = I**C

      I = R**I
      I = R**R
      I = R**D
      I = R**C

      I = C**I
      I = C**R
      I = C**D                  !ERR - PROHIBITED
      I = C**C

      I = D**I
      I = D**R
      I = D**D
      I = D**C                  !ERR - PROHIBITED

C     Relational operators: <, <=, =, !=, >, >=
C     For this, we only have to test the casting of 2 arguments
C     Value of return is always BOOL
C     ==============================
      L = I .LT. R
      L = I .LE. R
      L = I .EQ. R
      L = I .NE. R
      L = I .GT. R
      L = I .GE. R

      L = R .LT. I
      L = R .LE. I
      L = R .EQ. I
      L = R .NE. I
      L = R .GT. I
      L = R .GE. I

      I = R .GE. I              !ERROR
      L = R .GE. L              !ERROR
      L = L .GE. I              !ERROR
      L = D .GE. C              !ERROR

C     Logical operators: NOT, AND, OR, EQV, NEQV
C     Value of return is always BOOL
C     ==============================
      L = .NOT. L
      L = L .AND. L
      L = L .OR. L
      L = L .EQV. L
      L = L .NEQV. L

      L = I .OR. L              !ERROR
      L = R .AND. L             !ERROR
      L = R .AND. L .OR. 12.4E5 !ERROR

C     User-defined functions
C     ======================
      R = USER_FUNC(I, R)
      R = USER_FUNC(R, R)       !ERROR
      R = USER_FUNC(I, I)       !ERROR
      R = USER_FUNC(R, I)       !2 ERRORS
      R = USER_FUNC(R, USER_FUNC(R, R)) !2 ERRORS
      R = USER_FUNC(I)          !ERROR
      R = USER_FUNC(I, R, I, R) !ERROR

      CALL USER_SUB(I, R, C)
      CALL USER_SUB(I, I, C)
      CALL USER_SUB(R, C, I)
      CALL USER_SUB(I, R)
      CALL USER_SUB(I, R, C, L)

C     Do-Loop
C     =======
      DO I = 1.5, 5, 1.5
         CONTINUE
      ENDDO
      DO R = 1, 5, 1.5
         CONTINUE
      ENDDO
      DO D = 1, 5, 1.5
         CONTINUE
      ENDDO

      DO D = 1, 5, C            !ERROR
         CONTINUE
      ENDDO
      DO C = 1, 5, 1.5          !ERROR
         CONTINUE
      ENDDO
      DO CH = 1, 5, 1.5         !ERROR
         CONTINUE
      ENDDO

      DO L = .FALSE., .TRUE.    !ERROR
         CONTINUE
      ENDDO

C     While Loop
C     ==========
      DO WHILE (.TRUE.)
         CONTINUE
      ENDDO

      DO WHILE (2+I)            !ERROR
         CONTINUE
      ENDDO

      DO WHILE (USER_FUNC(1,.TRUE.)) !ERROR
         CONTINUE
      ENDDO

C     Condition Test
C     ==============
      IF ( I .LT. R) THEN
         STOP
      ELSE IF (R .GT. D) THEN
         STOP
      ELSE
         STOP
      ENDIF

      IF ( I + R) THEN          !ERROR
         STOP
      ELSE IF (CH) THEN         !EEROR
         STOP
      ELSE
         STOP
      ENDIF

      END

C     User-defined function
C     =====================
      REAL FUNCTION USER_FUNC(A, B)
      INTEGER A
      REAL B
      USER_FUNC = A + B
      END

      SUBROUTINE USER_SUB(I, R, C)
      INTEGER I
      REAL R
      COMPLEX C
      PRINT *, I, R, C
      END