MODULE A

  USE precise, ONLY : defaultp
  USE io
  USE fourthconst
  USE fifthpanel

!! variable declarations

  IMPLICIT NONE    ! makes sure the compiler complains about
                   ! undeclared variables
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp

CONTAINS

  FUNCTION panelinfluence( fieldpoint, center, area, coordsys, cornerslocal) RESULT (vel)
    !
    ! Function to compute the del dot phi
    ! It will return a 3D velocity vector
    ! Equivlent to the far approximation
    ! of the velocity induced by a panel
    ! source q on a point p.
    INTEGER :: i,j,k
    REAL(wp), DIMENSION(3) :: vel
    REAL(wp), DIMENSION(3) :: dphi           ! Page 3 of the notes
    REAL(wp), DIMENSION(3,3) :: ddphi
    REAL(wp), DIMENSION(3) :: fieldpoint
    REAL(wp), DIMENSION(3) :: center
    REAL(wp) :: area
    REAL(wp), DIMENSION(3,3) :: coordsys     ! local coordinate system
    REAL(wp), DIMENSION(2,4) :: cornerslocal ! quad corners in local coordinate system
    REAL(wp), DIMENSION(3) :: plocal         ! fieldpoint "p" in local coordinate system
    REAL(wp), DIMENSION(3) :: vellocal

    REAL(wp), DIMENSION(4) :: d,e,h,m,r

    integer, dimension(4) :: ip1 = (/ 2, 3, 4, 1 /)
    plocal = MATMUL((TRANSPOSE(coordsys)),fieldpoint-center)

    !write(6,*) 'center', center
    !write(6,*) 'plocal', plocal

    dphi(1)=0.
    dphi(2)=0.
    dphi(3)=0.

    Do, k=1,4

       !write(6,*)'cornerslocal', cornerslocal(:,k)
       d(k) = sqrt((cornerslocal(1,ip1(k))-cornerslocal(1,k))**2.+(cornerslocal(2,ip1(k))-cornerslocal(2,k))**2.)
       e(k) = (plocal(1)-cornerslocal(1,k))**2. + plocal(3)**2.
       h(k) = ((plocal(1)-cornerslocal(1,k))*(plocal(2)-cornerslocal(2,k)))
       m(k) = (((cornerslocal(2,ip1(k)))-(cornerslocal(2,k))) /(cornerslocal(1,ip1(k))-(cornerslocal(1,k))))
       r(k) = sqrt(((plocal(1))-(cornerslocal(1,k)))**2.+((plocal(2))-(cornerslocal(2,k)))**2.+(plocal(3))**2.)

       !write(6,*) 'd(k)', d(k)
       !write(6,*) 'e(k)', e(k)
       !write(6,*) 'h(k)', h(k)
       !write(6,*) 'm(k)', m(k)
       !write(6,*) 'r(k)', r(k)

     end do

     do, k=1,4

       If (abs(d(k))> 0.000001) then

          dphi(1) = dphi(1)+((((cornerslocal(2,ip1(k)))-(cornerslocal(2,k)))/d(k))*log((r(k)+r(ip1(k))-d(k))/(r(k)+r(ip1(k))+d(k))))

          dphi(2) = dphi(2)-(cornerslocal(1,ip1(k))-(cornerslocal(1,k)))/d(k)*log((r(k)+r(ip1(k))-d(k))/(r(k)+r(ip1(k))+d(k)))

          dphi(3) = dphi(3)+(atan((m(k)*e(k)-h(k))/(plocal(3)*r(k)))- atan((m(k)*e(ip1(k))-h(ip1(k)))/(plocal(3)*r(ip1(k)))))

          !!
          !! NOW TEST THE SECOND DERIVATIVES ( these will be needed for phase III )
          ddphi(1,1) =ddphi(1,1) + (2.*(cornerslocal(2,ip1(k)) - cornerslocal(2,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2) *&
               ((plocal(1)-cornerslocal(1,k))/r(k)+(plocal(1)-cornerslocal(1,ip1(k)))/r(ip1(K)) ))

          ddphi(1,2) =ddphi(1,2)+ (-2.*(cornerslocal(1,ip1(k)) - cornerslocal(1,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2) *&
               ((plocal(1)-cornerslocal(1,k))/r(k)+(plocal(1)-cornerslocal(1,ip1(k)))/r(ip1(K)) ))

          ddphi(1,3) =ddphi(1,3)+( plocal(3) * (cornerslocal(2,ip1(k)) - cornerslocal(2,k)) * (r(k) - r(ip1(k)))  /&
               ((r(k)*r(ip1(k)))* ( r(k)*r(ip1(k)) + ((plocal(1)-cornerslocal(1,k))*(plocal(1)*cornerslocal(1,ip1(K)))) &
               +((plocal(2)-cornerslocal(2,k))*(plocal(2)-cornerslocal(2,ip1(k))))  + (plocal(3)**2)    )))

          ddphi(2,1) = ddphi(2,1)+(2.*(cornerslocal(2,ip1(k)) - cornerslocal(2,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2) *&
               ((plocal(2)-cornerslocal(2,k))/r(k)+(plocal(2)-cornerslocal(2,ip1(k)))/r(ip1(K)) ))

          ddphi(2,2) =ddphi(2,2)+(-2.*(cornerslocal(1,ip1(k)) - cornerslocal(1,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2) *&
               ((plocal(2)-cornerslocal(2,k))/r(k)+(plocal(2)-cornerslocal(2,ip1(k)))/r(ip1(K)) ))

          ddphi(2,3) =ddphi(2,3)+(-plocal(3) * (cornerslocal(1,ip1(k)) - cornerslocal(1,k)) * (r(k) - r(ip1(k)))  /&
               ((r(k)*r(ip1(k)))* ( r(k)*r(ip1(k)) + ((plocal(1)-cornerslocal(1,k))*(plocal(1)*cornerslocal(1,ip1(K)))) &
               +((plocal(2)-cornerslocal(2,k))*(plocal(2)-cornerslocal(2,ip1(k))))  + (plocal(3)**2)    )))

          ddphi(3,1) =ddphi(3,1)+( 2.*(cornerslocal(2,ip1(k)) - cornerslocal(2,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2) *&
               (   plocal(3)/r(k) + plocal(3)/r(ip1(k))  ))

          ddphi(3,2) =ddphi(3,2)+(-2.*(cornerslocal(1,ip1(k)) - cornerslocal(1,k))/( (r(k)+r(ip1(K)))**2 - d(k)**2) *&
               (   plocal(3)/r(k) + plocal(3)/r(ip1(k))  ))

          ddphi(3,3) =ddphi(3,3)+((((plocal(1)-cornerslocal(1,k))*(plocal(2)-cornerslocal(2,ip1(k)))) &
               - ((plocal(1)-cornerslocal(1,ip1(k)))*(plocal(2)-cornerslocal(2,k))))*(r(k)-r(ip1(k)))/&
               ((r(k)*r(ip1(k)))*   (  r(k)*r(ip1(k))  +((plocal(1)-cornerslocal(1,k))*(plocal(1)*cornerslocal(1,ip1(K)))) &
               +(plocal(2)-cornerslocal(2,k))*(plocal(2)-cornerslocal(2,ip1(k)))  + (plocal(3)**2)    )))

       End if

    End do

    ddphi = -1./(4.*pi) * ddphi

    dphi(1)=-1./(4.*pi)*dphi(1)
    dphi(2)=-1./(4.*pi)*dphi(2)
    dphi(3)=-1./(4.*pi)*dphi(3)

    !write(6,*) 'dphi(1)', dphi(1)
    !write(6,*) 'dphi(2)', dphi(2)
    !write(6,*) 'dphi(3)', dphi(3)
!!$    write(6,*) 'ddphi(1,2)', ddphi(1,2)
!!$    write(6,*) 'ddphi(2,1)', ddphi(2,1)
!!$    write(6,*) ''
!!$    write(6,*) 'ddphi(1,3)', ddphi(1,3)
!!$    write(6,*) 'ddphi(3,1)', ddphi(3,1)
!!$    write(6,*) ''
!!$    write(6,*) 'ddphi(2,3)', ddphi(2,3)
!!$    write(6,*) 'ddphi(3,2)', ddphi(3,2)

    vellocal=(/ dphi(1),dphi(2),dphi(3) /)
    !write(6,*) 'vellocal'
    !write(6,'(3D16.8)')  vellocal

     vel=MATMUL(coordsys,vellocal)
     !if ( (sum(vel(:)**2)) > 9999.) then
     !   vel = (/0.,0.,0./)
     !end if

     !write(6,*) 'vel'
     !write (6,'(3D16.8)') vel
     !write(6,*) ''

   END FUNCTION panelinfluence

END MODULE A


MODULE dynldf_lap_blp
   !!======================================================================
   !!                   ***  MODULE  dynldf_lap_blp  ***
   !! Ocean dynamics:  lateral viscosity trend (laplacian and bilaplacian)
   !!======================================================================
   !! History : 3.7  ! 2014-01  (G. Madec, S. Masson)  Original code, re-entrant laplacian
   !!----------------------------------------------------------------------

   !!----------------------------------------------------------------------
   !!   dyn_ldf_lap   : update the momentum trend with the lateral viscosity using an iso-level   laplacian operator
   !!   dyn_ldf_blp   : update the momentum trend with the lateral viscosity using an iso-level bilaplacian operator
   !!----------------------------------------------------------------------
   USE oce            ! ocean dynamics and tracers
   USE dom_oce        ! ocean space and time domain
   USE ldfdyn         ! lateral diffusion: eddy viscosity coef.
   USE ldfslp         ! iso-neutral slopes
   USE zdf_oce        ! ocean vertical physics
   !
   USE in_out_manager ! I/O manager
   USE lbclnk         ! ocean lateral boundary conditions (or mpp link)

   IMPLICIT NONE
   PRIVATE

   PUBLIC dyn_ldf_lap  ! called by dynldf.F90
   PUBLIC dyn_ldf_blp  ! called by dynldf.F90

   !! * Substitutions
   !!----------------------------------------------------------------------
   !!                   ***  vectopt_loop_substitute  ***
   !!----------------------------------------------------------------------
   !! ** purpose :   substitute the inner loop start/end indices with CPP macro
   !!                allow unrolling of do-loop (useful with vector processors)
   !!----------------------------------------------------------------------
   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: vectopt_loop_substitute.h90 10068 2018-08-28 14:09:04Z nicolasmartin $
   !! Software governed by the CeCILL license (see ./LICENSE)
   !!----------------------------------------------------------------------
   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: dynldf_lap_blp.F90 10068 2018-08-28 14:09:04Z nicolasmartin $
   !! Software governed by the CeCILL license (see ./LICENSE)
   !!----------------------------------------------------------------------
CONTAINS

   SUBROUTINE dyn_ldf_lap( kt, pub, pvb, pua, pva, kpass )
      !!----------------------------------------------------------------------
      !!                     ***  ROUTINE dyn_ldf_lap  ***
      !!
      !! ** Purpose :   Compute the before horizontal momentum diffusive
      !!      trend and add it to the general trend of momentum equation.
      !!
      !! ** Method  :   The Laplacian operator apply on horizontal velocity is
      !!      writen as :   grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) )
      !!
      !! ** Action : - pua, pva increased by the harmonic operator applied on pub, pvb.
      !!----------------------------------------------------------------------
      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index
      INTEGER                         , INTENT(in   ) ::   kpass      ! =1/2 first or second passage
      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pub, pvb   ! before velocity  [m/s]
      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva   ! velocity trend   [m/s2]
      !
      INTEGER  ::   ji, jj, jk   ! dummy loop indices
      REAL(wp) ::   zsign        ! local scalars
      REAL(wp) ::   zua, zva     ! local scalars
      REAL(wp), DIMENSION(jpi,jpj) ::   zcur, zdiv
      !!----------------------------------------------------------------------
      !
      IF( kt == nit000 .AND. lwp ) THEN
         WRITE(numout,*)
         WRITE(numout,*) 'dyn_ldf : iso-level harmonic (laplacian) operator, pass=', kpass
         WRITE(numout,*) '~~~~~~~ '
      ENDIF
      !
      IF( kpass == 1 ) THEN   ;   zsign =  1._wp      ! bilaplacian operator require a minus sign
      ELSE                    ;   zsign = -1._wp      !  (eddy viscosity coef. >0)
      ENDIF
      !
      !                                                ! ===============
      DO jk = 1, jpkm1                                 ! Horizontal slab
         !                                             ! ===============
         DO jj = 2, jpj
            DO ji = 2, jpi   ! vector opt.
               !                                      ! ahm * e3 * curl  (computed from 1 to jpim1/jpjm1)
!!gm open question here : e3f  at before or now ?    probably now...
!!gm note that ahmf has already been multiplied by fmask
               zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f_n(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)       &
                  &     * (  e2v(ji  ,jj-1) * pvb(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pvb(ji-1,jj-1,jk)  &
                  &        - e1u(ji-1,jj  ) * pub(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pub(ji-1,jj-1,jk)  )
               !                                      ! ahm * div        (computed from 2 to jpi/jpj)
!!gm note that ahmt has already been multiplied by tmask
               zdiv(ji,jj)     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t_b(ji,jj,jk)                                         &
                  &     * (  e2u(ji,jj)*e3u_b(ji,jj,jk) * pub(ji,jj,jk) - e2u(ji-1,jj)*e3u_b(ji-1,jj,jk) * pub(ji-1,jj,jk)  &
                  &        + e1v(ji,jj)*e3v_b(ji,jj,jk) * pvb(ji,jj,jk) - e1v(ji,jj-1)*e3v_b(ji,jj-1,jk) * pvb(ji,jj-1,jk)  )
            END DO
         END DO
         !
         DO jj = 2, jpjm1                             ! - curl( curl) + grad( div )
            DO ji = 2, jpim1   ! vector opt.
               pua(ji,jj,jk) = pua(ji,jj,jk) + zsign * (                                                 &
                  &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u_n(ji,jj,jk)   &
                  &              + ( zdiv(ji+1,jj) - zdiv(ji,jj  ) ) * r1_e1u(ji,jj)                     )
                  !
               pva(ji,jj,jk) = pva(ji,jj,jk) + zsign * (                                                 &
                  &                ( zcur(ji,jj  ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk)   &
                  &              + ( zdiv(ji,jj+1) - zdiv(ji  ,jj) ) * r1_e2v(ji,jj)                     )
            END DO
         END DO
         !                                             ! ===============
      END DO                                           !   End of slab
      !                                                ! ===============
      !
   END SUBROUTINE dyn_ldf_lap

   SUBROUTINE dyn_ldf_blp( kt, pub, pvb, pua, pva )
      !!----------------------------------------------------------------------
      !!                 ***  ROUTINE dyn_ldf_blp  ***
      !!
      !! ** Purpose :   Compute the before lateral momentum viscous trend
      !!              and add it to the general trend of momentum equation.
      !!
      !! ** Method  :   The lateral viscous trends is provided by a bilaplacian
      !!      operator applied to before field (forward in time).
      !!      It is computed by two successive calls to dyn_ldf_lap routine
      !!
      !! ** Action :   pta   updated with the before rotated bilaplacian diffusion
      !!----------------------------------------------------------------------
      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index
      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pub, pvb   ! before velocity fields
      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva   ! momentum trend
      !
      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zulap, zvlap   ! laplacian at u- and v-point
      !!----------------------------------------------------------------------
      !
      IF( kt == nit000 )  THEN
         IF(lwp) WRITE(numout,*)
         IF(lwp) WRITE(numout,*) 'dyn_ldf_blp : bilaplacian operator momentum '
         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~'
      ENDIF
      !
      zulap(:,:,:) = 0._wp
      zvlap(:,:,:) = 0._wp
      !
      CALL dyn_ldf_lap( kt, pub, pvb, zulap, zvlap, 1 )   ! rotated laplacian applied to ptb (output in zlap)
      !
      CALL lbc_lnk_multi( zulap, 'U', -1., zvlap, 'V', -1. )             ! Lateral boundary conditions
      !
      CALL dyn_ldf_lap( kt, zulap, zvlap, pua, pva, 2 )   ! rotated laplacian applied to zlap (output in pta)
      !
   END SUBROUTINE dyn_ldf_blp

   !!======================================================================
END MODULE dynldf_lap_blp


Module structure_function_selector
	Use hs_structure
	Use hssw_structure
	Use hsay_structure
	Use hd_structure
	Use quadratures
	Implicit None
	contains

	!This functions serves the purpose of selecting a structural function
	!with a system potential, an approximation and parameters:
	!"F" options:
	!		"c" = Direct correlation function
	!		"is" = Inverse of the Structure Factor
	!		"s" = Structure Factor
	!"potential" options:
	!		"HS" = Hard Sphere
	!								"Approx" options for Hard Sphere:
	!									"PY" = Percus-Yevick
	! "fp" are the floating point parameters
	! "ip" are the integer point parameters
	!	"qp" is the quadrature array
	! "qw" is the weight array
	!needed by the function and are grouped inside a
	!vector, look inside the function for the potential and approximation
	!parameters needed and their organization
	Function	structure(F,potential,Approx,fp,ip,qp,qw) result(FR)
		Implicit None
		character(len=2), intent(in) :: F
		character(len=4), intent(in) :: potential,Approx	!Cases selectors
		real * 8, dimension(:), intent(in) :: fp	!Function real parameters
		real * 8, dimension(:), intent(inout), optional :: qp, qw !Quadrature arrays for points and weights
		integer, dimension(:), intent(inout), optional :: ip !Integer parameters
		real * 8 :: FR	!Function Result
		real * 8 :: phi, k, T, lambda, z, rmin, rmax
		integer :: qnp,selector1
		real * 8, dimension(2) :: CCfp
		integer, dimension(1) :: CCip
		!Potentials:
		select case(potential)
		!Hard Sphere:
		case("HS00")
			!Parameters:
			!volume fraction "phi" -> params(1)
			!wave vector "k" -> params(2)
			phi = fp(1)
			k = fp(2)
			!Approximations:
			select case(Approx)
			!Percus-Yevick
			case("PY00")
				!Functions:
				select case(F)
				case("c0")
					FR = c_hs_py(phi,k)
				case("is")
					FR = is_hs_py(phi,k)
				case("s0")
					FR = s_hs_py(phi,k)
				end select
			case("VW00")
				!Functions:
				select case(F)
				case("c0")
					FR = c_hs_vw(phi,k)
				case("is")
					FR = is_hs_vw(phi,k)
				case("s0")
					FR = s_hs_vw(phi,k)
				end select
			end select
		!Hard Disk:
		case("HD00")
			!Parameters:
			!volume fraction "phi" -> params(1)
			!wave vector "k" -> params(2)
			phi = fp(1)
			k = fp(2)
			!Approximations:
			select case(Approx)
			!Rosenfeld FMT
			case("ROSF")
				!Functions:
				select case(F)
				case("c0")
					FR = ck_HD_ros(phi,k)
				case("is")
					FR = isk_HD_ros(phi,k)
				case("s0")
					FR = sk_HD_ros(phi,k)
				end select
			!Modified Baus-Colot by Guo and Riebel
			case("BCGR")
				!Functions:
				select case(F)
				case("c0")
					FR = ck_HD_BCGR(phi,k)
				case("is")
					FR = isk_HD_BCGR(phi,k)
				case("s0")
					FR = sk_HD_BCGR(phi,k)
				end select
		end select
		!Hard Sphere + Square Well
		case("HSSW")
			!Parameters:
			!volume fraction "phi" -> params(1)
			!temperature "T" -> params(2)
			!square well length "lambda" -> params(3)
			!wave vector "k" -> params(4)
			phi = fp(1)
			T = fp(2)
			lambda = fp(3)
			k = fp(4)
			!Approximations:
			select case(Approx)
			!Sharma-Sharma with Verlet Weiss
			case("SHVW")
				!Functions:
				select case(F)
				case("c0")
					FR = c_hssw_shvw(phi,T,lambda,k)
				case("is")
					FR = is_hssw_shvw(phi,T,lambda,k)
				case("s0")
					FR = s_hssw_shvw(phi,T,lambda,k)
				end select
				!Generalized Sharma-Sharma with Verlet Weiss
			case("GSVW")
				!Functions:
				select case(F)
				case("c0")
					FR = c_hssw_gsvw(phi,T,lambda,k)
				case("is")
					FR = is_hssw_gsvw(phi,T,lambda,k)
				case("s0")
					FR = s_hssw_gsvw(phi,T,lambda,k)
				end select
			case("BOLT")
				!Functions:
				select case(F)
				case("s0")
					FR = s_hssw_bolt(phi,T,lambda,k)
				end select
			case("STOS")
				!Functions:
				select case(F)
				case("s0")
					FR = s_hssw_stos(phi,T,lambda,k)
				end select
			end select
		!Hard Sphere + Attractive Yukawa
		case("HSAY")
			!Parameters:
			!volume fraction "phi" -> params(1)
			!temperature "T" -> params(2)
			!Yukawa potential length parameter "z" -> params(3)
			!wave vector "k" -> params(4)
			phi = fp(1)
			T = fp(2)
			z = fp(3)
			k = fp(4)
			!Approximations:
			select case(Approx)
			!Sharma-Sharma with Verlet Weiss
			case("SHVW")
				!Functions:
				select case(F)
				case("c0")
					FR = c_hsay_shvw(phi,T,z,k)
				case("is")
					FR = is_hsay_shvw(phi,T,z,k)
				case("s0")
					FR = s_hsay_shvw(phi,T,z,k)
				end select
			!Generalized Sharma-Sharma with Verlet Weiss
			case("GSVW")
				!Parameters
				!Number of points -> ip(1)
				!Selector to compute Clenshaw Curtis quadrature -> ip(2) (0 for calculation)
				CCfp(1) = fp(5)
				CCfp(2) = fp(6)
				CCip(1) = ip(1)
				selector1 = ip(2)
				If (selector1 == 0) Then
					!Call quad_select("CLCU",CCip,CCfp,qp,qw)
					ip(2) = 1
				End If

				select case(F)
				case("c0")
					FR = c_hsay_gsvw(phi,T,z,k,qp,qw)
				case("is")
					FR = is_hsay_gsvw(phi,T,z,k,qp,qw)
				case("s0")
					FR = s_hsay_gsvw(phi,T,z,k,qp,qw)
				end select
			end select
		end select
		return
	End Function
End Module


      subroutine gen3m_rap(r,p,m3,m4,wt,*)
      implicit none

      include 'constants.f'
      include 'mxdim.f'
      include 'x1x2.f'
c---- generate phase space for 2-->3 process
c---- with 3 and 4 (masses m3,m4) and 5 massless.
c---- r(mxdim) and
c---- p1(4),p2(4) are input momenta reversed in sign from physical values
c---- phase space for -p1-p2 --> p3+p4+p5
c---- with all 2 pi)
      double precision r(mxdim),y5starmin,y5starmax,plstar,plstarsq,
     . Estar,p(mxpart,4),a,E34st,
     . wt,p3(4),p4(4),p5(4),p345(4),p34(4),pstsq,
     . xmin,pt5,ymin,ymax,phi,wt34,
     . dely,sinhy,coshy,y,rtshat,pt2,
     . vs,vsqmax,vsqmin,s34,sinhy5,coshy5,y5,y5max,s34max,s34min,
     . m3,m4,xjac,w,wmax,wmin
c      double precision p3cm(4),beta,costh,sinth
      integer j,nu
      include 'energy.f'
      wt=0d0

C---set all vectors to zero
      do nu=1,4
      p345(nu)=0d0
      do j=1,mxpart
          p(j,nu)=0d0
      enddo
      enddo

      xjac=0.5d0/((twopi)**3*sqrts**2)

C--- generate PT5
      wmin=dlog(1d-5)
      wmax=dlog((sqrts-m3-m4)/2d0)
      w=wmin+(wmax-wmin)*r(1)
      pt5=exp(w)
      pt2=pt5*pt5
C express in terms of dptsq
      xjac=xjac*pt5**2*(wmax-wmin)
C--generate rapidity
c--- rapidity limited by sqrts=2*pT*coshy
      a=sqrts/(pt5+dsqrt(pt2+(m3+m4)**2))
      y5max=dlog(a+dsqrt(a**2-1d0))
      y5=y5max*(2d0*r(2)-1d0)
      sinhy5=dsinh(y5)
      coshy5=dsqrt(1d0+sinhy5**2)
      xjac=xjac*2d0*y5max

C--generate phi
      phi=twopi*r(3)
      xjac=xjac*twopi

C in lab frame
      p5(4)=pt5*coshy5
      p5(1)=pt5*dcos(phi)
      p5(2)=pt5*dsin(phi)
      p5(3)=pt5*sinhy5

C  s34=(p_1+p_2-p_5)^2
      s34max=sqrts**2-2d0*sqrts*pt5
      s34min=(m3+m4)**2
      vsqmax=1d0/s34min
      vsqmin=1d0/s34max
      if (vsqmin .gt. vsqmax) then
        write(6,*) 'gen3m:vsqmin',vsqmin
        write(6,*) 'gen3m:vsqmax',vsqmax
      return 1
      endif
      xmin=vsqmin/vsqmax
      vs=(vsqmax-vsqmin)*r(4)+vsqmin
      s34=1/vs
      xjac=xjac*(vsqmax-vsqmin)*s34**2

c--- invariant mass of jets

C plstar is longitudinal momentum of p5 (and -p34) in 34-5 centre of mass
C plstar is obtained by solving s=(p5+p34)^2
      plstarsq=((sqrts**2-s34)**2-4d0*pt2*sqrts**2)/(4d0*sqrts**2)
      if (plstarsq .le. 0d0) then
      write(6,*) 'gen3m:plstarsq,s34,pt2',plstarsq,s34,pt2
      return 1
      endif

      plstar=dsqrt(plstarsq)
      Estar=dsqrt(plstarsq+pt2)
      y5starmax=dlog((Estar+plstar)/pt5)

      y5starmin=-y5starmax
      ymax=y5-y5starmin
      ymin=y5-y5starmax
      dely=ymax-ymin
      y=ymin+r(5)*dely
      sinhy=dsinh(y)
      coshy=dsqrt(1d0+sinhy**2)
      xjac=xjac*dely
c--- now calculate in the centre of mass
      pstsq=pt2+(p5(3)*coshy-p5(4)*sinhy)**2
      E34st=dsqrt(s34+pstsq)

      rtshat=E34st+dsqrt(pstsq)

c--- back in lab frame
      p345(4)=rtshat*coshy
      p345(3)=rtshat*sinhy

      do j=1,4
        p34(j)=p345(j)-p5(j)
      enddo

      xx(1)=(p345(4)+p345(3))/sqrts
      xx(2)=(p345(4)-p345(3))/sqrts

c      if   (xx(1)*xx(2) .gt. 1d0) then
c      write(6,*) 'gen3m:xx1*xx2,xx(1),xx(2)',xx(1)*xx(2),xx(1),xx(2)
c      endif

      if   ((xx(1) .gt. 1d0) .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin).or. (xx(2) .lt. xmin)) return 1

      xjac=rtshat/E34st*xjac

c--- now make the initial state momenta

      p(1,4)=-xx(1)*sqrts/2d0
      p(1,3)=p(1,4)

      p(2,4)=-xx(2)*sqrts/2d0
      p(2,3)=-p(2,4)

c--- decay s34 lump into two particles with mass m3 and m4
      call phi3m(r(6),r(7),p34,p3,p4,m3,m4,wt34,*99)

c      costh=2d0*r(6)-1d0
c      sinth=dsqrt(1d0-costh**2)
c      phi=2d0*pi*r(7)
c      beta=dsqrt(1d0-(m3+m4)**2/s34)
c      xjac=4d0*pi*xjac/8d0

c      p3cm(4)=dsqrt(s34+m3**2-m4**2)/2d0
c      p3cm(1)=p3cm(4)*beta*sinth*dcos(phi)
c      p3cm(2)=p3cm(4)*beta*sinth*dsin(phi)
c      p3cm(3)=p3cm(4)*beta*costh

c--- boost into lab frame
c      call boost(dsqrt(s34),p34,p3cm,p3)

      do j=1,4
      p(3,j)=p3(j)
      p(4,j)=p4(j)
      p(5,j)=p5(j)
      enddo

      wt=xjac*wt34
      return
 99   continue
      wt=0d0
      return 1
      end


module parameters_site

implicit none

!%%%%% Settings for Saerheim 2000

! Simulation period and time step
  real, parameter       :: DELT   =   1.0 ! Model time step

! Geography
  real                  :: LAT            ! Latitude in degrees north

! Atmospheric conditions
  real, parameter       :: CO2A   = 350   ! CO2 concentration in atmosphere (ppm)

! Soil
  real, parameter       :: DRATE  =  50   ! mm d-1 Maximum soil drainage rate
  real                  :: WCI
  real                  :: FWCAD, FWCWP, FWCFC, FWCWET, WCST, BD
  real                  ::  WCAD,  WCWP,  WCFC,  WCWET

! Soil - WINTER PARAMETERS
  real                  :: FGAS, FO2MX, KTSNOW, KRTOTAER, KSNOW ! Simon renamed gamma as KTSNOW
  real, parameter       :: LAMBDAice      = 1.9354e+005  ! J m-1 K-1 d-1 Thermal conductivity of ice
  real                  :: LAMBDAsoil
  real, parameter       :: LatentHeat     = 335000.      ! J kg-1 Latent heat of water fusion
  real, parameter       :: poolInfilLimit =      0.2     ! m Soil frost depth limit for water infiltration
  real                  :: RHOnewSnow, RHOpack
  real, parameter       :: RHOwater       =   1000.      ! kg m-3	Density of water
  real                  :: SWret, SWrf, TmeltFreeze, TrainSnow
  real                  :: WpoolMax

! Soil initial values
  real, parameter       :: DRYSTORI = 0.
  real, parameter       :: FdepthI  = 0.
  real, parameter       :: SDEPTHI  = 0.
  real, parameter       :: TANAERI  = 0.
  real, parameter       :: WAPLI    = 0.
  real, parameter       :: WAPSI    = 0.
  real, parameter       :: WASI     = 0.
  real, parameter       :: WETSTORI = 0.

! Management: harvest dates and irrigation
  integer, dimension(3) :: doyHA
  real, parameter       :: IRRIGF = 0.                   ! Relative irrigation rate (not currently used)

! Mathematical constants
  real, parameter       :: pi   = 3.141592653589793
  real, parameter       :: Freq = 2.*pi / 365.
  real, parameter       :: Kmin = 4.           ! mm C-1 d-1 in SnowMeltWmaxStore()
  real, parameter       :: Ampl = 0.625        ! mm C-1 d-1 Intra-annual amplitude snow melt at 1 degree > 'TmeltFreeze' in SnowMeltWmaxStore()
  real, parameter       :: Bias = Kmin + Ampl  ! mm C-1 d-1 Average snow melting rate at 1 degree above 'TmeltFreeze' in SnowMeltWmaxStore()

end module parameters_site


! difference operator, cell to node
module diff_cn_op
implicit none
contains

subroutine diff_cn(df, f, i, a, i1, i2, x, dx)
real, intent(out) :: df(:,:,:)
real, intent(in) :: f(:,:,:,:), x(:,:,:,:), dx(3)
integer, intent(in) :: i, a, i1(3), i2(3)
real :: h, b
integer :: j, k, l, b, c

if (any(i1 > i2)) return

h = sign(1.0 / 12.0, product(dx))
b = modulo(a, 3) + 1
c = modulo(a + 1, 3) + 1
!$omp parallel do schedule(static) private(j, k, l)
do l = i1(3), i2(3)
do k = i1(2), i2(2)
do j = i1(1), i2(1)
df(j,k,l) = h * f(j-1,k-1,l-1,i) * &
( (x(j-1,k,l,b) - x(j,k-1,l-1,b)) * (x(j,k,l-1,c) - x(j,k-1,l,c)) + x(j-1,k,l,b) * (x(j-1,k,l-1,c) - x(j-1,k-1,l,c)) &
+ (x(j,k-1,l,b) - x(j-1,k,l-1,b)) * (x(j-1,k,l,c) - x(j,k,l-1,c)) + x(j,k-1,l,b) * (x(j-1,k-1,l,c) - x(j,k-1,l-1,c)) &
+ (x(j,k,l-1,b) - x(j-1,k-1,l,b)) * (x(j,k-1,l,c) - x(j-1,k,l,c)) + x(j,k,l-1,b) * (x(j,k-1,l-1,c) - x(j-1,k,l-1,c)) )
end do
do j = i1(1), i2(1)
df(j,k,l) = df(j,k,l) + h  * f(j,k-1,l-1,i) * &
( (x(j+1,k,l,b) - x(j,k-1,l-1,b)) * (x(j,k-1,l,c) - x(j,k,l-1,c)) + x(j+1,k,l,b) * (x(j+1,k-1,l,c) - x(j+1,k,l-1,c)) &
+ (x(j,k-1,l,b) - x(j+1,k,l-1,b)) * (x(j,k,l-1,c) - x(j+1,k,l,c)) + x(j,k-1,l,b) * (x(j,k-1,l-1,c) - x(j+1,k-1,l,c)) &
+ (x(j,k,l-1,b) - x(j+1,k-1,l,b)) * (x(j+1,k,l,c) - x(j,k-1,l,c)) + x(j,k,l-1,b) * (x(j+1,k,l-1,c) - x(j,k-1,l-1,c)) )
end do
do j = i1(1), i2(1)
df(j,k,l) = df(j,k,l) + h * f(j-1,k-1,l,i) * &
( (x(j,k,l+1,b) - x(j-1,k-1,l,b)) * (x(j-1,k,l,c) - x(j,k-1,l,c)) + x(j,k,l+1,b) * (x(j-1,k,l+1,c) - x(j,k-1,l+1,c)) &
+ (x(j-1,k,l,b) - x(j,k-1,l+1,b)) * (x(j,k-1,l,c) - x(j,k,l+1,c)) + x(j-1,k,l,b) * (x(j-1,k-1,l,c) - x(j-1,k,l+1,c)) &
+ (x(j,k-1,l,b) - x(j-1,k,l+1,b)) * (x(j,k,l+1,c) - x(j-1,k,l,c)) + x(j,k-1,l,b) * (x(j,k-1,l+1,c) - x(j-1,k-1,l,c)) )
end do
do j = i1(1), i2(1)
df(j,k,l) = df(j,k,l) + h * f(j,k-1,l,i) * &
( (x(j,k-1,l,b) - x(j+1,k,l+1,b)) * (x(j+1,k,l,c) - x(j,k,l+1,c)) + x(j,k-1,l,b) * (x(j+1,k-1,l,c) - x(j,k-1,l+1,c)) &
+ (x(j,k,l+1,b) - x(j+1,k-1,l,b)) * (x(j,k-1,l,c) - x(j+1,k,l,c)) + x(j,k,l+1,b) * (x(j,k-1,l+1,c) - x(j+1,k,l+1,c)) &
+ (x(j+1,k,l,b) - x(j,k-1,l+1,b)) * (x(j,k,l+1,c) - x(j,k-1,l,c)) + x(j+1,k,l,b) * (x(j+1,k,l+1,c) - x(j+1,k-1,l,c)) )
end do
do j = i1(1), i2(1)
df(j,k,l) = df(j,k,l) + h * f(j-1,k,l-1,i) * &
( (x(j,k+1,l,b) - x(j-1,k,l-1,b)) * (x(j,k,l-1,c) - x(j-1,k,l,c)) + x(j,k+1,l,b) * (x(j,k+1,l-1,c) - x(j-1,k+1,l,c)) &
+ (x(j,k,l-1,b) - x(j-1,k+1,l,b)) * (x(j-1,k,l,c) - x(j,k+1,l,c)) + x(j,k,l-1,b) * (x(j-1,k,l-1,c) - x(j,k+1,l-1,c)) &
+ (x(j-1,k,l,b) - x(j,k+1,l-1,b)) * (x(j,k+1,l,c) - x(j,k,l-1,c)) + x(j-1,k,l,b) * (x(j-1,k+1,l,c) - x(j-1,k,l-1,c)) )
end do
do j = i1(1), i2(1)
df(j,k,l) = df(j,k,l) + h * f(j,k,l-1,i) * &
( (x(j,k,l-1,b) - x(j+1,k+1,l,b)) * (x(j,k+1,l,c) - x(j+1,k,l,c)) + x(j,k,l-1,b) * (x(j,k+1,l-1,c) - x(j+1,k,l-1,c)) &
+ (x(j+1,k,l,b) - x(j,k+1,l-1,b)) * (x(j,k,l-1,c) - x(j,k+1,l,c)) + x(j+1,k,l,b) * (x(j+1,k,l-1,c) - x(j+1,k+1,l,c)) &
+ (x(j,k+1,l,b) - x(j+1,k,l-1,b)) * (x(j+1,k,l,c) - x(j,k,l-1,c)) + x(j,k+1,l,b) * (x(j+1,k+1,l,c) - x(j,k+1,l-1,c)) )
end do
do j = i1(1), i2(1)
df(j,k,l) = df(j,k,l) + h * f(j-1,k,l,i) * &
( (x(j-1,k,l,b) - x(j,k+1,l+1,b)) * (x(j,k,l+1,c) - x(j,k+1,l,c)) + x(j-1,k,l,b) * (x(j-1,k,l+1,c) - x(j-1,k+1,l,c)) &
+ (x(j,k+1,l,b) - x(j-1,k,l+1,b)) * (x(j-1,k,l,c) - x(j,k,l+1,c)) + x(j,k+1,l,b) * (x(j-1,k+1,l,c) - x(j,k+1,l+1,c)) &
+ (x(j,k,l+1,b) - x(j-1,k+1,l,b)) * (x(j,k+1,l,c) - x(j-1,k,l,c)) + x(j,k,l+1,b) * (x(j,k+1,l+1,c) - x(j-1,k,l+1,c)) )
end do
do j = i1(1), i2(1)
df(j,k,l) = df(j,k,l) + h * f(j,k,l,i) * &
( (x(j+1,k,l,b) - x(j,k+1,l+1,b)) * (x(j,k+1,l,c) - x(j,k,l+1,c)) + x(j+1,k,l,b) * (x(j+1,k+1,l,c) - x(j+1,k,l+1,c)) &
+ (x(j,k+1,l,b) - x(j+1,k,l+1,b)) * (x(j,k,l+1,c) - x(j+1,k,l,c)) + x(j,k+1,l,b) * (x(j,k+1,l+1,c) - x(j+1,k+1,l,c)) &
+ (x(j,k,l+1,b) - x(j+1,k+1,l,b)) * (x(j+1,k,l,c) - x(j,k+1,l,c)) + x(j,k,l+1,b) * (x(j+1,k,l+1,c) - x(j,k+1,l+1,c)) )
end do
end do
end do
!$omp end parallel do

end subroutine

end module


!=========================================================================!
!                                                                         !
!                                                                         !
!          Rosenbrock Modul for integrating one time step                 !
!                                                                         !
!                                                                         !
!=========================================================================!

MODULE Rosenbrock_Mod
  !
  USE Kind_Mod
  USE Sparse_Mod
  USE Chemsys_Mod
  USE Rates_Mod
  USE Control_Mod
  USE Reac_Mod
  USE ChemKinInput_Mod
  IMPLICIT NONE
  !
  !
  ! Rosenbrock-Parameter
  TYPE RosenbrockMethod_T
    INTEGER :: Order                                ! Classical approximation order of the method
    INTEGER :: nStage                               ! Number of stages
    INTEGER :: pinterp                              ! Interpolation order
    REAL(dp) :: ga                            ! Diagonalentry gamma
    REAL(dp) :: pow                           ! needed for sitepsize control pow=1/nstage
    REAL(dp), ALLOCATABLE :: Asum(:)          ! Row sum of A
    REAL(dp), ALLOCATABLE :: Alpha(:,:)       ! Propagation table, strictly lower triangular
    REAL(dp), ALLOCATABLE :: a(:,:)           ! Propagation table, strictly lower triangular (converted Alpha)
    REAL(dp), ALLOCATABLE :: Gamma(:,:)       ! Stage table, lower triangular with nonzero diagonal
    REAL(dp), ALLOCATABLE :: iGamma(:,:)      ! inverse Stage table
    REAL(dp), ALLOCATABLE :: C(:,:)           ! Stage table, lower triangular with nonzero diagonal (converted Gamma)
    REAL(dp), ALLOCATABLE :: B(:)             ! Step completion table
    REAL(dp), ALLOCATABLE :: m(:)             ! Step completion table(converted B)
    REAL(dp), ALLOCATABLE :: Be(:)            ! Step completion table for embedded method of order one less
    REAL(dp), ALLOCATABLE :: me(:)            ! Step completion table for embedded method of order one less (converted Be)
    REAL(dp), ALLOCATABLE :: binterpt(:,:)    ! Dense output formula
  END TYPE RosenbrockMethod_T

  TYPE(RosenbrockMethod_T) :: ROS

  REAL(dp), PRIVATE :: timerStart
  REAL(dp), ALLOCATABLE :: LUvalsFix(:)

  INTEGER, ALLOCATABLE :: LU_Perm(:)

  CONTAINS
  !
  !
  !=======================================================
  !       chose one of the methods in ~/METHODS/
  !=======================================================
  SUBROUTINE SetRosenbrockMethod(RCo,method)
    !-------------------------------------------------------------
    ! Input: method ... string with Rosenbrock method path
    TYPE(RosenbrockMethod_T), INTENT(OUT) :: RCo
    CHARACTER(*) :: method
    !-------------------------------------------------------------
    ! Output:
    !   - RosenbrockMethod_T ... coefficients of the chosen one
    !-------------------------------------------------------------
    ! Temporary variables:
    REAL(dp), ALLOCATABLE :: ID(:,:)
    INTEGER, ALLOCATABLE :: IPIV(:)
    INTEGER :: INFO

    CHARACTER(20) :: tmethod
    !
    INTEGER :: i
    !
    IF ( TRIM(method(1:7)) == 'bwEuler') THEN
      INCLUDE 'METHODS/bwEuler.ros'
    ELSE
      tmethod = ADJUSTL(method(INDEX(method,'/')+1:INDEX(method,'.')-1))
      SELECT CASE (tmethod)
        CASE ('Ros2AMF')
          INCLUDE 'METHODS/Ros2AMF.ros'
        CASE ('Ros3w')
          INCLUDE 'METHODS/Ros3w.ros'
        CASE ('Ros3Dw')
          INCLUDE 'METHODS/Ros3Dw.ros'
        CASE ('Ros3Pw')
          INCLUDE 'METHODS/Ros3Pw.ros'
        CASE ('Ros34PW1a')
          INCLUDE 'METHODS/Ros34PW1a.ros'
        CASE ('Ros34PW2')
          INCLUDE 'METHODS/Ros34PW2.ros'
        CASE ('Ros34PW3')
          INCLUDE 'METHODS/Ros34PW3.ros'
        CASE ('Rodas3')
          !INCLUDE 'METHODS/TSRosWRodas3.ros'
          INCLUDE 'METHODS/Rodas3.ros'
        CASE ('TSRosW2P')
          INCLUDE 'METHODS/TSRosW2P.ros'
        CASE ('TSRosW2M')
          INCLUDE 'METHODS/TSRosW2M.ros'
        CASE ('TSRosWRA34PW2')
          INCLUDE 'METHODS/TSRosWRA34PW2.ros'
        CASE ('TSRosWSandu3')
          INCLUDE 'METHODS/TSRosWSandu3.ros'
        CASE DEFAULT
          IF (MPI_master) THEN
            WRITE(*,*) '    Unknown Method:  ',method
            WRITE(*,*) '    Use Rodas3 instead.'
          END IF
          INCLUDE 'METHODS/Rodas3.ros'
      END SELECT
    END IF
    !INCLUDE RosenbrockMethod
    !
    ! converting the butcher tableau
    ! automatic transformation to avoid mat*vec in ROW methode
    ALLOCATE(ID(ROS%nStage,ROS%nStage) , ROS%iGamma(ROS%nStage,ROS%nStage))
    ROS%pow    = ONE / (ROS%Order+ONE)
    ROS%iGamma = ZERO
    ID         = ZERO
    DO i=1,ROS%nStage
      ROS%iGamma(i,i) = ONE
      ID(i,i) = ONE
    END DO

    ALLOCATE(RCo%Asum(RCo%nStage))
    DO i=1,RCo%nStage
      RCo%Asum(i) = SUM(RCo%Alpha(i,:))
    END DO

    ! calculate the inverse matrix of gamma
    !
    ! CAUTION ROS%Gamma (IN) =/= ROS%Gamma (OUT) !!!
    !
    ALLOCATE(IPIV(ROS%nStage))
    CALL dgesv(  ROS%nStage,     &        ! # linear eqations
    &            ROS%nStage,     &        ! # RHS (coloums)
    &            ROS%Gamma,      &        ! Matrix A of A*A^(-1)=ID
    &            ROS%nStage,     &        ! leading dimension of A (nStage)
    &            IPIV,           &        ! pivot indices of dimension nStage
    &            ROS%iGamma,     &        ! Matrix ID of A*A^(-1)=ID
    &            ROS%nStage,     &        ! leading dimension of RHS
    &            INFO)                    ! INFO (integer) if INFO=0 succsessfull
    !
    IF ( INFO/= 0 .AND. MPI_master ) WRITE(*,*) 'Error while calc row-method parameter'
    !
    ALLOCATE(ROS%a(ROS%nStage,ROS%nStage))
    ROS%a = ZERO
    ROS%a = ROS%ga*MATMUL(ROS%Alpha, ROS%iGamma)
    !
    ALLOCATE(ROS%C(ROS%nStage,ROS%nStage))
    ROS%C = ZERO
    ROS%C = ID - ROS%ga * ROS%iGamma
    FORALL (i=1:ROS%nStage) ROS%C(i,i)=ZERO
    !
    ALLOCATE(ROS%m(ROS%nStage))
    ROS%B = MATMUL(ROS%B, ROS%iGamma)
    ROS%m = ROS%ga * ROS%B
    !
    IF (.NOT.ROS%nStage==1) THEN
      ALLOCATE(ROS%me(ROS%nStage))
      ROS%Be = MATMUL(ROS%Be,ROS%iGamma)
      ROS%me = ROS%ga * ROS%Be(:)
    END IF
    !
    DEALLOCATE(ID)
    DEALLOCATE(IPIV)
  END SUBROUTINE SetRosenbrockMethod
  !
  !
  !==========================================================
  !   Calculates an initial stepsize based on 2. deriv.
  !==========================================================
  FUNCTION InitialStepSize(Jac,Rate,t,Y_in,pow) RESULT(h)
    !-------------------------------------------------
    ! Input:
    !        - public variables
    !        - Tspan
    !        - Y0  ( initial vector )
    !        - Jacobian matrix
    TYPE(CSR_Matrix_T), INTENT(IN) :: Jac
    REAL(dp), INTENT(IN) :: t, pow
    REAL(dp), INTENT(IN) :: Y_in(:)
    REAL(dP), INTENT(INOUT) :: Rate(:)
    !REAL(dp) :: DRatedT(nr)     ! part. derv. rate over temperatur vector
    !-------------------------------------------------
    ! Output:
    !        - initial step size
    REAL(dp) :: h
    !-------------------------------------------------
    !
    ! Temp vars:
    REAL(dp) :: tdel, rh, absh
    REAL(dp), DIMENSION(nDIM) :: Y
    REAL(dp), DIMENSION(nspc) :: wt, DfDt, Tmp, f0, f1, zeros, Emiss
    REAL(dp), DIMENSION(nr)   :: dRdT
    REAL(dp), ALLOCATABLE     :: thresh(:)
    ! DEBUG
    INTEGER :: i

    zeros = ZERO

    Y = Y_in

    ! hmin is a small number such that t + hmin is clearlY different from t in
    ! the working precision, but with this definition, it is 0 if t = 0.

    !---- Compute an initial step size h using Yp=Y'(t)
    CALL UpdateEmission(Emiss,t)
    f0 = BAT * Rate + Emiss

    ALLOCATE( thresh(nDIM) )
    IF ( Teq ) THEN
      thresh(iGs)  = AtolGas / RTolROW
      thresh(nDIM) = AtolTemp / RTolROW
    ELSE
      IF ( hasGasSpc  ) thresh(iGs) = AtolGas / RTolROW
      IF ( hasAquaSpc ) thresh(iAs) = AtolAqua / RTolROW
    END IF

    wt   = MAX( ABS(Y(1:nspc)) , thresh(1:nspc) )
    rh   = ( 1.25_dp * MAXVAL(ABS(f0/wt)) )/(RTolRow**pow)
    absh = MIN( maxStp , Tspan(2)-Tspan(1) )
    IF ( absh * rh > ONE )  absh = ONE / rh

    !---- Compute Y''(t) and a better initial step size
    h = absh
    tdel  = t + MIN( SQRT(eps) * MAX( ABS(t) , ABS(t+h) ) , absh )

    IF (Teq) THEN
      CALL ReactionRates( t+tdel , Y , Rate , dRdT )
    ELSE
      CALL ReactionRates( t+tdel , Y , Rate)
    END IF
    Out%nRateEvals = Out%nRateEvals + 1

    CALL UpdateEmission(Emiss,tdel)
    f1   = BAT * Rate + Emiss
    DfDt = ( f1 - f0 ) / tdel

    tmp  = Jac * f0
    DfDt = DfDt + Tmp

    rh   = 1.25_dp * SQRT( rTWO * MAXVAL( ABS(DfDt/wt) ) ) / RTolRow**pow

    absh = MIN( maxStp , Tspan(2)-Tspan(1) )
    IF ( absh*rh > ONE )  absh = ONE/rh
    h = MAX( absh , minStp )

  END FUNCTION InitialStepSize
  !
  !
  !=========================================================================
  !    Subroutine Rosenbrock-Method universal for classic and extended case
  !=========================================================================
  SUBROUTINE Rosenbrock(YNew,err,ierr,Y0,t,h,Euler)
    USE ISSA_mod
    USE IO_Mod
    !--------------------------------------------------------
    ! Input:
    !   - Y0............. concentrations at Time = t
    !   - t.............. time
    !   - h.............. step size
    !   - RCo............ Rosenbrock method
    !   - Temp........... Temperatur at Time = t (optional for Teq)
    !   - Euler.......... if .true. --> use backward Euler method
    !
    REAL(dp),          INTENT(IN) :: Y0(nDIM)
    REAL(dp),          INTENT(IN) :: t, h
    !TYPE(RosenbrockMethod_T)      :: RCo
    LOGICAL, OPTIONAL, INTENT(IN) :: Euler
    !--------------------------------------------------------
    ! Output:
    !   - Ynew........... new concentratinos
    !   - err............ error calc with embedded formula.
    !   - TempNew........ new temperature (optional for Teq)
    !
    REAL(dp), INTENT(OUT) :: YNew(nDIM)
    REAL(dp), INTENT(OUT) :: err
    INTEGER , INTENT(OUT) :: ierr(1,1)
    !-------------------------------------------------------
    ! TemporarY variables:
    !
    REAL(dp), DIMENSION(nDIM)   :: Y,  Yhat, fRhs
    REAL(dp), DIMENSION(nspc)   :: Yrh, U, UMat, dUdT, dCdt, d2UdT2, Emiss
    REAL(dp), DIMENSION(nspc)   :: Jac_CT, Jac_TC
    REAL(dp), DIMENSION(nDIMex) :: bb
    !
    REAL(dp) :: k( nDIM , ROS%nStage )
    !
    REAL(dp) :: Tarr(10)
    REAL(dp) :: Rate(neq), rRate(neq), Rate_t(neq)
    REAL(dp) :: DRatedT(neq)
    REAL(dp) :: dTdt, Jac_TT

    REAL(dp) :: tt
    REAL(dp) :: cv ! mass average mixture specific heat at constant volume
    REAL(dp) :: dcvdT ! mass average mixture specific heat at constant volume
    REAL(dp) :: X
    REAL(dp) :: Press

    REAL(dp) :: TimeRhsCalc0
    !
    ! fuer verlgeich mit speedchem, andere spc reihenfolge
    !
    INTEGER :: iStg, jStg, i, j          ! increments
    LOGICAL :: dprint=.false.

    REAL(dp) :: CM(nDIM)

    dprint = DebugPrint   !init run

    ! Initial settings
    k       = ZERO
    fRhs    = ZERO
    Rate    = ZERO
    rRate   = ZERO
    bb      = ZERO
    Y       = Y0
    Emiss   = ZERO

    !********************************************************************************
    !    _   _             _         _          __  __         _          _
    !   | | | | _ __    __| |  __ _ | |_  ___  |  \/  |  __ _ | |_  _ __ (_)__ __
    !   | | | || '_ \  / _` | / _` || __|/ _ \ | |\/| | / _` || __|| '__|| |\ \/ /
    !   | |_| || |_) || (_| || (_| || |_|  __/ | |  | || (_| || |_ | |   | | >  <
    !    \___/ | .__/  \__,_| \__,_| \__|\___| |_|  |_| \__,_| \__||_|   |_|/_/\_\
    !          |_|
    !
    !********************************************************************************

    ! HIER UNBEDINGT RATE MIT Y0 ALS INPUT
    IF ( Teq ) THEN
      Yrh = Y0(1:nspc) / h
      CALL ReactionRates( t, Y0, Rate, DRatedT )
    ELSE
      Y   = MAX( ABS(Y0)  , eps ) * SIGN( ONE , Y0 )  ! concentrations =/= 0
      Yrh = Y(1:nspc) / h
      CALL ReactionRates( t, Y, Rate )
      Rate  = MAX( ABS(Rate) , eps ) * SIGN( ONE , Rate )    ! |r| >= eps
      rRate = ONE / Rate
    END IF
    Rate_t = Rate

    CALL UpdateEmission(Emiss,t)

    IF ( Teq ) THEN
      Tarr = UpdateTempArray   ( Y0(nDIM) )
      CALL InternalEnergy      ( U       , Tarr)
      CALL DiffInternalEnergy  ( dUdT    , Tarr)
      CALL Diff2InternalEnergy ( d2UdT2  , Tarr)
      CALL MassAveMixSpecHeat  ( cv      , dUdT    , MoleConc=Y0(1:nspc) , rho=rho)
      CALL MassAveMixSpecHeat  ( dcvdT   , d2UdT2  , MoleConc=Y0(1:nspc) , rho=rho)

      dCdT = BAT * Rate + Emiss

      dTdt    = - SUM(U * dCdt) * rRho/cv
      UMat    = ROS%ga*dcvdT*dTdt*Y0(1:nspc) + U*Yrh
      dRatedT = ROS%ga*dRatedT
      X       = cv/(h*rRho) + ROS%ga/cv*dcvdT*dTdt + ROS%ga*SUM(dUdT*dCdt)
      !
      !
      IF (dprint) THEN
        WRITE(*,*) '------------------------------------------------------------------------------'
        WRITE(*,*) '|    Combustion                                                              |'
        WRITE(*,*) '------------------------------------------------------------------------------'
        WRITE(*,'(A,E23.16,A)') 'debug     Temperature =  ',Tarr(1)   ,'   [K]'
        WRITE(*,'(A,E23.16,A)') 'debug     c_v         =  ',cv        ,'   [J/kg/K]'
        WRITE(*,'(A,E23.16,A,E23.16,A)') 'debug     Density     =  ',rho       ,'   [kg/m3]',rRho       ,'   [kg/m3]'
        WRITE(*,'(A,E23.16,A)') 'debug     SUM(U)      =  ',SUM(U)    ,'   [J/mol/K]'
        WRITE(*,'(A,E23.16,A)') 'debug     X in Matrix =  ',X         ,'   [???]'
        WRITE(*,'(A,E23.16,A)') 'debug     SUM(dCdt)   =  ',SUM(dCdt) ,'   [mol/cm3/sec]'
        WRITE(*,'(A,E23.16,A)') 'debug     dTdt        =  ',dTdt      ,'   [K/sec]'
        WRITE(*,*) '------------------------------------------------------------------------------'
        WRITE(*,*) ''
        do i=1,nspc
          WRITE(*,'(A,I5,A,E22.14,A3,A)') 'debug     dCdt(',i,') = ',dCdt(SCperm(i)),'   ',y_name(SCperm(i))
        end do
        WRITE(*,'(A,E22.14,A3,A)') 'debug      dTdt(last) = ',dTdt,'   ','Temperature'
        WRITE(*,*) ''
        !stop 'debug ros'
      END IF
      !stop
      !
    END IF

    ! --- Update matrix procedure
    IF ( CLASSIC ) THEN

      ! classic case needs to calculate the Jacobian first
      TimeJacobianA = MPI_WTIME()

      ! d(dcdt)/dc
      CALL Jacobian_CC(  Jac_CC , BAT  , A , Rate , Y )

      IF ( Teq ) THEN
        CALL Jacobian_CT( Jac_CT , BAT , Rate , DRatedT )
        CALL Jacobian_TC( Jac_TC , Jac_CC , cv , dUdT , dTdt , U , rRho)
        CALL Jacobian_TT( Jac_TT , Jac_CT , cv , dcvdT , dTdt , dUdT , dCdt , U , rRho)
        !
        CALL Miter_Classic( Miter , h , ROS%ga , Jac_CC , Jac_TC , Jac_CT , Jac_TT )
      ELSE
        CALL Miter_Classic( Miter , h , ROS%ga , Jac_CC )
      END IF
      Out%npds = Out%npds + 1

      CALL SetLUvaluesCL( LU_Miter , Miter , LU_Perm )
      TimeJac = TimeJac + (MPI_WTIME()-TimeJacobianA)

    ELSE !IF ( EXTENDED )
      !
      ! g = gamma (Rosenbrock method)
      !          _                                         _
      !         |              |              |             |
      !         |     rRate    |      g*A     |  g*dRatedT  |
      !         |              |              |             |
      !         |--------------+--------------+-------------|
      !         |              |              |             |
      ! miter = |      BAT     |      Yrh     |      0      |
      !         |              |              |             |
      !         !--------------+--------------+-------------|
      !         |              |              |             |
      !         |       0      |     UMat     |      X      |
      !         |_             |              |            _|
      !
      !
      rRate  = ONE / Rate
      CALL SetLUvaluesEX ( LU_Miter, rRate , Yrh, DRatedT , UMat , X , LUvalsFix)
    END IF
    !
    !                                  _
    !  _ __  _   _ _ __ ___   ___ _ __(_) ___
    ! | '_ \| | | | '_ ` _ \ / _ \ '__| |/ __|
    ! | | | | |_| | | | | | |  __/ |  | | (__
    ! |_| |_|\__,_|_| |_| |_|\___|_|  |_|\___|
    !         _                                          _ _   _
    !      __| | ___  ___ ___  _ __ ___  _ __   ___  ___(_) |_(_) ___  _ __
    !     / _` |/ _ \/ __/ _ \| '_ ` _ \| '_ \ / _ \/ __| | __| |/ _ \| '_ \
    !    | (_| |  __/ (_| (_) | | | | | | |_) | (_) \__ \ | |_| | (_) | | | |
    !     \__,_|\___|\___\___/|_| |_| |_| .__/ \___/|___/_|\__|_|\___/|_| |_|
    !                                   |_|
    ! --- LU - Decomposition ---
    timerStart = MPI_WTIME()
    CALL SparseLU( LU_Miter )

    TimeFac = TimeFac + (MPI_WTIME()-timerStart)

    IF (dprint) THEN
      WRITE(*,*)
      WRITE(*,*)
      WRITE(*,*) '------------------------------------------------------------------------------'
      WRITE(*,*) '|    Rosenbrock Input                                                        |'
      WRITE(*,*) '------------------------------------------------------------------------------'
      !WRITE(*,*) 'debug     i-th step      =  ',Out%nsteps
      WRITE(*,*) 'debug     Stepsize       =  ',h
      WRITE(*,*) 'debug     Time           =  ',t
      WRITE(*,*) 'debug     SUM(Y0)        =  ',SUM(Y0)
      WRITE(*,*) 'debug     SUM(Rate)      =  ',SUM(Rate)
      WRITE(*,*) 'debug     SUM(Miter%val) =  ',SUM(Miter%val)
      IF( useSparseLU ) THEN
        WRITE(*,*) 'debug    SUM(LU%val) vor = ', SUM(LU_Miter%val)
      END IF
      WRITE(*,*) '------------------------------------------------------------------------------'
      WRITE(*,*) ''
      WRITE(*,*) ''
      WRITE(*,*) '------------------------------------------------------------------------------'
      WRITE(*,*) '| Before solving Ax=b:  iStage                   b                           |'
      WRITE(*,*) '------------------------------------------------------------------------------'
      WRITE(*,*) ''
    END IF

    !****************************************************************************************
    !   ____    ___ __        __          _____  _                    ____   _
    !  |  _ \  / _ \\ \      / /         |_   _|(_) _ __ ___    ___  / ___| | |_  ___  _ __
    !  | |_) || | | |\ \ /\ / /   _____    | |  | || '_ ` _ \  / _ \ \___ \ | __|/ _ \| '_ \
    !  |  _ < | |_| | \ V  V /   |_____|   | |  | || | | | | ||  __/  ___) || |_|  __/| |_) |
    !  |_| \_\ \___/   \_/\_/              |_|  |_||_| |_| |_| \___| |____/  \__|\___|| .__/
    !                                                                                |_|
    !****************************************************************************************

    LOOP_n_STAGES:  DO iStg = 1 , ROS%nStage

      IF ( iStg==1 ) THEN

        IF ( EXTENDED ) THEN
          bb( 1     : neq ) = mONE
          bb( neq+1 : nsr ) = Emiss
          IF ( Teq ) bb(nDIMex)  = ZERO
          IF (dprint) WRITE(*,'(A25,I4,A3,*(E15.8,2X))') ' ',iStg,'   ',bb(1:4)
        END IF

      ELSE ! iStage > 1 ==> Update time and concentration

        tt  = t + ROS%Asum(iStg) * h
        Y   = Y0

        DO jStg = 1 , iStg
          Y = Y + ROS%a(iStg,jStg) * k(:,jStg)
        END DO

        ! Update Rates at  (t + SumA*h) , and  (Y + A*)k
        IF (Teq) THEN
          CALL ReactionRates( tt , Y , Rate , DRatedT )
        ELSE
          CALL ReactionRates( tt , Y , Rate )
        END IF

        CALL UpdateEmission(Emiss,tt)

        IF (dprint) THEN
          !DO i=1,nspc; WRITE(*,'(A,I0,A,Es18.10)') ' Conc(',i,') = ', Y(i); END DO
          !DO i=1,nr; WRITE(*,'(A,I0,A,Es18.10)')   ' Rate(',i,') = ', Rate(i); END DO
          !DO i=1,nspc; WRITE(*,'(A,I0,A,Es18.10)') ' Emis(',i,') = ', Emiss(i); END DO
          !DO i=1,nspc; WRITE(*,'(A,I0,A,4Es18.10)') '    k(',i,',:) = ', k(i,:); END DO
          !WRITE(*,*) '        STAGE :: ',iStg
          WRITE(*,*) ''
          WRITE(*,*) 'debug::         SUM(concentration) at (Y + a*k)  = ',SUM(Y)
          WRITE(*,*) 'debug::  SUM(Rates) at (t + SumA*h),  (Y + a*k)  = ',SUM(Rate)
        END IF
      END IF

      TimeRhsCalc0 = MPI_WTIME()
      !--- Calculate the right hand side of the linear System
      IF ( CLASSIC ) THEN

        dCdt = BAT * Rate + Emiss
        fRhs(1:nspc) =  h * dCdt
        IF (Teq) THEN
          Tarr = UpdateTempArray ( Y(nDIM) )
          CALL InternalEnergy    ( U       , Tarr)
          CALL DiffInternalEnergy( dUdT    , Tarr)
          CALL MassAveMixSpecHeat( cv      , dUdT    , MoleConc=Y(1:nspc) , rho=rho)
          fRhs( nDIM ) = - h * SUM(U*dCdt) * rRho / cv
        END IF

        DO jStg=1,iStg-1; fRhs = fRhs + ROS%C(iStg,jStg)*k(:,jStg); END DO

        IF (dprint) WRITE(*,'(A25,I4,A3,*(E15.8,2X))') ' ',iStg,'   ',fRhs( 1:4)

      ELSE !IF ( EXTENDED ) THEN

        IF ( iStg/=1 ) THEN

          fRhs = ZERO

          DO jStg = 1 , iStg-1
            fRhs(1:nspc) = fRhs(1:nspc) + ROS%C(iStg,jStg)*k(1:nspc,jStg)

            IF (Teq) THEN
              Tarr = UpdateTempArray( Y(nDIM) )
              CALL InternalEnergy( U , Tarr)
              CALL DiffInternalEnergy( dUdT , Tarr)
              CALL MassAveMixSpecHeat( cv   , dUdT , MoleConc=Y(1:nspc) , rho=rho)
              fRhs(nDIM)   = fRhs(nDIM) + ROS%C(iStg,jStg)*( cv/rRho*k(nDIM,jStg) + SUM(U*k(1:nspc,jStg)) )
            END IF
          END DO

          ! right hand side of the extended linear system

          bb( 1      : neq )  = -rRate * Rate
          bb( neq+1  : nsr )  = Emiss + fRhs(1:nspc)/h
          IF (Teq) bb(nDIMex) = fRhs(nDIM)/h

          IF (dprint) WRITE(*,'(A25,I4,A3,*(E15.8,2X))') ' ',iStg,'   ',bb(1:4)
        END IF

      END IF
      TimeRhsCalc = TimeRhsCalc + MPI_WTIME() - TimeRhsCalc0

      timerStart  = MPI_WTIME()

      IF ( CLASSIC ) THEN
        CALL SolveSparse( LU_Miter , fRhs )
        k( 1:nDIM , iStg ) = fRhs
      ELSE !IF ( EXTENDED ) THEN
        CALL SolveSparse( LU_Miter , bb)
        k( 1:nspc , iStg ) = Y0(1:nspc) * bb(neq+1:nsr)
        IF ( Teq ) &
        k(  nDIM  , iStg ) = bb(nDIMex)
      END IF

      TimeSolve   = TimeSolve + (MPI_WTIME()-timerStart)

    END DO  LOOP_n_STAGES
    IF (dprint) THEN
      WRITE(*,*) ''
      WRITE(*,*) '------------------------------------------------------------------------------'
      WRITE(*,*) '| After solving Ax=b:  Species         k( iSpc , : )                         |'
      WRITE(*,*) '------------------------------------------------------------------------------'
      WRITE(*,*) ''
      do istg=1,nspc
        WRITE(*,'(A9,I5,A25,A3,*(E15.8,2X))') 'debug::  ',istg, TRIM(y_name(istg)),'   ',k( istg , : )
      end do
      IF (Teq) WRITE(*,'(A9,I5,A25,A3,*(E15.8,2X))') 'debug::  ',nDIM,'Temperature','   ',k( nDIM , : )
      WRITE(*,*) '------------------------------------------------------------------------------'
    END IF

    !--- Update Concentrations (+Temperatur)
    YNew = Y0
    DO jStg=1,ROS%nStage; YNew = YNew + ROS%m(jStg)*k(:,jStg); END DO

    IF (dprint) THEN
      WRITE(*,*) ''
      WRITE(*,*) '------------------------------------------------------------------------------'
      WRITE(*,*) '| After Ros step:   Y_Old                     Y_New              Species name|'
      WRITE(*,*) '------------------------------------------------------------------------------'
      do istg=1,nspc
        WRITE(*,*)'debug::  ', Y0(istg),Ynew(iStg),'   ', TRIM(y_name(istg))
      end do
      IF (Teq) WRITE(*,*)'debug::  ', Y0(nDIM),Ynew(nDIM), '   Temperature'
      WRITE(*,*) '------------------------------------------------------------------------------'
      WRITE(*,*) ''
    END IF

    !***********************************************************************************************
    !   _____                           _____       _    _                    __
    !  | ____| _ __  _ __  ___   _ __  | ____| ___ | |_ (_) _ __ ___    __ _ | |_  (_)  ___   _ __
    !  |  _|  | '__|| '__|/ _ \ | '__| |  _|  / __|| __|| || '_ ` _ \  / _` ||  __|| | / _ \ | '_ \
    !  | |___ | |   | |  | (_) || |    | |___ \__ \| |_ | || | | | | || (_| || |_  | || (_) || | | |
    !  |_____||_|   |_|   \___/ |_|    |_____||___/ \__||_||_| |_| |_| \__,_| \__| |_| \___/ |_| |_|
    !
    !***********************************************************************************************

    IF (.NOT.EULER) THEN

      timerStart = MPI_WTIME()
      ! embedded formula for err calc ord-1
      YHat = Y0
      DO jStg=1,ROS%nStage; YHat = YHat + ROS%me(jStg)*k(:,jStg); END DO

      CALL ERROR( err , ierr , YNew , YHat , ATolAll , RTolROW , t )
      TimeErrCalc = TimeErrCalc + MPI_WTIME() - timerStart

      maxErrorCounter(ierr(1,1)) = maxErrorCounter(ierr(1,1)) + 1

      ! for analysis and reduction
      IF ( FluxDataPrint .AND. MPI_master .AND. err < ONE ) THEN
        IF ( t - Tspan_tot(1) >= StpFlux*REAL(iStpFlux,dp) ) THEN
          timerStart = MPI_WTIME()
          CALL StreamWriteFluxes(Rate_t,t,h)
          TimeFluxWrite = TimeFluxWrite + MPI_WTIME() - timerStart
        END IF
      END IF

      IF (dprint) THEN
        WRITE(*,*)'debug::     Error     =  ', err, '  Error index  =  ', ierr, '  Error species  =  ', TRIM(y_name(ierr(1,1)))
        WRITE(*,*) '------------------------------------------------------------------------------'
        WRITE(*,*) ''
        WRITE(*,*) ' Press ENTER to calculate next step '
        read(*,*)
      END IF

    END IF

  END SUBROUTINE Rosenbrock

  SUBROUTINE ERROR(err,ierr,ynew,yhat,ATol,RTol,t)
    !
    REAL(dp) :: err
    REAL(dp), DIMENSION(:) :: ynew, yhat, ATol
    REAL(dp) :: RTol, t
    !
    REAL(dp) :: scalTol(nDIM), e_n(nDIM), ymax(nDIM)
    INTEGER :: ierr(1,1)
    !
    ymax      = MAX(ABS(yhat),ABS(ynew))
    scalTol   = ONE / ( ATol + ymax*RTol )  ! scaling strategie
    e_n       = ABS( ynew - yhat ) * scalTol      ! local error est.
    ierr(1,1) = MAXLOC( e_n , 1 )           ! max error component
    !
    IF ( Error_Est == 2 ) THEN
      !err = SUM( e_n*e_n )
      !err = SQRT(err) / rNspc

      err = SUM( e_n*e_n ) * rNspc   ! euclikd norm
    ELSE
      err = MAXVAL( e_n )     ! maximum norm
    END IF

    !err = MAX(err,1.0e-10_dp)
    !
  END SUBROUTINE ERROR

END MODULE Rosenbrock_Mod


*DECK POCH
      FUNCTION POCH (A, X)
C***BEGIN PROLOGUE  POCH
C***PURPOSE  Evaluate a generalization of Pochhammer's symbol.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1, C7A
C***TYPE      SINGLE PRECISION (POCH-S, DPOCH-D)
C***KEYWORDS  FNLIB, POCHHAMMER, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate a generalization of Pochhammer's symbol
C (A)-sub-X = GAMMA(A+X)/GAMMA(A).  For X a non-negative integer,
C POCH(A,X) is just Pochhammer's symbol.  A and X are single precision.
C This is a preliminary version.  Error handling when POCH(A,X) is
C less than half precision is probably incorrect.  Grossly incorrect
C arguments are not handled properly.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALGAMS, ALNREL, FAC, GAMMA, GAMR, R9LGMC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  POCH
      EXTERNAL GAMMA
      SAVE PI
      DATA PI / 3.1415926535 89793238 E0 /
C***FIRST EXECUTABLE STATEMENT  POCH
      AX = A + X
      IF (AX.GT.0.0) GO TO 30
      IF (AINT(AX).NE.AX) GO TO 30
C
      IF (A .GT. 0.0 .OR. AINT(A) .NE. A) CALL XERMSG ('SLATEC', 'POCH',
     +   'A+X IS NON-POSITIVE INTEGER BUT A IS NOT', 2, 2)
C
C WE KNOW HERE THAT BOTH A+X AND A ARE NON-POSITIVE INTEGERS.
C
      POCH = 1.0
      IF (X.EQ.0.0) RETURN
C
      N = X
      IF (MIN(A+X,A).LT.(-20.0)) GO TO 20
C
      POCH = (-1.0)**N * FAC(-INT(A))/FAC(-INT(A)-N)
      RETURN
C
 20   POCH = (-1.0)**N * EXP ((A-0.5)*ALNREL(X/(A-1.0))
     1  + X*LOG(-A+1.0-X) - X + R9LGMC(-A+1.) - R9LGMC(-A-X+1.) )
      RETURN
C
C HERE WE KNOW A+X IS NOT ZERO OR A NEGATIVE INTEGER.
C
 30   POCH = 0.0
      IF (A.LE.0.0 .AND. AINT(A).EQ.A) RETURN
C
      N = ABS(X)
      IF (REAL(N).NE.X .OR. N.GT.20) GO TO 50
C
C X IS A SMALL NON-POSITIVE INTEGER, PRESUMMABLY A COMMON CASE.
C
      POCH = 1.0
      IF (N.EQ.0) RETURN
      DO 40 I=1,N
        POCH = POCH * (A+I-1)
 40   CONTINUE
      RETURN
C
 50   ABSAX = ABS(A+X)
      ABSA = ABS(A)
      IF (MAX(ABSAX,ABSA).GT.20.0) GO TO 60
      POCH = GAMMA(A+X)*GAMR(A)
      RETURN
C
 60   IF (ABS(X).GT.0.5*ABSA) GO TO 70
C
C HERE ABS(X) IS SMALL AND BOTH ABS(A+X) AND ABS(A) ARE LARGE.  THUS,
C A+X AND A MUST HAVE THE SAME SIGN.  FOR NEGATIVE A, WE USE
C GAMMA(A+X)/GAMMA(A) = GAMMA(-A+1)/GAMMA(-A-X+1) *
C SIN(PI*A)/SIN(PI*(A+X))
C
      B = A
      IF (B.LT.0.0) B = -A - X + 1.0
      POCH = EXP ((B-0.5)*ALNREL(X/B) + X*LOG(B+X) - X +
     1  R9LGMC(B+X) - R9LGMC(B) )
      IF (A.LT.0.0 .AND. POCH.NE.0.0) POCH = POCH/(COS(PI*X) +
     1  COT(PI*A)*SIN(PI*X))
      RETURN
C
 70   CALL ALGAMS (A+X, ALNGAX, SGNGAX)
      CALL ALGAMS (A, ALNGA, SGNGA)
      POCH = SGNGAX * SGNGA * EXP(ALNGAX-ALNGA)
C
      RETURN
      END


	FUNCTION PS_LIFT ( datain, nparm, tvflag )
C************************************************************************
C* PS_LIFT								*
C*									*
C* This function computes the lifted index:				*
C*									*
C*	LIFT = T500 - Tparcel						*
C*									*
C*	     T500    = 500 mb temperature in Celsius			*
C*									*
C*	     Tparcel = 500 mb parcel temperature in Celsius on the	*
C*		       moist adiabat determined by the average		*
C*		       pressure, temperature and dewpoint in the	*
C*		       layer from the surface to 100 mb above the	*
C*		       surface						*
C*									*
C* TVFLAG determines if temperature or virtual temperature is used	*
C* in the calculation.							*
C*									*
C* REAL PS_LIFT ( DATAIN, NPARM, TVFLAG )				*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARM,*)	REAL		Station data			*
C*	NPARM		INTEGER		Number of parameters		*
C*	TVFLAG		LOGICAL		Temperature flag		*
C*									*
C* Output parameters:							*
C*	PS_LIFT		REAL		Lifted index			*
C**									*
C* Log:									*
C* I. Graffman/RDS	 9/86						*
C* M. desJardins/GSFC	10/86	Added GEMPAK parameter names		*
C* M. desJardins/GSFC	 9/87	Corrected indicies in call to PC_CMDT	*
C* M. desJardins/GSFC	 3/88	Documentation				*
C* G. Huffman/USRA	 8/89	Move error check to PC_CMDT, clean up	*
C* M. desJardins/GSFC	 7/90	GEMPAK 5				*
C* T. Lee		 8/97	Added a temperature flag		*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		datain (*)
C*
	REAL		datlev ( MMPARM )
	LOGICAL		tvflag
C*
	INCLUDE		'ERMISS.FNC'
	DATA		datlev / MMPARM * RMISSD /
C------------------------------------------------------------------------
	PS_LIFT = RMISSD
C
C*	Get values in parcel.
C
	CALL PS_PRCL  ( datain, nparm, 100., 1, 1, depth, idcord, pavg,
     +			tavg, tdavg, uavg, vavg, zavg, thavg, rmxavg,
     +			ier )
	IF  ( ( ier .ne. 0 ) .or. ERMISS (tavg) .or. ERMISS (tdavg) )
     +								THEN
	    RETURN
	end if

C
C*	Calculate equivalent potential temperature in average layer.
C*	Then compute parcel temperature on moist adiabat.
C
	thte  = PR_THTE  ( pavg, tavg, tdavg )
	guess = 0.
	tmpe  = PR_TMST  ( thte, 500., guess )
	IF  ( tvflag )  THEN
	    tmpc  = PR_TMKC  ( tmpe )
	    tmpe  = PR_TVRK  ( tmpc, tmpc, 500. )
	END IF
C
C*	Get temperature at 500 millibars.
C
	CALL PC_CMDT  ( 5, 6, 7, 500., 1, datain, datlev, ier )
	IF  ( tvflag )  THEN
	    t500 = datlev (7)
	  ELSE
	    t500 = datlev (2)
	END IF
C
C*	Check for errors and then compute lifted index.
C
	IF ( ERMISS (t500) .or. ERMISS (thte) .or. ERMISS (tmpe) ) THEN
	    RETURN
	  ELSE
	    PS_LIFT = t500 - PR_TMKC ( tmpe )
	END IF
C*
	RETURN
	END


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!% Implementation of quaternion algebra. Primarily for use with
!% rigid body dynamics, although the 'Orientation', 'Rotation'
!% and 'Rotate' routines can be useful in many other situations.
!%
!% \begin{displaymath}
!% \begin{array}{c}
!% i^2 = j^2 = k^2 = ijk = -1 \\ ij = k \quad jk = i \quad ki = j
!% \end{array}
!% \end{displaymath}

module quaternions_module

  use system_module        ! for dp
  use units_module         ! for PI
  use linearalgebra_module ! for .feq./.fne

  implicit none
  private

  public :: quaternion, initialise, finalise, print
  public :: rotate, rotation, rotation_matrix, orientation, assignment(=)
  public :: rotation_parameters
  public :: operator(.dot.), operator(*), operator(+), operator(.conj.)

  type Quaternion

     real(dp) :: a = 0.0_dp   !
     real(dp) :: b = 0.0_dp   !
     real(dp) :: c = 0.0_dp   ! = a*1 + b*i + c*j + d*k
     real(dp) :: d = 0.0_dp   !

  end type Quaternion

  private :: quaternion_initialise
  interface initialise
     module procedure quaternion_initialise
  end interface initialise

  private :: quaternion_finalise
  interface finalise
     module procedure quaternion_finalise
  end interface finalise

  private :: quaternion_norm
  interface norm
     module procedure quaternion_norm
  end interface norm

  private :: quaternion_normsq
  interface normsq
     module procedure quaternion_normsq
  end interface normsq

  private :: quat_plus_quat, quat_plus_vect
  interface operator(+)
     module procedure quat_plus_quat, quat_plus_vect
  end interface

  private :: quat_minus_quat, quat_minus_vect
  interface operator(-)
     module procedure quat_minus_quat, quat_minus_vect
  end interface

  private :: quat_mult_real, quat_mult_quat, real_mult_quat
  interface operator(*)
     module procedure quat_mult_real, quat_mult_quat, real_mult_quat
  end interface

  private :: quat_divide_real, quat_divide_quat
  interface operator(/)
     module procedure quat_divide_real, quat_divide_quat
  end interface

  private :: quat_assign_vect, vect_assign_quat, quat_assign_real
  interface assignment(=)
     module procedure quat_assign_vect, vect_assign_quat, quat_assign_real
  end interface

  private :: quaternion_conjugate
  interface operator(.conj.)
     module procedure quaternion_conjugate
  end interface

  private :: quat_eq_quat, quat_eq_vect
  interface operator(.feq.)
     module procedure quat_eq_quat, quat_eq_vect
  end interface

  private :: quat_ne_quat, quat_ne_vect
  interface operator(.fne.)
     module procedure quat_ne_quat, quat_ne_vect
  end interface

  private :: quat_dot_quat
  interface operator(.dot.)
     module procedure quat_dot_quat
  end interface

  private :: rotate_vect, rotate_quat
  interface rotate
     module procedure rotate_vect, rotate_quat
  end interface rotate

  private :: quaternion_print
  interface print
     module procedure quaternion_print
  end interface print

contains

  subroutine quaternion_initialise(this, a, b, c, d)
    type(Quaternion), intent(out) :: this
    real(dp), intent(in), optional :: a, b, c, d

    this%a = optional_default(0.0_dp, a)
    this%b = optional_default(0.0_dp, b)
    this%c = optional_default(0.0_dp, c)
    this%d = optional_default(0.0_dp, d)

  end subroutine quaternion_initialise

  subroutine quaternion_finalise(this)
    type(Quaternion), intent(inout) :: this

    this%a = 0.0_dp
    this%b = 0.0_dp
    this%c = 0.0_dp
    this%d = 0.0_dp

  end subroutine quaternion_finalise

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X Assignment
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  subroutine quat_assign_vect(this,vect)

    type(Quaternion),       intent(out) :: this
    real(dp), dimension(:), intent(in)  :: vect

    select case(size(vect))

       case(3)
          this%a = 0.0_dp
          this%b = vect(1)
          this%c = vect(2)
          this%d = vect(3)

       case(4)
          this%a = vect(1)
          this%b = vect(2)
          this%c = vect(3)
          this%d = vect(4)

       case default
          call system_abort('Quat_Assign_Vect: Vector must have 3 or 4 components')

    end select

  end subroutine quat_assign_vect

  subroutine vect_assign_quat(vect,q)

    real(dp), dimension(:), intent(out) :: vect
    type(Quaternion),       intent(in)  :: q

    select case(size(vect))

       case(3)
          vect = (/q%b,q%c,q%d/)

       case(4)
          vect = (/q%a,q%b,q%c,q%d/)

       case default
          call system_abort('Vect_Assign_Quat: Vector must have 3 or 4 components')

    end select

  end subroutine vect_assign_quat

  subroutine quat_assign_real(q,r)

    type(Quaternion), intent(out) :: q
    real(dp),         intent(in)  :: r

    q%a = r
    q%b = 0.0_dp
    q%c = 0.0_dp
    q%d = 0.0_dp

  end subroutine quat_assign_real

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X Simple arithmetic
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  function quat_plus_quat(q1,q2) result(res)

    type(Quaternion), intent(in) :: q1,q2
    type(Quaternion)             :: res

    res%a = q1%a + q2%a
    res%b = q1%b + q2%b
    res%c = q1%c + q2%c
    res%d = q1%d + q2%d

  end function quat_plus_quat

  function quat_plus_vect(q,v) result(res)

    type(Quaternion),       intent(in) :: q
    real(dp), dimension(4), intent(in) :: v
    type(Quaternion)                   :: res

    res%a = q%a + v(1)
    res%b = q%b + v(2)
    res%c = q%c + v(3)
    res%d = q%d + v(4)

  end function quat_plus_vect

  function quat_minus_quat(q1,q2) result(res)

    type(Quaternion), intent(in) :: q1,q2
    type(Quaternion)             :: res

    res%a = q1%a - q2%a
    res%b = q1%b - q2%b
    res%c = q1%c - q2%c
    res%d = q1%d - q2%d

  end function quat_minus_quat

  function quat_minus_vect(q,v) result(res)

    type(Quaternion),       intent(in) :: q
    real(dp), dimension(4), intent(in) :: v
    type(Quaternion)                   :: res

    res%a = q%a - v(1)
    res%b = q%b - v(2)
    res%c = q%c - v(3)
    res%d = q%d - v(4)

  end function quat_minus_vect

  function quat_mult_quat(q1,q2) result(res)

    type(Quaternion), intent(in) :: q1,q2
    type(Quaternion)             :: res

    res%a = q1%a * q2%a  -  q1%b * q2%b  -  q1%c * q2%c - q1%d * q2%d
    res%b = q1%a * q2%b  +  q1%b * q2%a  +  q1%c * q2%d - q1%d * q2%c
    res%c = q1%a * q2%c  -  q1%b * q2%d  +  q1%c * q2%a + q1%d * q2%b
    res%d = q1%a * q2%d  +  q1%b * q2%c  -  q1%c * q2%b + q1%d * q2%a

  end function quat_mult_quat

  function quat_mult_real(q,r) result(res)

    type(Quaternion), intent(in) :: q
    real(dp),         intent(in) :: r
    type(Quaternion)             :: res

    res%a = q%a * r
    res%b = q%b * r
    res%c = q%c * r
    res%d = q%d * r

  end function quat_mult_real

  function real_mult_quat(r,q) result(res)

    type(Quaternion), intent(in) :: q
    real(dp),         intent(in) :: r
    type(Quaternion)             :: res

    res%a = q%a * r
    res%b = q%b * r
    res%c = q%c * r
    res%d = q%d * r

  end function real_mult_quat

  function quat_divide_real(q,r) result(res)

    type(Quaternion), intent(in) :: q
    real(dp),         intent(in) :: r
    type(Quaternion)             :: res

    res%a = q%a / r
    res%b = q%b / r
    res%c = q%c / r
    res%d = q%d / r

  end function quat_divide_real

  function quat_divide_quat(q1,q2) result(res)

    type(Quaternion), intent(in) :: q1,q2
    type(Quaternion)             :: res, q2c
    real(dp)                     :: q2n

    q2c = .conj. q2
    q2n = normsq(q2)

    res = (q1 * q2c) / q2n

  end function quat_divide_quat

  !Dot product as if they were 4 component vectors
  function quat_dot_quat(q1,q2) result(res)

    type(Quaternion), intent(in) :: q1,q2
    real(dp)                     :: res

    res = q1%a * q2%a  +  q1%b * q2%b  +  q1%c * q2%c + q1%d * q2%d

  end function quat_dot_quat

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X Comparison
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  function quat_eq_quat(q1,q2) result(res)

    type(Quaternion), intent(in) :: q1,q2
    logical                      :: res

    res = .false.

    if (q1%a .fne. q2%a) return
    if (q1%b .fne. q2%b) return
    if (q1%c .fne. q2%c) return
    if (q1%d .fne. q2%d) return

    res = .true.

  end function quat_eq_quat

  function quat_ne_quat(q1,q2) result(res)

    type(Quaternion), intent(in) :: q1,q2
    logical                      :: res

    res = .not. (q1 .feq. q2)

  end function quat_ne_quat

  function quat_eq_vect(q,v) result(res)

    type(Quaternion), intent(in)       :: q
    real(dp), dimension(:), intent(in) :: v
    logical                            :: res
    type(Quaternion)                   :: qv

    qv = v

    res = .false.

    if (q%a .fne. qv%a) return
    if (q%b .fne. qv%b) return
    if (q%c .fne. qv%c) return
    if (q%d .fne. qv%d) return

    res = .true.

  end function quat_eq_vect

  function quat_ne_vect(q,v) result(res)

    type(Quaternion),       intent(in) :: q
    real(dp), dimension(:), intent(in) :: v
    logical                            :: res

    res = .not. (q .feq. v)

  end function quat_ne_vect

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X Norms
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  function quaternion_normsq(this) result(normsq)

    type(Quaternion), intent(in) :: this
    real(dp)                     :: normsq

    normsq =   this%a*this%a &
            + this%b*this%b &
            + this%c*this%c &
            + this%d*this%d

  end function quaternion_normsq

  function quaternion_norm(this) result(norm)

    type(Quaternion), intent(in) :: this
    real(dp)                     :: norm

    norm = sqrt(quaternion_normsq(this))

  end function quaternion_norm

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X Quaternion conjugate
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  function quaternion_conjugate(this) result(res)

    type(Quaternion), intent(in) :: this
    type(Quaternion)             :: res

    res%a =  this%a
    res%b = -this%b
    res%c = -this%c
    res%d = -this%d

  end function quaternion_conjugate

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X Printing
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  subroutine quaternion_print(this,file)

    type(Quaternion), intent(in) :: this
    type(Inoutput),  optional, intent(in) :: file
    !local variables
    character                    :: s2,s3,s4

    s2 = '+'; s3 = '+'; s4 = '+'
    if (this%b < 0.0_dp) s2 = '-'
    if (this%c < 0.0_dp) s3 = '-'
    if (this%d < 0.0_dp) s4 = '-'

    write(line,'(4(f0.5,a))')     this%a,' '//s2//' ',   &
                              abs(this%b),'i '//s3//' ', &
                              abs(this%c),'j '//s4//' ', &
                              abs(this%d),'k'
    call Print(line,file=file)

  end subroutine quaternion_print

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X Rotation routines
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  !% Many rotations can be collapsed into one, e.g.
  !% to rotate using $q_1$ then $q_2$ :
  !% rotate using $q_3 = q_2 \times q_1$
  !%
  !%
  !% Construct a rotation quaternion from axis and angle (in a righthanded sense)
  !
  function rotation(axis,angle) result(res)

    real(dp), dimension(3), intent(in) :: axis
    real(dp),               intent(in) :: angle  ! in radians
    type(Quaternion)                   :: res
    !local variables
    real(dp)                           :: n

    n = norm(axis)

    res = (/ cos(angle/2.0_dp), sin(angle/2.0_dp)*axis/n /)

  end function rotation

  !
  !% Rotate a vector using the given quaternion
  !
  subroutine rotate_vect(v,qr)

    real(dp), dimension(3), intent(inout) :: v
    type(Quaternion),       intent(in)    :: qr
    !local variables
    type(Quaternion)                      :: qv

    qv = v
    call rotate_quat(qv,qr)
    v = qv

  end subroutine rotate_vect

  !
  !% Rotate a vector represented as a quaternion ('qv'), using a given rotation quaternion ('qr')
  !% This assumes that the rotation quaternion is properly normalised
  !%
  !% 'qv = qr * qv * (.conj.qr)'
  subroutine rotate_quat(qv,qr)

    type(Quaternion), intent(inout)  :: qv
    type(Quaternion), intent(in)     :: qr

    qv = qr * qv * (.conj. qr)

  end subroutine rotate_quat

  !
  !% Given two vectors ('a1' and 'b1'), calculate the rotation quaternion
  !% that must be used to rotate them into two other vectors ('a2' and 'b2').
  !% The angle between 'a1' and 'b1' must be the same as 'a2' and 'b2',
  !% unless 'correct_angle' is present and true
  !
  function orientation(a1, b1, a2, b2, correct_angle)

    real(dp), dimension(3), intent(in) :: a1,b1,a2,b2
    logical, optional,      intent(in) :: correct_angle
    type(Quaternion)                   :: Orientation
    !local variables
    type(Quaternion)                   :: r1, r2 !The two parts of the orientation
    real(dp), dimension(3)             :: n, p, q, a1_hat, b1_hat, a2_hat, b2_hat, b3_hat, zero3
    real(dp)                           :: theta
    logical                            :: do_correct_angle

    do_correct_angle = .false.
    if (present(correct_angle)) do_correct_angle = correct_angle
    zero3 = (/0.0_dp,0.0_dp,0.0_dp/)

    !Normalise the vectors
    a1_hat = a1 / norm(a1)
    b1_hat = b1 / norm(b1)
    a2_hat = a2 / norm(a2)
    b2_hat = b2 / norm(b2)

    !Check the angles a1-b1 and a2-b2 match
    if (.not. do_correct_angle .and. ((a1_hat .dot. b1_hat) .fne. (a2_hat .dot. b2_hat))) then
       call system_abort('Orientation: Angle a1--b1 is not equal to angle a2--b2')
    end if

    !Correct the a1--b1 angle to be the same as the a2--b2 angle by moving b1
    if (do_correct_angle) then
       n = b1_hat - (a1_hat .dot. b1_hat)*a1_hat !Perpendicular to a1 in a1--b1 plane
       n = n / norm(n)
       theta = angle(a2_hat, b2_hat)
       b1_hat = a1_hat * cos(theta) + n * sin(theta)
    end if

    !Now construct the rotation quaternion needed to take a1 to a2 around an axis perpendicular to both
    n = a1_hat .cross. a2_hat

    !Special case: The vectors could be almost (anti)parallel, in which case it we can choose any vector
    !perpendicular to them as the first rotation axis
    if (n .feq. zero3) then
       do while(n .feq. zero3)       !This is for the TINY possiblility that the random vector we choose
                                     !is STILL (anti)parallel to a1
       !Create a random unit vector
          p = random_unit_vector()
          n = a1_hat .cross. p
       end do
    end if

    n = n / norm(n)

    theta = angle(a1_hat,a2_hat)
    r1 = Rotation(n,theta)

    !Acting on b1 with r1 will take it to a new position, b3
    b3_hat = b1_hat
    call Rotate(b3_hat,r1)

    !Now figure out the angle which we need to rotate around a2 (or -a2) to take b3 to b2
    ! -> Construct vectors perpendicular to a2, in the a2-b3 and a2-b2 planes, then find angle between them
    p = b3_hat - (a2_hat .dot. b3_hat)*a2_hat
    p = p / norm(p)
    q = b2_hat - (a2_hat .dot. b2_hat)*a2_hat
    q = q / norm(q)
    n = p .cross. q   ! This will be either in the a2 or the -a2 direction

    !Another Special case: Miraculously, p and q could be (anti) parallel, in which case we can just
    !use a2_hat, then is doesn't matter if we rotate  by 0 (or PI) clockwise or anticlockwise
    if (n .feq. zero3) n = a2_hat

    n = n / norm(n)
    theta = angle(p,q)
    r2 = rotation(n,theta)

    !Combine the two rotations into one using quaternion multiplication
    orientation = r2 * r1

  end function orientation

  !
  !% Returns the angle and rotation axis of a (normalised) quaternion
  !
  subroutine rotation_parameters(q,theta,axis)

    type(Quaternion),       intent(in)  :: q
    real(dp),               intent(out) :: theta
    real(dp), dimension(3), intent(out) :: axis

    theta = 2.0_dp * acos(q%a)

    axis = (/q%b,q%c,q%d/) / (sqrt(1 - q%a*q%a))

  end subroutine rotation_parameters

  !
  !% Return the equivalent rotation matrix of a (unit) quaternion
  !
  function rotation_matrix(q_in) result(A)

    type(Quaternion), intent(in) :: q_in
    real(dp), dimension(3,3)     :: A
    type(Quaternion)             :: q

    !Normalise q_in
    q = q_in / norm(q_in)

    !Now build A
    A(1,1) = q%a*q%a+q%b*q%b-q%c*q%c-q%d*q%d; A(1,2) = 2.0_dp*(q%b*q%c-q%a*q%d);        A(1,3) = 2.0_dp*(q%b*q%d+q%a*q%c)
    A(2,1) = 2.0_dp*(q%b*q%c+q%a*q%d);        A(2,2) = q%a*q%a-q%b*q%b+q%c*q%c-q%d*q%d; A(2,3) = 2.0_dp*(q%c*q%d-q%a*q%b)
    A(3,1) = 2.0_dp*(q%b*q%d-q%a*q%c);        A(3,2) = 2.0_dp*(q%c*q%d+q%a*q%b);        A(3,3) = q%a*q%a-q%b*q%b-q%c*q%c+q%d*q%d

  end function rotation_matrix

  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  !X Testing
  !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  !%OMIT
  subroutine quaternion_test

    type(Quaternion) :: q1, q2, q3
    real(dp)         :: v3(3), v4(4), a(3), b(3), c(3), d(3), M(3,3)

    !Assignment
    call Print('Testing assignment...')
    call Print('q1 <- 4vector:')
    q1 = (/1.0_dp,1.0_dp,1.0_dp,1.0_dp/)
    call Print(q1)
    call Print('q2 <- 3vector:')
    q2 = (/2.0_dp,2.0_dp,2.0_dp/)
    call Print(q2)
    call Print('q1 -> 3vector:')
    v3 = q1
    call Print(v3)
    call Print('q2 -> 4vector:')
    v4 = q2
    call Print(v4)
    call Print('')

    !Algebra
    call Print('Testing alegbra...')
    call Print('q1 + q2:')
    q3 = q1 + q2
    call Print(q3)
    call Print('q1 - q2:')
    q3 = q1 - q2
    call Print(q3)
    call Print('q1 * q2:')
    q3 = q1 * q2
    call Print(q3)
    call Print('q1 / q2:')
    q3 = q1 / q2
    call Print(q3)
    call Print('')

    !Norms
    call Print('Testing norms...')
    call Print('normsq(q1):')
    call Print(normsq(q1))
    call Print('normsq(q2):')
    call Print(normsq(q2))
    call Print('norm(q1):')
    call Print(norm(q1))
    call Print('norm(q2):')
    call Print(norm(q2))
    call Print('')

    !Conjugate
    call Print('Testing conjugates...')
    call Print('q1*:')
    call Print(.conj.q1)
    call Print('q2*:')
    call Print(.conj.q2)
    call Print('')

    !Rotation
    call Print('Testing Rotations...')
    call Print('Setting q1 to x axis...')
    q1 = (/1.0_dp,0.0_dp,0.0_dp/)
    call Print('q1:')
    call Print(q1)
    call Print('Setting up q2 for rotation about z axis by 90deg...')
    q2 = Rotation(unit_vector(0.0_dp,0.0_dp),PI/2.0_dp)
    call Print('q2:')
    call Print(q2)
    call Print('Rotating...')
    call Rotate(q1,q2)
    q3 = q1
    call Print(q3)
    v3 = q3
    call Print('Rotated vector:')
    call Print(v3)
    call Print('')
    call Print('Rotating this by a further 90deg around z axis')
    call Rotate(v3,q2)
    call Print('Rotated vector:')
    call Print(v3)
    call Print('')
    call Print('Creating random rotation quaternion...')
    q1 = Rotation(random_unit_vector(),ran_uniform()*PI)
    call Print(q1)
    call Print('Calculating equivalent rotation matrix...')
    M = Rotation_matrix(q1)
    call Print(M)
    call Print('Creating random vector...')
    v3 = random_unit_vector()
    call Print(v3)
    call Print('Rotating with quaternion...')
    a = v3
    call Rotate(a,q1)
    call Print(a)
    call Print('Rotating with matrix...')
    b = M .mult. v3
    call Print(b)
    call Print('')

    !Orientation
    !NOTE: remember that q and -q represent the same rotation!
    call Print('Testing orientation...')
    call Print('Creating two random unit vectors...')
    a = random_unit_vector()
    b = random_unit_vector()
    call Print('a:')
    call Print(a)
    call Print('b:')
    call Print(b)
    call Print('Creating random rotation quaternion...')
    q1 = Rotation(random_unit_vector(),ran_uniform()*PI)
    call Print(q1)
    call Print('Rotating random vectors with random quaternion...')
    c = a
    call Rotate(c,q1)
    d = b
    call Rotate(d,q1)
    call Print('a -> c:')
    call Print(c)
    call Print('b -> d:')
    call Print(b)
    call Print('Calculating rotation quaternion based on a,b,c,d:')
    q2 = Orientation(a,b,c,d,.true.)
    call Print(q2)
    call Print('')

  end subroutine quaternion_test

end module quaternions_module


      COMPLEX FUNCTION CLADIV( X, Y )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      COMPLEX            X, Y
*     ..
*
*  Purpose
*  =======
*
*  CLADIV := X / Y, where X and Y are complex.  The computation of X / Y
*  will not overflow on an intermediary step unless the results
*  overflows.
*
*  Arguments
*  =========
*
*  X       (input) COMPLEX
*  Y       (input) COMPLEX
*          The complex scalars X and Y.
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL               ZI, ZR
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLADIV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          AIMAG, CMPLX, REAL
*     ..
*     .. Executable Statements ..
*
      CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR,
     $             ZI )
      CLADIV = CMPLX( ZR, ZI )
*
      RETURN
*
*     End of CLADIV
*
      END


C**** QUSDEF.f

      MODULE QUSDEF
!@sum  QUSDEF contains definitions for manipulating moments
!@auth Maxwell Kelley
      integer, parameter ::
     &     nmom=9,
     &     mx =1, my =2, mz =3,
     &     mxx=4, myy=5, mzz=6,
     &     mxy=7, mzx=8, myz=9

C**** some useful vector subscripts:

C**** moments with a vertical component
      integer, dimension(4), parameter ::
     &     zmoms=(/MZ,MZZ,MYZ,MZX/)
C**** moments with no vertical component
      integer, dimension(5), parameter ::
     &     xymoms=(/MX,MY,MXX,MXY,MYY/)
C**** moments with a horizontal component
      integer, dimension(7), parameter ::
     &     ihmoms=(/MX,MY,MXX,MYY,MXY,MYZ,MZX/)
C**** moments with no horizontal component
      integer, dimension(2), parameter ::
     &     zomoms=(/MZ,MZZ/)

C**** x-x, x-y, x-z switches
      integer, dimension(nmom), parameter ::
     &     xdir=(/mx,my,mz,mxx,myy,mzz,mxy,myz,mzx/)
      integer, dimension(nmom), parameter ::
     &     ydir=(/my,mx,mz,myy,mxx,mzz,mxy,mzx,myz/)
      integer, dimension(nmom), parameter ::
     &     zdir=(/mz,my,mx,mzz,myy,mxx,myz,mxy,mzx/)

!@dbparam prather_limits forces +ve sub-grid scale profiles (default=0)
      integer :: prather_limits = 0.

      END MODULE QUSDEF

      subroutine adv1d(s,smom, f,fmom, mass,dm, nx,qlimit,stride,dir
     *     ,ierr,nerr)
!@sum  adv1d implements the quadratic upstream scheme in one dimension
!@auth G. Russell, modified by Maxwell Kelley
c--------------------------------------------------------------
c adv1d advects tracers in x-direction using the qus
c the order of the moments in dir is: x,y,z,xx,yy,zz,xy,yz,zx
c--------------------------------------------------------------
      use QUSDEF, only : nmom,prather_limits
      implicit none
      !
!@var s      mean tracer amount (kg or J)
!@var smom   qus tracer moments (kg or J)
!@var f      tracer flux (diagnostic output) (kg or J)
!@var fmom   tracer moment flux (diagnostic output) (kg or J)
!@var mass   mass field (kg)
!@var dm     mass flux (kg)
!@var nx     length of 1D vector
!@var qlimit true if negative tracer is to be avoided
!@var stride spacing in s array between elements of relevant 1D array
!@var dir    direction switch (equals one of xdir ydir or zdir)
!@var ierr, nerr error codes
      integer, intent(in) :: nx,stride
      logical, intent(in) :: qlimit
      REAL*8, dimension(nx) :: dm, f
      REAL*8, dimension(nx*stride) :: s,mass
      REAL*8, dimension(nmom,nx*stride) :: smom
      REAL*8, dimension(nmom,nx) :: fmom
      integer, dimension(nmom) :: dir
      integer :: mx,my,mz,mxx,myy,mzz,mxy,myz,mzx
      integer :: n,np1,nm1,nn,ns
      integer,intent(out) :: ierr,nerr
      REAL*8 :: fracm,frac1,bymnew,mnew,dm2,tmp
      ! qlimit variables
      REAL*8 :: an, anm1, fn, fnm1, sn, sxn, sxxn
      !
      ierr=0 ; nerr=0
      mx  = dir(1)
      my  = dir(2)
      mz  = dir(3)
      mxx = dir(4)
      myy = dir(5)
      mzz = dir(6)
      mxy = dir(7)
      myz = dir(8)
      mzx = dir(9)
c-----------------------------------------------------------
      ! calculate tracer mass flux f
c-----------------------------------------------------------
      n = nx
      do np1=1,nx
         if(dm(n).lt.0.) then ! air mass flux is negative
            nn=np1
            frac1=+1.
         else                 ! air mass flux is positive
            nn=n
            frac1=-1.
         endif
         ns=1+(nn-1)*stride
         fracm=dm(n)/mass(ns)
         if(mass(ns).le.0.d0) fracm=0.d0
         frac1=fracm+frac1
         f(n)=fracm*(s(ns)-frac1*(smom(mx,ns)-
     &        (frac1+fracm)*smom(mxx,ns)))
      ! temporary storage of fracm in fx, to be used below
         fmom(mx,n)=fracm
      ! temporary storage of frac1 in fxx, to be used below
         fmom(mxx,n)=frac1
      !
        n = np1
      enddo
      if(qlimit) then
         nm1 = nx
         do n=1,nx
            ns=1+(n-1)*stride
            an = fmom(mx,n)      ! reading fracm which was stored in fx
            anm1 = fmom(mx,nm1)
            fn = f(n)
            fnm1 = f(nm1)
            sn = s(ns)
            sxn = smom(mx,ns)
            sxxn = smom(mxx,ns)
            call limitq(anm1,an,fnm1,fn,sn,sxn,sxxn,ierr)
            if (ierr.gt.0) then
              nerr=n
              if (ierr.eq.2) return
            end if
            f(n) = fn
            f(nm1) = fnm1
            smom(mx,ns) = sxn
            smom(mxx,ns) = sxxn
            nm1 = n
         enddo
      endif
c--------------------------------------------------------------------
      ! calculate tracer fluxes of slopes and curvatures
c--------------------------------------------------------------------
      n = nx
      do np1=1,nx
         if(dm(n).lt.0.) then ! air mass flux is negative
            nn=np1
         else                 ! air mass flux is positive
            nn=n
         endif
         ns=1+(nn-1)*stride
      ! retrieving fracm, which was stored in fx
         fracm=fmom(mx,n)
      ! retrieving frac1, which was stored in fxx
         frac1=fmom(mxx,n)
      !
         fmom(mx,n)=dm(n)*(fracm*fracm*(smom(mx,ns)
     &        -3.*frac1*smom(mxx,ns))-3.*f(n))
         fmom(mxx,n)=dm(n)*(dm(n)*fracm**3 *smom(mxx,ns)
     &        -5.*(dm(n)*f(n)+fmom(mx,n)))
      ! cross moments
         fmom(my,n)  = fracm*(smom(my,ns)-frac1*smom(mxy,ns))
         fmom(mxy,n) = dm(n)*(fracm*fracm*smom(mxy,ns)-3.*fmom(my,n))
         fmom(mz,n)  = fracm*(smom(mz,ns)-frac1*smom(mzx,ns))
         fmom(mzx,n) = dm(n)*(fracm*fracm*smom(mzx,ns)-3.*fmom(mz,n))
         fmom(myy,n) = fracm*smom(myy,ns)
         fmom(mzz,n) = fracm*smom(mzz,ns)
         fmom(myz,n) = fracm*smom(myz,ns)
         n = np1
      enddo
c-------------------------------------------------------------------
c update tracer mass, moments of tracer mass, air mass distribution
c-------------------------------------------------------------------
      nm1 = nx
      do n=1,nx
         ns=1+(n-1)*stride
         tmp=mass(ns)+dm(nm1)
         mnew=tmp-dm(n)
      !     mnew=mass(ns)+dm(nm1)-dm(n)
         bymnew = 1./mnew
         dm2=dm(nm1)+dm(n)
         tmp=s(ns)+f(nm1)
         s(ns)=tmp-f(n)
      !     s(ns)=s(ns)+f(nm1)-f(n)
      !
         smom(mx,ns)=(smom(mx,ns)*mass(ns)-3.*(-dm2*s(ns)
     &     +mass(ns)*(f(nm1)+f(n)))+(fmom(mx,nm1)-fmom(mx,n)))*bymnew
         smom(mxx,ns) = (smom(mxx,ns)*mass(ns)*mass(ns)
     &     +2.5*s(ns)*(mass(ns)*mass(ns)-mnew*mnew-3.*dm2*dm2)
     &     +5.*(mass(ns)*(mass(ns)*(f(nm1)-f(n))-fmom(mx,nm1)
     &     -fmom(mx,n))+dm2*smom(mx,ns)*mnew)
     &     +(fmom(mxx,nm1)-fmom(mxx,n))) * (bymnew*bymnew)
      ! cross moments
         smom(my,ns)=smom(my,ns)+fmom(my,nm1)-fmom(my,n)
         smom(mxy,ns)=(smom(mxy,ns)*mass(ns)-3.*(-dm2*smom(my,ns) +
     &        mass(ns)*(fmom(my,nm1)+fmom(my,n))) +
     &        (fmom(mxy,nm1)-fmom(mxy,n)))*bymnew
         smom(mz,ns)=smom(mz,ns)+fmom(mz,nm1)-fmom(mz,n)
         smom(mzx,ns)=(smom(mzx,ns)*mass(ns)-3.*(-dm2*smom(mz,ns) +
     &        mass(ns)*(fmom(mz,nm1)+fmom(mz,n))) +
     &        (fmom(mzx,nm1)-fmom(mzx,n)))*bymnew
      !
         smom(myy,ns)=smom(myy,ns)+fmom(myy,nm1)-fmom(myy,n)
         smom(mzz,ns)=smom(mzz,ns)+fmom(mzz,nm1)-fmom(mzz,n)
         smom(myz,ns)=smom(myz,ns)+fmom(myz,nm1)-fmom(myz,n)
      !
c------------------------------------------------------------------
         mass(ns) = mnew
         if(mass(ns).le.0.) then
            s(ns)=0.
            smom(:,ns)=0.
         endif
         if (qlimit .and. prather_limits.eq.1) then ! force Prather limits
           smom(mx,ns)=min(1.5*s(ns),max(-1.5*s(ns),smom(mx,ns)))
           smom(mxx,ns)=min(2.*s(ns)-abs(smom(mx,ns))/3.,max(abs(smom(mx
     *          ,ns))-s(ns),smom(mxx,ns)))
           smom(mxy,ns)=min(s(ns),max(-s(ns),smom(mxy,ns)))
           smom(mzx,ns)=min(s(ns),max(-s(ns),smom(mzx,ns)))
         end if
c-----------------------------------------------------------------
         nm1 = n
      enddo
      return
      end subroutine adv1d

      subroutine limitq(anm1,an,fnm1,fn,sn,sx,sxx,ierr)
!@sum  limitq adjusts moments to maintain non-neg. tracer means/fluxes
!@auth G. Russell, modified by Maxwell Kelley
        implicit none
        REAL*8 :: anm1,an,fnm1,fn,sn,sx,sxx
c local variables
        REAL*8 :: sl,sc,sr, frl,frl1, frr,frr1, gamma,g13ab,
     &       fr,fr1, fsign,su,sd
        integer, intent(out) ::ierr
        ierr=0
c****
c**** modify the tracer moments so that the tracer mass in each
c**** division is non-negative
c****
c**** no air leaving the box
        if(anm1.ge.0. .and. an.le.0.) return
c**** air is leaving through both the left and right edges
        if(anm1.lt.0. .and. an.gt.0.) then
           sl = -fnm1
           sr = +fn
           sc = sn - sl
           sc = sc - sr
c**** all three divisions are non-negative
           if(sl.ge.0. .and. sr.ge.0. .and. sc.ge.0.) return
c**** first check for the cases when only one of the three is negative
           frl = anm1
           frl1 = frl+1.
           frr = an
           frr1 = frr-1.
           if(sl.ge.0. .and. sr.ge.0.) then ! center division
              gamma = 1.+(frl-frr)
              g13ab = gamma*gamma - 1. + 3.*(frl+frr)**2
              sxx = sxx - sc*10.*g13ab /
     &             (gamma*(12.*(frl+frr)**2 + 5.*g13ab*g13ab))
              sx = sx + sc*12.*(frl+frr) /
     &             (gamma*(12.*(frl+frr)**2 + 5.*g13ab*g13ab))
              sl = -frl*(sn-frl1*(sx-(frl+frl1)*sxx))
              sr = sn-sl
           else if(sr.ge.0.) then           ! leftmost division
              sxx = sxx + sl*(frl+frl1)/(frl*frl1*(.6d0+(frl+frl1)**2))
              sx = sn/frl1 + (frl+frl1)*sxx
              sr = frr*(sn-frr1*(sx-(frr+frr1)*sxx))
              sl = 0.
           else if(sl.ge.0.) then           ! rightmost division
              sxx = sxx - sr*(frr+frr1)/(frr*frr1*(.6d0+(frr+frr1)**2))
              sx = sn/frr1 + (frr+frr1)*sxx
              sl = -frl*(sn-frl1*(sx-(frl+frl1)*sxx))
              sr = 0.
           endif
           sc = sn - sl
           sc = sc - sr
c check for the cases where two of the three divisions are nonpositive
c these cases arise due to adjustments made when only one of the three
c divisions was negative
           if(sl.le.0. .and. sr.le.0.) then ! two outer divisions
              gamma = 1.+(frl-frr)
              sxx = sn*(1.+gamma)/(2.*gamma*frl1*frr1)
              sx  = sn*(frl+frr)*(1.+2.*gamma)/(2.*gamma*frl1*frr1)
              sl = 0.
              sr = 0.
           else if(sl.le.0. .and. sc.le.0.) then ! center/left divs
              sxx = sn/(2.*frr*frl1)
              sx  = sn*(frl+frr+.5)/(frr*frl1)
              sl = 0.
              sr = sn
           else if(sr.le.0. .and. sc.le.0.) then ! center/right divs
              sxx = sn/(2.*frl*frr1)
              sx  = sn*(frl+frr-.5)/(frl*frr1)
              sl = sn
              sr = 0.
           endif
           fnm1 = -sl
           fn   = +sr
        else
c**** air is leaving only through one edge
           if(an.gt.0.)  then ! right edge
              fr=an
              sd=fn
              fsign=-1.
           else                  ! left edge
              fr=anm1
              sd=-fnm1
              fsign=1.
           endif
           if(abs(fr).gt.1.)  then
c**** give warnings if fractional mass loss > 1
             ierr=1
             write(6,*) "limitq warning: abs(a)>1",fr,sd
             write(6,*) "limitq input: anm1,an,fnm1,fn,sn,sx,sxx",anm1
     *            ,an,fnm1,fn,sn,sx,sxx
c**** only stop if net tracer mass is negative
             if (sn+fnm1-fn.lt.0) then
               ierr=2
               write(6,*) "limitq error: new sn < 0",sn,sn+fnm1-fn
               return
             end if
           end if
           su = sn-sd
           if(sd.ge.0. .and. su.ge.0.) return
           fr1=fr+fsign
           if(sd.lt.0.)  then
c**** downstream division is negative
              sxx = sxx +fsign*sd*(fr+fr1)/(fr*fr1*(.6d0+(fr+fr1)**2))
              sx = sn/fr1 + (fr+fr1)*sxx
              su = sn
           else
c**** upstream division is negative
              sxx = sxx -fsign*su*(fr+fr1)/(fr*fr1*(.6d0+(fr+fr1)**2))
              sx = sn/fr + (fr+fr1)*sxx
              su = 0.
           endif
           sd = sn - su
           if(an.gt.0.) then
              fn=sd
           else
              fnm1=-sd
           endif
        endif
        return
      end subroutine limitq

      SUBROUTINE CTMIX (RM,RMOM,FMAIR,FMIX,FRAT)
!@sum CTMIX  Cloud top mixing of tracer moments (incl. q,t) from CONDSE
!@auth Gary Russell, Jean Lerner, Gavin Schmidt
!@ver 1.0
!@var RM,RX,RY,RZ,RXX,RYY,RZZ,RXY,RYZ,RZX mean and moments of tracer
      USE QUSDEF
      IMPLICIT NONE
      REAL*8, DIMENSION(2) :: RM
      REAL*8, DIMENSION(NMOM,2) :: RMOM
      REAL*8 FMIX      !@var FMIX  fraction of lower box mixed up
      REAL*8 FRAT      !@var FRAT  fraction of upper box mixed down
      REAL*8 FMAIR     !@var FMAIR mass of air mixed
      REAL*8 RTEMP     !@var RTEMP dummy variable

      RTEMP = RM(1)*(1.-FMIX)+FRAT*RM(2)
      RM(2) = RM(2)*(1.-FRAT)+FMIX*RM(1)
      RM(1) = RTEMP
C X
      RTEMP       = RMOM(MX ,1)*(1.-FMIX)+FRAT*RMOM(MX ,2)
      RMOM(MX ,2) = RMOM(MX ,2)*(1.-FRAT)+FMIX*RMOM(MX ,1)
      RMOM(MX ,1) = RTEMP
C Y
      RTEMP       = RMOM(MY ,1)*(1.-FMIX)+FRAT*RMOM(MY ,2)
      RMOM(MY ,2) = RMOM(MY ,2)*(1.-FRAT)+FMIX*RMOM(MY ,1)
      RMOM(MY ,1) = RTEMP
C XX
      RTEMP       = RMOM(MXX,1)*(1.-FMIX)+FRAT*RMOM(MXX,2)
      RMOM(MXX,2) = RMOM(MXX,2)*(1.-FRAT)+FMIX*RMOM(MXX,1)
      RMOM(MXX,1) = RTEMP
C YY
      RTEMP       = RMOM(MYY,1)*(1.-FMIX)+FRAT*RMOM(MYY,2)
      RMOM(MYY,2) = RMOM(MYY,2)*(1.-FRAT)+FMIX*RMOM(MYY,1)
      RMOM(MYY,1) = RTEMP
C XY
      RTEMP       = RMOM(MXY,1)*(1.-FMIX)+FRAT*RMOM(MXY,2)
      RMOM(MXY,2) = RMOM(MXY,2)*(1.-FRAT)+FMIX*RMOM(MXY,1)
      RMOM(MXY,1) = RTEMP
C Z MOMENTS
      RMOM(ZMOMS,:) = RMOM(ZMOMS,:)*(1.-FMAIR)

      END SUBROUTINE CTMIX


module intervals
   use constants
   implicit none
   private

   public :: interval

contains

   subroutine interval(x, a, b, n)
      real(dp), intent(out) :: x(:)
      real(dp), intent(in) :: a, b
      integer, intent(in), optional :: n
      !      n:      0      1      2      3
      ! binary:     00     01     10     11
      ! yields:  (a,b)  (a,b]  [a,b)  [a,b]

      integer :: i, j, k

      i = size(x)
      j = 1

      if (present(n)) then
         if (btest(n, 1)) j = j - 1
         if (btest(n, 0)) i = i - 1
      end if

      do k = 1, size(x)
         x(k) = i * a + j * b
         i = i - 1
         j = j + 1
      end do

      x = x / (i + j)
   end subroutine interval
end module intervals