module slope_module

  implicit none

  private

  public slope_2d, slope_3d

contains

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine slope_2d(q,qd_l1,qd_l2,qd_h1,qd_h2, &
                          dq,qpd_l1,qpd_l2,qpd_h1,qpd_h2, &
                          ilo,jlo,ihi,jhi,nv,idir)

      implicit none

      integer qd_l1,qd_l2,qd_h1,qd_h2
      integer qpd_l1,qpd_l2,qpd_h1,qpd_h2
      integer ilo,jlo,ihi,jhi,nv,idir

      double precision     q( qd_l1: qd_h1, qd_l2: qd_h2,nv)
      double precision    dq(qpd_l1:qpd_h1,qpd_l2:qpd_h2,nv)

!     Local arrays
      double precision, allocatable::dsgn(:),dlim(:),df(:),dcen(:)

      integer i, j, n, lo, hi
      double precision dlft, drgt, slop, dq1
      double precision four3rd, sixth

      four3rd = 4.d0/3.d0
      sixth = 1.d0/6.d0

      if (idir .eq. 1) then
          lo = ilo
          hi = ihi
      else
          lo = jlo
          hi = jhi
      end if

      allocate (dsgn(lo-2:hi+2))
      allocate (dlim(lo-2:hi+2))
      allocate (  df(lo-2:hi+2))
      allocate (dcen(lo-2:hi+2))

      do n = 1, nv
          if (idir .eq. 1) then

             ! slopes in first coordinate direction
             do j = jlo-1, jhi+1

                ! first compute Fromm slopes
                do i = ilo-2, ihi+2
                      dlft = 2.d0*(q(i  ,j,n) - q(i-1,j,n))
                      drgt = 2.d0*(q(i+1,j,n) - q(i  ,j,n))
                      dcen(i) = .25d0 * (dlft+drgt)
                      dsgn(i) = sign(1.d0, dcen(i))
                      slop = min( abs(dlft), abs(drgt) )
!                      dlim(i) = cvmgp( slop, 0.d0, dlft*drgt )
                      if (dlft*drgt .ge. 0.d0) then
                         dlim(i) = slop
                      else
                         dlim(i) = 0.d0
                      endif
                      df(i) = dsgn(i)*min( dlim(i), abs(dcen(i)) )
                  enddo

!                 Now limited fourth order slopes
                  do i = ilo-1, ihi+1
                      dq1 = four3rd*dcen(i) - sixth*(df(i+1) + df(i-1))
                      dq(i,j,n) = dsgn(i)*min(dlim(i),abs(dq1))
                  enddo
              enddo

          else

!            Compute slopes in second coordinate direction
             do i = ilo-1, ihi+1

!               First compute Fromm slopes for this column
                do j = jlo-2, jhi+2
                      dlft = 2.d0*(q(i,j  ,n) - q(i,j-1,n))
                      drgt = 2.d0*(q(i,j+1,n) - q(i,j  ,n))
                      dcen(j) = .25d0 * (dlft+drgt)
                      dsgn(j) = sign( 1.d0, dcen(j) )
                      slop = min( abs(dlft), abs(drgt) )
                      if (dlft*drgt .ge. 0.d0) then
                         dlim(j) = slop
                      else
                         dlim(j) = 0.d0
                      endif
                      df(j) = dsgn(j)*min( dlim(j),abs(dcen(j)) )
                  enddo

!                 Now compute limited fourth order slopes
                  do j = jlo-1, jhi+1
                      dq1 = four3rd*dcen(j) - &
                           sixth*( df(j+1) + df(j-1) )
                      dq(i,j,n) = dsgn(j)*min(dlim(j),abs(dq1))
                  enddo
              enddo

          endif
      enddo

      deallocate(dsgn,dlim,df,dcen)

      end subroutine slope_2d

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine slope_3d( q, qd_l1, qd_l2, qd_l3, qd_h1, qd_h2, qd_h3, &
                          dq,qpd_l1,qpd_l2,qpd_l3,qpd_h1,qpd_h2,qpd_h3, &
                          ilo,jlo,klo,ihi,jhi,khi,nv,idir)

      use bl_constants_module

      implicit none

      integer qd_l1,qd_l2,qd_l3,qd_h1,qd_h2,qd_h3
      integer qpd_l1,qpd_l2,qpd_l3,qpd_h1,qpd_h2,qpd_h3
      integer ilo,jlo,klo,ihi,jhi,khi,nv,idir

      double precision q(qd_l1:qd_h1,qd_l2:qd_h2,qd_l3:qd_h3,nv)
      double precision dq(qpd_l1:qpd_h1,qpd_l2:qpd_h2,qpd_l3:qpd_h3,nv)

      integer i,j,k,n
      integer lo,hi

      double precision dlft, drgt, slop, dq1

      double precision, allocatable::dsgn(:),dlim(:),df(:),dcen(:)

      if (idir .eq. 1) then
          lo = ilo
          hi = ihi
      else if (idir .eq. 2) then
          lo = jlo
          hi = jhi
      else
          lo = klo
          hi = khi
      end if

      allocate(dsgn(lo-2:hi+2))
      allocate(dlim(lo-2:hi+2))
      allocate(  df(lo-2:hi+2))
      allocate(dcen(lo-2:hi+2))

      do n = 1, nv

          ! Compute slopes in first coordinate direction
          if (idir .eq. 1) then
            do k = klo-1, khi+1
            do j = jlo-1, jhi+1

               ! First compute Fromm slopes
               do i = ilo-2, ihi+2
                  dlft = TWO*(q(i  ,j,k,n) - q(i-1,j,k,n))
                  drgt = TWO*(q(i+1,j,k,n) - q(i  ,j,k,n))
                  dcen(i) = FOURTH * (dlft+drgt)
                  dsgn(i) = sign(ONE, dcen(i))
                  slop = min( abs(dlft), abs(drgt) )
                  if (dlft*drgt .ge. ZERO) then
                     dlim(i) = slop
                  else
                     dlim(i) = ZERO
                  endif
                  df(i) = dsgn(i)*min( dlim(i), abs(dcen(i)) )
               enddo

               ! Now compute limited fourth order slopes
               do i = ilo-1, ihi+1
                  dq1         = FOUR3RD*dcen(i) - SIXTH*(df(i+1) + df(i-1))
                  dq(i,j,k,n) = dsgn(i)*min(dlim(i),abs(dq1))
               enddo

            enddo
            enddo

          else if (idir .eq. 2) then

            ! Compute slopes in second coordinate direction
            do k = klo-1, khi+1
            do i = ilo-1, ihi+1

               ! First compute Fromm slopes for this column
               do j = jlo-2, jhi+2
                  dlft = TWO*(q(i,j  ,k,n) - q(i,j-1,k,n))
                  drgt = TWO*(q(i,j+1,k,n) - q(i,j  ,k,n))
                  dcen(j) = FOURTH * (dlft+drgt)
                  dsgn(j) = sign( ONE, dcen(j) )
                  slop = min( abs(dlft), abs(drgt) )
                  if (dlft*drgt .ge. ZERO) then
                     dlim(j) = slop
                  else
                     dlim(j) = ZERO
                  endif
                  df(j) = dsgn(j)*min( dlim(j),abs(dcen(j)) )
               enddo

               ! Now compute limited fourth order slopes
               do j = jlo-1, jhi+1
                  dq1 = FOUR3RD*dcen(j) - SIXTH*( df(j+1) + df(j-1) )
                  dq(i,j,k,n) = dsgn(j)*min(dlim(j),abs(dq1))
               enddo
            enddo
            enddo

          else if (idir .eq. 3) then

            ! Compute slopes in third coordinate direction
            do j = jlo-1, jhi+1
            do i = ilo-1, ihi+1

               ! First compute Fromm slopes for this column
               do k = klo-2, khi+2
                  dlft = TWO*(q(i,j,k  ,n) - q(i,j,k-1,n))
                  drgt = TWO*(q(i,j,k+1,n) - q(i,j,k  ,n))
                  dcen(k) = FOURTH * (dlft+drgt)
                  dsgn(k) = sign( ONE, dcen(k) )
                  slop = min( abs(dlft), abs(drgt) )
                  if (dlft*drgt .ge. ZERO) then
                     dlim(k) = slop
                  else
                     dlim(k) = ZERO
                  endif
                  df(k) = dsgn(k)*min( dlim(k),abs(dcen(k)) )
               enddo

               ! Now compute limited fourth order slopes
               do k = klo-1, khi+1
                  dq1 = FOUR3RD*dcen(k) - SIXTH*( df(k+1) + df(k-1) )
                  dq(i,j,k,n) = dsgn(k)*min(dlim(k),abs(dq1))
               enddo
            enddo
            enddo

          endif ! idir

      end do  ! n = 1, nv

      deallocate(dsgn,dlim,df,dcen)

      end subroutine slope_3d

end module slope_module


module dynsoil_empirical_laws
implicit none

contains

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

  function erosion(temp,runoff,slope,klith)
    use dynsoil_physical_parameters, only: ke, a, b
    double precision, intent(in):: temp, runoff, slope ! runoff (cm/y) ; temperature (°C) !
    integer, intent(in):: klith
    double precision:: erosion
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    !erosion = ke(klith) * ((runoff/100)**a) * (slope**b) * max( 2. , temp ) ! BQART exponents
    erosion = ke(klith) * ((runoff/100)**a) * (slope**b)
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  end function

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

  function reg_prod_opt(temp,runoff,klith)
    use dynsoil_physical_parameters, only: krp, Ea_rp, T0_rp, Rgas
    double precision, intent(in):: temp, runoff ! runoff (cm/y) ; temperature (°C) !
    integer, intent(in):: klith
    double precision:: reg_prod_opt
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    reg_prod_opt = krp(klith) * (runoff/100) * exp(-(Ea_rp(klith)/Rgas)*(1./(temp+273.15)-1./T0_rp(klith)))
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!   Optimal soil production rate. Should be multiplied by the soil production function to get the actual soil production rate
  end function

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

  function soil_prod_func(h_soil)
    use dynsoil_physical_parameters, only: h0 !k1, d1, d2
    double precision, intent(in):: h_soil
    double precision:: soil_prod_func
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    !soil_prod_func = ( exp(-1*h_soil/d1) - k1*exp(-1*h_soil/d2) ) / knorm ! normalized HUMPED FUNCTION
    !soil_prod_func = h0/h_soil                                            ! inverse function
    soil_prod_func = exp(-1*h_soil/h0)                                    ! exponential SPF
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  end function

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

  function eq_reg_thick(RPopt,E)
    use dynsoil_physical_parameters, only: h0 !d1
    double precision, intent(in):: RPopt,E
    double precision:: eq_reg_thick
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    !eq_reg_thick = d1*log(RPopt/E) ! for humped SPF
    !eq_reg_thick = h0*RPopt/E      ! for inverse SPF
    eq_reg_thick = h0*log(RPopt/E) ! for exponential SPF
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!   Estimated soil equilibrium thickness by approximating the SPF.
  end function

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

  function dissolution_constant(temp,runoff,klith)
    use dynsoil_physical_parameters, only: Kwest, kw, Ea, T0, Rgas
    double precision, intent(in):: temp, runoff ! runoff (cm/y) ; temperature (°C) !
    integer, intent(in):: klith
    double precision:: dissolution_constant
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    dissolution_constant = Kwest(klith) * (1-exp(-kw(klith)*(runoff/100))) * exp( (Ea(klith)/Rgas) * (1/T0(klith)-1/(temp+273.15)) )
!   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!   rock dissolution constant, computed from climatic variables
  end function

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

  function SP_fraction(temp,runoff,h_soil)
    use dynsoil_physical_parameters, only: xSP_max, xSP_min, reg_porosity, TauSP0
    double precision, intent(in):: temp, runoff, h_soil ! temperature (°C) ; runoff (m/y) ; h_soil (m)
    double precision:: TauWat, TauSP ! water residence time (y) ; SP charcteristic time (y)
    double precision:: SP_fraction
    if (runoff == 0) then
      SP_fraction = xSP_max
    elseif (h_soil == 0) then
      SP_fraction = xSP_min
    else
!     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      TauWat = reg_porosity * h_soil / runoff
      TauSP = TauSP0 !* exp((Ea_SP/Rgas)*(1./(temp+273.15)-1./T0))
!     @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
      SP_fraction = xSP_min  +  (xSP_max-xSP_min) / ( 1 + (TauSP/TauWat) )
!     @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    end if
  end function SP_fraction

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

  function Li_fractionation(temp)
   use dynsoil_physical_parameters, only: aDland, bDland
   double precision, intent(in):: temp ! temperature (°C)
   double precision:: Li_fractionation
   Li_fractionation = aDland/(temp+273.15)**2 + bDland
  end function

end module


c     ============================================
      subroutine setaux(mbc,mx,my,xlow,ylow,dxc,dyc,
     &                  maux,aux)
c     ============================================
c
c     # set auxiliary arrays for advection on a curvilinear grid
c
c     # on input, (xc(i),yc(j)) gives uniformly spaced computational grid.
c     # on output,
c     #   aux(1,i,j) is edge velocity at "left" boundary of grid point (i,j)
c     #   aux(2,i,j) is edge velocity at "bottom" boundary of grid point (i,j)
c     #   aux(3,i,j) = kappa  is ratio of cell area to dxc*dyc
c
      use amr_module, only: NEEDS_TO_BE_SET, xlower, ylower
      implicit double precision (a-h,o-z)
      double precision, intent(inout),
     &              dimension(3, 1-mbc:mx+mbc,1-mbc:my+mbc) :: aux
      dimension xccorn(5),yccorn(5),xpcorn(5),ypcorn(5)
c
          ilo = floor((xlow - xlower + .05*dxc)/dxc)
          jlo = floor((ylow - ylower + .05*dyc)/dyc)
c
      do 20 j=1-mbc,my+mbc
         do 20 i=1-mbc,mx+mbc
c
            if (aux(1,i,j) .ne. NEEDS_TO_BE_SET) cycle
c
c           # computational points (xc,yc) are mapped to physical
c           # coordinates (xp,yp) by mapc2p:
c
c           # lower left corner:
!           xccorn(1) = xlower + (i-1)*dxc orig version, with xlower !           passed in
!           yccorn(1) = ylower + (j-1)*dyc
!           xccorn(1) = xlow + (i-1)*dxc   ! changed names of args, so !           this is equiv.
!           yccorn(1) = ylow + (j-1)*dyc   ! next should be w/o roundoff
            xccorn(1) = xlower + (ilo + i-1)*dxc
            yccorn(1) = ylower + (jlo + j-1)*dyc
            call mapc2p(xccorn(1),yccorn(1),xpcorn(1),ypcorn(1))

c           # upper left corner:
            xccorn(2) = xccorn(1)
            yccorn(2) = yccorn(1) + dyc
            call mapc2p(xccorn(2),yccorn(2),xpcorn(2),ypcorn(2))
c
c           # upper right corner:
            xccorn(3) = xccorn(1) + dxc
            yccorn(3) = yccorn(1) + dyc
            call mapc2p(xccorn(3),yccorn(3),xpcorn(3),ypcorn(3))
c
c           # lower right corner:
            xccorn(4) = xccorn(1) + dxc
            yccorn(4) = yccorn(1)
            call mapc2p(xccorn(4),yccorn(4),xpcorn(4),ypcorn(4))
c
c
c           # compute edge velocities by differencing stream function:
c
            aux(1,i,j) = (stream(xpcorn(2),ypcorn(2))
     &                    - stream(xpcorn(1),ypcorn(1)))/ dyc
c
            aux(2,i,j) = -(stream(xpcorn(4),ypcorn(4))
     &                    - stream(xpcorn(1),ypcorn(1)))/ dxc

c
c
c           # compute area of physical cell from four corners:

            xpcorn(5) = xpcorn(1)
            ypcorn(5) = ypcorn(1)
            area = 0.d0
            do ic=1,4
              area = area + 0.5d0 * (ypcorn(ic)+ypcorn(ic+1)) *
     &               (xpcorn(ic+1)-xpcorn(ic))
            enddo

            aux(3,i,j) = area / (dxc*dyc)
c
   20  continue
c
       return

       end


      SUBROUTINE DPBCO(ABD, LDA, N, M, RCOND, Z, INFO)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ddot_I
      USE dasum_I
      USE dpbfa_I
      USE dscal_I
      USE daxpy_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: LDA
      INTEGER  :: N
      INTEGER  :: M
      INTEGER  :: INFO
      REAL(DOUBLE) , INTENT(OUT) :: RCOND
      REAL(DOUBLE)  :: ABD(LDA,1)
      REAL(DOUBLE)  :: Z(1)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, J, J2, K, KB, KP1, L, LA, LB, LM, MU
      REAL(DOUBLE) :: EK, T, WK, WKM, ANORM, S, SM, YNORM
!-----------------------------------------------
!
!     DPBCO FACTORS A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE
!     MATRIX STORED IN BAND FORM AND ESTIMATES THE CONDITION OF THE
!     MATRIX.
!
!     IF  RCOND  IS NOT NEEDED, DPBFA IS SLIGHTLY FASTER.
!     TO SOLVE  A*X = B , FOLLOW DPBCO BY DPBSL.
!     TO COMPUTE  INVERSE(A)*C , FOLLOW DPBCO BY DPBSL.
!     TO COMPUTE  DETERMINANT(A) , FOLLOW DPBCO BY DPBDI.
!
!     ON ENTRY
!
!        ABD     DOUBLE PRECISION(LDA, N)
!                THE MATRIX TO BE FACTORED.  THE COLUMNS OF THE UPPER
!                TRIANGLE ARE STORED IN THE COLUMNS OF ABD AND THE
!                DIAGONALS OF THE UPPER TRIANGLE ARE STORED IN THE
!                ROWS OF ABD .  SEE THE COMMENTS BELOW FOR DETAILS.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  ABD .
!                LDA MUST BE .GE. M + 1 .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!        M       INTEGER
!                THE NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
!                0 .LE. M .LT. N .
!
!     ON RETURN
!
!        ABD     AN UPPER TRIANGULAR MATRIX  R , STORED IN BAND
!                FORM, SO THAT  A = TRANS(R)*R .
!                IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
!
!        RCOND   DOUBLE PRECISION
!                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
!                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
!                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
!                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
!                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
!                           1.0 + RCOND .EQ. 1.0
!                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
!                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
!                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
!                UNDERFLOWS.  IF INFO .NE. 0 , RCOND IS UNCHANGED.
!
!        Z       DOUBLE PRECISION(N)
!                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
!                IF  A  IS SINGULAR TO WORKING PRECISION, THEN  Z  IS
!                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
!                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
!                IF  INFO .NE. 0 , Z  IS UNCHANGED.
!
!        INFO    INTEGER
!                = 0  FOR NORMAL RETURN.
!                = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR
!                     OF ORDER  K  IS NOT POSITIVE DEFINITE.
!
!     BAND STORAGE
!
!           IF  A  IS A SYMMETRIC POSITIVE DEFINITE BAND MATRIX,
!           THE FOLLOWING PROGRAM SEGMENT WILL SET UP THE INPUT.
!
!                   M = (BAND WIDTH ABOVE DIAGONAL)
!                   DO 20 J = 1, N
!                      I1 = MAX0(1, J-M)
!                      DO 10 I = I1, J
!                         K = I-J+M+1
!                         ABD(K,J) = A(I,J)
!                10    CONTINUE
!                20 CONTINUE
!
!           THIS USES  M + 1  ROWS OF  A , EXCEPT FOR THE  M BY M
!           UPPER LEFT TRIANGLE, WHICH IS IGNORED.
!
!     EXAMPLE..  IF THE ORIGINAL MATRIX IS
!
!           11 12 13  0  0  0
!           12 22 23 24  0  0
!           13 23 33 34 35  0
!            0 24 34 44 45 46
!            0  0 35 45 55 56
!            0  0  0 46 56 66
!
!     THEN  N = 6 , M = 2  AND  ABD  SHOULD CONTAIN
!
!            *  * 13 24 35 46
!            * 12 23 34 45 56
!           11 22 33 44 55 66
!
!     LINPACK.  THIS VERSION DATED 08/14/78 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     LINPACK DPBFA
!     BLAS DAXPY,DDOT,DSCAL,DASUM
!     FORTRAN DABS,DMAX1,MAX0,MIN0,DREAL,DSIGN
!
!     INTERNAL VARIABLES
!
!
!
!     FIND NORM OF A
!
      DO J = 1, N
         L = MIN0(J,M + 1)
         MU = MAX0(M + 2 - J,1)
         Z(J) = DASUM(L,ABD(MU,J),1)
         K = J - L
         IF (M < MU) CYCLE
         DO I = MU, M
            K = K + 1
            Z(K) = Z(K) + DABS(ABD(I,J))
         END DO
      END DO
      ANORM = 0.0D0
      DO J = 1, N
         ANORM = DMAX1(ANORM,Z(J))
      END DO
!
!     FACTOR
!
      CALL DPBFA (ABD, LDA, N, M, INFO)
      IF (INFO == 0) THEN
!
!        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
!        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
!        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
!        GROWTH IN THE ELEMENTS OF W  WHERE  TRANS(R)*W = E .
!        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
!
!        SOLVE TRANS(R)*W = E
!
         EK = 1.0D0
         Z(:N) = 0.0D0
         DO K = 1, N
            IF (Z(K) /= 0.0D0) EK = DSIGN(EK,(-Z(K)))
            IF (DABS(EK - Z(K)) > ABD(M+1,K)) THEN
               S = ABD(M+1,K)/DABS(EK - Z(K))
               CALL DSCAL (N, S, Z, 1)
               EK = S*EK
            ENDIF
            WK = EK - Z(K)
            WKM = (-EK) - Z(K)
            S = DABS(WK)
            SM = DABS(WKM)
            WK = WK/ABD(M+1,K)
            WKM = WKM/ABD(M+1,K)
            KP1 = K + 1
            J2 = MIN0(K + M,N)
            I = M + 1
            IF (KP1 <= J2) THEN
               DO J = KP1, J2
                  I = I - 1
                  SM = SM + DABS(Z(J)+WKM*ABD(I,J))
                  Z(J) = Z(J) + WK*ABD(I,J)
                  S = S + DABS(Z(J))
               END DO
               IF (S < SM) THEN
                  T = WKM - WK
                  WK = WKM
                  I = M + 1
                  DO J = KP1, J2
                     I = I - 1
                     Z(J) = Z(J) + T*ABD(I,J)
                  END DO
               ENDIF
            ENDIF
            Z(K) = WK
         END DO
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL (N, S, Z, 1)
!
!        SOLVE  R*Y = W
!
         DO KB = 1, N
            K = N + 1 - KB
            IF (DABS(Z(K)) > ABD(M+1,K)) THEN
               S = ABD(M+1,K)/DABS(Z(K))
               CALL DSCAL (N, S, Z, 1)
            ENDIF
            Z(K) = Z(K)/ABD(M+1,K)
            LM = MIN0(K - 1,M)
            LA = M + 1 - LM
            LB = K - LM
            T = -Z(K)
            CALL DAXPY (LM, T, ABD(LA,K), 1, Z(LB), 1)
         END DO
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL (N, S, Z, 1)
!
         YNORM = 1.0D0
!
!        SOLVE TRANS(R)*V = Y
!
         DO K = 1, N
            LM = MIN0(K - 1,M)
            LA = M + 1 - LM
            LB = K - LM
            Z(K) = Z(K) - DDOT(LM,ABD(LA,K),1,Z(LB),1)
            IF (DABS(Z(K)) > ABD(M+1,K)) THEN
               S = ABD(M+1,K)/DABS(Z(K))
               CALL DSCAL (N, S, Z, 1)
               YNORM = S*YNORM
            ENDIF
            Z(K) = Z(K)/ABD(M+1,K)
         END DO
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL (N, S, Z, 1)
         YNORM = S*YNORM
!
!        SOLVE  R*Z = W
!
         DO KB = 1, N
            K = N + 1 - KB
            IF (DABS(Z(K)) > ABD(M+1,K)) THEN
               S = ABD(M+1,K)/DABS(Z(K))
               CALL DSCAL (N, S, Z, 1)
               YNORM = S*YNORM
            ENDIF
            Z(K) = Z(K)/ABD(M+1,K)
            LM = MIN0(K - 1,M)
            LA = M + 1 - LM
            LB = K - LM
            T = -Z(K)
            CALL DAXPY (LM, T, ABD(LA,K), 1, Z(LB), 1)
         END DO
!        MAKE ZNORM = 1.0
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL (N, S, Z, 1)
         YNORM = S*YNORM
         IF (ANORM /= 0.0D0) THEN
!
            RCOND = YNORM/ANORM
         ELSE
            RCOND = 0.0D0
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE DPBCO


subroutine find_particle_uvw(t_amend,ip,IPP,t0,t1,uvw)

    use global, only : Nx,Ny,Nz,Npts,xyz,&
        dxg_r,dyg_r,drf_r,dtp,&
        uu,vv,ww,hFacC,tsg,theta,salt,&
        gam,tt, &
        pi2f,pj2f,pk2f,pi2c,pj2c,pk2c, &
        dif, djf, dkf, dic, djc, dkc

    implicit none

    real*8, intent(in) :: t_amend
    integer*8,intent(in) :: t0,t1,ip,IPP

    real*8,dimension(3),intent(out) :: uvw

    real*8,dimension(3) :: dxyz_fac
    integer*8 :: i,j,k
    real*8 :: tmp0,tmp1,tamend,deltat

    if (dtp+t_amend>1) then
        tamend=0.0
        deltat=1d0
    else
        tamend=t_amend
        deltat=dtp+t_amend
    endif

    if (xyz(ip,2,IPP)>Ny-1 .or. xyz(ip,2,IPP) < 0) then
        uvw=0d0
    else

        call find_index(ip,IPP)

        dxyz_fac(1) = dxg_r(pi2f(ip,IPP),pj2c(ip,IPP))
        dxyz_fac(2) = dyg_r(pi2c(ip,IPP),pj2f(ip,IPP))
        dxyz_fac(3) = drf_r(pk2f(ip,IPP))

        i=pi2f(ip,IPP)
        j=pj2c(ip,IPP)
        k=pk2c(ip,IPP)

        call interp_trilinear(dif(ip,IPP),djc(ip,IPP),dkc(ip,IPP),&
            uu(i:i+1,j:j+1,k:k+1,t0),tmp0)
        call interp_trilinear(dif(ip,IPP),djc(ip,IPP),dkc(ip,IPP),&
            uu(i:i+1,j:j+1,k:k+1,t1),tmp1)
        uvw(1)= (tmp1-tmp0)*deltat + tmp0

        i=pi2c(ip,IPP)
        j=pj2f(ip,IPP)
        call interp_trilinear(dic(ip,IPP),djf(ip,IPP),dkc(ip,IPP),&
            vv(i:i+1,j:j+1,k:k+1,t0),tmp0)
        call interp_trilinear(dic(ip,IPP),djf(ip,IPP),dkc(ip,IPP),&
            vv(i:i+1,j:j+1,k:k+1,t1),tmp1)

        uvw(2) = (tmp1-tmp0)*deltat + tmp0

        j=pj2c(ip,IPP)
        k=pk2f(ip,IPP)

        call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkf(ip,IPP),&
            ww(i:i+1,j:j+1,k:k+1,t0),tmp0)
        call interp_trilinear(dic(ip,IPP),djc(ip,IPP),dkf(ip,IPP),&
            ww(i:i+1,j:j+1,k:k+1,t1),tmp1)

        uvw(3) = (-tmp1+tmp0)*deltat - tmp0 !positive velocity points downward
        uvw=uvw*dxyz_fac
    endif

end subroutine find_particle_uvw


!!!!!
!!! This subroutine implements the two-stream solution for plane-parallel atmospheres from:
!!!     Meador and Weaver (1980). Two-stream approximations to radiative transfer in planetary atmospheres: A unified description of
!!!     existing methods and a new improvement. Journal of the Atmospheric Sciences 37: 630-643.
!!!!!
subroutine meador_plane_parallel(w0, mu0, tau, &
        gamma1, gamma2, gamma3, gamma4, &
        R, Tdif)

    use mod_dataspec_wavelength
    implicit none

    !! Inputs
    real*8, intent(in) :: mu0, tau
    real*8, intent(in), dimension(nw) :: w0
    real*8, intent(in), dimension(nw) :: gamma1, gamma2, gamma3, gamma4

    !! Outputs
    real*8, intent(out), dimension(nw) :: R, Tdif

    !! Derived terms
    real*8 :: Tdir
    real*8, dimension(nw) :: alpha1, alpha2, k, ksquare
    real*8, dimension(nw) :: expktau, kmu0, kgamma3, kgamma4
    real*8, dimension(nw) :: term1, term2, term3, term4

    !! Direct transmittance follows a simple exponential formula
    Tdir = exp(-tau / mu0)

    !! Define alphas and k
    alpha1 = gamma1 * gamma4 + gamma2 * gamma3      !! (16)
    alpha2 = gamma1 * gamma3 + gamma2 * gamma4      !! (17)
    ksquare = gamma1 * gamma1 - gamma2 * gamma2     !! (18)
    k = sqrt(ksquare)

    !! Reflectance (14)
    expktau = exp(k * tau)
    kmu0 = k * mu0
    kgamma3 = k * gamma3
    kgamma4 = k * gamma4

    term1 = w0 * 1.0d0 / ((1 - kmu0 * kmu0) * &
        ((k + gamma1) * expktau + (k * gamma2) * expktau))
    term2 = (1.0d0 - kmu0) * (alpha2 + kgamma3) * expktau
    term3 = (1.0d0 + kmu0) * (alpha2 - kgamma3) / expktau
    term4 = 2.0d0 * k * (gamma3 - alpha2 * mu0) * Tdir

    R = term1 * (term2 - term3 - term4)

    !! Diffuse transmittance (15)
    !! term1 is reused from Reflectance
    term2 = (1.0d0 + kmu0) * (alpha1 + kgamma4) * expktau
    term3 = (1.0d0 - kmu0) * (alpha1 - kgamma4) / expktau
    term4 = 2.0d0 * k * (gamma4 + alpha1 * mu0) / Tdir
    Tdif = Tdir * (1.0d0 - (term1 * (term2 - term3 - term4)))

end subroutine meador_plane_parallel


*DECK DCHDD
      SUBROUTINE DCHDD (R, LDR, P, X, Z, LDZ, NZ, Y, RHO, C, S, INFO)
C***BEGIN PROLOGUE  DCHDD
C***PURPOSE  Downdate an augmented Cholesky decomposition or the
C            triangular factor of an augmented QR decomposition.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D7B
C***TYPE      DOUBLE PRECISION (SCHDD-S, DCHDD-D, CCHDD-C)
C***KEYWORDS  CHOLESKY DECOMPOSITION, DOWNDATE, LINEAR ALGEBRA, LINPACK,
C             MATRIX
C***AUTHOR  Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     DCHDD downdates an augmented Cholesky decomposition or the
C     triangular factor of an augmented QR decomposition.
C     Specifically, given an upper triangular matrix R of order P,  a
C     row vector X, a column vector Z, and a scalar Y, DCHDD
C     determines an orthogonal matrix U and a scalar ZETA such that
C
C                        (R   Z )     (RR  ZZ)
C                    U * (      )  =  (      ) ,
C                        (0 ZETA)     ( X   Y)
C
C     where RR is upper triangular.  If R and Z have been obtained
C     from the factorization of a least squares problem, then
C     RR and ZZ are the factors corresponding to the problem
C     with the observation (X,Y) removed.  In this case, if RHO
C     is the norm of the residual vector, then the norm of
C     the residual vector of the downdated problem is
C     SQRT(RHO**2 - ZETA**2).  DCHDD will simultaneously downdate
C     several triplets (Z,Y,RHO) along with R.
C     For a less terse description of what DCHDD does and how
C     it may be applied, see the LINPACK guide.
C
C     The matrix U is determined as the product U(1)*...*U(P)
C     where U(I) is a rotation in the (P+1,I)-plane of the
C     form
C
C                       ( C(I)     -S(I)     )
C                       (                    ) .
C                       ( S(I)       C(I)    )
C
C     The rotations are chosen so that C(I) is double precision.
C
C     The user is warned that a given downdating problem may
C     be impossible to accomplish or may produce
C     inaccurate results.  For example, this can happen
C     if X is near a vector whose removal will reduce the
C     rank of R.  Beware.
C
C     On Entry
C
C         R      DOUBLE PRECISION(LDR,P), where LDR .GE. P.
C                R contains the upper triangular matrix
C                that is to be downdated.  The part of  R
C                below the diagonal is not referenced.
C
C         LDR    INTEGER.
C                LDR is the leading dimension of the array R.
C
C         P      INTEGER.
C                P is the order of the matrix R.
C
C         X      DOUBLE PRECISION(P).
C                X contains the row vector that is to
C                be removed from R.  X is not altered by DCHDD.
C
C         Z      DOUBLE PRECISION(LDZ,N)Z), where LDZ .GE. P.
C                Z is an array of NZ P-vectors which
C                are to be downdated along with R.
C
C         LDZ    INTEGER.
C                LDZ is the leading dimension of the array Z.
C
C         NZ     INTEGER.
C                NZ is the number of vectors to be downdated
C                NZ may be zero, in which case Z, Y, and RHO
C                are not referenced.
C
C         Y      DOUBLE PRECISION(NZ).
C                Y contains the scalars for the downdating
C                of the vectors Z.  Y is not altered by DCHDD.
C
C         RHO    DOUBLE PRECISION(NZ).
C                RHO contains the norms of the residual
C                vectors that are to be downdated.
C
C     On Return
C
C         R
C         Z      contain the downdated quantities.
C         RHO
C
C         C      DOUBLE PRECISION(P).
C                C contains the cosines of the transforming
C                rotations.
C
C         S      DOUBLE PRECISION(P).
C                S contains the sines of the transforming
C                rotations.
C
C         INFO   INTEGER.
C                INFO is set as follows.
C
C                   INFO = 0  if the entire downdating
C                             was successful.
C
C                   INFO =-1  if R could not be downdated.
C                             in this case, all quantities
C                             are left unaltered.
C
C                   INFO = 1  if some RHO could not be
C                             downdated.  The offending RHO's are
C                             set to -1.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DDOT, DNRM2
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DCHDD
      INTEGER LDR,P,LDZ,NZ,INFO
      DOUBLE PRECISION R(LDR,*),X(*),Z(LDZ,*),Y(*),S(*)
      DOUBLE PRECISION RHO(*),C(*)
C
      INTEGER I,II,J
      DOUBLE PRECISION A,ALPHA,AZETA,NORM,DNRM2
      DOUBLE PRECISION DDOT,T,ZETA,B,XX,SCALE
C
C     SOLVE THE SYSTEM TRANS(R)*A = X, PLACING THE RESULT
C     IN THE ARRAY S.
C
C***FIRST EXECUTABLE STATEMENT  DCHDD
      INFO = 0
      S(1) = X(1)/R(1,1)
      IF (P .LT. 2) GO TO 20
      DO 10 J = 2, P
         S(J) = X(J) - DDOT(J-1,R(1,J),1,S,1)
         S(J) = S(J)/R(J,J)
   10 CONTINUE
   20 CONTINUE
      NORM = DNRM2(P,S,1)
      IF (NORM .LT. 1.0D0) GO TO 30
         INFO = -1
      GO TO 120
   30 CONTINUE
         ALPHA = SQRT(1.0D0-NORM**2)
C
C        DETERMINE THE TRANSFORMATIONS.
C
         DO 40 II = 1, P
            I = P - II + 1
            SCALE = ALPHA + ABS(S(I))
            A = ALPHA/SCALE
            B = S(I)/SCALE
            NORM = SQRT(A**2+B**2)
            C(I) = A/NORM
            S(I) = B/NORM
            ALPHA = SCALE*NORM
   40    CONTINUE
C
C        APPLY THE TRANSFORMATIONS TO R.
C
         DO 60 J = 1, P
            XX = 0.0D0
            DO 50 II = 1, J
               I = J - II + 1
               T = C(I)*XX + S(I)*R(I,J)
               R(I,J) = C(I)*R(I,J) - S(I)*XX
               XX = T
   50       CONTINUE
   60    CONTINUE
C
C        IF REQUIRED, DOWNDATE Z AND RHO.
C
         IF (NZ .LT. 1) GO TO 110
         DO 100 J = 1, NZ
            ZETA = Y(J)
            DO 70 I = 1, P
               Z(I,J) = (Z(I,J) - S(I)*ZETA)/C(I)
               ZETA = C(I)*ZETA - S(I)*Z(I,J)
   70       CONTINUE
            AZETA = ABS(ZETA)
            IF (AZETA .LE. RHO(J)) GO TO 80
               INFO = 1
               RHO(J) = -1.0D0
            GO TO 90
   80       CONTINUE
               RHO(J) = RHO(J)*SQRT(1.0D0-(AZETA/RHO(J))**2)
   90       CONTINUE
  100    CONTINUE
  110    CONTINUE
  120 CONTINUE
      RETURN
      END


      FUNCTION DARCOS(X)
      IMPLICIT REAL*8(A-H,O-Z)
      IF(X) 20,10,20
   10 DARCOS=1.5707963267948966D0
      RETURN
   20 IF(DABS(X).LT.1.D0) GO TO 30
      DARCOS=0.D0
      GO TO 40
   30 DARCOS=DATAN(DSQRT(1.D0-X**2)/X)
   40 IF(X.GT.0.D0) RETURN
      DARCOS=DARCOS + 3.141592653589793D0
      RETURN
      END


c-----------------------------------------------------------------------
      subroutine riemann_aug_JCP(maxiter,meqn,mwaves,hL,hR,huL,huR,
     &   hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,pL,pR,sE1,sE2,drytol,g,rho,
     &   sw,fw)

      ! solve shallow water equations given single left and right states
      ! This solver is described in J. Comput. Phys. (6): 3089-3113, March 2008
      ! Augmented Riemann Solvers for the Shallow Equations with Steady States and Inundation

      ! To use the original solver call with maxiter=1.

      ! This solver allows iteration when maxiter > 1. The iteration seems to help with
      ! instabilities that arise (with any solver) as flow becomes transcritical over variable topo
      ! due to loss of hyperbolicity.

      implicit none

      !input
      integer meqn,mwaves,maxiter
      double precision fw(meqn,mwaves)
      double precision sw(mwaves)
      double precision hL,hR,huL,huR,bL,bR,uL,uR,phiL,phiR,sE1,sE2
      double precision hvL,hvR,vL,vR,pL,pR
      double precision drytol,g,rho

      !local
      integer m,mw,k,iter
      double precision A(3,3)
      double precision r(3,3)
      double precision lambda(3)
      double precision del(3)
      double precision beta(3)

      double precision delh,delhu,delphi,delb,delnorm
      double precision rare1st,rare2st,sdelta,raremin,raremax
      double precision criticaltol,convergencetol,raretol
      double precision criticaltol_2, hustar_interface
      double precision s1s2bar,s1s2tilde,hbar,hLstar,hRstar,hustar
      double precision huRstar,huLstar,uRstar,uLstar,hstarHLL
      double precision deldelh,deldelphi,delP
      double precision s1m,s2m,hm
      double precision det1,det2,det3,determinant

      logical rare1,rare2,rarecorrector,rarecorrectortest,sonic

      !determine del vectors
      delh = hR-hL
      delhu = huR-huL
      delphi = phiR-phiL
      delb = bR-bL
      delP = pR - pL
      delnorm = delh**2 + delphi**2

      call riemanntype(hL,hR,uL,uR,hm,s1m,s2m,rare1,rare2,
     &                                          1,drytol,g)

      lambda(1)= min(sE1,s2m) !Modified Einfeldt speed
      lambda(3)= max(sE2,s1m) !Modified Eindfeldt speed
      sE1=lambda(1)
      sE2=lambda(3)
      lambda(2) = 0.d0  ! ### Fix to avoid uninitialized value in loop on mw -- Correct?? ###

      hstarHLL = max((huL-huR+sE2*hR-sE1*hL)/(sE2-sE1),0.d0) ! middle state in an HLL solve

c     !determine the middle entropy corrector wave------------------------
      rarecorrectortest=.false.
      rarecorrector=.false.
      if (rarecorrectortest) then
         sdelta=lambda(3)-lambda(1)
         raremin = 0.5d0
         raremax = 0.9d0
         if (rare1.and.sE1*s1m.lt.0.d0) raremin=0.2d0
         if (rare2.and.sE2*s2m.lt.0.d0) raremin=0.2d0
         if (rare1.or.rare2) then
            !see which rarefaction is larger
            rare1st=3.d0*(sqrt(g*hL)-sqrt(g*hm))
            rare2st=3.d0*(sqrt(g*hR)-sqrt(g*hm))
            if (max(rare1st,rare2st).gt.raremin*sdelta.and.
     &         max(rare1st,rare2st).lt.raremax*sdelta) then
                  rarecorrector=.true.
               if (rare1st.gt.rare2st) then
                  lambda(2)=s1m
               elseif (rare2st.gt.rare1st) then
                  lambda(2)=s2m
               else
                  lambda(2)=0.5d0*(s1m+s2m)
               endif
            endif
         endif
         if (hstarHLL.lt.min(hL,hR)/5.d0) rarecorrector=.false.
      endif

c     ## Is this correct 2-wave when rarecorrector == .true. ??
      do mw=1,mwaves
         r(1,mw)=1.d0
         r(2,mw)=lambda(mw)
         r(3,mw)=(lambda(mw))**2
      enddo
      if (.not.rarecorrector) then
         lambda(2) = 0.5d0*(lambda(1)+lambda(3))
c         lambda(2) = max(min(0.5d0*(s1m+s2m),sE2),sE1)
         r(1,2)=0.d0
         r(2,2)=0.d0
         r(3,2)=1.d0
      endif
c     !---------------------------------------------------

c     !determine the steady state wave -------------------
      !criticaltol = 1.d-6
      ! MODIFIED:
      criticaltol = max(drytol*g, 1d-6)
      criticaltol_2 = sqrt(criticaltol)
      deldelh = -delb
      deldelphi = -0.5d0 * (hR + hL) * (g * delb + delp / rho)

c     !determine a few quanitites needed for steady state wave if iterated
      hLstar=hL
      hRstar=hR
      uLstar=uL
      uRstar=uR
      huLstar=uLstar*hLstar
      huRstar=uRstar*hRstar

      !iterate to better determine the steady state wave
      convergencetol=1.d-6
      do iter=1,maxiter
         !determine steady state wave (this will be subtracted from the delta vectors)
         if (min(hLstar,hRstar).lt.drytol.and.rarecorrector) then
            rarecorrector=.false.
            hLstar=hL
            hRstar=hR
            uLstar=uL
            uRstar=uR
            huLstar=uLstar*hLstar
            huRstar=uRstar*hRstar
            lambda(2) = 0.5d0*(lambda(1)+lambda(3))
c           lambda(2) = max(min(0.5d0*(s1m+s2m),sE2),sE1)
            r(1,2)=0.d0
            r(2,2)=0.d0
            r(3,2)=1.d0
         endif

         hbar =  max(0.5d0*(hLstar+hRstar),0.d0)
         s1s2bar = 0.25d0*(uLstar+uRstar)**2 - g*hbar
         s1s2tilde= max(0.d0,uLstar*uRstar) - g*hbar

c        !find if sonic problem
         ! MODIFIED from 5.3.1 version
         sonic = .false.
         if (abs(s1s2bar) <= criticaltol) then
            sonic = .true.
         else if (s1s2bar*s1s2tilde <= criticaltol**2) then
            sonic = .true.
         else if (s1s2bar*sE1*sE2 <= criticaltol**2) then
            sonic = .true.
         else if (min(abs(sE1),abs(sE2)) < criticaltol_2) then
            sonic = .true.
         else if (sE1 <  criticaltol_2 .and. s1m > -criticaltol_2) then
            sonic = .true.
         else if (sE2 > -criticaltol_2 .and. s2m <  criticaltol_2) then
            sonic = .true.
         else if ((uL+dsqrt(g*hL))*(uR+dsqrt(g*hR)) < 0.d0) then
            sonic = .true.
         else if ((uL- dsqrt(g*hL))*(uR- dsqrt(g*hR)) < 0.d0) then
            sonic = .true.
         end if

c        !find jump in h, deldelh
         if (sonic) then
            deldelh =  -delb
         else
            deldelh = delb*g*hbar/s1s2bar
         endif
c        !find bounds in case of critical state resonance, or negative states
         if (sE1.lt.-criticaltol.and.sE2.gt.criticaltol) then
            deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE2)
            deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE1)
         elseif (sE1.ge.criticaltol) then
            deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE1)
            deldelh = max(deldelh,-hL)
         elseif (sE2.le.-criticaltol) then
            deldelh = min(deldelh,hR)
            deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE2)
         endif

c        ! adjust deldelh for well-balancing of atmospheric pressure difference
         deldelh = deldelh - delP/(rho*g)

c        !find jump in phi, deldelphi
         if (sonic) then
            deldelphi = -g*hbar*delb
         else
            deldelphi = -delb*g*hbar*s1s2tilde/s1s2bar
         endif
c        !find bounds in case of critical state resonance, or negative states
         deldelphi=min(deldelphi,g*max(-hLstar*delb,-hRstar*delb))
         deldelphi=max(deldelphi,g*min(-hLstar*delb,-hRstar*delb))
         deldelphi = deldelphi - hbar * delp / rho

         del(1)=delh-deldelh
         del(2)=delhu
         del(3)=delphi-deldelphi

c        !Determine determinant of eigenvector matrix========
         det1=r(1,1)*(r(2,2)*r(3,3)-r(2,3)*r(3,2))
         det2=r(1,2)*(r(2,1)*r(3,3)-r(2,3)*r(3,1))
         det3=r(1,3)*(r(2,1)*r(3,2)-r(2,2)*r(3,1))
         determinant=det1-det2+det3

c        !solve for beta(k) using Cramers Rule=================
         do k=1,3
            do mw=1,3
                  A(1,mw)=r(1,mw)
                  A(2,mw)=r(2,mw)
                  A(3,mw)=r(3,mw)
            enddo
            A(1,k)=del(1)
            A(2,k)=del(2)
            A(3,k)=del(3)
            det1=A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
            det2=A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1))
            det3=A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
            beta(k)=(det1-det2+det3)/determinant
         enddo

         !exit if things aren't changing
         if (abs(del(1)**2+del(3)**2-delnorm).lt.convergencetol) exit
         delnorm = del(1)**2+del(3)**2
         !find new states qLstar and qRstar on either side of interface
         hLstar=hL
         hRstar=hR
         uLstar=uL
         uRstar=uR
         huLstar=uLstar*hLstar
         huRstar=uRstar*hRstar
         do mw=1,mwaves
            if (lambda(mw).lt.0.d0) then
               hLstar= hLstar + beta(mw)*r(1,mw)
               huLstar= huLstar + beta(mw)*r(2,mw)
            endif
         enddo
         do mw=mwaves,1,-1
            if (lambda(mw).gt.0.d0) then
               hRstar= hRstar - beta(mw)*r(1,mw)
               huRstar= huRstar - beta(mw)*r(2,mw)
            endif
         enddo

         if (hLstar.gt.drytol) then
            uLstar=huLstar/hLstar
         else
            hLstar=max(hLstar,0.d0)
            uLstar=0.d0
         endif
         if (hRstar.gt.drytol) then
            uRstar=huRstar/hRstar
         else
            hRstar=max(hRstar,0.d0)
            uRstar=0.d0
         endif

      enddo ! end iteration on Riemann problem

      do mw=1,mwaves
         sw(mw)=lambda(mw)
         fw(1,mw)=beta(mw)*r(2,mw)
         fw(2,mw)=beta(mw)*r(3,mw)
         fw(3,mw)=beta(mw)*r(2,mw)
      enddo
      !find transverse components (ie huv jumps).
      ! MODIFIED from 5.3.1 version
      fw(3,1)=fw(3,1)*vL
      fw(3,3)=fw(3,3)*vR
      fw(3,2)= 0.d0

      hustar_interface = huL + fw(1,1)   ! = huR - fw(1,3)
      if (hustar_interface <= 0.0d0) then
          fw(3,1) = fw(3,1) + (hR*uR*vR - hL*uL*vL - fw(3,1)- fw(3,3))
        else
          fw(3,3) = fw(3,3) + (hR*uR*vR - hL*uL*vL - fw(3,1)- fw(3,3))
        end if

      return

      end !subroutine riemann_aug_JCP-------------------------------------------------

c-----------------------------------------------------------------------
      subroutine riemann_ssqfwave(maxiter,meqn,mwaves,hL,hR,huL,huR,
     &    hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,pL,pR,sE1,sE2,drytol,g,
     &    rho,sw,fw)

      ! solve shallow water equations given single left and right states
      ! steady state wave is subtracted from delta [q,f]^T before decomposition

      implicit none

      !input
      integer meqn,mwaves,maxiter

      double precision hL,hR,huL,huR,bL,bR,uL,uR,phiL,phiR,sE1,sE2
      double precision vL,vR,hvL,hvR,pL,pR
      double precision drytol,g,rho

      !local
      integer iter

      logical sonic

      double precision delh,delhu,delphi,delb,delhdecomp,delphidecomp
      double precision s1s2bar,s1s2tilde,hbar,hLstar,hRstar,hustar
      double precision uRstar,uLstar,hstarHLL
      double precision deldelh,deldelphi,delP
      double precision alpha1,alpha2,beta1,beta2,delalpha1,delalpha2
      double precision criticaltol,convergencetol
      double precision sL,sR
      double precision uhat,chat,sRoe1,sRoe2

      double precision sw(mwaves)
      double precision fw(meqn,mwaves)

      !determine del vectors
      delh = hR-hL
      delhu = huR-huL
      delphi = phiR-phiL
      delb = bR-bL
      delP = pR - pL

      convergencetol= 1.d-16
      criticaltol = 1.d-99

      deldelh = -delb
      deldelphi = -0.5d0 * (hR + hL) * (g * delb + delP / rho)

!     !if no source term, skip determining steady state wave
      if (abs(delb).gt.0.d0) then
!
         !determine a few quanitites needed for steady state wave if iterated
         hLstar=hL
         hRstar=hR
         uLstar=uL
         uRstar=uR
         hstarHLL = max((huL-huR+sE2*hR-sE1*hL)/(sE2-sE1),0.d0) ! middle state in an HLL solve

         alpha1=0.d0
         alpha2=0.d0

!        !iterate to better determine Riemann problem
         do iter=1,maxiter

            !determine steady state wave (this will be subtracted from the delta vectors)
            hbar =  max(0.5d0*(hLstar+hRstar),0.d0)
            s1s2bar = 0.25d0*(uLstar+uRstar)**2 - g*hbar
            s1s2tilde= max(0.d0,uLstar*uRstar) - g*hbar

c           !find if sonic problem
            sonic=.false.
            if (abs(s1s2bar).le.criticaltol) sonic=.true.
            if (s1s2bar*s1s2tilde.le.criticaltol) sonic=.true.
            if (s1s2bar*sE1*sE2.le.criticaltol) sonic = .true.
            if (min(abs(sE1),abs(sE2)).lt.criticaltol) sonic=.true.

c           !find jump in h, deldelh
            if (sonic) then
               deldelh =  -delb
            else
               deldelh = delb*g*hbar/s1s2bar
            endif
!           !bounds in case of critical state resonance, or negative states
            if (sE1.lt.-criticaltol.and.sE2.gt.criticaltol) then
               deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE2)
               deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE1)
            elseif (sE1.ge.criticaltol) then
               deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE1)
               deldelh = max(deldelh,-hL)
            elseif (sE2.le.-criticaltol) then
               deldelh = min(deldelh,hR)
               deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE2)
            endif

c           !find jump in phi, deldelphi
            if (sonic) then
               deldelphi = -g*hbar*delb
            else
               deldelphi = -delb*g*hbar*s1s2tilde/s1s2bar
            endif
!           !bounds in case of critical state resonance, or negative states
            deldelphi=min(deldelphi,g*max(-hLstar*delb,-hRstar*delb))
            deldelphi=max(deldelphi,g*min(-hLstar*delb,-hRstar*delb))

!---------determine fwaves ------------------------------------------

!           !first decomposition
            delhdecomp = delh-deldelh
            delalpha1 = (sE2*delhdecomp - delhu)/(sE2-sE1)-alpha1
            alpha1 = alpha1 + delalpha1
            delalpha2 = (delhu - sE1*delhdecomp)/(sE2-sE1)-alpha2
            alpha2 = alpha2 + delalpha2

            !second decomposition
            delphidecomp = delphi - deldelphi
            beta1 = (sE2*delhu - delphidecomp)/(sE2-sE1)
            beta2 = (delphidecomp - sE1*delhu)/(sE2-sE1)

            if ((delalpha2**2+delalpha1**2).lt.convergencetol**2) then
               exit
            endif
!
            if (sE2.gt.0.d0.and.sE1.lt.0.d0) then
               hLstar=hL+alpha1
               hRstar=hR-alpha2
c               hustar=huL+alpha1*sE1
               hustar = huL + beta1
            elseif (sE1.ge.0.d0) then
               hLstar=hL
               hustar=huL
               hRstar=hR - alpha1 - alpha2
            elseif (sE2.le.0.d0) then
               hRstar=hR
               hustar=huR
               hLstar=hL + alpha1 + alpha2
            endif
!
            if (hLstar.gt.drytol) then
               uLstar=hustar/hLstar
            else
               hLstar=max(hLstar,0.d0)
               uLstar=0.d0
            endif
!
            if (hRstar.gt.drytol) then
               uRstar=hustar/hRstar
            else
               hRstar=max(hRstar,0.d0)
               uRstar=0.d0
            endif

         enddo
      endif

      delhdecomp = delh - deldelh
      delphidecomp = delphi - deldelphi

      !first decomposition
      alpha1 = (sE2*delhdecomp - delhu)/(sE2-sE1)
      alpha2 = (delhu - sE1*delhdecomp)/(sE2-sE1)

      !second decomposition
      beta1 = (sE2*delhu - delphidecomp)/(sE2-sE1)
      beta2 = (delphidecomp - sE1*delhu)/(sE2-sE1)

      ! 1st nonlinear wave
      fw(1,1) = alpha1*sE1
      fw(2,1) = beta1*sE1
      fw(3,1) = fw(1,1)*vL
      ! 2nd nonlinear wave
      fw(1,3) = alpha2*sE2
      fw(2,3) = beta2*sE2
      fw(3,3) = fw(1,3)*vR
      ! advection of transverse wave
      fw(1,2) = 0.d0
      fw(2,2) = 0.d0
      fw(3,2) = hR*uR*vR - hL*uL*vL -fw(3,1)-fw(3,3)
      !speeds
      sw(1)=sE1
      sw(2)=0.5d0*(sE1+sE2)
      sw(3)=sE2

      return

      end subroutine !-------------------------------------------------

c-----------------------------------------------------------------------
      subroutine riemann_fwave(meqn,mwaves,hL,hR,huL,huR,hvL,hvR,
     &            bL,bR,uL,uR,vL,vR,phiL,phiR,pL,pR,s1,s2,drytol,g,rho,
     &            sw,fw)

      ! solve shallow water equations given single left and right states
      ! solution has two waves.
      ! flux - source is decomposed.

      implicit none

      !input
      integer meqn,mwaves

      double precision hL,hR,huL,huR,bL,bR,uL,uR,phiL,phiR,s1,s2
      double precision hvL,hvR,vL,vR,pL,pR
      double precision drytol,g,rho

      double precision sw(mwaves)
      double precision fw(meqn,mwaves)

      !local
      double precision delh,delhu,delphi,delb,delhdecomp,delphidecomp
      double precision deldelh,deldelphi,delP
      double precision beta1,beta2

      !determine del vectors
      delh = hR-hL
      delhu = huR-huL
      delphi = phiR-phiL
      delb = bR-bL
      delP = pR - pL

      deldelphi = -0.5d0 * (hR + hL) * (g * delb + delP / rho)
      delphidecomp = delphi - deldelphi

      !flux decomposition
      beta1 = (s2*delhu - delphidecomp)/(s2-s1)
      beta2 = (delphidecomp - s1*delhu)/(s2-s1)

      sw(1)=s1
      sw(2)=0.5d0*(s1+s2)
      sw(3)=s2
      ! 1st nonlinear wave
      fw(1,1) = beta1
      fw(2,1) = beta1*s1
      fw(3,1) = beta1*vL
      ! 2nd nonlinear wave
      fw(1,3) = beta2
      fw(2,3) = beta2*s2
      fw(3,3) = beta2*vR
      ! advection of transverse wave
      fw(1,2) = 0.d0
      fw(2,2) = 0.d0
      fw(3,2) = hR*uR*vR - hL*uL*vL -fw(3,1)-fw(3,3)
      return

      end !subroutine -------------------------------------------------

c=============================================================================
      subroutine riemanntype(hL,hR,uL,uR,hm,s1m,s2m,rare1,rare2,
     &             maxiter,drytol,g)

      !determine the Riemann structure (wave-type in each family)

      implicit none

      !input
      double precision hL,hR,uL,uR,drytol,g
      integer maxiter

      !output
      double precision s1m,s2m
      logical rare1,rare2

      !local
      double precision hm,u1m,u2m,um,delu
      double precision h_max,h_min,h0,F_max,F_min,dfdh,F0,slope,gL,gR
      integer iter

c     !Test for Riemann structure

      h_min=min(hR,hL)
      h_max=max(hR,hL)
      delu=uR-uL

      if (h_min.le.drytol) then
         hm=0.d0
         um=0.d0
         s1m=uR+uL-2.d0*sqrt(g*hR)+2.d0*sqrt(g*hL)
         s2m=uR+uL-2.d0*sqrt(g*hR)+2.d0*sqrt(g*hL)
         if (hL.le.0.d0) then
            rare2=.true.
            rare1=.false.
         else
            rare1=.true.
            rare2=.false.
         endif

      else
         F_min= delu+2.d0*(sqrt(g*h_min)-sqrt(g*h_max))
         F_max= delu +
     &         (h_max-h_min)*(sqrt(.5d0*g*(h_max+h_min)/(h_max*h_min)))

         if (F_min.gt.0.d0) then !2-rarefactions

            hm=(1.d0/(16.d0*g))*
     &               max(0.d0,-delu+2.d0*(sqrt(g*hL)+sqrt(g*hR)))**2
            um=sign(1.d0,hm)*(uL+2.d0*(sqrt(g*hL)-sqrt(g*hm)))

            s1m=uL+2.d0*sqrt(g*hL)-3.d0*sqrt(g*hm)
            s2m=uR-2.d0*sqrt(g*hR)+3.d0*sqrt(g*hm)

            rare1=.true.
            rare2=.true.

         elseif (F_max.le.0.d0) then !2 shocks

c           !root finding using a Newton iteration on sqrt(h)===
            h0=h_max
            do iter=1,maxiter
               gL=sqrt(.5d0*g*(1/h0 + 1/hL))
               gR=sqrt(.5d0*g*(1/h0 + 1/hR))
               F0=delu+(h0-hL)*gL + (h0-hR)*gR
               dfdh=gL-g*(h0-hL)/(4.d0*(h0**2)*gL)+
     &                   gR-g*(h0-hR)/(4.d0*(h0**2)*gR)
               slope=2.d0*sqrt(h0)*dfdh
               h0=(sqrt(h0)-F0/slope)**2
            enddo
               hm=h0
               u1m=uL-(hm-hL)*sqrt((.5d0*g)*(1/hm + 1/hL))
               u2m=uR+(hm-hR)*sqrt((.5d0*g)*(1/hm + 1/hR))
               um=.5d0*(u1m+u2m)

               s1m=u1m-sqrt(g*hm)
               s2m=u2m+sqrt(g*hm)
               rare1=.false.
               rare2=.false.

         else !one shock one rarefaction
            h0=h_min

            do iter=1,maxiter
               F0=delu + 2.d0*(sqrt(g*h0)-sqrt(g*h_max))
     &                  + (h0-h_min)*sqrt(.5d0*g*(1/h0+1/h_min))
               slope=(F_max-F0)/(h_max-h_min)
               h0=h0-F0/slope
            enddo

            hm=h0
            if (hL.gt.hR) then
               um=uL+2.d0*sqrt(g*hL)-2.d0*sqrt(g*hm)
               s1m=uL+2.d0*sqrt(g*hL)-3.d0*sqrt(g*hm)
               s2m=uL+2.d0*sqrt(g*hL)-sqrt(g*hm)
               rare1=.true.
               rare2=.false.
            else
               s2m=uR-2.d0*sqrt(g*hR)+3.d0*sqrt(g*hm)
               s1m=uR-2.d0*sqrt(g*hR)+sqrt(g*hm)
               um=uR-2.d0*sqrt(g*hR)+2.d0*sqrt(g*hm)
               rare2=.true.
               rare1=.false.
            endif
         endif
      endif

      return

      end ! subroutine riemanntype----------------------------------------------------------------


!***********************************/
!	Name:Roe平均を計算するプログラム
!	Alias:GetRoeAverage
!	Description:隣接する2つのセルから保存変数を受け取ってRoe平均を計算する
!	Type:RoeAverage
!	Input:Geometory,RoeAverage
!	Output:RoeAverage
!	Note:内部関数としてRoeの荷重平均を求める関数が入っている
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.09
!	Other:1次元と2次元に対応
!***********************************/
subroutine GetRoeAverage(Geom,RA,SP4O)
    use StructVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio
    implicit none

    type(Geometry), intent(in) :: Geom
    type(RoeAverage), intent(inout) :: RA
    type(PrivateVar4OMP) :: SP4O

    SP4O%GRA%SqrtDensity(:) = dsqrt(RA%SideQuantity(1,:))
    SP4O%GRA%InverseDensitySum = 1.0d0 / (SP4O%GRA%SqrtDensity(1) + SP4O%GRA%SqrtDensity(2))

        !1:音速,2~:速度,最後:エンタルピ
        if(Geom%Dimension == 1) then
            SP4O%GRA%Velocity(1,:) = RA%SideQuantity(2,:)/RA%SideQuantity(1,:)

            SP4O%GRA%Enthalpy(:) = Gamma*RA%SideQuantity(3,:)/ RA%SideQuantity(1,:) - Gmin1*0.5d0*SP4O%GRA%Velocity(1,:)**2

            RA%RoeAverage(2) = RoeLoadAverage(SP4O%GRA%Velocity(1,1),SP4O%GRA%Velocity(1,2))
            RA%RoeAverage(3) = RoeLoadAverage(SP4O%GRA%Enthalpy(1),SP4O%GRA%Enthalpy(2))
            RA%RoeAverage(1) = dsqrt(Gmin1*RA%RoeAverage(3)-0.5d0*RA%RoeAverage(2)**2)

        else if(Geom%Dimension == 2) then
            SP4O%GRA%Velocity(1,:) = RA%SideQuantity(2,:)/RA%SideQuantity(1,:)
            SP4O%GRA%Velocity(2,:) = RA%SideQuantity(3,:)/RA%SideQuantity(1,:)
            SP4O%GRA%Enthalpy(:) = Gamma*RA%SideQuantity(4,:)/ RA%SideQuantity(1,:) &
                &   - Gmin1*0.5d0*(SP4O%GRA%Velocity(1,:)**2 + SP4O%GRA%Velocity(2,:)**2)

            RA%RoeAverage(2) = RoeLoadAverage(SP4O%GRA%Velocity(1,1),SP4O%GRA%Velocity(1,2))
            RA%RoeAverage(3) = RoeLoadAverage(SP4O%GRA%Velocity(2,1),SP4O%GRA%Velocity(2,2))
            RA%RoeAverage(4) = RoeLoadAverage(SP4O%GRA%Enthalpy(1),SP4O%GRA%Enthalpy(2))
            RA%RoeAverage(1) = dsqrt(Gmin1*RA%RoeAverage(4)-0.5d0*(RA%RoeAverage(2)**2 + RA%RoeAverage(3)**2))
        end if

    return

contains
    function RoeLoadAverage(QuantityL,QuantityR) result(Average)
    implicit none
    double precision,intent(in) :: QuantityL,QuantityR
    double precision :: Average

    Average =  (SP4O%GRA%SqrtDensity(1)*QuantityL + SP4O%GRA%SqrtDensity(2)*QuantityR)*SP4O%GRA%InverseDensitySum

    return
    end function RoeLoadAverage

end subroutine GetRoeAverage


module transformation
  implicit none

  private :: T_a12_IndvAngles, T_a12_ArrayAngles, &
             T_r21_IndvAngles, T_r21_ArrayAngles

  interface T_a12
    module procedure T_a12_IndvAngles
    module procedure T_a12_ArrayAngles
  end interface T_a12

  interface T_r21
    module procedure T_r21_ArrayAngles
    module procedure T_r21_IndvAngles
  end interface T_r21

  contains
    subroutine tester(input)
      use types
      type(disc_status), intent(in) :: input
      print *, input%theta
    end subroutine tester

    function test() result(j)
      real*8 :: j
      j = 2
    end function test

    pure function T_a12_IndvAngles(phi, theta, psi) result(T_a)
      real*8 :: T_a(3,3)
      real*8, intent(in) :: phi, theta, psi
      real*8 :: cosphi, costheta, cospsi, &
                sinphi, sintheta, sinpsi
      cosphi = cos(phi)
      costheta = cos(theta)
      cospsi = cos(psi)
      sinphi = sin(phi)
      sintheta = sin(theta)
      sinpsi = sin(psi)

      T_a(1,1) =  cosphi*cospsi
      T_a(1,2) =  sinphi*sintheta*cospsi + cosphi*sinpsi
      T_a(1,3) = -cosphi*sintheta*cospsi + sinphi*sinpsi

      T_a(2,1) =  costheta*sinpsi
      T_a(2,2) =  sinphi*sintheta*sinpsi + cosphi*cospsi
      T_a(2,3) =  cosphi*sintheta*sinpsi + sinphi*cospsi

      T_a(3,1) =  sintheta
      T_a(3,2) = -sinphi*costheta
      T_a(3,3) =  cosphi*costheta
    end function T_a12_IndvAngles

    pure function T_a12_ArrayAngles(angles) result(T_a)
      real*8 :: T_a(3,3)
      real*8, intent(in) :: angles(3)
      ! real*8 :: phi, theta, psi
      real*8 :: cosphi, costheta, cospsi, &
                sinphi, sintheta, sinpsi
      cosphi = cos(angles(1))
      costheta = cos(angles(2))
      cospsi = cos(angles(3))
      sinphi = sin(angles(1))
      sintheta = sin(angles(2))
      sinpsi = sin(angles(3))

      T_a(1,1) =  cosphi*cospsi
      T_a(1,2) =  sinphi*sintheta*cospsi + cosphi*sinpsi
      T_a(1,3) = -cosphi*sintheta*cospsi + sinphi*sinpsi

      T_a(2,1) =  costheta*sinpsi
      T_a(2,2) =  sinphi*sintheta*sinpsi + cosphi*cospsi
      T_a(2,3) =  cosphi*sintheta*sinpsi + sinphi*cospsi

      T_a(3,1) =  sintheta
      T_a(3,2) = -sinphi*costheta
      T_a(3,3) =  cosphi*costheta
    end function T_a12_ArrayAngles

    pure function T_a23(beta) result(T_a)
      real*8 :: T_a(3,3)
      real*8, intent(in) :: beta
      real*8 :: cosbeta, sinbeta

      cosbeta = cos(beta)
      sinbeta = sin(beta)

      T_a(1,:) = (/  cosbeta, -sinbeta, 0D0 /)
      T_a(2,:) = (/ -sinbeta,  cosbeta, 0D0 /)
      T_a(3,:) = (/      0D0,      0D0, 1D0 /)

    end function T_a23

    pure function T_a34(alpha) result(T_a)
      real*8 :: T_a(3,3)
      real*8, intent(in) :: alpha
      real*8 :: cosalpha, sinalpha

      cosalpha = cos(alpha)
      sinalpha = sin(alpha)

      T_a(1,:) = (/  cosalpha, 0D0, -sinalpha /)
      T_a(2,:) = (/       0D0, 1D0,       0D0 /)
      T_a(3,:) = (/  sinalpha, 0D0,  cosalpha /)

    end function T_a34

    pure function T_r21_ArrayAngles(angles) result(T_r)
      real*8 :: T_r(3,3)
      real*8, intent(in) :: angles(3)
      real*8 :: cosphi, costheta, cospsi, &
                sinphi, sintheta, sinpsi, tantheta
      costheta = cos(angles(2))
      cospsi = cos(angles(3))
      tantheta = tan(angles(2))
      sinpsi = sin(angles(3))

      T_r(1,:) = (/ 1d0, sinpsi*tantheta, cospsi*tantheta /)
      T_r(2,:) = (/ 0d0,          cospsi,         -sinpsi /)
      T_r(3,:) = (/ 0d0, sinpsi/costheta, cospsi/costheta /)

    end function T_r21_ArrayAngles

    pure function T_r21_IndvAngles(theta, psi) result(T_r)
      real*8 :: T_r(3,3)
      real*8, intent(in) :: theta, psi
      real*8 :: cosphi, costheta, cospsi, &
                sinphi, sintheta, sinpsi, tantheta
      costheta = cos(theta)
      cospsi = cos(psi)
      tantheta = tan(theta)
      sinpsi = sin(psi)

      T_r(1,:) = (/ 1d0, sinpsi*tantheta, cospsi*tantheta /)
      T_r(2,:) = (/ 0d0,          cospsi,         -sinpsi /)
      T_r(3,:) = (/ 0d0, sinpsi/costheta, cospsi/costheta /)

    end function T_r21_IndvAngles

end module transformation


MODULE maskf_module

  implicit none

  PRIVATE
  PUBLIC :: nmsk,maskr,xm,dxm,makemaskf

  integer,parameter :: nmsk=201
  real(8) :: maskr(0:nmsk),xm(0:nmsk),dxm

CONTAINS

  SUBROUTINE makemaskf(eta)
    real(8),intent(IN) :: eta
    real(8),allocatable :: X12(:,:),iX12(:,:),lambda(:),rwork(:)
    real(8) :: dx,x1,x2,x,c,pi
    integer,parameter :: matz=1
    integer :: ierr,mxtmp,i,j,LWORK,LIWORK
    integer,allocatable :: iwork(:)
    pi=acos(-1.d0)
    mxtmp=nmsk-1
    dx=1.d0/mxtmp
    allocate( lambda(mxtmp) )
    allocate( X12(mxtmp,mxtmp) )
    do j=1,mxtmp
       x2=j*dx
       do i=j,mxtmp
          x1=i*dx
          if ( i==j ) then
             X12(i,j)=sin((x1+x2)*eta)/(x1+x2)+mxtmp*pi-eta
          else
             X12(i,j)=sin((x1+x2)*eta)/(x1+x2)-sin((x1-x2)*eta)/(x1-x2)
             X12(j,i)=X12(i,j)
          end if
       end do
    end do
    LWORK=1+6*mxtmp+2*mxtmp*mxtmp
    LIWORK=3+5*mxtmp
    allocate( rwork(LWORK),iwork(LIWORK) )
    call DSYEVD('V','L',mxtmp,X12,mxtmp,lambda,rwork,LWORK,iwork,LIWORK,ierr)
    deallocate( iwork,rwork )
    c=X12(1,1)/dx
    do i=1,mxtmp
       x=i*dx
       maskr(i)=X12(i,1)/x/c
    end do
    maskr(0)=1.d0
    maskr(nmsk)=0.d0
    dxm=dx
    do i=0,nmsk
       xm(i)=i*dxm
    end do
    deallocate( lambda )
    deallocate( X12 )
    return
  END SUBROUTINE makemaskf

END MODULE maskf_module


c
c program xyy2hdtv
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter (maxsamp=40000)

      integer*2 red(maxsamp),green(maxsamp),blue(maxsamp)
      integer*4 ounit(3)
      integer*4 unit(3),status
      logical use_macbeth,xvptst
      real*4 x(maxsamp),y(maxsamp),yy(maxsamp)
      real*4 macbeth(3,24)
      real*4 aa(3,3),bb(3,3),cc(3,3)
      character*80 msg

      data aa/3.240479, -1.537150, -0.498535,
     +        -0.969256, 1.875992, 0.041556,
     +        0.055648, -0.204043, 1.057311/
      data bb/0.,0.,0., 0.,0.,0., 0.,0.,0./
      data cc/0.,0.,0., 0.,0.,0., 0.,0.,0./

c table of macbeth Yxy values to test algorithm accuracy.
c only used with the MACBETH keyword.
      data macbeth/
     +  10.1,.400,.350,  35.8,.377,.345,  19.3,.247,.251,
     +  13.3,.337,.422,  24.3,.265,.240,  43.1,.261,.343,
     +  30.1,.506,.407,  12.0,.211,.175,  19.8,.453,.306,
     +   6.6,.285,.202,  44.3,.380,.489,  43.1,.473,.438,
     +   6.1,.187,.129,  23.4,.305,.478,  12.0,.539,.313,
     +  59.1,.448,.470,  19.8,.364,.233,  19.8,.196,.252,
     +  90.0,.310,.316,  59.1,.310,.316,  36.2,.310,.316,
     +  19.8,.310,.316,   9.0,.310,.316,   3.1,.310,.316/

c parameters
      use_macbeth=xvptst('MACBETH')
      if(use_macbeth)then
        nl=4
        ns=6
        kmac=0
      endif

c open all inputs
      if(.not.use_macbeth)then
        do i=1,3
          call xvunit(unit(i),'INP',i,status,' ')
          call xvopen(unit(i),status,'U_FORMAT','REAL',' ')
          call xvget(unit(i),status,'NL',nl,'NS',ns,' ')
          if(ns.gt.maxsamp)then
            call xvmessage('Line length too long',' ')
            call abend
          endif
        enddo
      endif

c open all outputs
      do i=1,3
        call xvunit(ounit(i),'OUT',i,status,' ')
        call xvopen(ounit(i),status,'O_FORMAT','BYTE','U_FORMAT','HALF',
     +              'U_NL',nl,'U_NS',ns,'OP','WRITE',' ')
      enddo

      if(use_macbeth)then
        call xvmessage('Macbeth color table',' ')
        call xvmessage('step    x         y         Y     r    g    b'
     +   ,' ')
      endif

c process images
      do line=1,nl
                                   ! line loop
        if(.not.use_macbeth)then
          call xvread(unit(1),x,status,'LINE',line,' ')
          call xvread(unit(2),y,status,'LINE',line,' ')
          call xvread(unit(3),yy,status,'LINE',line,' ')
        endif

        do ii=1,ns                              ! pixel loop

c         if macbeth cycle through the 24 colors
          if(use_macbeth)then
            kmac=kmac+1
            x(ii)=macbeth(2,kmac)
            y(ii)=macbeth(3,kmac)
            yy(ii)=macbeth(1,kmac)
          endif

c         convert xyY to XYZ normalized from 0 to 1.
          y_tristim=yy(ii)
          x_tristim=yy(ii)*x(ii)/y(ii)
          z_tristim=yy(ii)/y(ii)-x_tristim-yy(ii)
          x_tristim=x_tristim/100.
          y_tristim=y_tristim/100.
          z_tristim=z_tristim/100.
          if(x_tristim.lt.0.)x_tristim=0.
          if(x_tristim.gt.1.)x_tristim=1.
          if(y_tristim.lt.0.)y_tristim=0.
          if(y_tristim.gt.1.)y_tristim=1.
          if(z_tristim.lt.0.)z_tristim=0.
          if(z_tristim.gt.1.)z_tristim=1.

c         convert XYZ to sRGB normalized 0 to 1.
   	  bb(1,1) = x_tristim
 	  bb(1,2) = y_tristim
 	  bb(1,3) = z_tristim
          do i=1,3
            do j=1,3
              cc(j,i)=0.
              do k=1,3
                cc(j,i)=cc(j,i)+aa(k,i)*bb(j,k)
              enddo
            enddo
          enddo
          r=cc(1,1)
          g=cc(1,2)
          b=cc(1,3)
          if(r.lt.0.)r=0.
          if(r.gt.1.)r=1.
          if(g.lt.0.)g=0.
          if(g.gt.1.)g=1.
          if(b.lt.0.)b=0.
          if(b.gt.1.)b=1.

c         convert sRGB to spRGB
          if(r.le..00304)then
            r=12.92*r
          else
            r=1.055*r**(1./2.4) - .055
          endif
          if(g.le..00304)then
            g=12.92*g
          else
            g=1.055*g**(1./2.4) - .055
          endif
          if(b.le..00304)then
            b=12.92*b
          else
            b=1.055*b**(1./2.4) - .055
          endif
          red(ii)=nint(r*255.)
          green(ii)=nint(g*255.)
          blue(ii)=nint(b*255.)
          if(red(ii).lt.0)red(ii)=0
          if(red(ii).gt.255)red(ii)=255
          if(green(ii).lt.0)green(ii)=0
          if(green(ii).gt.255)green(ii)=255
          if(blue(ii).lt.0)blue(ii)=0
          if(blue(ii).gt.255)blue(ii)=255

          if(use_macbeth)then
            write(msg,*)kmac,x(ii),y(ii),yy(ii),
     +        red(ii),green(ii),blue(ii)
            call xvmessage(msg,' ')
          endif

        enddo                                  ! pixel loop
        call xvwrit(ounit(1),red,status,' ')
        call xvwrit(ounit(2),green,status,' ')
        call xvwrit(ounit(3),blue,status,' ')
      enddo                                    ! line loop

      RETURN
      END


!==========================================================================
elemental function gsw_alpha (sa, ct, p)
!==========================================================================
!
!  Calculates the thermal expansion coefficient of seawater with respect to
!  Conservative Temperature using the computationally-efficient expression
!  for specific volume in terms of SA, CT and p (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  alpha  =  thermal expansion coefficient                          [ 1/K ]
!            with respect to Conservative Temperature
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_specvol

use gsw_mod_teos10_constants, only : gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p

real (r8) :: gsw_alpha

real (r8) :: xs, ys, z, v_ct_part

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z = p*1e-4_r8

v_ct_part = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) &
         + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) &
         + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 &
         + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) &
         + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) &
         + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 &
         + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) &
         + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 &
         + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) &
         + z*(a003 + a103*xs + a013*ys + a004*z)))

gsw_alpha = 0.025_r8*v_ct_part/gsw_specvol(sa,ct,p)

return
end function

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


!
! sum program
!
! Example of a do directive
!
! 2007,2008
! Creation: A. Muller, 2007
! Modification: F. Silber-Chaussumier

      program sum
      implicit none
      integer N
      parameter (N=10)
      integer i,a(N,2),b(N),c(N)

      do 5 i=1,N
         a(i,1)=0
         a(i,2)=0
         b(i)=0
         c(i)=-1
 5    continue
!$omp PARALLEL DO
      do 10 i=1,N
         a(i,1)=i
         a(i,2)=2*i
         b(i)=i*10
         c(i)=0
 10   continue

!$omp PARALLEL DO
      do 20 i=2,N
         c(i)=a(i-1,1)+a(i,1)+b(i)
 20   continue

!$omp PARALLEL DO
      do 30 i=1,N/2
         b(i)=i
         b(N+1-i)=i
 30   continue

      print *,a
      print *,b
      print *,c
      end


! Program to test the WHERE constructs
program where_2
   integer temp(10), reduce(10)

   temp = 10
   reduce(1:3) = -1
   reduce(4:6) = 0
   reduce(7:8) = 5
   reduce(9:10) = 10

   WHERE (reduce < 0)
      temp = 100
   ELSE WHERE (reduce .EQ. 0)
      temp = 200 + temp
   ELSE WHERE
      WHERE (reduce > 6) temp = temp + sum(reduce)
      temp = 300 + temp
   END WHERE

   if (any (temp .ne. (/100, 100, 100, 210, 210, 210, 310, 310, 337, 337/))) &
      call abort
end program


      DOUBLE PRECISION FUNCTION DGAM1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 DGAM1 Krogh  Moved external statement up for mangle.
c>> 1994-10-20 DGAM1 Krogh  Changes to use M77CON
c>> 1994-05-18 DGAM1 WVS make DP and SP versions alike using CHGTYP
C>> 1993-08-04 DGAM1 CLL Add type stmt for DGAMMA.
C>> 1993-05-06 DGAM1 WVS JPL Convert from NSWC to Math 77
c--D replaces "?": ?GAM1, ?GAMMA
C ----------------------------------------------------------------------
C     EVALUATION OF 1/GAMMA(1 + X) - 1  FOR -0.5 .LE. X .LE. 1.5
C ----------------------------------------------------------------------
C
C     THE FOLLOWING ARE THE FIRST 49 COEFFICIENTS OF THE MACLAURIN
C     EXPANSION FOR 1/GAMMA(1 + X) - 1. THE COEFFICIENTS ARE
C     CORRECT TO 40 DIGITS. THE COEFFICIENTS WERE OBTAINED BY
C     ALFRED H. MORRIS JR. (NAVAL SURFACE WARFARE CENTER) AND ARE
C     GIVEN HERE FOR REFERENCE. ONLY THE FIRST 14 COEFFICIENTS ARE
C     USED IN THIS CODE.
C
C                           -----------
C
C     DATA A(1)  / .5772156649015328606065120900824024310422D+00/,
C    *     A(2)  /-.6558780715202538810770195151453904812798D+00/,
C    *     A(3)  /-.4200263503409523552900393487542981871139D-01/,
C    *     A(4)  / .1665386113822914895017007951021052357178D+00/,
C    *     A(5)  /-.4219773455554433674820830128918739130165D-01/,
C    *     A(6)  /-.9621971527876973562114921672348198975363D-02/,
C    *     A(7)  / .7218943246663099542395010340446572709905D-02/,
C    *     A(8)  /-.1165167591859065112113971084018388666809D-02/,
C    *     A(9)  /-.2152416741149509728157299630536478064782D-03/,
C    *     A(10) / .1280502823881161861531986263281643233949D-03/
C     DATA A(11) /-.2013485478078823865568939142102181838229D-04/,
C    *     A(12) /-.1250493482142670657345359473833092242323D-05/,
C    *     A(13) / .1133027231981695882374129620330744943324D-05/,
C    *     A(14) /-.2056338416977607103450154130020572836513D-06/,
C    *     A(15) / .6116095104481415817862498682855342867276D-08/,
C    *     A(16) / .5002007644469222930055665048059991303045D-08/,
C    *     A(17) /-.1181274570487020144588126565436505577739D-08/,
C    *     A(18) / .1043426711691100510491540332312250191401D-09/,
C    *     A(19) / .7782263439905071254049937311360777226068D-11/,
C    *     A(20) /-.3696805618642205708187815878085766236571D-11/
C     DATA A(21) / .5100370287454475979015481322863231802727D-12/,
C    *     A(22) /-.2058326053566506783222429544855237419746D-13/,
C    *     A(23) /-.5348122539423017982370017318727939948990D-14/,
C    *     A(24) / .1226778628238260790158893846622422428165D-14/,
C    *     A(25) /-.1181259301697458769513764586842297831212D-15/,
C    *     A(26) / .1186692254751600332579777242928674071088D-17/,
C    *     A(27) / .1412380655318031781555803947566709037086D-17/,
C    *     A(28) /-.2298745684435370206592478580633699260285D-18/,
C    *     A(29) / .1714406321927337433383963370267257066813D-19/,
C    *     A(30) / .1337351730493693114864781395122268022875D-21/
C     DATA A(31) /-.2054233551766672789325025351355733796682D-21/,
C    *     A(32) / .2736030048607999844831509904330982014865D-22/,
C    *     A(33) /-.1732356445910516639057428451564779799070D-23/,
C    *     A(34) /-.2360619024499287287343450735427531007926D-25/,
C    *     A(35) / .1864982941717294430718413161878666898946D-25/,
C    *     A(36) /-.2218095624207197204399716913626860379732D-26/,
C    *     A(37) / .1297781974947993668824414486330594165619D-27/,
C    *     A(38) / .1180697474966528406222745415509971518560D-29/,
C    *     A(39) /-.1124584349277088090293654674261439512119D-29/,
C    *     A(40) / .1277085175140866203990206677751124647749D-30/
C     DATA A(41) /-.7391451169615140823461289330108552823711D-32/,
C    *     A(42) / .1134750257554215760954165259469306393009D-34/,
C    *     A(43) / .4639134641058722029944804907952228463058D-34/,
C    *     A(44) /-.5347336818439198875077418196709893320905D-35/,
C    *     A(45) / .3207995923613352622861237279082794391090D-36/,
C    *     A(46) /-.4445829736550756882101590352124643637401D-38/,
C    *     A(47) /-.1311174518881988712901058494389922190237D-38/,
C    *     A(48) / .1647033352543813886818259327906394145400D-39/,
C    *     A(49) /-.1056233178503581218600561071538285049997D-40/
C
C                           -----------
C
C     C = A(1) - 1 IS ALSO FREQUENTLY NEEDED. C HAS THE VALUE ...
C
C     DATA C /-.4227843350984671393934879099175975689578D+00/
C
C ----------------------------------------------------------------------
      EXTERNAL D1MACH, DGAMMA
      DOUBLE PRECISION D1MACH, DGAMMA
      DOUBLE PRECISION D, ROUND, T, W, X, XMAX, Z
      SAVE ROUND, XMAX
      DOUBLE PRECISION A0, A1, B1, B2, B3, B4, B5, B6, B7, B8
      DOUBLE PRECISION C, C0, C1, C2, C3, C4, C5, C6, C7, C8, C9,
     *                 C10, C11, C12, C13
      DOUBLE PRECISION F0, F1, F2, F3, F4, F5, F6, G1, G2, G3, G4
      DOUBLE PRECISION P1, P2, P3, P4, P5, P6, P7
      DOUBLE PRECISION Q2, Q3, Q4, Q5
      DOUBLE PRECISION R1, R2, R3, R4, R5, R6, R7, R8, R9
      DOUBLE PRECISION S1, S2
C ---------------------------
      DATA XMAX /-1.0D0/
C ---------------------------
      DATA A0 / .611609510448141581788D-08/,
     *     A1 / .624730830116465516210D-08/
      DATA B1 / .203610414066806987300D+00/,
     *     B2 / .266205348428949217746D-01/,
     *     B3 / .493944979382446875238D-03/,
     *     B4 /-.851419432440314906588D-05/,
     *     B5 /-.643045481779353022248D-05/,
     *     B6 / .992641840672773722196D-06/,
     *     B7 /-.607761895722825260739D-07/,
     *     B8 / .195755836614639731882D-09/
C ---------------------------
      DATA F0 /.6116095104481415817861D-08/,
     *     F1 /.6871674113067198736152D-08/,
     *     F2 /.6820161668496170657918D-09/,
     *     F3 /.4686843322948848031080D-10/,
     *     F4 /.1572833027710446286995D-11/,
     *     F5/-.1249441572276366213222D-12/,
     *     F6 /.4343529937408594255178D-14/
      DATA G1 /.3056961078365221025009D+00/,
     *     G2 /.5464213086042296536016D-01/,
     *     G3 /.4956830093825887312020D-02/,
     *     G4 /.2692369466186361192876D-03/
C ---------------------------
C     C = C0 - 1
C ---------------------------
      DATA C /-.422784335098467139393487909917598D+00/
C ---------------------------
      DATA C0  / .577215664901532860606512090082402D+00/,
     *     C1  /-.655878071520253881077019515145390D+00/,
     *     C2  /-.420026350340952355290039348754298D-01/,
     *     C3  / .166538611382291489501700795102105D+00/,
     *     C4  /-.421977345555443367482083012891874D-01/,
     *     C5  /-.962197152787697356211492167234820D-02/,
     *     C6  / .721894324666309954239501034044657D-02/,
     *     C7  /-.116516759185906511211397108401839D-02/,
     *     C8  /-.215241674114950972815729963053648D-03/,
     *     C9  / .128050282388116186153198626328164D-03/
      DATA C10 /-.201348547807882386556893914210218D-04/,
     *     C11 /-.125049348214267065734535947383309D-05/,
     *     C12 / .113302723198169588237412962033074D-05/,
     *     C13 /-.205633841697760710345015413002057D-06/
C --------------------------
      DATA P1/ .577215664901533D+00/, P2/-.409078193005776D+00/,
     *     P3/-.230975380857675D+00/, P4/ .597275330452234D-01/,
     *     P5/ .766968181649490D-02/, P6/-.514889771323592D-02/,
     *     P7/ .589597428611429D-03/
C --------------------------
      DATA Q2/ .427569613095214D+00/,
     *     Q3/ .158451672430138D+00/, Q4/ .261132021441447D-01/,
     *     Q5/ .423244297896961D-02/
C --------------------------
      DATA R1/-.422784335098468D+00/, R2/-.771330383816272D+00/,
     *     R3/-.244757765222226D+00/, R4/ .118378989872749D+00/,
     *     R5/ .930357293360349D-03/, R6/-.118290993445146D-01/,
     *     R7/ .223047661158249D-02/, R8/ .266505979058923D-03/,
     *     R9/-.132674909766242D-03/
C --------------------------
      DATA S1/ .273076135303957D+00/, S2/ .559398236957378D-01/
C ---------------------------
      IF (XMAX .LT. 0.0D0) THEN
         ROUND = D1MACH(4)
         XMAX = 1.0D0 / ROUND
      END IF
      T = X
      D = X - 0.5D0
      IF (D .GT. 0.D0) T = D - 0.5D0
      IF (ROUND .LT. 1.0D-14) THEN
C
C        CASE WHEN PRECISION IS GREATER THAN 14 DIGITS:
C
         IF (T) 30,10,20
C
   10    DGAM1 = 0.D0
         RETURN
C -----------
C
C                CASE WHEN 0 .LT. T .LE. 0.5
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C -----------
   20    IF (T .GT. 0.5) THEN
            IF (X .GT. XMAX) THEN
               DGAM1 = -1.0D0
               RETURN
            END IF
            DGAM1 = 1.0D0 / DGAMMA(1.0D0 + X) - 1.0D0
            RETURN
         END IF
         W = ((((((F6*T + F5)*T + F4)*T + F3)*T + F2)*T + F1)*T + F0)/
     *         ((((G4*T + G3)*T + G2)*T + G1)*T + 1.D0)
         Z = (((((((((((((W*T + C13)*T + C12)*T + C11)*T + C10)*T +
     *            C9)*T + C8)*T + C7)*T + C6)*T + C5)*T + C4)*T +
     *            C3)*T + C2)*T + C1)*T + C0
C
         IF (D .LE. 0.D0) THEN
            DGAM1 = X*Z
            RETURN
         END IF
         DGAM1 = (T/X)*((Z - 0.5D0) - 0.5D0)
         RETURN
C -----------
C
C                CASE WHEN -0.5 .LE. T .LT. 0
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C -----------
   30    IF (T .LT. -0.5) THEN
            IF (X .GT. XMAX) THEN
               DGAM1 = -1.0D0
               RETURN
            END IF
            DGAM1 = 1.0D0 / DGAMMA(1.0D0 + X) - 1.0D0
            RETURN
         END IF
         W = (A1*T + A0)/((((((((B8*T + B7)*T + B6)*T + B5)*T +
     *          B4)*T + B3)*T + B2)*T + B1)*T + 1.D0)
         Z = (((((((((((((W*T + C13)*T + C12)*T + C11)*T + C10)*T +
     *            C9)*T + C8)*T + C7)*T + C6)*T + C5)*T + C4)*T +
     *            C3)*T + C2)*T + C1)*T + C
C
         IF (D .LE. 0.D0) THEN
            DGAM1 = X*((Z + 0.5D0) + 0.5D0)
            RETURN
         END IF
         DGAM1 = T*Z/X
         RETURN
      ELSE
C
C        CASE WHEN PRECISION IS LESS THAN 14 DIGITS
C
         IF (T) 300,100,200
C
  100    DGAM1 = 0.0
         RETURN
C -----------
C
C                CASE WHEN 0 .LT. T .LE. 0.5
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C -----------
  200    IF (T .GT. 0.5D0) THEN
            IF (X .GT. XMAX) THEN
               DGAM1 = -1.0D0
               RETURN
            END IF
            DGAM1 = 1.0D0 / DGAMMA(1.0D0 + X) - 1.0D0
            RETURN
         END IF
         Z = ((((((P7*T + P6)*T + P5)*T + P4)*T + P3)*T + P2)*T + P1) /
     *       ((((Q5*T + Q4)*T + Q3)*T + Q2)*T + 1.0)
         IF (D .LE. 0.0) THEN
            DGAM1 = X*Z
            RETURN
         END IF
         DGAM1 = (T/X)*((Z - 0.5) - 0.5)
         RETURN
C
C -----------
C
C                CASE WHEN -0.5 .LE. T .LT. 0
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C -----------
  300    IF (T .LT. -0.5D0) THEN
            IF (X .GT. XMAX) THEN
               DGAM1 = -1.0D0
               RETURN
            END IF
            DGAM1 = 1.0D0 / DGAMMA(1.0D0 + X) - 1.0D0
            RETURN
         END IF
         Z = ((((((((R9*T + R8)*T + R7)*T + R6)*T + R5)*T
     *                       + R4)*T + R3)*T + R2)*T + R1) /
     *       ((S2*T + S1)*T + 1.0)
         IF (D .LE. 0.0) THEN
            DGAM1 = X*((Z + 0.5) + 0.5)
            RETURN
         END IF
         DGAM1 = T*Z/X
         RETURN
      END IF
      END


	SUBROUTINE initialdata(Nx,Ny,Nz,x,y,z,u,uold,decomp)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine gets initial data for nonlinear Klein-Gordon equation
	! in 3 dimensions
	! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*u^3+
	!
	! The boundary conditions are u(x=-Lx*\pi,y,z)=u(x=Lx*\pi,y,z),
	!	u(x,y=-Ly*\pi,z)=u(x,y=Ly*\pi,z),u(x,y,z=-Ly*\pi)=u(x,y,z=Ly*\pi)
	! The initial condition is u=0.5*exp(-x^2-y^2-z^2)*sin(10*x+12*y)
	!
	! INPUT
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	! .. Vectors ..
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!					see http://www.2decomp.org/ for more information
	! OUTPUT
	!
	! .. Arrays ..
	!  u 				= initial solution
	!  uold 			= approximate solution based on time derivative of
	!					initial solution
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library
	USE decomp_2d
	IMPLICIT NONE
	INCLUDE 'mpif.h'
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)							:: Nx,Ny,Nz
	TYPE(DECOMP_INFO), INTENT(IN)						::  decomp
	REAL(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1)), INTENT(IN) :: x
	REAL(KIND=8), DIMENSION(decomp%xst(2):decomp%xen(2)), INTENT(IN) :: y
	REAL(KIND=8), DIMENSION(decomp%xst(3):decomp%xen(3)), INTENT(IN) :: z
	COMPLEX(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1),&
   							decomp%xst(2):decomp%xen(2),&
   							decomp%xst(3):decomp%xen(3)),&
   											INTENT(OUT) :: u,uold
	INTEGER(kind=4)										:: i,j,k

	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				u(i,j,k)=0.5d0*exp(-1.0d0*(x(i)**2 +y(j)**2+z(k)**2))!*&
					!sin(10.0d0*x(i)+12.0d0*y(j))
			END DO
		END DO
	END DO
	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				uold(i,j,k)=0.5d0*exp(-1.0d0*(x(i)**2 +y(j)**2+z(k)**2))!*&
					!sin(10.0d0*x(i)+12.0d0*y(j))
				END DO
		END DO
	END DO

	END SUBROUTINE initialdata


!================================================================================
!
! Modules:
!
! (1) blas_m      Originally By DAS      Last Modified 1/13/2011 (das)
!
!     Interfaces for BLAS functions, taken from http://www.netlib.org/blas/
!     Every BLAS function used in the code should be listed here, and this
!     module should be used in every routine containing BLAS calls to ensure
!     the argument types are correct.
!
!     Note that if any array name from netlib.org is X, the interface will
!     be interpreted as a preprocessor macro and cause a compilation failure,
!     solved by changed to lower-case x.
!
!================================================================================

#include "f_defs.h"

module blas_m

  public ! only interfaces in this module

  interface
    SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
      implicit none
      DOUBLE PRECISION ALPHA,BETA
      INTEGER K,LDA,LDB,LDC,M,N
      CHARACTER TRANSA,TRANSB
      DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
    end subroutine DGEMM
  end interface

  interface
    SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
      implicit none
      DOUBLE COMPLEX ALPHA,BETA
      INTEGER K,LDA,LDB,LDC,M,N
      CHARACTER TRANSA,TRANSB
      DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
    end subroutine ZGEMM
  end interface

  interface
    SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,x,INCX,BETA,Y,INCY)
      implicit none
      DOUBLE PRECISION ALPHA,BETA
      INTEGER INCX,INCY,LDA,M,N
      CHARACTER TRANS
      DOUBLE PRECISION A(LDA,*),x(*),Y(*)
    end SUBROUTINE DGEMV
  end interface

  interface
    SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,x,INCX,BETA,Y,INCY)
      implicit none
      DOUBLE COMPLEX ALPHA,BETA
      INTEGER INCX,INCY,LDA,M,N
      CHARACTER TRANS
      DOUBLE COMPLEX A(LDA,*),x(*),Y(*)
    end SUBROUTINE ZGEMV
  end interface

  interface
    SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,x,INCX,BETA,Y,INCY)
      implicit none
      DOUBLE COMPLEX ALPHA,BETA
      INTEGER INCX,INCY,LDA,N
      CHARACTER UPLO
      DOUBLE COMPLEX A(LDA,*),x(*),Y(*)
    end SUBROUTINE ZHEMV
  end interface

  interface
    SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,x,INCX,BETA,Y,INCY)
      implicit none
      DOUBLE COMPLEX ALPHA,BETA
      INTEGER INCX,INCY,N
      CHARACTER UPLO
      DOUBLE COMPLEX AP(*),x(*),Y(*)
    end SUBROUTINE ZHPMV
  end interface

  interface
    SUBROUTINE ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
      implicit none
      DOUBLE COMPLEX ALPHA,BETA
      INTEGER LDA,LDB,LDC,M,N
      CHARACTER SIDE,UPLO
      DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
    end SUBROUTINE ZHEMM
  end interface

  interface blas_dot
    DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
      implicit none
      INTEGER INCX,INCY,N
      DOUBLE PRECISION DX(*),DY(*)
    end FUNCTION DDOT

    DOUBLE COMPLEX FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY)
      implicit none
      INTEGER INCX,INCY,N
      DOUBLE COMPLEX ZX(*),ZY(*)
    end FUNCTION ZDOTC
  end interface blas_dot

  interface blas_zdotu
    DOUBLE COMPLEX FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY)
      implicit none
      INTEGER INCX,INCY,N
      DOUBLE COMPLEX ZX(*),ZY(*)
    end FUNCTION ZDOTU
  end interface blas_zdotu

  interface
    SUBROUTINE DSCAL(N,DA,DX,INCX)
      implicit none
      DOUBLE PRECISION DA
      INTEGER INCX,N
      DOUBLE PRECISION DX(*)
    end SUBROUTINE DSCAL
  end interface

  interface
    SUBROUTINE ZSCAL(N,ZA,ZX,INCX)
      implicit none
      DOUBLE COMPLEX ZA
      INTEGER INCX,N
      DOUBLE COMPLEX ZX(*)
    end SUBROUTINE ZSCAL
  end interface

  interface blas_nrm2
    DOUBLE PRECISION FUNCTION DNRM2(N,x,INCX)
      implicit none
      INTEGER INCX,N
      DOUBLE PRECISION x(*)
    end FUNCTION DNRM2

    DOUBLE PRECISION FUNCTION DZNRM2(N,x,INCX)
      implicit none
      INTEGER INCX,N
      DOUBLE COMPLEX x(*)
    end FUNCTION DZNRM2
  end interface

end module blas_m


      REAL             FUNCTION STZT02( M, N, AF, LDA, TAU, WORK,
     $                 LWORK )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      REAL               AF( LDA, * ), TAU( * ), WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  STZT02 returns
*       || I - Q'*Q || / ( M * eps)
*  where the matrix Q is defined by the Householder transformations
*  generated by STZRQF.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix AF.
*
*  N       (input) INTEGER
*          The number of columns of the matrix AF.
*
*  AF      (input) REAL array, dimension (LDA,N)
*          The output of STZRQF.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array AF.
*
*  TAU     (input) REAL array, dimension (M)
*          Details of the Householder transformations as returned by
*          STZRQF.
*
*  WORK    (workspace) REAL array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          length of WORK array. Must be >= N*N+N
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
*     ..
*     .. Local Arrays ..
      REAL               RWORK( 1 )
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLANGE
      EXTERNAL           SLAMCH, SLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLATZM, SLASET, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, REAL
*     ..
*     .. Executable Statements ..
*
      STZT02 = ZERO
*
      IF( LWORK.LT.N*N+N ) THEN
         CALL XERBLA( 'STZT02', 7 )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
*     Q := I
*
      CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, N )
*
*     Q := P(1) * ... * P(m) * Q
*
      DO 10 I = M, 1, -1
         CALL SLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
     $                WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
   10 CONTINUE
*
*     Q := P(m) * ... * P(1) * Q
*
      DO 20 I = 1, M
         CALL SLATZM( 'Left', N-M+1, N, AF( I, M+1 ), LDA, TAU( I ),
     $                WORK( I ), WORK( M+1 ), N, WORK( N*N+1 ) )
   20 CONTINUE
*
*     Q := Q - I
*
      DO 30 I = 1, N
         WORK( ( I-1 )*N+I ) = WORK( ( I-1 )*N+I ) - ONE
   30 CONTINUE
*
      STZT02 = SLANGE( 'One-norm', N, N, WORK, N, RWORK ) /
     $         ( SLAMCH( 'Epsilon' )*REAL( MAX( M, N ) ) )
      RETURN
*
*     End of STZT02
*
      END


! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
! { dg-do run }
program test
  implicit none
  real, volatile, allocatable :: A(:)
  logical, volatile :: mask(11)

  A = [1,2,3,5,6,1,35,3,7,-3,-47]
  mask = .true.
  mask(7) = .false.
  mask(11) = .false.
  call sub2 (minloc(A),11)
  call sub2 (maxloc(A, mask=mask),9)
  A = minloc(A)
  if (size (A) /= 1 .or. A(1) /= 11) STOP 1
contains
  subroutine sub2(A,n)
    integer :: A(:),n
    if (A(1) /= n .or. size (A) /= 1) STOP 2
  end subroutine sub2
end program test


program black_hole_s_curve
  use mod_constants
  use mod_read_parameters
  use mod_s_curve

  implicit none

  real(x_precision), dimension(n_cell) :: temperature_c
  real(x_precision), dimension(n_cell) :: sigma_c

  call get_parameters()
  call make_temperature()
  call set_conditions()

  call curve(temperature_c, sigma_c)

end program black_hole_s_curve