module STI_SCHE
! Description:
!    Contains procedures necessary for the Stiefel-Scheifele formulation. The
!    procedures evaluate the right-hand-side of the Stiefel-Scheifele equations
!    (STISCHE_RHS), provide an event function for LSODAR (STISCHE_EVT), and
!    provide coordinate and time transformations (STISCHE_TE2TIME, STISCHE2CART,
!    CART2STISCHE).
!
! References:
!    [1] Stiefel, E. L. and Scheifele, G. "Linear and Regular Celestial Mechanics",
!     Springer-Verlag, 1971.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!     180608: change interface to PERT_EJ2K to add iF107.
!     180801: change call to perturbation routine, PERT_EJ2K. Eliminate needless
!             use associations. Refine comments.
!     190110: Add check for collision with the Moon.
!
! ==============================================================================

use KINDS, only: dk
implicit none

contains

! ==============================================================================
! 01. INTEGRATION PROCEDURES
! ==============================================================================

subroutine STISCHE_RHS(neq,phi,z,zdot)
! Description:
!    Computes the value of the right-hand side of the equations of motion of the
!    EDromo formulation.
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!     180608: change interface to PERT_EJ2K to add iF107.
!     180801: change call to perturbation routine, PERT_EJ2K. Eliminate needless
!             use associations.
!
! ==============================================================================

! ! MODULES
use SETTINGS,      only: eqs,insgrav,isun,imoon,idrag,iF107,iSRP
use PHYS_CONST,    only: GE_nd
use PERTURBATIONS, only: PERT_EJ2K

! VARIABLES
implicit none

! Arguments
integer,intent(in)    ::  neq              ! Number of equations
real(dk),intent(in)   ::  phi              ! StiSche independent variable
real(dk),intent(in)   ::  z(1:neq)         ! StiSche state vector, ND
real(dk),intent(out)  ::  zdot(1:neq)      ! RHS of EoM's, ND

! Auxiliary quantities
real(dk)  ::  sph2,cph2
real(dk)  ::  aux(1:4),lte1,lte2,lte3
integer   ::  flag_time

! K-S state vector and its derivative
real(dk)  ::  u(1:4)
real(dk)  ::  du(1:4)

! State
real(dk)  ::  rV(1:3),vV(1:3),t
! real(dk)  ::  x_vec(1:3),y_vec(1:3)
real(dk)  ::  rmag,vsq

! Perturbations
real(dk)  ::  Vpot,mdVdr(1:3),dVdu(1:4),dVdt  ! Perturbing potential and its derivatives
real(dk)  ::  p(1:3),Lp(1:4)             ! Non-conservative perturbing accelerations

! ==============================================================================

! STATE VECTOR DICTIONARY

! z(1:4) = alpha
! z(5:8) = beta
! z(9)   = omega
! z(10)  = time (flag_time = 0) or time element (flag_time = 1)

! ==============================================================================
! 01. AUXILIARY QUANTITIES (1)
! ==============================================================================

! Store trig functions
sph2 = sin(0.5_dk*phi)
cph2 = cos(0.5_dk*phi)

! ==============================================================================
! 02. POSITION AND VELOCITY IN INERTIAL FRAME, TIME
! ==============================================================================

! K-S vector, Eq. (19,50)
u = z(1:4)*cph2 + z(5:8)*sph2
! Derivative of K-S vector, Eq. (19,51)
du = .5_dk*(-z(1:4)*sph2 + z(5:8)*cph2)

! Position in inertial frame. Eq. (19,56).
rV = [u(1)**2 - u(2)**2 - u(3)**2 + u(4)**2,&
      2._dk*(u(1)*u(2) - u(3)*u(4))        ,&
      2._dk*(u(1)*u(3) + u(2)*u(4))         ]
rmag = dot_product(u,u)

! Velocity in inertial frame. Eq. (19,58)
vV = 4._dk*z(9)/rmag*&
    [u(1)*du(1) - u(2)*du(2) - u(3)*du(3) + u(4)*du(4),  &
     u(2)*du(1) + u(1)*du(2) - u(4)*du(3) - u(3)*du(4),  &
     u(3)*du(1) + u(4)*du(2) + u(1)*du(3) + u(2)*du(4)]
vsq = dot_product(vV,vV)

flag_time = eqs - 7

! Get time
if ( flag_time == 0 ) then
    ! Physical time
    t = z(10)
elseif  ( flag_time == 1 ) then
    ! Linear time element
    t = z(10) - dot_product(u,du)/z(9)
end if

! ==============================================================================
! 03. PERTURBING POTENTIAL
! ==============================================================================

! Initialize
Vpot = 0._dk; dVdt = 0._dk; mdVdr = 0._dk
! Evaluate potential perturbations
call PERT_EJ2K(insgrav,0,0,0,0,0,rV,vV,rmag,t,mdVdr,Vpot,dVdt)

! ==============================================================================
! 04. PERTURBING ACCELERATIONS
! ==============================================================================

! Initializations
p = 0._dk
call PERT_EJ2K(0,isun,imoon,idrag,iF107,iSRP,rV,vV,rmag,t,p)

! ==============================================================================
! 05. COMPUTE AUXILIARY QUANTITIES (2)
! ==============================================================================

! Eq. (19,60)
Lp = [ u(1)*p(1) + u(2)*p(2) + u(3)*p(3),  &
      -u(2)*p(1) + u(1)*p(2) + u(4)*p(3),  &
      -u(3)*p(1) - u(4)*p(2) + u(1)*p(3),  &
       u(4)*p(1) - u(3)*p(2) + u(2)*p(3)   ]

! Eq. (9,44) - note that mdVdr = -dV/dr
dVdu = -2._dk*[u(1)*mdVdr(1) + u(2)*mdVdr(2) + u(3)*mdVdr(3),  &
              -u(2)*mdVdr(1) + u(1)*mdVdr(2) + u(4)*mdVdr(3),  &
              -u(3)*mdVdr(1) - u(4)*mdVdr(2) + u(1)*mdVdr(3),  &
               u(4)*mdVdr(1) - u(3)*mdVdr(2) + u(2)*mdVdr(3)]

! ==============================================================================
! 06. COMPUTE RIGHT-HAND SIDE
! ==============================================================================

! Eq. (19,61)
zdot(9) = -rmag/(8._dk*z(9)**2)*dVdt - .5_dk/z(9)*dot_product(du,Lp)

! Eq. (19,63)
aux = (.5_dk/z(9)**2) * (.5_dk*Vpot*u + rmag/4._dk * (dVdu - 2._dk*Lp)) + &
    &   2._dk/z(9) * zdot(9) * du

zdot(1:4) =  aux*sph2
zdot(5:8) = -aux*cph2

! Time / Time Element
if (flag_time == 0) then
   ! Generalized Sundman transformation
   zdot(10) = .5_dk*rmag/z(9)

else if (flag_time == 1) then   ! Linear Time Element
   ! Eq. (19,62)
   lte1 = (GE_nd - 2._dk*rmag*Vpot)/(8._dk*z(9)**3)
   lte2 = (rmag/(16._dk*z(9)**3)) * dot_product(u,dVdu - 2._dk*Lp)
   lte3 = (2._dk/z(9)**2) * zdot(9) * dot_product(u,du)
   zdot(10) = lte1 - lte2 - lte3

end if

end subroutine STISCHE_RHS

subroutine STISCHE_EVT(neq,phi,z,ng,roots)
! Description:
!    Finds roots to stop the integration for the SS formulation.
!
! Revisions:
!    190110: Add header comments. Add check for collision with the Moon.
!
! ==============================================================================

! MODULES
use SUN_MOON,    only: EPHEM
use AUXILIARIES, only: MJD0,MJDnext,MJDf,DU,TU
use PHYS_CONST,  only: secsPerDay,RE,reentry_radius_nd,ReqM
use SETTINGS,    only: eqs, imoon, imcoll

! VARIABLES
implicit none
! Arguments IN
integer,intent(in)    ::  neq
integer,intent(in)    ::  ng
real(dk),intent(in)   ::  phi
real(dk),intent(in)   ::  z(1:neq)
! Arguments OUT
real(dk),intent(out)  ::  roots(1:ng)

! Locals
integer   ::  flag_time
real(dk)  ::  t                   ! Current time [-]
real(dk)  ::  sph2,cph2,rmag, dmag
real(dk)  ::  r_vec(1:3), v_vec(1:3), rMoon(1:3), vMoon(1:3)
real(dk)  ::  u(1:4)

! ==============================================================================

roots = 1._dk

! Get time
flag_time = eqs - 7
t = STISCHE_TE2TIME(z,phi,flag_time)

! ==============================================================================
! 01. Next timestep
! ==============================================================================

roots(1) = t - (MJDnext - MJD0)*secsPerDay*TU

! ==============================================================================
! 02. Stop integration
! ==============================================================================

roots(2) = t - (MJDf - MJD0)*secsPerDay*TU

! ==============================================================================
! 03. Earth re-entry
! ==============================================================================
sph2 = sin(phi/2._dk)
cph2 = cos(phi/2._dk)
u    = z(1:4)*cph2 + z(5:8)*sph2

rmag = dot_product(u,u)

roots(3) = rmag - reentry_radius_nd

! ==============================================================================
! 04. Moon collision (only active when Moon is present)
! ==============================================================================

! All quantities are dimensional. Accuracy could be improved by using
! dimensionless quantities, but this would require
! non-dimensionalizing ReqM in some part of the code, which would worsen the
! code reliability.
roots(4) = 1.
if (imoon > 0 .and. (imcoll /= 0)) then
  call STISCHE2CART(phi,z,r_vec,v_vec)
  r_vec = r_vec * DU
  call EPHEM(2, 1._dk, 1._dk, t, rMoon, vMoon)
  dmag = sqrt(dot_product( (r_vec - rMoon), (r_vec - rMoon) ) )
  roots(4) = dmag - ReqM

end if

end subroutine STISCHE_EVT

! ==============================================================================
! 02. TRANSFORMATIONS AND PROCESSING PROCEDURES
! ==============================================================================

function STISCHE_TE2TIME(z,phi,flag_time)
! Description:
!    Gets the value of physical time from the Stiefel-Scheifele state vector "z" and
!    fictitious time "phi".
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments IN
real(dk),intent(in)  ::  z(1:10),phi
integer,intent(in)   ::  flag_time
! Locals
real(dk)             ::  alphaSq,betaSq,alphaDotBeta
! Function definition
real(dk)  ::  STISCHE_TE2TIME

! ==============================================================================

if ( flag_time == 0 ) then
    ! Physical time
    STISCHE_TE2TIME = z(10)

else if  ( flag_time == 1 ) then
    ! Linear time element. This is derived by plugging Eq. (19, 55) in
    ! Eq. (19,59)
    alphaSq = dot_product(z(1:4),z(1:4))
    betaSq  = dot_product(z(5:8),z(5:8))
    alphaDotBeta = dot_product(z(1:4),z(5:8))
    STISCHE_TE2TIME = z(10) +&
    &.5_dk*( (alphaSq-betaSq)/2._dk * sin(phi) - alphaDotBeta * cos(phi) )/z(9)

end if

end function STISCHE_TE2TIME

subroutine CART2STISCHE(R,V,t0,mu,DU,TU,z,phi,W,flag_time)
! Description:
!    Converts from Cartesian coordinates to Stiefel-Scheifele elements. It requires
!    the current values of the fictitious time, perturbing potential and initial
!    time.
!
!===============================================================================

! VARIABLES
implicit none

! Arguments
integer,parameter     ::  neq = 10	  ! Number of elements of Stiefel-Scheifele state vector
real(dk),intent(in)   ::  R(1:3),V(1:3)	  ! Dimensional position and velocity [km,km/s]
real(dk),intent(in)   ::  mu              ! Gravitational parameter (dimensional)
real(dk),intent(in)   ::  DU,TU           ! Ref. quantities for non-dimensionalization
real(dk),intent(in)   ::  phi             ! Initial phi value
real(dk),intent(in)   ::  t0              ! Initial time value [s]
real(dk),intent(in)   ::  W               ! Potential energy [km^2/s^2]
integer,intent(in)    ::  flag_time	  ! = 0 physical time
         				  ! = 1 constant time element
					  ! = 2 linear time element
real(dk),intent(out)  ::  z(1:neq)        ! Stiefel-Scheifele state vector

! Local variables
real(dk)  ::  x(1:3)           		        ! Cartesian position, ND
real(dk)  ::  xdot(1:3)                     ! Cartesian velocity, ND
real(dk)  ::  Ksq                           ! Grav parameter, ND
real(dk)  ::  Rmag,Vmag 	                ! Radius and velocity magnitudes, ND
real(dk)  ::  pot0           		        ! Potential, ND
real(dk)  ::  totEn0           		        ! Initial total energy, ND
real(dk)  ::  cph2,sph2
real(dk)  ::  u_vec(1:4),du_vec(1:4)            ! K-S parameters and their derivatives
real(dk)  ::  GE                	        ! Auxiliary variable
real(dk)  ::  zero             		        ! Reference machine zero

! ==============================================================================

! ==============================================================================
! 01. NON-DIMENSIONALIZATION
! ==============================================================================
x(1:3)    = R/DU
xdot(1:3) = V/(DU*TU)
pot0      = W/(DU*TU)**2
Ksq       = mu/(DU**3*TU**2)

! ==============================================================================
! 02. AUXILIARY QUANTITIES
! ==============================================================================
! Compute machine zero for comparisons
zero = epsilon(0._dk)

Rmag = sqrt(dot_product(x(1:3),x(1:3)))
cph2 = cos(phi/2._dk)
sph2 = sin(phi/2._dk)

! ==============================================================================
! 03. COMPUTE z(1) - z(9)
! ==============================================================================
! Total energy
totEn0  = .5_dk*dot_product(xdot,xdot) - Ksq/Rmag + pot0
z(9) = sqrt(-totEn0/2._dk)

! K-S parameters
if ( x(1) >= 0._dk ) then
   u_vec(1) = 0._dk
   u_vec(4) = sqrt(.5_dk*(Rmag + x(1)) - u_vec(1)**2)
   u_vec(2) = (x(2)*u_vec(1) + x(3)*u_vec(4))/(Rmag + x(1))
   u_vec(3) = (x(3)*u_vec(1) - x(2)*u_vec(4))/(Rmag + x(1))
else
   u_vec(2) = 0._dk
   u_vec(3) = sqrt(.5_dk*(Rmag - x(1)) - u_vec(2)**2)
   u_vec(1) = (x(2)*u_vec(2) + x(3)*u_vec(3))/(Rmag - x(1))
   u_vec(4) = (x(3)*u_vec(2) - x(2)*u_vec(3))/(Rmag - x(1))
end if
! Derivatives of the K-S parameters wrt the independent variable
du_vec(1) = ( u_vec(1)*xdot(1) + u_vec(2)*xdot(2) + u_vec(3)*xdot(3))/(4._dk*z(9))
du_vec(2) = (-u_vec(2)*xdot(1) + u_vec(1)*xdot(2) + u_vec(4)*xdot(3))/(4._dk*z(9))
du_vec(3) = (-u_vec(3)*xdot(1) - u_vec(4)*xdot(2) + u_vec(1)*xdot(3))/(4._dk*z(9))
du_vec(4) = ( u_vec(4)*xdot(1) - u_vec(3)*xdot(2) + u_vec(2)*xdot(3))/(4._dk*z(9))

z(1:4) = cph2*u_vec - 2._dk*sph2*du_vec
z(5:8) = sph2*u_vec + 2._dk*cph2*du_vec

! ==============================================================================
! 04. TIME / TIME ELEMENT
! ==============================================================================
if ( flag_time == 0 ) then
    ! Physical time
    z(10) = t0*TU

elseif  ( flag_time == 1 ) then
    ! Linear time element
    z(10) = t0*TU + dot_product(u_vec,du_vec)/z(9)

end if

end subroutine CART2STISCHE

subroutine STISCHE2CART(phi,z,r,v)
! Description:
!    Transforms from the Stiefel-Scheifele state vector "z" and fictitious time
!    "phi" to Cartesian position and velocity "r", "v".
!    **All quantities are dimensionless, unlike in CART2STISCHE**.
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments IN
real(dk),intent(in)   ::  z(1:10),phi
! Arguments OUT
real(dk),intent(out)  ::  r(1:3),v(1:3)

! Auxiliaries
real(dk)  ::  sph2,cph2
real(dk)  ::  rmag
real(dk)  ::  u(1:4),du(1:4)

! ==============================================================================

! ==============================================================================
! 01. AUXILIARY QUANTITIES
! ==============================================================================

! Store trig functions
sph2 = sin(phi/2._dk)
cph2 = cos(phi/2._dk)

! ==============================================================================
! 02. POSITION IN INERTIAL FRAME
! ==============================================================================

! K-S state vector and its derivative
u  = z(1:4)*cph2 + z(5:8)*sph2
du = .5_dk*( -z(1:4)*sph2 + z(5:8)*cph2)

! Position in inertial frame
r = [u(1)**2 - u(2)**2 - u(3)**2 + u(4)**2,  &
     2._dk*(u(1)*u(2) - u(3)*u(4)),  &
     2._dk*(u(1)*u(3) + u(2)*u(4))]
rmag = u(1)**2 + u(2)**2 + u(3)**2 + u(4)**2

! ==============================================================================
! 03. VELOCITY IN INERTIAL FRAME
! ==============================================================================

v = 4._dk*z(9)/rmag*&
    [u(1)*du(1) - u(2)*du(2) - u(3)*du(3) + u(4)*du(4),  &
     u(2)*du(1) + u(1)*du(2) - u(4)*du(3) - u(3)*du(4),  &
     u(3)*du(1) + u(4)*du(2) + u(1)*du(3) + u(2)*du(4)]

end subroutine STISCHE2CART

end module STI_SCHE


      subroutine qlbox1(Y,musq,Ires)
c    $I_4^{D=4-2 \epsilon}(0,0,0,0;s_{12},s_{23};0,0,0,0)$}
c----%\cite{Bern:1993kr}
c----\bibitem{Bern:1993kr}
c----  Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
c----  %``Dimensionally regulated pentagon integrals,''
c----  Nucl.\ Phys.\ B {\bf 412}, 751 (1994)
c----  [arXiv:hep-ph/9306240].
c----  %%CITATION = HEP-PH 9306240;%%
c----  Eqn (I.11)
c----Cayley matrix
c                [                 s12        ]
c                [   0      0    - ---    0   ]
c                [                  2         ]
c                [                            ]
c                [                        s23 ]
c                [   0      0      0    - --- ]
c                [                         2  ]
c           Y1 = [                            ]
c                [   s12                      ]
c                [ - ---    0      0      0   ]
c                [    2                       ]
c                [                            ]
c                [          s23               ]
c                [   0    - ---    0      0   ]
c                [           2                ]
      implicit none
      include 'qlconstants.f'
      double precision musq,Y(4,4),si,ta
      double complex Ires(-2:0),qllnrat,fac

      si=two*Y(1,3)
      ta=two*Y(2,4)
      fac=dcmplx(1d0/(si*ta))
      Ires(-2)=fac*ctwo*ctwo
      Ires(-1)=fac*ctwo*(
     . -qllnrat(ta,musq)-qllnrat(si,musq))
      Ires( 0)=fac*(qllnrat(ta,musq)**2+qllnrat(si,musq)**2
     . -qllnrat(ta,si)**2-dcmplx(pi**2))
      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine gaspipe_fanno(node1,node2,nodem,nelem,lakon,kon,
     &        ipkon,nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &        nodef,idirf,df,cp,r,physcon,dvi,numf,set,
     &        shcon,nshcon,rhcon,nrhcon,ntmat_,co,vold,mi,iaxial)
!
!     pipe with friction losses (Fanno Formulas) GAPF
!
!     author: Yannick Muller
!
      implicit none
!
      logical identity,crit
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,numf,
     &     ielprop(*),nodef(5),idirf(5),index,iflag,
     &     inv,ipkon(*),kon(*),icase,kgas,k_oil
     &     ,nshcon(*),nrhcon(*),ntmat_,i,mi(*),nodea,nodeb,
     &     nodec,iaxial
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,R,a,d,l,
     &     p1,p2,T1,T2,Tt1,Tt2,pt1,pt2,cp,physcon(3),p2p1,km1,dvi,
     &     kp1,kdkm1,reynolds,pi,e,lambda,lld,kdkp1,T2dTt2,
     &     T1dTt1,X_t1dTt1,X_t2dTt2,X2_den,X1_den,
     &     X1,X2,B1,B2,C1,C2,tdkp1,
     &     pt2zpt1,ks,form_fact,xflow_oil,Tt1dT1,Tt2dT2,
     &     Pt2zPt1_c,qred_crit,l_neg,Qred,
     &     expon1,expon2,cte,term1,term2,term3,term4,term5,term6,
     &     term,phi,M1,M2,qred2,qred1,qred_max1,qred_crit_out,co(3,*),
     &     shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),vold(0:mi(2),*),
     &     radius,initial_radius,l_initial
!
      if (iflag.eq.0) then
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif (iflag.eq.1)then
!
         crit=.false.
!
         pi=4.d0*datan(1.d0)
!
         index=ielprop(nelem)
         kappa=(cp/(cp-R))
         A=prop(index+1)
         d=prop(index+2)
         l=prop(index+3)
         if(l.lt.0d0) then
            l_neg=l
            l=abs(l)
         else
            l_neg=l
         endif
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPFA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPFI') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=int(prop(index+7))
!
         if((lakon(nelem)(2:6).eq.'GAPFF').and.
     &        (lakon(nelem)(2:7).ne.'GAPFF2')) then
!
            icase=0
            nodea=int(prop(index+1))
            nodeb=int(prop(index+2))
c            iaxial=int(prop(index+3))
            radius=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &           co(1,nodea)-vold(1,nodea))**2)
!
            initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2)
!
c            if(iaxial.ne.0) then
c              A=pi*radius**2/iaxial
c            else
              A=pi*radius**2
c            endif
            d=2*radius
            l=prop(index+4)
            if(l.lt.0d0) then
               l_neg=l
               l=abs(l)
            else
               l_neg=l
            endif
            ks=prop(index+5)
            form_fact=prop(index+6)
            xflow_oil=prop(index+7)
            k_oil=int(prop(index+8))
!
         elseif (lakon(nelem)(2:7).eq.'GAPFF2') then
            write(*,*) nelem,lakon(nelem)(1:6)
            icase=0
            nodea=int(prop(index+1))
            nodeb=int(prop(index+2))
            nodec=int(prop(index+3))
c            iaxial=int(prop(index+4))
            radius=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &           co(1,nodea)-vold(1,nodea))**2)
            initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2)
            d=2*radius
c           if(iaxial.ne.0) then
c              A=pi*radius**2/iaxial
c            else
               A=pi*radius**2
c            endif
            l_initial=dsqrt((co(2,nodec)-co(2,nodeb))**2)
            l=dsqrt((co(2,nodec)+vold(2,nodec)-
     &           co(2,nodeb)-vold(2,nodeb))**2)
            if(l.lt.0d0) then
               l_neg=l
               l=abs(l)
            else
               l_neg=l
            endif
            ks=prop(index+5)
            form_fact=prop(index+6)
            xflow_oil=prop(index+7)
            k_oil=int(prop(index+8))
         endif
!
         pt1=v(2,node1)
         pt2=v(2,node2)
!
         if(pt1.ge.pt2) then
            inv=1
            Tt1=v(0,node1)+physcon(1)
            Tt2=v(0,node2)+physcon(1)
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            Tt1=v(0,node2)+physcon(1)
            Tt2=v(0,node1)+physcon(1)
         endif
!
         p2p1=pt2/pt1
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         tdkp1=2.d0/kp1
         C2=tdkp1**kdkm1
!
!     incompressible flow
         xflow=inv*A*dsqrt(d/l*2*Pt1/(R*Tt1)*(pt1-pt2))
         if(p2p1.gt.C2) then
           xflow=inv*pt1*a*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa)
     &           *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(Tt1)
         else
            xflow=inv*pt1*a*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/
     &           dsqrt(Tt1)
         endif
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1E-30) then
            kgas=0
            call dynamic_viscosity(kgas,Tt1,dvi)
         endif
!
         reynolds=dabs(xflow)*d/(dvi*a)
!
         call friction_coefficient(l_neg,d,ks,reynolds,form_fact,lambda)
         xflow=inv*A*dsqrt(d/(lambda*l)*2*Pt1/(R*Tt1)*(pt1-pt2))
!
         call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag,
     &     inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase)
!
         Qred=dabs(xflow)*dsqrt(Tt1)/(A*pt1)
!
         if (crit) then
            xflow=0.5*inv*Qred_crit*Pt1*A/dsqrt(Tt1)
            if(icase.eq.1) then
!
               call ts_calc(xflow,Tt1,pt1,kappa,r,a,T1,icase)
               if (inv.eq.1) then
                  v(3,node1)=T1
                  v(3,node2)=T1
                  if(nactdog(0,node2).eq.1) then
                     v(0,node2)=T1*(1.d0+km1/(2*kappa))
                  endif
               else
                  v(3,node2)=T1
                  v(3,node1)=T1
                  if(nactdog(0,node1).eq.1) then
                     v(0,node1)=T1*(1.d0+km1/(2*kappa))
                  endif
               endif
            endif
         elseif(Qred.gt.Qred_crit) then
            xflow=0.5*inv*Qred_crit*pt1*A/dsqrt(Tt1)
         else
            xflow=inv*Qred*pt1*A/dsqrt(Tt1)
         endif
!
      elseif (iflag.eq.2)then
!
         numf=5
         crit=.false.
!
         pi=4.d0*datan(1.d0)
         e=2.7182818d0
!
         kappa=(cp/(cp-R))
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         kdkp1=kappa/kp1
!
         index=ielprop(nelem)
         A=prop(index+1)
         d=prop(index+2)
!
         l=prop(index+3)
         if(l.lt.0d0) then
            l_neg=l
            l=abs(l)
         else
            l_neg=l
         endif
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPFA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPFI') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=int(prop(index+7))
!
                  if((lakon(nelem)(2:6).eq.'GAPFF').and.
     &        (lakon(nelem)(2:7).ne.'GAPFF2')) then
            icase=0
            nodea=int(prop(index+1))
            nodeb=int(prop(index+2))
c            iaxial=int(prop(index+3))
            radius=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &           co(1,nodea)-vold(1,nodea))**2)
            initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2)
            d=2*radius
c           if(iaxial.ne.0) then
c              A=pi*radius**2/iaxial
c            else
               A=pi*radius**2
c            endif
            l=prop(index+4)
            if(l.lt.0d0) then
               l_neg=l
               l=abs(l)
            else
               l_neg=l
            endif
            ks=prop(index+5)
            form_fact=prop(index+6)
            xflow_oil=prop(index+7)
            k_oil=int(prop(index+8))
!
         elseif (lakon(nelem)(2:7).eq.'GAPFF2') then
            icase=0
            nodea=int(prop(index+1))
            nodeb=int(prop(index+2))
            nodec=int(prop(index+3))
c            iaxial=int(prop(index+4))
            radius=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &           co(1,nodea)-vold(1,nodea))**2)
            initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2)
            d=2*radius
c           if(iaxial.ne.0) then
c              A=pi*radius**2/iaxial
c            else
               A=pi*radius**2
c            endif
            l_initial=dsqrt((co(2,nodec)-co(2,nodeb))**2)
            l=-dsqrt((co(2,nodec)+vold(2,nodec)-
     &           co(2,nodeb)-vold(2,nodeb))**2)
            if(l.lt.0d0) then
               l_neg=l
               l=abs(l)
            else
               l_neg=l
            endif
            ks=prop(index+5)
            form_fact=prop(index+6)
            xflow_oil=prop(index+7)
            k_oil=int(prop(index+8))
         endif
!
         pt1=v(2,node1)
         pt2=v(2,node2)
         xflow=v(1,nodem)*iaxial
!
         if((pt1.gt.pt2).or.(xflow.ge.0d0)) then
            inv=1
            Tt1=v(0,node1)+physcon(1)
            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
            if(icase.eq.0) then
               Tt2=Tt1
               call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
            else
               t2=t1
               Tt2=v(0,node2)+physcon(1)
            endif
!
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
            nodef(5)=node2
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            Tt1=v(0,node2)+physcon(1)
            if(icase.eq.0) then
               Tt2=Tt1
            else
               Tt2=v(0,node1)+physcon(1)
            endif
!
            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
!
            call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
!
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
            nodef(5)=node1
         endif
!
         idirf(1)=2
         idirf(2)=0
         idirf(3)=1
         idirf(4)=2
         idirf(5)=0
!
         pt2zpt1=pt2/pt1
!
!     calculation of the dynamic viscosity
!
           if(dabs(dvi).lt.1E-30) then
              kgas=0
              call dynamic_viscosity(kgas,T1,dvi)
           endif
!
           reynolds=dabs(xflow)*d/(dvi*a)
!
           if(reynolds.lt.1) then
              reynolds = 1.d0
           endif
!
!     definition of the friction coefficient for 2 phase flows and pure air
!
!     Friedel's Method
         if(lakon(nelem)(7:7).eq.'F') then
!
            if((k_oil.lt.0).or.(k_oil.gt.12)) then
               write(*,*) '*ERROR:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the type of oil is not defined'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Current calculation stops here'
               call exit(201)
            elseif(xflow_oil.eq.0.d0) then
               write(*,*) '*WARNING:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the oil mass flow rate is NULL'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Only pure air is considered'
               call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &              lambda)
            else
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi)
!
               lambda=lambda*phi
!
            endif
!
!     Alber's Method
!
         elseif (lakon(nelem)(7:7).eq.'A') then
            if((k_oil.lt.0).or.(k_oil.gt.12)) then
               write(*,*) '*ERROR:in gaspipe_fanno.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the type of oil is not defined'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Current calculation stops here'
               call exit(201)
            elseif(xflow_oil.eq.0) then
               write(*,*) '*WARNING:in gaspipe_fanno.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the oil mass flow rate is NULL'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Only pure air is considered'
               call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &              lambda)
            else
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi)
!
               call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &              lambda)
!
               lambda=lambda*phi
!
            endif
!
!     for pure air
!
         else
!
            phi=1.d0
            call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &           lambda)
         endif
!
         call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag,
     &     inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase)
!
         Qred1=xflow*dsqrt(Tt1)/(A*Pt1)
!
         if(dabs(xflow)*dsqrt(Tt1)/(A*Pt1).gt.qred_max1) then
            crit=.true.
         endif
!
         Qred2=xflow*dsqrt(Tt2)/(A*Pt2)
         if(icase.eq.0) then
            qred_crit_out=dsqrt(kappa/R)*(2/(kappa+1))**(0.5d0*
     &           (kappa+1)/(kappa-1))
         else
            qred_crit_out=R**(-0.5d0)*(2/(kappa+1))**(0.5d0*
     &           (kappa+1)/(kappa-1))
         endif
!
!     definition of the coefficients
!
         lld=lambda*l/d
!
         M2=dsqrt(2/km1*((Tt2/T2)-1))
         if(icase.eq.0) then
            if((M2.lt.1)) then
               crit=.false.
               if((M2.ge.1.d0).or.(dabs(M2-1).lt.1E-5)) then
                  pt2=pt1*pt2zpt1_c
               endif
            endif
         elseif (icase.eq.1) then
            if(M2.lt.1/dsqrt(kappa)) then
               crit=.false.
            else
               crit=.true.
            endif
         endif
!
!     adiabatic case
!
         if(icase.eq.0) then
!
            T2dTt2=T2/Tt2
            Tt2dT2=1.d0/T2dTt2
            X_T2dTt2=T2dTt2**(2*kdkm1)
            T1dTt1=T1/Tt1
            Tt1dT1=1.d0/T1dTt1
            X_T1dTt1=T1dTt1**(2*kdkm1)
!
            X2_den=pt2**2*X_T2dTt2
            X2=t2**2/X2_den
            X1_den=pt1**2*X_T1dTt1
            X1=T1**2/X1_den
!
!            C1=2.d0*cp*A**2*X1_den*(-1.d0+2.d0*kdkm1*T1dTt1)
!     &           -2.d0*xflow**2*R**2*T1
            C1=2.d0*cp*A**2*X1_den*(-1.d0+2.d0*kdkm1*(T1dTt1-1))
     &           -2.d0*xflow**2*R**2*T1
!
!            C2=2.d0*cp*A**2*X2_den*(-1.d0+2.d0*kdkm1*T2dTt2)
!     &           -2.d0*xflow**2*R**2*T2
            C2=2.d0*cp*A**2*X2_den*(-1.d0+2.d0*kdkm1*(T2dTt2-1))
     &           -2.d0*xflow**2*R**2*T2
!
            expon1=(kappa+1)/km1
            expon2=2*kappa/(km1)
!
            cte=0.5d0*(kappa+1)/kappa
!
            term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2
!
            if(.not.crit) then
               term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2
               term2=pt2**2*T2**expon1*Tt2**(-expon2)*A**2
!
!     simplified version
               term3=Tt2dT2
               term4=Tt1dT1
!
               term5=T1**(expon1)*Tt1**(-expon2)*(pt1**2)
               term6=T2**(expon1)*Tt2**(-expon2)*(pt2**2)
!
               B1=1/(R*xflow**2)*term1*expon1/T1
     &              +cte*(-(2/km1)*1/T1)
!
               B2=1/(R*xflow**2)*term2*(-expon1/T2)
     &              +cte*(2/km1*1/T2)
!
!     residual
!
!     Simplified version
!
               f=1/(R*xflow**2)*(term1-term2)
     &              +cte*(log(term3)-log(term4)-log(term5)+log(term6))
     &              -lld
     &              +b2/c2*(2*cp*A**2*(Tt2-T2)
     &              *X2_den-xflow**2*R**2*T2**2)
     &              +b1/c1*(2*cp*A**2*(Tt1-T1)
     &              *X1_den-xflow**2*R**2*T1**2)
!
!     pressure node1
!
               df(1)=1/(R*xflow**2)*(term1*2/pt1)
     &              +cte*(-2/pt1)
     &              +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1)
!
!     temperature node1
!
               df(2)=1/(R*xflow**2)*term1*(-expon2)/Tt1
     &              +cte*(expon1*1/Tt1)
     &              +b1/c1*(2*cp*A**2*X1_den
     &              *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1))
!
!     mass flow
!
               df(3)=-2.d0/(R*(inv*xflow)**3)*(term1-term2)
     &              +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0)
     &              +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0)
!
!     pressure node2
!
               df(4)=1/(R*xflow**2)*(-term2*2/pt2)
     &              +cte*(2/pt2)
     &              +B2/C2*(4.d0*cp*A**2*(Tt2-T2)*pt2*X_T2dTt2)
!
!     temperature node2
!
               df(5)=1/(R*xflow**2)*term2*(expon2/Tt2)
     &              +cte*(-expon1*1/Tt2)
     &              +b2/c2*(2*cp*A**2*X2_den
     &              *(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2))
!
            else
!
               term=kappa*term1/(xflow**2*R)
               B1=expon1*1/T1*(1/kappa*term-1)+cte*1/T1
!     f=1/kappa*(term1-1)+cte*(log(T1dTt1)-log(2/kp1*term))
               f=1/kappa*(term-1)+cte*(log(T1dTt1)-log(2/kp1*term))
     &              -lld
     &              +b1/c1*(2*cp*A**2*(Tt1-T1)
     &              *X1_den-xflow**2*R**2*T1**2)
!
!     pressure node1
!
               df(1)=2/pt1*(1/kappa*term-cte)
     &              +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1)
!
!     temperature node1
!
               df(2)=expon2*1/Tt1*(-1/kappa*term+1)-cte*1/Tt1
     &              +b1/c1*(2*cp*A**2*X1_den
     &              *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1))
!
!     mass flow
!
               df(3)=2.d0/(inv*xflow)*(-term/kappa+cte)
     &              +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0)
!
!     pressure node2
!
               df(4)=0.d0
!
!     temperature node2
!
               df(5)=0.d0
!
            endif
!
!     isothermal icase
!
         elseif(icase.eq.1) then
               T2dTt2=T2/Tt2
               Tt2dT2=1.d0/T2dTt2
               X_T2dTt2=T2dTt2**(2*kdkm1)
               T1dTt1=T1/Tt1
               Tt1dT1=1.d0/T1dTt1
               X_T1dTt1=T1dTt1**(2*kdkm1)
!
               X2_den=pt2**2*X_T2dTt2
               X2=t2**2/X2_den
               X1_den=pt1**2*X_T1dTt1
               X1=T1**2/X1_den
!
               C1=2.d0*cp*A**2*X1_den*(1.d0-2.d0*kdkm1*(Tt1dT1-1.d0))
     &              +2.d0*xflow**2*R**2*T1
!
               C2=2.d0*cp*A**2*X2_den*(1.d0-2.d0*kdkm1*(Tt2dT2-1.d0))
     &              +2.d0*xflow**2*R**2*T2
!
               expon1=(kappa+1)/km1
               expon2=2*kappa/(kappa-1)
!
               cte=0.5d0*(kappa+1)/kappa
!
               term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2
               term2=pt2**2*T2**expon1*Tt2**(-expon2)*A**2
!
               term5=T1**(expon1)*Tt1**(-expon2)*(pt1**2*A**2)
               term6=T2**(expon1)*Tt2**(-expon2)*(pt2**2*A**2)
!
            if(.not.crit) then
               B1=1/(R*xflow**2)*term1*expon1/T1
     &              -expon1/T1
!
               B2=1/(R*xflow**2)*term2*(-expon1/T2)
     &              +expon1/T2
!
!     Simplified version
!
               f=1/(R*xflow**2)*(term1-term2)
     &              +(-log(term5)+log(term6))
     &              -lld
     &              +b2/c2*(2*cp*A**2*(Tt2-T2)
     &              *X2_den-xflow**2*R**2*T2**2)
     &              +b1/c1*(2*cp*A**2*(Tt1-T1)
     &              *X1_den-xflow**2*R**2*T1**2)
!
!     pressure node1
!
               df(1)=1/(R*xflow**2)*(term1*2/pt1)
     &              +(-(2/pt1))
     &              +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1)
!
!     temperature node1
!
               df(2)=1/(R*xflow**2)*term1*(-expon2)/Tt1
     &              +(expon2/Tt1)
     &              +b1/c1*(2*cp*A**2*X1_den
     &              *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1))
!
!     mass flow
!
               df(3)=-2.d0/(R*xflow**3)*(term1-term2)
     &              +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0)
     &              +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0)
!
!     pressure node2
!
               df(4)=1/(R*xflow**2)*(-term2*2/pt2)
     &              +(2/pt2)
     &              +B2/C2*(4.d0*cp*A**2*(Tt2-T2)*pt2*X_T2dTt2)
!
!
!     temperature node2
!
               df(5)=1/(R*xflow**2)*term2*(expon2/Tt2)
     &              +(-expon2/Tt2)
     &              +b2/c2*(2*cp*A**2*X2_den
     &              *(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2))

            else
               term=term1/(xflow**2*R)
               B1=expon1/T1*(term-1)
!     alternate critical equation
!
               f=term-1-log(term)
     &              -lld
     &              +b1/c1*(2*cp*A**2*(Tt1-T1)
     &              *X1_den-xflow**2*R**2*T1**2)
!
!     pressure node1
!
               df(1)=2/pt1*(term-1)
     &              +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1)
!
!     temperature node1
!
               df(2)=expon2/Tt1*(-term+1)
     &              +b1/c1*(2*cp*A**2*X1_den
     &              *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1))
!
!     mass flow
!
               df(3)=2/xflow*(-term+1)
     &              +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0)
!
!     pressure node2
!
               df(4)=0.d0
!
!     temperature node2
!
               df(5)=0.d0
!
            endif
         endif
!
!     output
!
      elseif((iflag.eq.3).or.(iflag.eq.4)) then
!
         pi=4.d0*datan(1.d0)
         e=2.7182818d0
!
         kappa=(cp/(cp-R))
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         kdkp1=kappa/kp1
!
         index=ielprop(nelem)
         A=prop(index+1)
         d=prop(index+2)
         l=prop(index+3)
!
         lambda=0.5
!
         if(l.lt.0d0) then
            l_neg=l
            l=abs(l)
         else
            l_neg=l
         endif
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPFA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPFI') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=int(prop(index+7))
!
         pt1=v(2,node1)
         pt2=v(2,node2)
!
         if(xflow.ge.0d0) then
            inv=1
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)+physcon(1)
            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
            if(icase.eq.0) then
               Tt2=Tt1
               call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
            else
               T2=T1
               Tt2=v(0,node2)+physcon(1)
               call tt_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase,iflag)
            endif
!
!            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
!!
!            call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
!
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=v(1,nodem)*iaxial
!
            Tt1=v(0,node2)+physcon(1)
            if(icase.eq.0) then
               Tt2=Tt1
            else
               Tt2=v(0,node1)+physcon(1)
            endif
!
            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
            call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
!
         endif
!
         pt2zpt1=pt2/pt1
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1E-30) then
            kgas=0
            call dynamic_viscosity(kgas,T1,dvi)
         endif
!
         reynolds=dabs(xflow)*d/(dvi*a)
!
        if(reynolds.lt.1.d0) then
            reynolds= 1.d0
         endif
!
!     definition of the friction coefficient for 2 phase flows and pure air
!
!     Friedel's Method
         if(lakon(nelem)(7:7).eq.'F') then
!
            if((k_oil.lt.0).or.(k_oil.gt.12)) then
               write(*,*) '*ERROR:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the type of oil is not defined'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Current calculation stops here'
               call exit(201)
            elseif(xflow_oil.eq.0) then
               write(*,*) '*WARNING:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the oil mass flow rate is NULL'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Only pure air is considered'
               call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &              lambda)
            else
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi)
!
               call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &              lambda)
!
            endif
!
         elseif (lakon(nelem)(7:7).eq.'A') then
            if((k_oil.lt.0).or.(k_oil.gt.12)) then
               write(*,*) '*ERROR:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the type of oil is not defined'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Current calculation stops here'
               call exit(201)
            elseif(xflow_oil.eq.0) then
               write(*,*) '*WARNING:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the oil mass flow rate is NULL'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Only pure air is considered'
               call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &              lambda)
            else
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi)
!
               call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &              lambda)
!
            endif
!
!     for pure air
!
         else
            phi=1.d0
            call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &           lambda)
         endif
!
         call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag,
     &     inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase)
!
!     definition of the coefficients
!
         M1=dsqrt(2/km1*((Tt1/T1)-1))
         M2=dsqrt(2/km1*((Tt2/T2)-1))
!
         if(iflag.eq.3) then
!
            write(1,*) ''
            write(1,55) 'In line ',int(nodem/1000),' from node ',node1,
     &           ' to node ', node2,':   air massflow rate = ',xflow,
     &           ' kg/s',' , oil massflow rate = ',xflow_oil,' kg/s'
!
            if(inv.eq.1) then
               write(1,53)'       Inlet node ',node1,' :    Tt1 = ',Tt1,
     &              ' K, Ts1 = ',T1,' K , Pt1 = ',Pt1/1E5,
     &              ' Bar , M1 = ',M1
               write(1,*)'             Element W    ',set(numf)(1:30)
               write(1,57)'             eta = ',dvi,' kg/(m*s) , Re = '
     &              ,reynolds
               write(1,58)'             PHI = ',phi,' , LAMBDA = ',
     &              lambda,
     &              ', LAMBDA*l/d = ',lambda*l/d,' , ZETA_PHI = ',
     &              phi*lambda*l/d
               write(1,53)'       Outlet node ',node2,' :    Tt2 = ',
     &              Tt2,
     &              ' K , Ts2 = ',T2,' K , Pt2 = ',Pt2/1e5,
     &              ' Bar , M2 = ',M2
!
            else if(inv.eq.-1) then
               write(1,53)'       Inlet node ',node2,':    Tt1= ',Tt1,
     &              ' K, Ts1= ',T1,' K, Pt1= ',Pt1/1E5,
     &              ' Bar, M1= ',M1
               write(1,*)'             element W    ',set(numf)(1:30)
               write(1,57)'             eta = ',dvi,' kg/(m*s) , Re = '
     &              ,reynolds
               write(1,58)'             PHI = ',phi,' , LAMBDA = ',
     &              lambda,
     &              ', LAMBDA*l/d = ',lambda*l/d,' , ZETA_PHI = ',
     &              phi*lambda*l/d
               write(1,53)'       Outlet node ',node1,' :    Tt2 = ',
     &              Tt2,
     &              ' K , Ts2 = ',T2,' K , Pt2 =',Pt2/1e5,
     &              ' Bar , M2 = ',M2
            endif
!
         else if(iflag.eq.4) then
!
!     Write the main information about the element
!
            write(1,*) ''
            write(1,78)'Element nr.= ',nelem,', type=Gas Pipe Fanno',
     &           ', name= ',set(numf)(1:30)
            write(1,79)'Nodes: ',node1,',',nodem,',',node2
!
            write(1,80)'Inlet: Tt1= ',Tt1,
     &           ', pt1= ',pt1,', M1= ',M1
            write(1,77)'mass flow = ',xflow,', kappa = ',kappa,
     &           ', lambda= ',lambda,
     &           ', phi= ',phi,
     &           ', zeta= ',phi*lambda*l/d,
     &           ', eta= ',dvi,
     &           ', Re= ',reynolds
            write(1,80)'Outlet: Tt2= ',Tt2,
     &           ', pt2= ',pt2,', M2= ',M2
!
         endif
      endif
!
 55   format(1X,a,i6.3,a,i6.3,a,i6.3,a,f9.6,a,a,f9.6,a)
 53   format(1X,a,i6.3,a,f6.1,a,f6.1,a,f9.5,a,f8.5)
 57   format(1X,a,g9.4,a,g11.4)
 58   format(1X,a,f10.5,a,f10.5,a,f10.5,a,f10.5)
 77   format(3x,a,f10.6,a,f10.2,a,f10.6,a,f10.6,a,f10.6,a,e10.4
     &     ,a,f10.2)
 78   format(a,i4,a,a,a)
 79   format(3X,a,i4,a,i4,a,i4)
 80   format(3x,a,f10.6,a,f10.2,a,f10.6)
!
      xflow=xflow/iaxial
      df(3)=df(3)*iaxial
!
      return
      end


      FUNCTION DQSDT_OHD ( SFCTMP, SFCPRS )

      IMPLICIT NONE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CC    PURPOSE:  TO RETRIEVE THE APPROPRIATE VALUE OF DQSDT (THE CHANGE
CC    =======   OF THE SATURATION MIXING RATIO WITH RESPECT TO THE
CC              CHANGE IN TEMPERATURE), SO CALLED SLOPE, FROM:
CC
CC               FORMULAS INTRODUCED IN NEW FUNCTION DQS
CC                                  (MODIFIED BY PABLO GRUNMANN, 7/9/97).
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      REAL SFCTMP
      REAL SFCPRS
      REAL DQS_OHD
      REAL DQSDT_OHD

      IF ((SFCTMP .GE. 173.0) .AND. (SFCTMP  .LE.  373.0)) THEN

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       IF THE INPUT SFC AIR TEMP IS BTWN 173 K AND 373 K, USE
C       FUNCTION DQS TO DETERMINE THE SLOPE OF SAT.MIX RATIO FUNCTION
C                                 -ADAPTED TO USE NEW DQS, 7/9/97.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        DQSDT_OHD = DQS_OHD (SFCTMP) / SFCPRS

      ELSE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       OTHERWISE, SET DQSDT EQUAL TO ZERO
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        DQSDT_OHD = 0.0

      END IF

      RETURN
      END


      subroutine rhgen(j)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine generates weather relative humidity, solar
!!    radiation, and wind speed.

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    dewpt(:,:)  |deg C         |average dew point temperature for the month
!!    idg(:)      |none          |array location of random number seed used
!!                               |for a given process
!!    j           |none          |HRU number
!!    irelh       |none          |irelh = 0 (dewpoint)
!!                               |      = 1 (relative humidity)
!!                               |note:  inputs > 1.0 (dewpoint)
!!                                       inputs < 1.0 (relative humidity)
!!    i_mo        |none          |month being simulated
!!    pr_w(3,:,:) |none          |proportion of wet days in a month
!!    rndseed(:,:)|none          |random number seeds
!!    subp(:)     |mm H2O        |precipitation for the day in HRU
!!    tmpmn(:,:)  |deg C         |avg monthly minimum air temperature
!!    tmpmx(:,:)  |deg C         |avg monthly maximum air temperature
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    rhd(:)      |none          |relative humidity for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    blm         |none          |lowest relative humidity value allowed for
!!                               |any day in month
!!    rhm         |none          |mean monthly relative humidity adjusted for
!!                               |wet or dry condiditions
!!    rhmo        |none          |mean monthly relative humidity
!!    tmpmean     |deg C         |average temperature for the month in HRU
!!    uplm        |none          |highest relative humidity value allowed for
!!                               |any day in month
!!    vv          |none          |variable to hold intermediate calculation
!!    yy          |none          |variable to hold intermediate calculation
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp
!!    SWAT: Atri, Ee

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer, intent (in) :: j

      real :: vv, rhm, yy, uplm, blm
      real :: rhmo, tmpmean

      !! Climate Paramenters required for Penman-Monteith !!

        !! Generate relative humidity !!
        rhmo = 0.
        yy = 0.
        rhm = 0.
        vv = 0.
        uplm = 0.
        blm = 0.
        tmpmean = 0.
        tmpmean = (tmpmx(i_mo,hru_sub(j)) + tmpmn(i_mo,hru_sub(j))) / 2.

!!   dewpoint or relative humidity --
        if (irelh(hru_sub(j)) == 1) then
           rhmo = dewpt(i_mo,hru_sub(j))
        else
           rhmo = Ee(dewpt(i_mo,hru_sub(j))) / Ee(tmpmean)
        endif

        yy = 0.9 * pr_w(3,i_mo,hru_sub(j))
        rhm = (rhmo - yy) / (1.0 - yy)
        if (rhm < 0.05) rhm = 0.5 * rhmo
        if (subp(j) > 0.0) rhm = rhm * 0.1 + 0.9
        vv = rhm - 1.
        uplm = rhm - vv * Exp(vv)
        blm = rhm * (1.0 - Exp(-rhm))
        rhd(j) = Atri(blm,rhm,uplm,rndseed(idg(7),j))

      return
      end


cc Copyright (C) 2017: Travis Askham, Leslie Greengard, Zydrunas Gimbutas
cc email: askhamwhat@gmail.com
cc
cc This software is being released under a modified FreeBSD license
cc (see licenses folder in home directory).
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      Remarks on scaling conventions.
c
c      1)  Hankel and Bessel functions are consistently scaled as
c       	hvec(n)= H_n(z)*rscale^(n)
c       	jvec(n)= J_n(z)/rscale^(n)
c
c          rscale should be of the order of |z| if |z| < 1. Otherwise,
c          rscale should be set to 1.
c
c      2) The potential scaling is that required of the delta function
c      response:  pot = H_0(k*r)*(eye/4)
c
c-----------------------------------------------------------------------
c
c
c
C***********************************************************************
      subroutine h2dformmp_qp(ier,zk,rscale,source,quadstr,quadvec,
     $     ns,center,nterms,mpole)
      implicit none
C***********************************************************************
c
c     This subroutine constructs a multipole (h) expansion about
c     CENTER due to NS quadrupole sources located at SOURCES(2,*).
c
c     When evaluated at the point p (assumed to be well separated),
c     the multipole expansion approximates the function
c
c     sum quadstr(j)*( quadvec(1,j)* (H_0)_xx (zk ||p-source_j||)
c                    + quadvec(2,j)* (H_0)_xy (zk ||p-source_j||)
c                    + quadvec(3,j)* (H_0)_yy (zk ||p-source_j||))
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     zk              : Helmholtz parameter
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     quadstr(ns)     : quadrupole strengths
c     quadvec(3,ns)   : quadrupole ``orientation''
c                     quadvec(1,i) - (H_0)_xx term
c                     quadvec(2,i) - (H_0)_xy term
c                     quadvec(3,i) - (H_0)_yy term
c     ns              : number of sources
c     center(2)       : expansion center
c     nterms          : order of multipole expansion
c
c     OUTPUT:
c
c     ier       : error return code
c     ier=0 returned successfully;
c
c     mpole     : coeffs for the h-expansion
c

c     global variables
      complex *16 zk,quadstr(*),mpole(-nterms:nterms)
      integer ns, nterms, ier
      real *8 center(2),source(2,*),quadvec(3,*), rscale
c     local variables
      complex *16 z,ima, zmul,zinv,ztemp1,ztemp2,hexp(-2:2),zk2
      real *8 zdiff(2), theta, r, rs2, rs4, pi, done
      integer iii, i, j, ntop, lwfjs, ifder
      complex *16, allocatable :: jval(:), jder(:), jtemp(:)
      integer, allocatable :: iscale(:)
c
      data ima/(0.0d0,1.0d0)/
c
      ier = 0

      done=1
      pi=4*atan(done)
c
      lwfjs = nterms+5 + 4*nterms + 100
      allocate(jval(0:lwfjs+10), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(jder(0:lwfjs+10), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(iscale(0:lwfjs+10), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(jtemp(-nterms-5:nterms+5), stat=ier)
      if (ier.eq.1) then
         return
      endif
c
      zk2 = zk*zk

      do i = -nterms,nterms
         mpole(i) = 0
      enddo

      do iii = 1,ns

c     get j vals for this source

         zdiff(1)=center(1)-source(1,iii)
         zdiff(2)=center(2)-source(2,iii)
         call h2cart2polar(zdiff,r,theta)
         theta=theta-pi
         z=zk*r
         ifder=0
         call jfuns2d(ier,nterms+2,z,rscale,jval,ifder,jder,
     1        lwfjs,iscale,ntop)
c
         jtemp(0) = jval(0)
         zmul=exp(-ima*theta)
         zinv=conjg(zmul)
         ztemp1= zmul
         ztemp2=-zinv
         do j = 1,nterms+2
            jtemp( j) = ztemp1*jval(j)
            jtemp(-j) = ztemp2*jval(j)
            ztemp1= ztemp1*zmul
            ztemp2=-ztemp2*zinv
         enddo

c     set-up quadrupole as if centered at the source

         rs2 = rscale*rscale

         hexp(-2) = quadstr(iii)*(zk2*quadvec(1,iii)
     1                           +zk2*quadvec(2,iii)*ima
     2                           -zk2*quadvec(3,iii))/(rs2*4.0d0)

         hexp(-1) = 0.0d0
         hexp(0) = quadstr(iii)*(-zk2*quadvec(1,iii)
     1                           -zk2*quadvec(3,iii))/2.0d0
         hexp(1) = 0.0d0
         hexp(2) = quadstr(iii)*(zk2*quadvec(1,iii)
     1                          -zk2*quadvec(2,iii)*ima
     2                          -zk2*quadvec(3,iii))/(rs2*4.0d0)

c     shift the quadrupole

         mpole(0) = mpole(0) + hexp(0)*jtemp(0)

         rs4 = rs2*rs2

         mpole(0) = mpole(0)+(hexp(2)*jtemp(-2))*rs4
         mpole(0) = mpole(0)+(hexp(-2)*jtemp(2))*rs4

         do i = 1,nterms

c     due to zero-th term

            mpole(i) = mpole(i) + hexp(0)*jtemp(i)
            mpole(-i) = mpole(-i) + hexp(0)*jtemp(-i)

c     due to 2nd term

            if (i .ge. 2) then
               mpole(i) = mpole(i)+(hexp(2)*jtemp(i-2))
               mpole(i) = mpole(i)+(hexp(-2)*jtemp(i+2))*rs4
               mpole(-i) = mpole(-i)+(hexp(2)*jtemp(-i-2))*rs4
               mpole(-i) = mpole(-i)+(hexp(-2)*jtemp(-i+2))
            else
c     i = 1 here
               mpole(i) = mpole(i)+(hexp(2)*jtemp(i-2))*rs2
               mpole(i) = mpole(i)+(hexp(-2)*jtemp(i+2))*rs4
               mpole(-i) = mpole(-i)+(hexp(2)*jtemp(-i-2))*rs4
               mpole(-i) = mpole(-i)+(hexp(-2)*jtemp(-i+2))*rs2
            endif

         enddo

      enddo

      return
      end
c
c
c
c
C***********************************************************************
      subroutine h2dformmp_qp_add(ier,zk,rscale,source,quadstr,
     1     quadvec,ns,center,nterms,mpole)
      implicit none
C***********************************************************************
c
c     This subroutine constructs a multipole (h) expansion about
c     CENTER due to NS quadrupole sources located at SOURCES(2,*).
c
c     When evaluated at the point p (assumed to be well separated),
c     the multipole expansion approximates the function
c
c     sum quadstr(j)*( quadvec(1,j)* (H_0)_xx (zk ||p-source_j||)
c                    + quadvec(2,j)* (H_0)_xy (zk ||p-source_j||)
c                    + quadvec(3,j)* (H_0)_yy (zk ||p-source_j||))
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     zk              : Helmholtz parameter
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     quadstr(ns)     : quadrupole strengths
c     quadvec(3,ns)   : quadrupole ``orientation''
c                     quadvec(1,i) - (H_0)_xx term
c                     quadvec(2,i) - (H_0)_xy term
c                     quadvec(3,i) - (H_0)_yy term
c     ns              : number of sources
c     center(2)       : expansion center
c     nterms          : order of multipole expansion
c
c     OUTPUT:
c
c     ier       : error return code
c     ier=0 returned successfully;
c
c     mpole     : coeffs for the h-expansion
c

c     global variables
      complex *16 zk,quadstr(*),mpole(-nterms:nterms)
      integer ns, nterms, ier
      real *8 center(2),source(2,*),quadvec(3,*), rscale
c     local variables
      complex *16 z,ima, zmul,zinv,ztemp1,ztemp2,hexp(-2:2),zk2
      real *8 zdiff(2), theta, r, rs2, rs4, pi, done
      integer iii, i, j, ntop, lwfjs, ifder
      complex *16, allocatable :: jval(:), jder(:), jtemp(:)
      integer, allocatable :: iscale(:)
c
      data ima/(0.0d0,1.0d0)/
c
      ier = 0

      done=1
      pi=4*atan(done)
c
      lwfjs = nterms+5 + 4*nterms + 100
      allocate(jval(0:lwfjs+10), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(jder(0:lwfjs+10), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(iscale(0:lwfjs+10), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(jtemp(-nterms-5:nterms+5), stat=ier)
      if (ier.eq.1) then
         return
      endif
c
      zk2 = zk*zk

      do iii = 1,ns

c     get j vals for this source

         zdiff(1)=center(1)-source(1,iii)
         zdiff(2)=center(2)-source(2,iii)
         call h2cart2polar(zdiff,r,theta)
         theta=theta-pi
         z=zk*r
         ifder=0
         call jfuns2d(ier,nterms+2,z,rscale,jval,ifder,jder,
     1        lwfjs,iscale,ntop)
c
         jtemp(0) = jval(0)
         zmul=exp(-ima*theta)
         zinv=conjg(zmul)
         ztemp1= zmul
         ztemp2=-zinv
         do j = 1,nterms+2
            jtemp( j) = ztemp1*jval(j)
            jtemp(-j) = ztemp2*jval(j)
            ztemp1= ztemp1*zmul
            ztemp2=-ztemp2*zinv
         enddo

c     set-up quadrupole as if centered at the source

         rs2 = rscale*rscale

         hexp(-2) = quadstr(iii)*(zk2*quadvec(1,iii)
     1                           +zk2*quadvec(2,iii)*ima
     2                           -zk2*quadvec(3,iii))/(rs2*4.0d0)
         hexp(-1) = 0.0d0
         hexp(0) = quadstr(iii)*(-zk2*quadvec(1,iii)
     1                           -zk2*quadvec(3,iii))/2.0d0
         hexp(1) = 0.0d0
         hexp(2) = quadstr(iii)*(zk2*quadvec(1,iii)
     1                          -zk2*quadvec(2,iii)*ima
     2                          -zk2*quadvec(3,iii))/(rs2*4.0d0)

c     shift the quadrupole

         mpole(0) = mpole(0) + hexp(0)*jtemp(0)

         rs4 = rs2*rs2

         mpole(0) = mpole(0)+(hexp(2)*jtemp(-2))*rs4
         mpole(0) = mpole(0)+(hexp(-2)*jtemp(2))*rs4

         do i = 1,nterms

c     due to zero-th term

            mpole(i) = mpole(i) + hexp(0)*jtemp(i)
            mpole(-i) = mpole(-i) + hexp(0)*jtemp(-i)

c     due to 2nd term

            if (i .ge. 2) then
               mpole(i) = mpole(i)+(hexp(2)*jtemp(i-2))
               mpole(i) = mpole(i)+(hexp(-2)*jtemp(i+2))*rs4
               mpole(-i) = mpole(-i)+(hexp(2)*jtemp(-i-2))*rs4
               mpole(-i) = mpole(-i)+(hexp(-2)*jtemp(-i+2))
            else
c     i = 1 here
               mpole(i) = mpole(i)+(hexp(2)*jtemp(i-2))*rs2
               mpole(i) = mpole(i)+(hexp(-2)*jtemp(i+2))*rs4
               mpole(-i) = mpole(-i)+(hexp(2)*jtemp(-i-2))*rs4
               mpole(-i) = mpole(-i)+(hexp(-2)*jtemp(-i+2))*rs2
            endif

         enddo

      enddo

      return
      end
c
c
c
C***********************************************************************
      subroutine h2dformta_qp(ier,zk,rscale,source,quadstr,quadvec,
     $     ns,center,nterms,mpole)
      implicit none
C***********************************************************************
c
c     This subroutine constructs a local (j) expansion about CENTER due
c     to NS sources located at SOURCES(2,*).
c
c
c     mpole_n  =  sum quadstr_j  H_n(k r) exp(-i n theta_j) *rscale_j^n
c                  j
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     zk              : Helmholtz parameter
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     quadstr(ns)      : dipole strengths
c     quadvec(2,ns)    : dipole orientation vectors
c     ns              : number of sources
c     center(2)       : epxansion center
c     nterms          : order of local expansion
c
c     OUTPUT:
c
c     ier       : error return code
c                 ier=0 returned successfully;
c
c     mpole     : coeffs for the j-expansion
c

c     global variables
      complex *16 zk,mpole(-nterms:nterms),quadstr(*)
      real *8 center(2),source(2,*),quadvec(3,*)
      real *8 rscale
      integer ns, nterms, ier
c     local variables
      complex *16 hexp(-2:2)
      complex *16, allocatable :: hval(:), htemp(:)
      complex *16, allocatable :: hder(:)
      complex *16 zmul,zinv,ztemp1,ztemp2,zk2
      real *8 theta, r, rs2, rs4, zdiff(2)
      integer i, iii, ifder
c
      complex *16 ima,ima4,z
      data ima/(0.0d0,1.0d0)/
c
c
      allocate(hval(0:nterms+5), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(hder(0:nterms+5), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(htemp(-nterms-5:nterms+5), stat=ier)
      if (ier.eq.1) then
         return
      endif

c
      do i=-nterms,nterms
         mpole(i)=0
      enddo

      zk2 = zk*zk

      do iii=1,ns

c     get h vals for this source

         zdiff(1)=source(1,iii)-center(1)
         zdiff(2)=source(2,iii)-center(2)
         call h2cart2polar(zdiff,r,theta)
         z=zk*r
         ifder=0
         call h2dall(nterms+2,z,rscale,hval,ifder,hder)
         htemp(0) = hval(0)
         zmul=exp(-ima*theta)
         zinv=conjg(zmul)
         ztemp1= zmul
         ztemp2=-zinv
         do i = 1,nterms+2
            htemp( i) = ztemp1*hval(i)
            htemp(-i) = ztemp2*hval(i)
            ztemp1= ztemp1*zmul
            ztemp2=-ztemp2*zinv
         enddo

c     set-up quadrupole as if centered at the source

         rs2 = rscale*rscale

         hexp(-2) = quadstr(iii)*(zk2*quadvec(1,iii)
     1                           +zk2*quadvec(2,iii)*ima
     2                           -zk2*quadvec(3,iii))/(rs2*4.0d0)
         hexp(-1) = 0.0d0
         hexp(0) = quadstr(iii)*(-zk2*quadvec(1,iii)
     1                           -zk2*quadvec(3,iii))/2.0d0
         hexp(1) = 0.0d0
         hexp(2) = quadstr(iii)*(zk2*quadvec(1,iii)
     1                          -zk2*quadvec(2,iii)*ima
     2                          -zk2*quadvec(3,iii))/(rs2*4.0d0)

c     shift the quadrupole

         mpole(0) = mpole(0) + hexp(0)*htemp(0)

         mpole(0) = mpole(0)+(hexp(2)*htemp(-2))
         mpole(0) = mpole(0)+(hexp(-2)*htemp(2))
c
         rs2 = rscale*rscale
         rs4 = rs2*rs2
         do i = 1,nterms
            mpole(i) = mpole(i) + hexp(0)*htemp(i)
            mpole(-i) = mpole(-i) + hexp(0)*htemp(-i)
            if (i .ge. 2) then
               mpole(i) = mpole(i)+(hexp(2)*htemp(i-2))*rs4
               mpole(i) = mpole(i)+(hexp(-2)*htemp(i+2))
               mpole(-i) = mpole(-i)+(hexp(2)*htemp(-i-2))
               mpole(-i) = mpole(-i)+(hexp(-2)*htemp(-i+2))*rs4
            else
c     here i = 1
               mpole(i) = mpole(i)+(hexp(2)*htemp(i-2))*rs2
               mpole(i) = mpole(i)+(hexp(-2)*htemp(i+2))
               mpole(-i) = mpole(-i)+(hexp(2)*htemp(-i-2))
               mpole(-i) = mpole(-i)+(hexp(-2)*htemp(-i+2))*rs2
            endif
         enddo
      enddo

      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine h2dformta_qp_add(ier,zk,rscale,source,quadstr,
     1     quadvec,ns,center,nterms,mpole)
      implicit none
C***********************************************************************
c
c     This subroutine constructs a local (j) expansion about CENTER due
c     to NS sources located at SOURCES(2,*).
c
c
c     mpole_n  =  sum quadstr_j  H_n(k r) exp(-i n theta_j) *rscale_j^n
c                  j
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     zk              : Helmholtz parameter
c     rscale          : the scaling factor.
c     source(2,ns)    : coordinates of sources
c     quadstr(ns)      : dipole strengths
c     quadvec(2,ns)    : dipole orientation vectors
c     ns              : number of sources
c     center(2)       : epxansion center
c     nterms          : order of local expansion
c
c     OUTPUT:
c
c     ier       : error return code
c                 ier=0 returned successfully;
c
c     mpole     : coeffs for the j-expansion
c

c     global variables
      complex *16 zk,mpole(-nterms:nterms),quadstr(*)
      real *8 center(2),source(2,*),quadvec(3,*)
      real *8 rscale
      integer ns, nterms, ier
c     local variables
      complex *16 hexp(-2:2)
      complex *16, allocatable :: hval(:), htemp(:)
      complex *16, allocatable :: hder(:)
      complex *16 zmul,zinv,ztemp1,ztemp2,zk2
      real *8 theta, r, rs2, rs4, zdiff(2)
      integer i, iii, ifder
c
      complex *16 ima,ima4,z
      data ima/(0.0d0,1.0d0)/
c
c
      allocate(hval(0:nterms+5), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(hder(0:nterms+5), stat=ier)
      if (ier.eq.1) then
         return
      endif
      allocate(htemp(-nterms-5:nterms+5), stat=ier)
      if (ier.eq.1) then
         return
      endif

      zk2 = zk*zk

      do iii=1,ns

c     get h vals for this source

         zdiff(1)=source(1,iii)-center(1)
         zdiff(2)=source(2,iii)-center(2)
         call h2cart2polar(zdiff,r,theta)
         z=zk*r
         ifder=0
         call h2dall(nterms+2,z,rscale,hval,ifder,hder)
         htemp(0) = hval(0)
         zmul=exp(-ima*theta)
         zinv=conjg(zmul)
         ztemp1= zmul
         ztemp2=-zinv
         do i = 1,nterms+2
            htemp( i) = ztemp1*hval(i)
            htemp(-i) = ztemp2*hval(i)
            ztemp1= ztemp1*zmul
            ztemp2=-ztemp2*zinv
         enddo

c     set-up quadrupole as if centered at the source

         rs2 = rscale*rscale

         hexp(-2) = quadstr(iii)*(zk2*quadvec(1,iii)
     1                           +zk2*quadvec(2,iii)*ima
     2                           -zk2*quadvec(3,iii))/(rs2*4.0d0)
         hexp(-1) = 0.0d0
         hexp(0) = quadstr(iii)*(-zk2*quadvec(1,iii)
     1                           -zk2*quadvec(3,iii))/2.0d0
         hexp(1) = 0.0d0
         hexp(2) = quadstr(iii)*(zk2*quadvec(1,iii)
     1                          -zk2*quadvec(2,iii)*ima
     2                          -zk2*quadvec(3,iii))/(rs2*4.0d0)

c     shift the quadrupole

         mpole(0) = mpole(0) + hexp(0)*htemp(0)

         mpole(0) = mpole(0)+(hexp(2)*htemp(-2))
         mpole(0) = mpole(0)+(hexp(-2)*htemp(2))
c
         rs2 = rscale*rscale
         rs4 = rs2*rs2
         do i = 1,nterms
            mpole(i) = mpole(i) + hexp(0)*htemp(i)
            mpole(-i) = mpole(-i) + hexp(0)*htemp(-i)
            if (i .ge. 2) then
               mpole(i) = mpole(i)+(hexp(2)*htemp(i-2))*rs4
               mpole(i) = mpole(i)+(hexp(-2)*htemp(i+2))
               mpole(-i) = mpole(-i)+(hexp(2)*htemp(-i-2))
               mpole(-i) = mpole(-i)+(hexp(-2)*htemp(-i+2))*rs4
            else
c     here i = 1
               mpole(i) = mpole(i)+(hexp(2)*htemp(i-2))*rs2
               mpole(i) = mpole(i)+(hexp(-2)*htemp(i+2))
               mpole(-i) = mpole(-i)+(hexp(2)*htemp(-i-2))
               mpole(-i) = mpole(-i)+(hexp(-2)*htemp(-i+2))*rs2
            endif
         enddo
      enddo

      return
      end
c
c
c


      subroutine phi1_2m_bw(m2,x3,xth,xphi,s3min,p1,p2,p3,
     . bwmass,bwwidth,wt,*)
c     This routine differs from phi1_2m in that s3 is always generated
c     according to a Breit-Wigner described by the additional
c     arguments bwmass and bwwidth
c-----------------------------------------------------------------------
c     massive particle p1 decaying into p2 mass m2 and p3 mass-squared s3.
c     with invariant mass of particle three s3 integrated over.
c     s3min is the minimum value of s3.
c     Vectors returned p2 and p3 are in the same frame as p1 is supplied.
c     Expression evaluated is
c     ds3 d^4 p2 d^4 p3 (2 pi)^4 delta(p1-p2-p3)/(2 pi)^6
c     delta(p2^2-m2) delta(p3^2-s3)
      implicit none
      include 'constants.f'
      include 'debug.f'
      double precision p1(4),p2(4),p3(4),p3cm(4)
      double precision x3,xth,xphi,costh,sinth,phi,cphi,sphi
      double precision wt,wt0,w3
      double precision s3max,s3min,xx,xexp
      double precision m1,m2,m3,s1,s2,s3,lambda,bwmass,bwwidth
      integer j
      parameter(wt0=one/8d0/pi)

      wt=0d0
      s1=p1(4)**2-p1(1)**2-p1(2)**2-p1(3)**2
      if (s1 .lt. 0d0) return 1
      m1=dsqrt(s1)
      s2=m2**2
      s3max=(m2-m1)**2
      if (s3min .gt. s3max) return 1

      xx=1d0
      call breitw(x3,s3min,s3max,bwmass,bwwidth,s3,w3)

      m3=dsqrt(s3)

      costh=two*xth-one
      phi=twopi*xphi
      sinth=dsqrt(one-costh**2)
      cphi=dcos(phi)
      sphi=dsin(phi)
      lambda=((s1-s2-s3)**2-4d0*s2*s3)

      if ((lambda .lt. 0d0) .or. debug) then
      write(6,*) 'lambda in phi1_2m_bw',lambda
      write(6,*) 's1 in phi1_2m_bw',s1
      write(6,*) 's2 in phi1_2m_bw',s2
      write(6,*) 's3 in phi1_2m_bw',s3
      write(6,*) 'm1 in phi1_2m_bw',m1
      write(6,*) 'm2 in phi1_2m_bw',m2
      write(6,*) 'm3 in phi1_2m_bw',m3
      write(6,*) 'm1-m2-m3 in phi1_2m_bw',m1-m2-m3
      write(6,*) 'xx in phi1_2m_bw',xx
      write(6,*) 'x3 in phi1_2m_bw',x3
      write(6,*) 'bwmass in phi1_2m',bwmass
      write(6,*) 'bwwidth in phi1_2m',bwwidth
      return 1
      endif
      lambda=dsqrt(lambda)

      wt=wt0*w3*lambda/s1

      if(debug) write(6,*) 'wt in phi1_2m_bw',wt

      p3cm(4)=m1/two*(s1+s3-s2)/s1
      p3cm(1)=m1/two*lambda/s1*sinth*sphi
      p3cm(2)=m1/two*lambda/s1*sinth*cphi
      p3cm(3)=m1/two*lambda/s1*costh

      call boost(m1,p1,p3cm,p3)
      do j=1,4
      p2(j)=p1(j)-p3(j)
      enddo

      if (  (p1(4) .lt. 0d0)
     & .or. (p2(4) .lt. 0d0)
     & .or. (p3(4) .lt. 0d0)) then
      return 1
      endif
      return
      end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine input_Ac_ms
  use global_variables_ms
  implicit none
  integer :: it,ix
  real(8) :: Xstart
  real(8) :: tt,xx

!  allocate(Act(0:Nt+1),Act_dt2(0:Nt+1),jtz(0:Nt+1),jtz_intra(0:Nt+1),jtz_inter(0:Nt+1))
  allocate(xn(Nx_L:Nx_R), Az(Nx_L:Nx_R), Az_new(Nx_L:Nx_R), Az_old(Nx_L:Nx_R), jz(Mx))
  Az_new = 0d0; Az = 0d0; Az_old = 0d0; jz = 0d0
  do ix = Nx_L,Nx_R
    xn(ix) = Hx*(dble(ix)-0.5d0)
  end do

  E0_1=5.338d-9*sqrt(Iwcm2_1)
  omega_1 = omega_ev_1/(2d0*Ry)
  tpulse_1 = tpulse_fs_1/0.02418d0
  E0_2=5.338d-9*sqrt(Iwcm2_2)
  omega_2 = omega_ev_2/(2d0*Ry)
  tpulse_2 = tpulse_fs_2/0.02418d0
  Tdelay = Tdelay_fs/0.02418d0

  Xstart=5*Hx

! Pump
  select case(envelope_1)
  case("cos4cos")
     do ix=NX_L,0
        xx=xn(ix)
        if(xx > -Xstart-tpulse_1*c_light .and. xx < -Xstart) then
           Az(ix)=-E0_1/omega_1*sin(pi*(xx+Xstart+tpulse_1*c_light)/(tpulse_1*c_light))**4 &
                *cos(omega_1*(xx+Xstart+tpulse_1*c_light)/c_light)
        endif

        xx=xx-dt*c_light
        if(xx > -Xstart-tpulse_1*c_light+dt*c_light .and. xx < -Xstart+dt*c_light) then
           Az_new(ix)=-E0_1/omega_1*sin(pi*(xx+Xstart+tpulse_1*c_light)/(tpulse_1*c_light))**4 &
                *cos(omega_1*(xx+Xstart+tpulse_1*c_light)/c_light)
        end if
     end do
  case("cos2cos")
     do ix=NX_L,0
        xx=xn(ix)
        if(xx > -Xstart-tpulse_1*c_light .and. xx < -Xstart) then
           Az(ix)=-E0_1/omega_1*sin(pi*(xx+Xstart+tpulse_1*c_light)/(tpulse_1*c_light))**2 &
                *cos(omega_1*(xx+Xstart+tpulse_1*c_light)/c_light)
        endif

        xx=xx-dt*c_light
        if(xx > -Xstart-tpulse_1*c_light+dt*c_light .and. xx < -Xstart+dt*c_light) then
           Az_new(ix)=-E0_1/omega_1*sin(pi*(xx+Xstart+tpulse_1*c_light)/(tpulse_1*c_light))**2 &
                *cos(omega_1*(xx+Xstart+tpulse_1*c_light)/c_light)
        end if
     end do
  case default
     stop "Invalid envelope_1"
  end select

! Probe
  select case(envelope_2)
  case("cos4cos")
     do ix=NX_L,0
        xx=xn(ix)
        if(xx > -Xstart-(tpulse_1*0.5d0+Tdelay)*c_light .and. &
             xx < -Xstart-(tpulse_1*0.5d0+Tdelay-tpulse_2)*c_light ) then
           Az(ix)=Az(ix)-E0_2/omega_2*sin(pi*(xx+Xstart+(tpulse_1*0.5d0+Tdelay)*c_light) &
                /(tpulse_2*c_light))**4 &
                *cos(omega_2*(xx+Xstart+(tpulse_1*0.5d0+Tdelay)*c_light)/c_light)
        endif

        xx=xx-dt*c_light
        if(xx > -Xstart-(tpulse_1*0.5d0+Tdelay)*c_light+dt*c_light &
             .and. xx < -Xstart-(tpulse_1*0.5d0+Tdelay-tpulse_2)*c_light+dt*c_light ) then
           Az_new(ix)=Az_new(ix)-E0_2/omega_2*sin(pi*(xx+Xstart+(tpulse_1*0.5d0+Tdelay)*c_light)&
                /(tpulse_2*c_light))**4 &
                *cos(omega_2*(xx+Xstart+(tpulse_1*0.5d0+Tdelay)*c_light)/c_light)
        end if
     end do
  case("cos2cos")
     do ix=NX_L,0
        xx=xn(ix)
        if(xx > -Xstart-(tpulse_1*0.5d0+Tdelay)*c_light .and. &
             xx < -Xstart-(tpulse_1*0.5d0+Tdelay-tpulse_2)*c_light ) then
           Az(ix)=Az(ix)-E0_2/omega_2*sin(pi*(xx+Xstart+(tpulse_1*0.5d0+Tdelay)*c_light) &
                /(tpulse_2*c_light))**2 &
                *cos(omega_2*(xx+Xstart+(tpulse_1*0.5d0+Tdelay)*c_light)/c_light)
        endif

        xx=xx-dt*c_light
        if(xx > -Xstart-(tpulse_1*0.5d0+Tdelay)*c_light+dt*c_light &
             .and. xx < -Xstart-(tpulse_1*0.5d0+Tdelay-tpulse_2)*c_light+dt*c_light ) then
           Az_new(ix)=Az_new(ix)-E0_2/omega_2*sin(pi*(xx+Xstart+(tpulse_1*0.5d0+Tdelay)*c_light)&
                /(tpulse_2*c_light))**2 &
                *cos(omega_2*(xx+Xstart+(tpulse_1*0.5d0+Tdelay)*c_light)/c_light)
        end if
     end do
  case default
     stop "Invalid envelope_2"
  end select

  return
end subroutine input_Ac_ms


!==============================================================================!
  subroutine CalcWALE(grid)
!------------------------------------------------------------------------------!
!  Compute SGS viscosity for LES by using WALE model.
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use allp_mod, only: ONE_THIRD
  use all_mod
  use pro_mod
  use les_mod
  use rans_mod
  use Grid_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  real    :: SijdSijd(-grid % n_bnd_cells:grid % n_cells),  &
             She     (-grid % n_bnd_cells:grid % n_cells),  &
             Vor     (-grid % n_bnd_cells:grid % n_cells)
  integer :: c
  real    :: S11,  S22,  S33,  S12,  S13,  S23,  S21,  S31,  S32
  real    :: S11d, S22d, S33d, S12d, S13d, S23d, S21d, S31d, S32d
  real    :: V11,  V22,  V33,  V12,  V13,  V23,  V21,  V31,  V32
!==============================================================================!

  write(*,*) '# I think there is a bug in this function (Bojan)'

  !---------------!
  !               !
  !   SGS terms   !
  !               !
  !---------------!
  do c = 1, grid % n_cells
    S11 = u % x(c)
    S22 = v % y(c)
    S33 = w % z(c)
    S12 = 0.5*(v % x(c) + u % y(c))
    S13 = 0.5*(u % z(c) + w % x(c))
    S23 = 0.5*(v % y(c) + w % y(c))
    S21 = S12
    S31 = S13
    S32 = S23

    V11 = 0.0
    V22 = 0.0
    V33 = 0.0
    V12 = 0.5*(v % x(c) - u % y(c))
    V13 = 0.5*(u % z(c) - w % x(c))
    V23 = 0.5*(v % y(c) - w % y(c))
    V21 = -V12
    V31 = -V13
    V32 = -V23

    She(c) = 0.5 * Shear(c) * Shear(c)
    Vor(c) = 0.5 * Vort(c) * Vort(c)

    S11d =  S11*S11 + S12*S12 + S13*S13   &
         - (V11*V11 + V12*V12 + V13*V13)  &
         - ONE_THIRD * (She(c) - Vor(c))

    S22d =  S12*S12 + S22*S22 + S23*S23   &
         - (V12*V12 + V22*V22 + V23*V23)  &
         - ONE_THIRD * (She(c) - Vor(c))

    S33d =  S13*S13 + S23*S23 + S33*S33   &
         - (V13*V13 + V23*V23 + V33*V33)  &
         - ONE_THIRD * (She(c) - Vor(c))

    S12d = S11*S12 + S12*S22 + S13*S32 + (V11*V12 + V12*V22 + V13*V32)
    S13d = S11*S13 + S12*S23 + S13*S33 + (V11*V13 + V12*V23 + V13*V33)
    S23d = S21*S13 + S22*S23 + S23*S33 + (V21*V13 + V22*V23 + V23*V33)

    S21d = S12d
    S31d = S13d
    S32d = S23d

    SijdSijd(c) = S11d*S11d + S22d*S22d + S33d*S33d  &
                + S12d*S12d + S13d*S13d + S23d*S23d

    WALEv(c) =  sqrt( abs (SijdSijd(c)**3) )          &
             / (sqrt( abs (She(c)     **5) ) +        &
                sqrt( sqrt(SijdSijd(c)**6) ) + TINY)
  end do

  end subroutine


      SUBROUTINE DOTPROD(a, b, c)

      INCLUDE 'DOTPROD_INC.f'

      INTEGER i
      INTEGER*2 a(1:1), b(1:SIZE), c(1:SIZE)

      a(1) = 0
      DO 10 i = 1, SIZE
          a(1) = a(1) + b(i) * c(i)
10    ENDDO

      RETURN
      END

      SUBROUTINE DOTPRODREF(a, b, c)

      INCLUDE 'DOTPROD_INC.f'

      INTEGER i
      INTEGER*2 a(1:1), b(1:SIZE), c(1:SIZE)

      a(1) = 0
      DO 10 i = 1, SIZE
          a(1) = a(1) + b(i) * c(i)
10    ENDDO

      RETURN
      END

      INTEGER FUNCTION CLOCK()

      CLOCK = 0

      RETURN
      END

      PROGRAM MAIN

      INCLUDE 'DOTPROD_INC.f'

      INTEGER i, j
      INTEGER bef, af, diff
      INTEGER befRef, afRef, diffRef
      INTEGER CLOCK
      INTEGER*2  a(1:1), b(1:SIZE), c(1:SIZE)
      INTEGER*2  aRef(1:1), bRef(1:SIZE),
     & cRef(1:SIZE)

      LOGICAL success

      DO 10 i = 1, SIZE
          b(i) = i
          c(i) = i
          bRef(i) = i
          cRef(i) = i
10    ENDDO

      bef = CLOCK()
      DO 20 i = 1, 100000
          CALL DOTPROD(a, b, c)
20    ENDDO
      af = CLOCK()

      befRef = CLOCK()
      DO 21 i = 1, 100000
          CALL DOTPRODREF(aRef, bRef, cRef)
21    ENDDO
      afRef = CLOCK()

      success = .TRUE.

c      IF((ABS(a(i) - aRef(i)) / aRef(i)) .GT. 0.000001) THEN
      IF(a(1) .NE. aRef(1)) THEN
          success = .FALSE.
      ENDIF

      PRINT *, 'a = ', a(1)
      PRINT *, 'aRef = ', aRef(1)

      IF(success .EQV. .TRUE.) THEN
         PRINT *, 'SUCCESS'
      ELSE
         PRINT *, 'ERROR'
      ENDIF

      diff = af - bef
      diffRef = afRef - befRef
      PRINT *, 'time: ', diff
      PRINT *, 'reference time: ', diffRef

      RETURN
      END


!=======================================================================================
!
!     Author:   Jan Eitzinger (je), jan.treibig@gmail.com
!     Copyright (c) 2019 RRZE, University Erlangen-Nuremberg
!
!     Permission is hereby granted, free of charge, to any person obtaining a copy
!     of this software and associated documentation files (the "Software"), to deal
!     in the Software without restriction, including without limitation the rights
!     to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
!     copies of the Software, and to permit persons to whom the Software is
!     furnished to do so, subject to the following conditions:
!
!     The above copyright notice and this permission notice shall be included in all
!     copies or substantial portions of the Software.
!
!     THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!     IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!     FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
!     AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!     LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
!     OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
!     SOFTWARE.#include <stdlib.h>
!
!=======================================================================================

program bwBench
    use timing
    use constants
    use benchmarks

    implicit none

    integer, parameter :: numbench = 8
    real(kind=dp), allocatable :: a(:), b(:), c(:), d(:)
    real(kind=dp) :: scalar, tmp
    real(kind=dp) :: maxtime(numbench), mintime(numbench), avgtime(numbench), &
        times(numbench,ntimes)
    integer :: i, k
    integer :: bytes(numbench)
    integer :: bytesPerWord
    character :: label(numbench)*11

!$    INTEGER omp_get_num_threads
!$    EXTERNAL omp_get_num_threads

    !FIXME: Fuck Fortran
    bytesPerWord = 8

    bytes(1) = 1 * bytesPerWord * n ! init
    bytes(2) = 1 * bytesPerWord * n ! summ
    bytes(3) = 2 * bytesPerWord * n ! copy
    bytes(4) = 2 * bytesPerWord * n ! update
    bytes(5) = 3 * bytesPerWord * n ! triad
    bytes(6) = 3 * bytesPerWord * n ! daxpy
    bytes(7) = 4 * bytesPerWord * n ! striad
    bytes(8) = 4 * bytesPerWord * n ! sdaxpy

    label(1) = " Init:       "
    label(2) = " Sum:        "
    label(3) = " Copy:       "
    label(4) = " Update:     "
    label(5) = " Triad:      "
    label(6) = " Daxpy:      "
    label(7) = " STriad:     "
    label(8) = " SDaxpy:     "

    do  i = 1, numbench
       avgtime(i) = 0.0D0
       mintime(i) = 1.0D+36
       maxtime(i) = 0.0D0
    end do

    allocate(a(n))
    allocate(b(n))
    allocate(c(n))
    allocate(d(n))

!$omp parallel
!$omp master
      print *,'----------------------------------------------'
!$    print *,'Number of Threads = ',OMP_GET_NUM_THREADS()
!$omp end master
!$omp end parallel

      PRINT *,'----------------------------------------------'

!$OMP PARALLEL DO
    do  i = 1, n
       a(i) = 2.0d0
       b(i) = 2.0d0
       c(i) = 0.5d0
       d(i) = 1.0d0
    end do

    scalar = 3.0d0

    do  k = 1, ntimes
       times(1, k) = init(b, scalar)
       times(2, k) = summ(a)
       times(3, k) = copy(c, a)
       times(4, k) = update(a, scalar)
       times(5, k) = triad(a, b, c, scalar)
       times(6, k) = daxpy(a, b, scalar)
       times(7, k) = striad(a, b, c, d)
       times(8, k) = sdaxpy(a, b, c)
    end do

    do  k = 1, ntimes
       do  i = 1, numbench
          avgtime(i) = avgtime(i) + times(i, k)
          mintime(i) = MIN(mintime(i), times(i, k))
          maxtime(i) = MAX(mintime(i), times(i, k))
       end do
    end do

    print *,"-------------------------------------------------------------"
    print *,"Function      Rate (MB/s)   Avg time     Min time     Max time"

    do  i = 1, numbench
       avgtime(i) = avgtime(i)/dble(ntimes-1)
       print "(a,f12.2, 2x, 3 (f10.4,3x))", label(i), bytes(i)/mintime(i)/1.0D6, &
               avgtime(i), mintime(i), maxtime(i)
    end do
    print *,"-------------------------------------------------------------"

end program bwBench


program test_real
    use, intrinsic :: iso_fortran_env
    use :: test_check
    implicit none

    call test_numeric_real()

contains
    subroutine test_numeric_real()
        use :: numeric_real
        implicit none

        print *, "numeric real test start"

        real32_check: block
            call check(Real32_Positive_Max == +huge(result_type_real32), "real32 positive maximum test")

            call check(Real32_Positive_Min == +tiny(result_type_real32), "real32 positive minimun test")

            call check(Real32_Negative_Max == -huge(result_type_real32), "real32 negative maximum test")

            call check(Real32_Negative_Min == -tiny(result_type_real32), "real32 negative minimun test")

        end block real32_check

        real64_check: block
            call check(Real64_Positive_Max == +huge(result_type_real64), "real64 positive maximum test")

            call check(Real64_Positive_Min == +tiny(result_type_real64), "real64 positive minimun test")

            call check(Real64_Negative_Max == -huge(result_type_real64), "real64 negative maximum test")

            call check(Real64_Negative_Min == -tiny(result_type_real64), "real64 negative minimun test")

        end block real64_check

        block
            call check(to_string(-tiny(0e0)) == "-0.1175494351E-037", "to_string() real32 value test")
            call check(to_string(-tiny(0d0)) == "-0.2225073858507201383E-0307", "to_string() real64 value test")
        end block

        print *, "numeric real test end"
    end subroutine test_numeric_real
end program test_real


      SUBROUTINE PHO_LOOREG(S,Ga,Aa,Gb,Bb,Delta,Alphap,Gppp,Bppp,Vir2a,
     &                      Vir2b,Siglo,Blo)
C**********************************************************************
C
C     calculation of loop-Pomeron total cross section
C     according to Gribov's Regge theory
C
C     input:        S        squared cms energy
C                   GA       coupling constant to diffractive line
C                   AA       slope related to GA (GeV**-2)
C                   GB       coupling constant to elastic line
C                   BB       slope related to GB (GeV**-2)
C                   DELTA    effective pomeron delta (intercept-1)
C                   ALPHAP   slope of pomeron trajectory (GeV**-2)
C                   GPPP     triple-Pomeron coupling
C                   BPPP     slope related to B0PPP (GeV**-2)
C                   VIR2A    virtuality of particle a (GeV**2)
C                   VIR2B    virtuality of particle b (GeV**2)
C                   note: units of all coupling constants are mb**1/2
C
C     output:       SIGLO    total loop-Pomeron cross section
C                   BLO      effective loop-Pomeron slope
C                            (differs from double diffractive slope!)
C
C     uses E_i (Exponential-Integral function)
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION Aa , Alphap , alsca , Bb , Blo , Bppp , Delta ,
     &                 EPS , Ga , Gb , Gppp , part1 , parta , partb ,
     &                 PHO_EXPINT , S , sigl , Siglo , sigu , Vir2a
      DOUBLE PRECISION Vir2b
      SAVE

      PARAMETER (EPS=0.0001D0)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  some constants
      INCLUDE 'inc/pocons'

C  integration cut-off Sigma_U ( see Nucl.Phys.B97(1975)493 )
      sigu = 2.5
C  integration cut-off Sigma_L (min. squared mass of diff. blob)
      sigl = 5. + Vir2a + Vir2b
C  debug output
      IF ( LPRi.GT.4 .AND. IDEb(51).GE.10 )
     &      WRITE (LO,'(1X,A,/1X,1P,9E10.3)')
     &      'PHO_LOOREG: S,GA,AA,GB,BB,DELTA,ALPHAP,GPPP,BPPP ' , S ,
     &     Ga , Aa , Gb , Bb , Delta , Alphap , Gppp , Bppp
C
      IF ( S.LT.5.D0 ) THEN
         Siglo = 0.D0
         Blo = 2.D0*Bppp
         RETURN
      END IF

C
C  change units of ALPHAP to mb
      alsca = Alphap*GEV2mb
C
C  cross section
      part1 = Ga*Gb*Gppp**2/(16.*PI*2.*alsca)
     &        *S**Delta*EXP(-Delta*Bppp/Alphap)
      parta = Bppp/Alphap + LOG(S/sigl**2)
      partb = Bppp/Alphap + LOG(sigu)
      Siglo = part1*
     &        (parta*(PHO_EXPINT(parta*Delta)-PHO_EXPINT(partb*Delta))
     &        +EXP(parta*Delta)/Delta-EXP(partb*Delta)/Delta)
C
C  slope
      part1 = LOG(ABS(parta/partb))*(parta-LOG(1.D0+S/(sigl**2*sigu)))
      part1 = 0.25*Alphap*LOG(1.D0+S/(sigu*sigl))**2/part1
      Blo = (Aa+Bb)/2. + 2.*Bppp + Alphap*LOG(S/4.D0)
      Blo = Blo - part1
C
      IF ( Siglo.LT.EPS ) Siglo = 0.D0
      IF ( Blo.LT.2.D0*Bppp ) Blo = 2.D0*Bppp
C
      IF ( LPRi.GT.4 .AND. IDEb(51).GE.7 ) WRITE (LO,'(1X,A,1P,3E12.3)')
     &      'PHO_LOOREG: ENERGY,SIGLO,BLO' , SQRT(S) , Siglo , Blo
      END SUBROUTINE


Real Function rrbbar(srt)
  Parameter (pimass=0.140, arho=0.77, aomega=0.782)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Save
  sppb4p = xppbar(srt)*factr2(4)*ene**2/fsum
  pi2 = (s-4*arho**2)/4
  rrbbar = 4./81.*(sppb4p/2)/pi2*wtot
  Return
End Function rrbbar


    subroutine Phydrotherm(t)
!   *************************
!   scavenging of P on iron oxides (hydrothermal)
    implicit none
    include 'combine_foam.inc'

    do i=1,nbasin
        fhydP(i)=0.325d+10*var(3,i)/1.5d-3*clo*phosss* &
                 indice_deep(i)
        !! add O2 feedback
        !fhydP(i)=1.505d+10*var(3,i)/1.5d-3*var(11,i)*clo*phosss * indice_deep(i)
        !!              PO4 ^^^^^^^^     O2 ^^^^^^^^^
        !! stronger O2 feedback
        !fhydP(i)=6.965d+10*var(3,i)/1.5d-3*(var(11,i)**2) * clo*phosss * indice_deep(i)
        !!              PO4 ^^^^^^^^      O2 ^^^^^^^^^
    enddo
    return
    end


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine numeral  --  convert number to text string  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "numeral" converts an input integer number into the
c     corresponding right- or left-justified text numeral
c
c     number  integer value of the number to be transformed
c     string  text string to be filled with corresponding numeral
c     size    on input, the minimal acceptable numeral length, if
c               zero then output will be right justified, if
c               nonzero then numeral is left-justified and padded
c               with leading zeros as necessary; upon output, the
c               number of non-blank characters in the numeral
c
c
      subroutine numeral (number,string,size)
      implicit none
      integer i,number,size
      integer multi,pos
      integer length,minsize,len
      integer million,hunthou
      integer tenthou,thousand
      integer hundred,tens,ones
      logical right,negative
      character*1 digit(0:9)
      character*(*) string
      data digit  / '0','1','2','3','4','5','6','7','8','9' /
c
c
c     set justification and size bounds for numeral string
c
      if (size .eq. 0) then
         right = .true.
         size = 1
      else
         right = .false.
      end if
      minsize = size
      length = len(string)
c
c     test the sign of the original number
c
      if (number .ge. 0) then
         negative = .false.
      else
         negative = .true.
         number = -number
      end if
c
c     use modulo arithmetic to find place-holding digits
c
      million = number / 1000000
      multi = 1000000 * million
      hunthou = (number-multi) / 100000
      multi = multi + 100000*hunthou
      tenthou = (number-multi) / 10000
      multi = multi + 10000*tenthou
      thousand = (number-multi) / 1000
      multi = multi + 1000*thousand
      hundred = (number-multi) / 100
      multi = multi + 100*hundred
      tens = (number-multi) / 10
      multi = multi + 10*tens
      ones = number - multi
c
c     find the correct length to be used for the numeral
c
      if (million .ne. 0) then
         size = 7
      else if (hunthou .ne. 0) then
         size = 6
      else if (tenthou .ne. 0) then
         size = 5
      else if (thousand .ne. 0) then
         size = 4
      else if (hundred .ne. 0) then
         size = 3
      else if (tens .ne. 0) then
         size = 2
      else
         size = 1
      end if
      size = min(size,length)
      size = max(size,minsize)
c
c     convert individual digits to a string of numerals
c
      if (size .eq. 7) then
         string(1:1) = digit(million)
         string(2:2) = digit(hunthou)
         string(3:3) = digit(tenthou)
         string(4:4) = digit(thousand)
         string(5:5) = digit(hundred)
         string(6:6) = digit(tens)
         string(7:7) = digit(ones)
      else if (size .eq. 6) then
         string(1:1) = digit(hunthou)
         string(2:2) = digit(tenthou)
         string(3:3) = digit(thousand)
         string(4:4) = digit(hundred)
         string(5:5) = digit(tens)
         string(6:6) = digit(ones)
      else if (size .eq. 5) then
         string(1:1) = digit(tenthou)
         string(2:2) = digit(thousand)
         string(3:3) = digit(hundred)
         string(4:4) = digit(tens)
         string(5:5) = digit(ones)
      else if (size .eq. 4) then
         string(1:1) = digit(thousand)
         string(2:2) = digit(hundred)
         string(3:3) = digit(tens)
         string(4:4) = digit(ones)
      else if (size .eq. 3) then
         string(1:1) = digit(hundred)
         string(2:2) = digit(tens)
         string(3:3) = digit(ones)
      else if (size .eq. 2) then
         string(1:1) = digit(tens)
         string(2:2) = digit(ones)
      else
         string(1:1) = digit(ones)
      end if
c
c     right-justify if desired, and pad with blanks
c
      if (right) then
         do i = size, 1, -1
            pos = length - size + i
            string(pos:pos) = string(i:i)
         end do
         do i = 1, length-size
            string(i:i) = ' '
         end do
      else
         do i = size+1, length
            string(i:i) = ' '
         end do
      end if
      return
      end