module EDROMO
! Description:
!    Contains procedures necessary for the EDromo formulation. The procedures
!    evaluate the right-hand side of the equations (EDROMO_RHS), provide an
!    event function for LSODAR (EDROMO_EVT), provide coordinate and time
!    transformations (EDROMO_TE2TIME, CART2EDROMO, EDROMO2CART,
!    INERT2ORB_EDROMO), and compute auxiliary quantities (EDROMO_PHI0).
!
! References:
! [1] Baù, G., Bombardelli, C., Peláez, J., and Lorenzini, E., "Nonsingular
!     orbital elements for special perturbations in the two-body problem".
!     MNRAS 454(3), pp. 2890-2908. 2015.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!    180801: change call to perturbation routine, PERT_EJ2K. Eliminate use
!            association with PHYS_CONST in EDROMO_RHS. Refine comments to the
!            module.
!    190110: Add check for collision with the Moon. Add optional flag to
!            EDROMO2CART to return position only.
!
! ==============================================================================

use KINDS, only: dk
implicit none

contains

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

subroutine EDROMO_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
!    Space Dynamics Group - Technical University of Madrid
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!     180608: change interface to PACC_EJ2K to add iF107.
!     180801: change call to perturbation routine, PERT_EJ2K. Eliminate use
!             association with PHYS_CONST.
!
! ==============================================================================

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

! VARIABLES
implicit none

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

! Auxiliary quantities
real(dk)    ::  sph,cph
real(dk)    ::  rho,rmag,zeta,emme
real(dk)    ::  cnu,snu
real(dk)    ::  enne,L3,wz
real(dk)    ::  aux0,aux1,aux2,aux3,aux4
integer     ::  flag_time

! State
real(dk)    ::  rV(1:3),vV(1:3),t
real(dk)    ::  x_vec(1:3),y_vec(1:3)
real(dk)    ::  i_vec(1:3),j_vec(1:3)
real(dk)    ::  v_rad,v_tan,vmag,vsq
real(dk)    ::  cosg,sing

! Perturbations
real(dk)    ::  Upot,dUdr(1:3),dUdt  ! Perturbing potential and its derivatives
real(dk)    ::  f(1:3),p(1:3)        ! Total and non-conservative perturbing accelerations

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

! INDEX OF STATE VECTORS

! z(1) = zeta1
! z(2) = zeta2
! z(3) = zeta3
! z(4) = zeta4
! z(5) = zeta5
! z(6) = zeta6
! z(7) = zeta7
! z(8) = zeta8 (physical time,
!               constant time element,
!               linear time element,
!               depending on flag_time)

! Safety check
!if (any(z/=z)) then
!	write(*,*) 'NaNs detected in the RHS, stopping execution.'
!	stop
!end if

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

! Store trig functions
sph = sin(phi)
cph = cos(phi)

rho   = 1._dk - z(1)*cph - z(2)*sph
rmag  = z(3)*rho
zeta  = z(1)*sph - z(2)*cph
emme  = sqrt(1._dk - z(1)**2 - z(2)**2)

cnu = (cph - z(1) + (zeta*z(2))/(emme + 1._dk))/rho
snu = (sph - z(2) - (zeta*z(1))/(emme + 1._dk))/rho

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

! Intermediate frame unit vectors
x_vec = 2._dk*[ .5_dk - z(5)**2 - z(6)**2,  &
           &  z(4)*z(5) + z(6)*z(7),  &
           &  z(4)*z(6) - z(5)*z(7)]
y_vec = 2._dk*[  z(4)*z(5) - z(6)*z(7),  &
           & .5_dk - z(4)**2 - z(6)**2,  &
           &  z(5)*z(6) + z(4)*z(7)]

! Position in inertial frame
rV = rmag*(x_vec*cnu + y_vec*snu)

flag_time = eqs - 2

! Get time
if ( flag_time == 0 ) then
    ! Physical time
    t = z(8)
elseif  ( flag_time == 1 ) then
    ! Constant time element
    t = z(8) - z(3)**1.5_dk*(zeta - phi)
elseif  ( flag_time == 2 ) then
    ! Linear time element
    t = z(8) - z(3)**1.5_dk*zeta
end if

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

Upot = 0._dk; dUdt = 0._dk; dUdr = 0._dk
call PERT_EJ2K(insgrav,0,0,0,0,0,rV,vV,rmag,t,dUdr,Upot,dUdt)
dUdr = INERT2ORB_EDROMO(dUdr,z,cnu,snu)

! ==============================================================================
! 04. VELOCITY IN THE INERTIAL FRAME
! ==============================================================================

i_vec = x_vec*cnu + y_vec*snu
j_vec = y_vec*cnu - x_vec*snu
v_rad = zeta/(sqrt(z(3))*rho)
v_tan = sqrt((1._dk - z(1)**2 - z(2)**2)/(z(3)*rho**2) - 2._dk*Upot)
vV = v_rad*i_vec + v_tan*j_vec
vsq = v_rad**2 + v_tan**2
vmag = sqrt(vsq)
cosg = v_rad/vmag; sing = v_tan/vmag

! ==============================================================================
! 05. PERTURBING ACCELERATIONS
! ==============================================================================

! Initializations
p = 0._dk; f = 0._dk
call PERT_EJ2K(0,isun,imoon,idrag,iF107,iSRP,rV,vV,rmag,t,p)
p = INERT2ORB_EDROMO(p,z,cnu,snu)

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

f = p + dUdr

enne = sqrt(emme**2 - 2._dk*z(3)*rho**2*Upot)

aux0 = (p(1)*zeta + p(2)*enne + dUdt*sqrt(z(3))*rho)
zdot(3) = 2._dk*z(3)**3*aux0
L3 = zdot(3)/(2._dk*z(3))

aux1 = ((2._dk*Upot - f(1)*rmag)*(2._dk - rho + emme)*rmag)/(emme*(emme+1._dk))
aux2 = (L3*zeta*(rho-emme))/(emme*(emme+1._dk))
wz   = (enne - emme)/rho + aux1 + aux2

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

! In-plane
aux3 = (f(1)*rmag - 2._dk*Upot)*rmag

zdot(1) =  aux3*sph + L3*((1._dk+rho)*cph - z(1))
zdot(2) = -aux3*cph + L3*((1._dk+rho)*sph - z(2))

! Out-of-plane
aux4 = (f(3)*rmag**2)/(2._dk*enne)

zdot(4) =  aux4*(z(7)*cnu - z(6)*snu) + 0.5_dk*wz*z(5)
zdot(5) =  aux4*(z(6)*cnu + z(7)*snu) - 0.5_dk*wz*z(4)
zdot(6) = -aux4*(z(5)*cnu - z(4)*snu) + 0.5_dk*wz*z(7)
zdot(7) = -aux4*(z(4)*cnu + z(5)*snu) - 0.5_dk*wz*z(6)

! Time / Time Element
if (flag_time == 0) then
    zdot(8) = sqrt(z(3))*rmag
else if (flag_time == 1) then   ! Constant Time Element
    zdot(8) = z(3)**1.5_dk * ( aux3 + (zeta - 1.5_dk*phi)*zdot(3)/z(3) )
else if (flag_time == 2) then   ! Linear Time Element
    zdot(8) = z(3)**1.5_dk * ( 1._dk + aux3 + 2._dk*L3*zeta )
end if

end subroutine EDROMO_RHS

subroutine EDROMO_EVT(neq,phi,z,ng,roots)
! Description:
!    Finds roots to stop the integration for the EDromo 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)  ::  rho, rmag, dmag
real(dk)  ::  r_vec(1:3), dummy(1:3), rMoon(1:3), vMoon(1:3)

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

roots = 1._dk

! Get time
flag_time = eqs - 2
t = EDROMO_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
! ==============================================================================

rho   = 1._dk - z(1)*cos(phi) - z(2)*sin(phi)
rmag  = z(3)*rho

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 EDROMO2CART(phi,z,r_vec,dummy,posOnly=.true.)
  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 EDROMO_EVT

function EDROMO_PHI0(R,V,pot,GM,DU,TU)
! Description:
!    Computes initial value of the EDromo fictitious time according to the
!    suggestion in [1].
!
! ==============================================================================

implicit none
! Arguments
real(dk),intent(in)  ::  R(1:3),V(1:3),pot,GM,DU,TU
real(dk)  :: EDROMO_PHI0
! Locals
real(dk)  ::  R_nd(1:3),V_nd(1:3),GM_nd,Rmag_nd
real(dk)  ::  rvdot
real(dk)  ::  pot_nd,totEn

R_nd = R/DU; V_nd = V/(DU*TU); GM_nd = GM/(DU**3*TU**2); pot_nd = pot/(DU*TU)**2
Rmag_nd = sqrt(dot_product(R_nd,R_nd))
rvdot = dot_product(R_nd,V_nd)
totEn = .5_dk*dot_product(V_nd,V_nd) - GM_nd/Rmag_nd - pot_nd
EDROMO_PHI0 = atan2(rvdot*sqrt(-2._dk*totEn), 1._dk + 2._dk*totEn*Rmag_nd)

end function EDROMO_PHI0

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

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

! VARIABLES
implicit none
! Arguments IN
real(dk),intent(in)     ::  z(1:8),phi
integer,intent(in)  ::  flag_time
! Function definition
real(dk)                ::  EDROMO_TE2TIME

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

if ( flag_time == 0 ) then
    ! Physical time
    EDROMO_TE2TIME = z(8)

else if  ( flag_time == 1 ) then
    ! Constant time element
    EDROMO_TE2TIME = z(8) - z(3)**1.5_dk*(z(1)*sin(phi) - z(2)*cos(phi) - phi)

else if  ( flag_time == 2 ) then
    ! Linear time element
    EDROMO_TE2TIME = z(8) - z(3)**1.5_dk*(z(1)*sin(phi) - z(2)*cos(phi))

end if

end function EDROMO_TE2TIME

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

! VARIABLES
implicit none

! Arguments
integer,parameter       ::  neq = 8		        ! Number of elements of EDromo state vector
real(dk),intent(in)     ::  R(1:3),V(1:3)		! Dimensional position and velocity [km,km/s]
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)              ! EDromo state vector

! Local variables
real(dk)  ::  y(1:6)           		            ! Cartesian state vector, ND
real(dk)  ::  Rmag,Vmag      	                ! Radius and velocity magnitudes, ND
real(dk)  ::  rV                                ! r dot v, ND
real(dk)  ::  h0(1:3),hmag0    	                ! Initial angular momentum and magnitude
real(dk)  ::  pot0           		            ! Potential, ND
real(dk)  ::  totEn0           		            ! Initial total energy, ND
real(dk)  ::  c0                                ! Generalized angular momentum
real(dk)  ::  cph,sph
real(dk)  ::  nu0,cnu,snu          	            ! Auxiliary variables
real(dk)  ::  i_vec(1:3),j_vec(1:3),k_vec(1:3)  ! Orbital frame unit vectors in inertial RF
real(dk)  ::  x_vec(1:3),y_vec(1:3)             ! Intermediate frame unit vectors in inertial RF
real(dk)  ::  aux                	            ! Auxiliary variables
real(dk)  ::  zero             		            ! Reference machine zero

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

! ==============================================================================
! 01. NON-DIMENSIONALIZATION
! ==============================================================================
y(1:3) = R/DU
y(4:6) = V/(DU*TU)
pot0   = W/(DU*TU)**2

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

! ==============================================================================
! 02. IN-PLANE ELEMENTS
! ==============================================================================
Rmag = sqrt(dot_product(y(1:3),y(1:3)))
Vmag = sqrt(dot_product(y(4:6),y(4:6)))

cph = cos(phi)
sph = sin(phi)

! Total energy
totEn0  = .5_dk*Vmag**2 - 1._dk/Rmag + pot0

! Angular momentum
h0 = DCROSS_PRODUCT(y(1:3),y(4:6))
hmag0 = sqrt(dot_product(h0,h0))

! Generalized angular momentum
c0 = sqrt(hmag0**2 + 2._dk*Rmag**2*pot0)

! Dot product
rV = dot_product(y(1:3),y(4:6))

! IN-PLANE ELEMENTS
z(1) = (1._dk + 2._dk*totEn0*Rmag)*cph + rV*sqrt(-2._dk*totEn0)*sph
z(2) = (1._dk + 2._dk*totEn0*Rmag)*sph - rV*sqrt(-2._dk*totEn0)*cph
z(3) = -1._dk/(2._dk*totEn0)

! ==============================================================================
! 03. QUATERNION ELEMENTS
! ==============================================================================

nu0 = phi + 2._dk*atan2(rV,(c0 + Rmag*sqrt(-2._dk*totEn0)))
cnu = cos(nu0); snu = sin(nu0)

! Orbital frame unit vectors in IRF
i_vec = y(1:3)/Rmag
k_vec = h0/hmag0
j_vec = DCROSS_PRODUCT(k_vec,i_vec)

! Intermediate frame unit vectors in IRF
x_vec = i_vec*cnu - j_vec*snu
y_vec = j_vec*cnu + i_vec*snu

! SAFE INITIALIZATION OF THE QUATERNION
! The arguments of the roots have to be always positive, therefore we can safely use ABS()
aux = abs(1._dk + x_vec(1) + y_vec(2) + k_vec(3))
z(7) = .5_dk*sqrt(aux)
! Check for singularities and NaNs
if ( aux <= zero ) then
    aux    = abs((.5_dk*(k_vec(3) + 1._dk)))
    z(6)  = sqrt(aux)
    if ( aux <= zero ) then
        aux   = abs(.5_dk*(1._dk - y_vec(2)))
        z(4) = sqrt(aux)
        if ( aux <= zero ) then
            z(5) = 1._dk
        else
            z(5) = y_vec(1)/(2._dk*z(4))
        end if
    else
        z(4) = k_vec(1)/(2.*z(6))
        z(5) = k_vec(2)/(2.*z(6))
    end if
else
    z(4) = (y_vec(3) - k_vec(2))/(4._dk*z(7))
    z(5) = (k_vec(1) - x_vec(3))/(4._dk*z(7))
    z(6) = (x_vec(2) - y_vec(1))/(4._dk*z(7))
end if

! ==============================================================================
! 04. TIME / TIME ELEMENT
! ==============================================================================

if ( flag_time == 0 ) then
    ! Physical time
    z(8) = t0*TU
elseif  ( flag_time == 1 ) then
    ! Constant time element
    z(8) = t0*TU + z(3)**1.5*(z(1)*sph - z(2)*cph - phi)
elseif  ( flag_time == 2 ) then
    ! Linear time element
    z(8) = t0*TU + z(3)**1.5*(z(1)*sph - z(2)*cph)
end if

contains

FUNCTION DCROSS_PRODUCT(a,b)

! VARIABLES
implicit none
! Function definition
real(dk)        :: DCROSS_PRODUCT(1:3)
! Arguments
real(dk)        :: a(1:3),b(1:3)

DCROSS_PRODUCT(1) = a(2)*b(3) - a(3)*b(2)
DCROSS_PRODUCT(2) = a(3)*b(1) - a(1)*b(3)
DCROSS_PRODUCT(3) = a(1)*b(2) - a(2)*b(1)
END FUNCTION DCROSS_PRODUCT

end subroutine CART2EDROMO

subroutine EDROMO2CART(phi,z,r_vec,v_vec,posOnly)
! Description:
!    Transforms from the EDromo state vector "z", fictitious time "phi" and
!    potential "Upot" to Cartesian position and velocity "r_vec", "v_vec".
!    **All quantities are dimensionless, unlike in CART2EDROMO**.
!
! Revisions:
!    190113: Add optional flag for the calculation of the position only.
!
! ==============================================================================

! MODULES
use NSGRAV,        only: PINES_NSG
use SETTINGS,      only: insgrav,eqs
use PHYS_CONST,    only: GE_nd,RE_nd
! VARIABLES
implicit none
! Arguments IN
real(dk),intent(in)   ::  z(1:8),phi
logical, optional, intent(in)  ::  posOnly
! Arguments OUT
real(dk),intent(out)  ::  r_vec(1:3),v_vec(1:3)

! Auxiliaries
real(dk)    ::  Upot
real(dk)    ::  sph,cph
real(dk)    ::  rho,rmag,zeta,emme
real(dk)    ::  cnu,snu
real(dk)    ::  x_vec(1:3),y_vec(1:3)
real(dk)    ::  i_vec(1:3),j_vec(1:3)
real(dk)    ::  v_rad,v_tan
real(dk)    ::  t
integer     ::  flag_time

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

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

! Store trig functions
sph = sin(phi)
cph = cos(phi)

rho   = 1._dk - z(1)*cph - z(2)*sph
rmag  = z(3)*rho
zeta  = z(1)*sph - z(2)*cph
emme  = sqrt(1._dk - z(1)**2 - z(2)**2)

cnu = (cph - z(1) + (zeta*z(2))/(emme + 1._dk))/rho
snu = (sph - z(2) - (zeta*z(1))/(emme + 1._dk))/rho

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

! Intermediate frame unit vectors
x_vec = 2._dk*[ .5_dk - z(5)**2 - z(6)**2,  &
           &  z(4)*z(5) + z(6)*z(7),  &
           &  z(4)*z(6) - z(5)*z(7)]
y_vec = 2._dk*[  z(4)*z(5) - z(6)*z(7),  &
           & .5_dk - z(4)**2 - z(6)**2,  &
           &  z(5)*z(6) + z(4)*z(7)]

! Position in inertial frame
r_vec = rmag*(x_vec*cnu + y_vec*snu)

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

! By default, compute velocity
if(.not.(present(posOnly))) then
    flag_time = eqs - 2
    t = EDROMO_TE2TIME(z,phi,flag_time)
    Upot = 0._dk
    if (insgrav == 1) then
    call PINES_NSG(GE_nd,RE_nd,r_vec,t,pot=Upot)

    end if

! ==============================================================================
! 04. COMPUTE VELOCITY IN INERTIAL FRAME
! ==============================================================================

    ! Radial and tangential unit vectors in the inertial frame
    i_vec = x_vec*cnu + y_vec*snu
    j_vec = y_vec*cnu - x_vec*snu

    ! Radial and tangential components
    v_rad = zeta/(sqrt(z(3))*rho)
    v_tan = sqrt((1._dk - z(1)**2 - z(2)**2)/(z(3)*rho**2) - 2._dk*Upot)

    ! Velocity in the inertial frame
    v_vec = v_rad*i_vec + v_tan*j_vec

end if

end subroutine EDROMO2CART

function INERT2ORB_EDROMO(vI,z,cnu,snu)
! Description:
!    Transforms a vector vI from inertial to orbital axes through a rotation
!    matrix obtained fromo EDromo elements.
!
! ==============================================================================

! VARIABLES
implicit none

! Arguments
real(dk),intent(in)  ::  vI(1:3)
real(dk),intent(in)  ::  z(:)
real(dk),intent(in)  ::  cnu,snu
real(dk)             ::  INERT2ORB_EDROMO(1:3)
! Locals
real(dk)             ::  R1(1:3,1:3)    ! Inertial -> Intermediate rotation matrix
real(dk)             ::  R2(1:3,1:3)    ! Intermediate -> Orbital rotation matrix
real(dk)             ::  RTOT(1:3,1:3)  ! Inertial -> Orbital rotation matrix (= R2*R1)

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

R1 = 2._dk*reshape([ .5_dk - z(5)**2 - z(6)**2, z(4)*z(5) + z(6)*z(7), z(4)*z(6) - z(5)*z(7),&
            &  z(4)*z(5) - z(6)*z(7), .5_dk - z(4)**2 -z(6)**2, z(5)*z(6) + z(4)*z(7), &
            &  z(4)*z(6) + z(5)*z(7), z(5)*z(6) - z(4)*z(7), .5_dk - z(4)**2 - z(5)**2 ], [3,3])
R1 = transpose(R1)
R2   = reshape([ cnu, -snu, 0._dk,&
              &   snu,  cnu, 0._dk,&
              &   0._dk,    0._dk, 1._dk ],[3,3])
RTOT = matmul(R2,R1)

INERT2ORB_EDROMO = matmul(RTOT,vI)

end function INERT2ORB_EDROMO

end module EDROMO


      SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
     $                   T, LDT, C, LDC, WORK, LDWORK )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
*     ..
*     .. Array Arguments ..
      REAL               C( LDC, * ), T( LDT, * ), V( LDV, * ),
     $                   WORK( LDWORK, * )
*     ..
*
*  Purpose
*  =======
*
*  SLARFB applies a real block reflector H or its transpose H' to a
*  real m by n matrix C, from either the left or the right.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply H or H' from the Left
*          = 'R': apply H or H' from the Right
*
*  TRANS   (input) CHARACTER*1
*          = 'N': apply H (No transpose)
*          = 'T': apply H' (Transpose)
*
*  DIRECT  (input) CHARACTER*1
*          Indicates how H is formed from a product of elementary
*          reflectors
*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
*  STOREV  (input) CHARACTER*1
*          Indicates how the vectors which define the elementary
*          reflectors are stored:
*          = 'C': Columnwise
*          = 'R': Rowwise
*
*  M       (input) INTEGER
*          The number of rows of the matrix C.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C.
*
*  K       (input) INTEGER
*          The order of the matrix T (= the number of elementary
*          reflectors whose product defines the block reflector).
*
*  V       (input) REAL array, dimension
*                                (LDV,K) if STOREV = 'C'
*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
*          The matrix V. See further details.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V.
*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*          if STOREV = 'R', LDV >= K.
*
*  T       (input) REAL array, dimension (LDT,K)
*          The triangular k by k matrix T in the representation of the
*          block reflector.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= K.
*
*  C       (input/output) REAL array, dimension (LDC,N)
*          On entry, the m by n matrix C.
*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDA >= max(1,M).
*
*  WORK    (workspace) REAL array, dimension (LDWORK,K)
*
*  LDWORK  (input) INTEGER
*          The leading dimension of the array WORK.
*          If SIDE = 'L', LDWORK >= max(1,N);
*          if SIDE = 'R', LDWORK >= max(1,M).
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          TRANST
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SGEMM, STRMM
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
      IF( LSAME( TRANS, 'N' ) ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
*
      IF( LSAME( STOREV, 'C' ) ) THEN
*
         IF( LSAME( DIRECT, 'F' ) ) THEN
*
*           Let  V =  ( V1 )    (first K rows)
*                     ( V2 )
*           where  V1  is unit lower triangular.
*
            IF( LSAME( SIDE, 'L' ) ) THEN
*
*              Form  H * C  or  H' * C  where  C = ( C1 )
*                                                  ( C2 )
*
*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
*
*              W := C1'
*
               DO 10 J = 1, K
                  CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
   10          CONTINUE
*
*              W := W * V1
*
               CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                     K, ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
*
*                 W := W + C2'*V2
*
                  CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K,
     $                        ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
*
*              W := W * T'  or  W * T
*
               CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - V * W'
*
               IF( M.GT.K ) THEN
*
*                 C2 := C2 - V2 * W'
*
                  CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K,
     $                        -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
     $                        C( K+1, 1 ), LDC )
               END IF
*
*              W := W * V1'
*
               CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
     $                     ONE, V, LDV, WORK, LDWORK )
*
*              C1 := C1 - W'
*
               DO 30 J = 1, K
                  DO 20 I = 1, N
                     C( J, I ) = C( J, I ) - WORK( I, J )
   20             CONTINUE
   30          CONTINUE
*
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
*
*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
*
*              W := C1
*
               DO 40 J = 1, K
                  CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   40          CONTINUE
*
*              W := W * V1
*
               CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
     $                     K, ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
*
*                 W := W + C2 * V2
*
                  CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K,
     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
*
*              W := W * T  or  W * T'
*
               CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - W * V'
*
               IF( N.GT.K ) THEN
*
*                 C2 := C2 - W * V2'
*
                  CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
     $                        C( 1, K+1 ), LDC )
               END IF
*
*              W := W * V1'
*
               CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
     $                     ONE, V, LDV, WORK, LDWORK )
*
*              C1 := C1 - W
*
               DO 60 J = 1, K
                  DO 50 I = 1, M
                     C( I, J ) = C( I, J ) - WORK( I, J )
   50             CONTINUE
   60          CONTINUE
            END IF
*
         ELSE
*
*           Let  V =  ( V1 )
*                     ( V2 )    (last K rows)
*           where  V2  is unit upper triangular.
*
            IF( LSAME( SIDE, 'L' ) ) THEN
*
*              Form  H * C  or  H' * C  where  C = ( C1 )
*                                                  ( C2 )
*
*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
*
*              W := C2'
*
               DO 70 J = 1, K
                  CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
   70          CONTINUE
*
*              W := W * V2
*
               CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
*
*                 W := W + C1'*V1
*
                  CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
*
*              W := W * T'  or  W * T
*
               CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - V * W'
*
               IF( M.GT.K ) THEN
*
*                 C1 := C1 - V1 * W'
*
                  CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K,
     $                        -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
*
*              W := W * V2'
*
               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
     $                     ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
*              C2 := C2 - W'
*
               DO 90 J = 1, K
                  DO 80 I = 1, N
                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
   80             CONTINUE
   90          CONTINUE
*
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
*
*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
*
*              W := C2
*
               DO 100 J = 1, K
                  CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  100          CONTINUE
*
*              W := W * V2
*
               CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
*
*                 W := W + C1 * V1
*
                  CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
*
*              W := W * T  or  W * T'
*
               CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - W * V'
*
               IF( N.GT.K ) THEN
*
*                 C1 := C1 - W * V1'
*
                  CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
*
*              W := W * V2'
*
               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
     $                     ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
*
*              C2 := C2 - W
*
               DO 120 J = 1, K
                  DO 110 I = 1, M
                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
  110             CONTINUE
  120          CONTINUE
            END IF
         END IF
*
      ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
         IF( LSAME( DIRECT, 'F' ) ) THEN
*
*           Let  V =  ( V1  V2 )    (V1: first K columns)
*           where  V1  is unit upper triangular.
*
            IF( LSAME( SIDE, 'L' ) ) THEN
*
*              Form  H * C  or  H' * C  where  C = ( C1 )
*                                                  ( C2 )
*
*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
*
*              W := C1'
*
               DO 130 J = 1, K
                  CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
  130          CONTINUE
*
*              W := W * V1'
*
               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
     $                     ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
*
*                 W := W + C2'*V2'
*
                  CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
     $                        WORK, LDWORK )
               END IF
*
*              W := W * T'  or  W * T
*
               CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - V' * W'
*
               IF( M.GT.K ) THEN
*
*                 C2 := C2 - V2' * W'
*
                  CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
     $                        C( K+1, 1 ), LDC )
               END IF
*
*              W := W * V1
*
               CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
     $                     K, ONE, V, LDV, WORK, LDWORK )
*
*              C1 := C1 - W'
*
               DO 150 J = 1, K
                  DO 140 I = 1, N
                     C( J, I ) = C( J, I ) - WORK( I, J )
  140             CONTINUE
  150          CONTINUE
*
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
*
*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
*
*              W := C1
*
               DO 160 J = 1, K
                  CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
  160          CONTINUE
*
*              W := W * V1'
*
               CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
     $                     ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
*
*                 W := W + C2 * V2'
*
                  CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K,
     $                        ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
*
*              W := W * T  or  W * T'
*
               CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - W * V
*
               IF( N.GT.K ) THEN
*
*                 C2 := C2 - W * V2
*
                  CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
     $                        C( 1, K+1 ), LDC )
               END IF
*
*              W := W * V1
*
               CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
     $                     K, ONE, V, LDV, WORK, LDWORK )
*
*              C1 := C1 - W
*
               DO 180 J = 1, K
                  DO 170 I = 1, M
                     C( I, J ) = C( I, J ) - WORK( I, J )
  170             CONTINUE
  180          CONTINUE
*
            END IF
*
         ELSE
*
*           Let  V =  ( V1  V2 )    (V2: last K columns)
*           where  V2  is unit lower triangular.
*
            IF( LSAME( SIDE, 'L' ) ) THEN
*
*              Form  H * C  or  H' * C  where  C = ( C1 )
*                                                  ( C2 )
*
*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
*
*              W := C2'
*
               DO 190 J = 1, K
                  CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
  190          CONTINUE
*
*              W := W * V2'
*
               CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
     $                     ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
*
*                 W := W + C1'*V1'
*
                  CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                        C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
*
*              W := W * T'  or  W * T
*
               CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - V' * W'
*
               IF( M.GT.K ) THEN
*
*                 C1 := C1 - V1' * W'
*
                  CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
     $                        V, LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
*
*              W := W * V2
*
               CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
*              C2 := C2 - W'
*
               DO 210 J = 1, K
                  DO 200 I = 1, N
                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
  200             CONTINUE
  210          CONTINUE
*
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
*
*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
*
*              W := C2
*
               DO 220 J = 1, K
                  CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  220          CONTINUE
*
*              W := W * V2'
*
               CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
     $                     ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
*
*                 W := W + C1 * V1'
*
                  CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
*
*              W := W * T  or  W * T'
*
               CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - W * V
*
               IF( N.GT.K ) THEN
*
*                 C1 := C1 - W * V1
*
                  CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
*
*              W := W * V2
*
               CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
*              C1 := C1 - W
*
               DO 240 J = 1, K
                  DO 230 I = 1, M
                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
  230             CONTINUE
  240          CONTINUE
*
            END IF
*
         END IF
      END IF
*
      RETURN
*
*     End of SLARFB
*
      END


! -----------------------------------------------------------------------
! tide2roms
!
! Read netcdf files with tidal information
! for a polar stereographic domain and creates a NetCDF tide-file for ROMS
! ----------------------------------------------------------------------

! The program is written in Fortran 90
! It uses standard Fortran 77 NetCDF calls for NetCDF
! partly directly and partly through the module ncout_util
!
! Written by Ann Kristin Sperrevik, met.no, 2010
!
! 09.02.2012 - nilsmk@met.no: Added dims for u and v (for detiding)
!
! ----------------------------------------------------------------------

program tidenc2roms

  implicit none
  include "netcdf.inc"

  ! ------------------------------------------
  ! --- Constants
  ! ------------------------------------------

  character(len=*), parameter :: outfile = "tide.nc"

  ! --- Constituents
  integer, parameter :: Nconstit = 11
 ! character(len=5), dimension(Nconstit), parameter :: constit =   &
 !      (/ 'K2   ', 'S2   ', 'M2   ', 'N2   ', 'K1   ', 'P1   ',   &
 !      'O1   ', 'Q1   ' /)!,  'MM   ', 'MF   ', 'M4   ' /)
 character(len=5), dimension(Nconstit), parameter :: constit =   &
       (/'K2   ', 'S2   ', 'M2   ', 'N2   ', 'K1   ', 'P1   ',   &
       'O1   ', 'Q1   ', 'MN4  ', 'M4   ', 'MS4  ' /)

  character(len=*), parameter :: infile =  "tpxo.nc"

  !real, dimension(Nconstit), parameter :: freq =      &
  !     (/ 0.0835614924, 0.0833333333,                 &
  !     0.0805114007, 0.0789992488,                 &
  !     0.0417807462, 0.0415525871,                 &
  !     0.0387306544, 0.0372185026 /) ! ,             &
  !          0.0015121518, 0.0030500918,                 &
  !          0.1610228013 /)
  real, dimension(Nconstit), parameter :: freq =      &
       (/ 0.0835614924, 0.0833333333,                 &
          0.0805114007, 0.0789992488,                 &
          0.0417807462, 0.0415525871,                 &
          0.0387306544, 0.0372185026,                 &
          0.1595106495, 0.1610228013,                 &
           0.163844734 /)
  real, dimension(Nconstit), parameter :: period =      &
       (/ 1/freq(1), 1/freq(2), 1/freq(3),              &
          1/freq(4), 1/freq(5), 1/freq(6),              &
          1/freq(7), 1/freq(8), 1/freq(9),              &
          1/freq(10), 1/freq(11) /)

  ! --- NetCDF global title attribute
  character(len=*), parameter :: title = "Tidal forcing from met.no"

  ! --- Debug switch
  logical, parameter :: debug = .TRUE.

  ! --- Mathematical values
  real, parameter :: pi = 3.1415926
  real, parameter :: rad = pi/180.0
  real, parameter :: deg = 180.0/pi
  complex, parameter :: i = (0.0, 1.0)

  ! ---------------------------------------------
  ! --- Variables
  ! ---------------------------------------------

  ! -- Variables for feltfile reading

  integer :: imax, jmax, nc, nct

  real, dimension(:,:), allocatable :: uamp, uphase
  real, dimension(:,:), allocatable :: vamp, vphase
  complex, dimension(:,:), allocatable :: A, B
  real, dimension(:,:), allocatable :: rA, rB
  real, dimension(:,:), allocatable :: fA, fB

  real, dimension(:,:), allocatable :: rmask, error
  real, dimension(:,:), allocatable :: angle      ! Local rotation angle

  ! --- Output fields
  real, dimension(:,:,:), allocatable :: h_amp
  real, dimension(:,:,:), allocatable :: h_pha
  real, dimension(:,:,:), allocatable :: u_amp
  real, dimension(:,:,:), allocatable :: u_pha
  real, dimension(:,:,:), allocatable :: v_amp
  real, dimension(:,:,:), allocatable :: v_pha
  real, dimension(:,:), allocatable :: tide_Eamp
  real, dimension(:,:), allocatable :: tide_Ephase
  real, dimension(:,:), allocatable :: tide_Cmax
  real, dimension(:,:), allocatable :: tide_Cmin
  real, dimension(:,:), allocatable :: tide_Cangle
  real, dimension(:,:), allocatable :: tide_Cphase
  real, dimension(:,:), allocatable :: Areal, Aimag
  real, dimension(:,:), allocatable :: Breal, Bimag
  real, dimension(:,:), allocatable :: lat,lon, field, lon_rho, lat_rho
  character (len=4), dimension(:), allocatable :: con
  ! --- NetCDF dimensions
  integer ::  xi_rho, eta_rho, tide_period

  ! --- misc NetCDF
  integer :: status    ! Error return code
  integer :: ncid      ! NetCDF file identifier
  integer :: varid     ! NetCDF variable identifier
  integer :: dimid
  integer :: imax_id, jmax_id, xiu_id, xiv_id, etau_id, etav_id

  ! --- Indices
  integer :: ii, jj
  integer :: k

  ! --- misc variables
  !real :: lon, lat
  !real :: lon0, lat0
  !real :: lon1, lat1
  character(len=300) :: string, constring
  integer, dimension(8) :: date
  integer, dimension(:), allocatable :: indx
  integer :: nvalue
  integer :: testdum
  real :: reflat
  character (len=20) :: str, str2
  ! ==================================================================

  write (*,'(/,a12,a)') "Input file: ", trim(infile)
  ! Get dimensions from input file
  status=nf_open(infile, NF_NOWRITE, ncid); call check_err(status)
  status=nf_inq_dimid(ncid,'imax', dimid); call check_err(status)
  status = nf_inq_dimlen(ncid, dimid, imax); call check_err(status)
  status=nf_inq_dimid(ncid,'jmax', dimid); call check_err(status)
  status = nf_inq_dimlen(ncid, dimid, jmax); call check_err(status)

  !write (*,'(/,a6,i5,x,a6,i5)') "imax: ", imax, "jmax: ",jmax
  status=nf_inq_dimid(ncid,'nc', dimid); call check_err(status)
  status = nf_inq_dimlen(ncid, dimid, nc); call check_err(status)
  status=nf_inq_dimid(ncid,'nct', dimid); call check_err(status)
  status = nf_inq_dimlen(ncid, dimid, nct); call check_err(status)
  !
  ! --- Allocate arrays ---
  !
  allocate(field(imax, jmax),lon(imax, jmax),lat(imax, jmax))
  allocate(h_amp(imax, jmax, nc))
  allocate(h_pha(imax, jmax, nc))
  allocate(u_amp(imax, jmax, nc))
  allocate(u_pha(imax, jmax, nc))
  allocate(v_amp(imax, jmax, nc))
  allocate(v_pha(imax, jmax, nc))
  allocate(tide_Eamp(  0:imax+1, 0:jmax+1))
  allocate(tide_Ephase(0:imax+1, 0:jmax+1))
  allocate(tide_Cmax(  0:imax+1, 0:jmax+1))
  allocate(tide_Cmin(  0:imax+1, 0:jmax+1))
  allocate(tide_Cangle(0:imax+1, 0:jmax+1))
  allocate(tide_Cphase(0:imax+1, 0:jmax+1))
  allocate(uamp(0:imax+1, 0:jmax+1), uphase(0:imax+1, 0:jmax+1))
  allocate(vamp(0:imax+1, 0:jmax+1), vphase(0:imax+1, 0:jmax+1))
  allocate(A(0:imax+1, 0:jmax+1), B(0:imax+1, 0:jmax+1))
  allocate(rA(0:imax+1, 0:jmax+1), rB(0:imax+1, 0:jmax+1))
  allocate(fA(0:imax+1, 0:jmax+1), fB(0:imax+1, 0:jmax+1))
  allocate(angle(0:imax+1,0:jmax+1),lon_rho(0:imax+1,0:jmax+1),lat_rho(0:imax+1,0:jmax+1))
  allocate(rmask(0:imax+1,0:jmax+1), error(0:imax+1,0:jmax+1))

  allocate(con(nc))
  status=nf_inq_varid(ncid,"con",varid); call check_err(status)
  status=nf_get_var_text(ncid,varid,con); call check_err(status)

  status=nf_inq_varid(ncid,"angle",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,field); call check_err(status)

  status=nf_inq_varid(ncid,"longitude",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,lon); call check_err(status)

  status=nf_inq_varid(ncid,"latitude",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,lat); call check_err(status)

  status=nf_inq_varid(ncid,"lon_rho",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,lon_rho); call check_err(status)

  status=nf_inq_varid(ncid,"lat_rho",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,lat_rho); call check_err(status)

  status=nf_inq_varid(ncid,"h_amp",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,h_amp); call check_err(status)

  status=nf_inq_varid(ncid,"h_pha",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,h_pha); call check_err(status)

  status=nf_inq_varid(ncid,"u_amp",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,u_amp); call check_err(status)

  status=nf_inq_varid(ncid,"u_pha",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,u_pha); call check_err(status)

  status=nf_inq_varid(ncid,"v_amp",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,v_amp); call check_err(status)

  status=nf_inq_varid(ncid,"v_pha",varid); call check_err(status)
  status=nf_get_var_real(ncid,varid,v_pha); call check_err(status)

  status=nf_close(ncid); call check_err(status)
  write (*, '(a26)' ) "Inputfile grid dimensions:"
  write (*, '(a7,i5, x, a11, i5,/)' ) "imax = ", imax, "and jmax = ", jmax
  write (*, '(a)') "Tidal constituents on inputfile:"
  print *, con

  ! Include only constituents given in constit
  allocate(indx(nc))
! Very bad hardcoding... verify-algoritmen klarer ikke aa skille noen konstituenter
  indx(9)=13
  indx(10)=11
  indx(11)=12
  do k = 1, nc
     str=con(k)
     call To_Upper(str)
     if (verify(trim(constit(1)),trim(str)).eq.0) indx(1)=k
     if (verify(trim(constit(2)),trim(str)).eq.0) indx(2)=k
     if (verify(trim(constit(3)),trim(str)).eq.0) indx(3)=k
     if (verify(trim(constit(4)),trim(str)).eq.0) indx(4)=k
     if (verify(trim(constit(5)),trim(str)).eq.0) indx(5)=k
     if (verify(trim(constit(6)),trim(str)).eq.0) indx(6)=k
     if (verify(trim(constit(7)),trim(str)).eq.0) indx(7)=k
     if (verify(trim(constit(8)),trim(str)).eq.0) indx(8)=k

!!$     if (verify(trim(constit(9)),trim(str)).eq.0) indx(9)=k
!!$     if (verify(trim(constit(10)),trim(str)).eq.0) indx(10)=k
!!$     if (verify(trim(constit(11)),trim(str)).eq.0) indx(11)=k
!!$     if (verify(trim(constit(12)),trim(str)).eq.0) indx(12)=k
!!$     if (verify(trim(constit(13)),trim(str)).eq.0) indx(13)=k
  end do

  do k=1, nconstit
     string=constit(k)

    read(string,'(a)') str2
     if (len_trim(constring).eq.len(constring)) then
        constring=trim(str2)
     else
        constring = trim(constring)//" "//trim(str2)
     end if
  end do
  write (*, '(/,a)') "Tidal constituents on outputfile:"
  write (*, '(a)') trim(constring)

  ! --------------------------------
  ! ---- Define NetCDF grid file ---
  ! --------------------------------
  write (*, '(/,a,a)') "Create and define output file: ", trim(outfile)
  status = nf_create(trim(outfile), NF_CLOBBER, ncid);  call check_err(status)
  ! --- Define global attributes ---

  status = nf_put_att_text(ncid, NF_GLOBAL, "title", len_trim(title), title)
  call check_err(status)

  status = nf_put_att_text(ncid, NF_GLOBAL, "type", 9, "Tidal forcing file")
  call check_err(status)

  write(string,'(A)') "Created by tide2roms from sequential files from met.no"
  status = nf_put_att_text(ncid, NF_GLOBAL, "history", len_trim(string), string)
  call check_err(status)

  status = nf_put_att_text(ncid, NF_GLOBAL, 'constituents',     &
       len_trim(constring), constring)
  call check_err(status)

  call date_and_time(values=date)
  status = nf_put_att_int(ncid, NF_GLOBAL, 'Creation_date', NF_INT, 3, date(1:3))

  status = nf_def_dim(ncid, "xi_rho", imax+2, imax_id); call check_err(status)
  status = nf_def_dim(ncid, "eta_rho", jmax+2, jmax_id); call check_err(status)
  status = nf_def_dim(ncid, "xi_u", imax+1, xiu_id); call check_err(status)
  status = nf_def_dim(ncid, "eta_u", jmax+2, etau_id); call check_err(status)
  status = nf_def_dim(ncid, "xi_v", imax+2, xiv_id); call check_err(status)
  status = nf_def_dim(ncid, "eta_v", jmax+1, etav_id); call check_err(status)
  status = nf_def_dim(ncid, "tide_period", Nconstit, tide_period); call check_err(status)

  status = nf_def_var(ncid,"tide_period", NF_REAL,1,(/ tide_period /),varid); call check_err(status)
  status = nf_put_att_text(ncid,varid,"long_name",12,"Tidal period"); call check_err(status)
  status = nf_put_att_text(ncid,varid,"units",4,"hour"); call check_err(status)

  status = nf_def_var(ncid,"tide_Eamp", NF_REAL,3,(/ imax_id, jmax_id, tide_period /),varid); call check_err(status)
  status = nf_put_att_text(ncid,varid,"long_name",25,"Tidal elevation amplitude"); call check_err(status)
  status = nf_put_att_text(ncid,varid,"units",5,"meter"); call check_err(status)

  status = nf_def_var(ncid,"tide_Ephase", NF_REAL,3,(/ imax_id, jmax_id, tide_period /),varid); call check_err(status)
  status = nf_put_att_text(ncid,varid,"long_name",22,"Tidal elevation phase"); call check_err(status)
  status = nf_put_att_text(ncid,varid,"units",7,"degrees"); call check_err(status)

  status = nf_def_var(ncid,"tide_Cmax", NF_REAL,3,(/ imax_id, jmax_id, tide_period /),varid); call check_err(status)
  status = nf_put_att_text(ncid,varid,"long_name",21,"Maximum tidal current"); call check_err(status)
  status = nf_put_att_text(ncid,varid,"units",14,"meter second-1"); call check_err(status)

  status = nf_def_var(ncid,"tide_Cmin", NF_REAL,3,(/ imax_id,jmax_id, tide_period /),varid); call check_err(status)
  status = nf_put_att_text(ncid,varid,"long_name",21,"Minimum tidal current"); call check_err(status)
  status = nf_put_att_text(ncid,varid,"units",14,"meter second-1"); call check_err(status)

  status = nf_def_var(ncid,"tide_Cangle", NF_REAL,3,(/ imax_id,jmax_id, tide_period /),varid); call check_err(status)
  status = nf_put_att_text(ncid,varid,"long_name",20,"Tidal ellipsis angle"); call check_err(status)
  status = nf_put_att_text(ncid,varid,"units",7,"degrees"); call check_err(status)

  status = nf_def_var(ncid,"tide_Cphase", NF_REAL,3,(/ imax_id,jmax_id, tide_period /),varid); call check_err(status)
  status = nf_put_att_text(ncid,varid,"long_name",21,"Tidal current phase"); call check_err(status)
  status = nf_put_att_text(ncid,varid,"units",7,"degrees"); call check_err(status)

  status = nf_enddef(ncid);  call check_err(status)

  status = nf_inq_varid(ncid,'tide_period',varid); call check_err(status)
  status = nf_put_var_real(ncid,varid,period);  call check_err(status)

  ! -------------------------------------
  ! --- Loop through the constituents ---
  ! -------------------------------------
  write (*, '(/,a)') "Loop through the constituents: "
  reflat=55;
  do k = 1, Nconstit

     write (*,'(/,a4,a13,f7.4,1x,a5)') trim(constit(k)), " with period ", period(k), "hours"
     call extend(h_amp(:,:,indx(k)), tide_Eamp,imax,jmax)
     call extend(h_pha(:,:,indx(k)), tide_Ephase,imax,jmax)
     call extend(u_amp(:,:,indx(k)), uamp,imax,jmax)
     call extend(u_pha(:,:,indx(k)), uphase,imax,jmax)
     call extend(v_amp(:,:,indx(k)), vamp,imax,jmax)
     call extend(v_pha(:,:,indx(k)), vphase,imax,jmax)

     write(*,'(a)') "Perform phase shift and nodal corrections"

     !write (*,'(/,a6,i5,x,a6,i5)') "imax: ", imax, "jmax: ",jmax
     call shiftphase(tide_Eamp,tide_Ephase,uamp,uphase,vamp,vphase,imax,jmax,constit(k),reflat)

     !write(*,'(a)') "1"
     allocate(Areal(0:imax+1,0:jmax+1), Aimag(0:imax+1,0:jmax+1))
     allocate(Breal(0:imax+1,0:jmax+1), Bimag(0:imax+1,0:jmax+1))

     ! --- Elevation, fill
     ! Eamp*cos(wt-Ephase) =
     !    Eamp*cos(Ephase)*cos(wt) + Eamp*sin(Ephase)*sin(wt)

     Areal = tide_Eamp*cos(tide_Ephase*rad)
     Breal = tide_Eamp*sin(tide_Ephase*rad)

     where (tide_Eamp < 0.001)
        Areal = 1.0E36
        Breal = 1.0E36
     end where
     call fill(imax+2, jmax+2, 1, imax+2, 1, jmax+2, Areal,              &
          1.0E35, 0.01, 1.6, 100, rmask, error, nvalue)
     call fill(imax+2, jmax+2, 1, imax+2, 1, jmax+2, Breal,              &
          1.0E35, 0.01, 1.6, 100, rmask, error, nvalue)

     tide_Eamp   = sqrt(Areal*Areal + Breal*Breal)
     tide_Ephase = atan2(Breal, Areal)*deg
     where(tide_Ephase < 0)
        tide_Ephase = tide_Ephase + 360.0
     end where
     write(*,'(a)') "Convert to ellipse parameters"
     ! --- Convert to ellipse parameters
     A = 0.5*(uamp*exp(-i*uphase*rad) + i*vamp*exp(-i*vphase*rad))
     B = 0.5*(uamp*exp( i*uphase*rad) + i*vamp*exp( i*vphase*rad))

     ! --- Fill
     Areal = real(A)
     Aimag = imag(A)
     where (abs(A) < 0.001)
        Areal = 1.0E36
        Aimag = 1.0E36
     end where

     call fill(imax+2, jmax+2, 1, imax+2, 1, jmax+2, Areal,              &
          1.0E35, 0.01, 1.6, 100, rmask, error, nvalue)
     call fill(imax+2, jmax+2, 1, imax+2, 1, jmax+2, Aimag,              &
          1.0E35, 0.01, 1.6, 100, rmask, error, nvalue)

     A = Areal + i*Aimag

     Breal = real(B)
     Bimag = imag(B)

     where (abs(B) < 0.001)
        Breal = 1.0E36
        Bimag = 1.0E36
     end where

     call fill(imax+2, jmax+2, 1, imax+2, 1, jmax+2, Breal,              &
          1.0E35, 0.01, 1.6, 100, rmask, error, nvalue)
     call fill(imax+2, jmax+2, 1, imax+2, 1, jmax+2, Bimag,              &
          1.0E35, 0.01, 1.6, 100, rmask, error, nvalue)

     B = Breal + i*Bimag
     deallocate(Areal,Breal, Aimag, Bimag)
     rA = abs(A)
     fA = imag(log(A/rA))
     where(rA < 0.00001)
        fA = 0.0
     end where
     rB = abs(B)
     fB = imag(log(B/rB))
     where(rB < 0.00001)
        fB = 0.0
     end where

     tide_Cmax = rA + rB
     tide_Cmin = rA - rB
     tide_Cangle = 0.5*(fA + fB)*deg
     write(*,'(a)') "Rotate so that Cangle is measured from the grid's east"
     ! rotate so that Cangle is measured from east
     tide_Cangle = tide_Cangle + angle

     where(tide_Cangle < 0)
        tide_Cangle = tide_Cangle + 360.0
     end where

     tide_Cphase = 0.5*(fB - fA)*deg
     where(tide_Cphase < 0)
        tide_Cphase = tide_Cphase + 360.0
     end where

     write(*,'(a)') "Write tidal forcing to file"
     status = nf_inq_varid(ncid, "tide_Eamp", varid);  call check_err(status)

     status = nf_put_vara_real(ncid, varid, (/ 1, 1, k /), (/ imax+2, jmax+2, 1 /), tide_Eamp(0:imax+1,0:jmax+1))
     call check_err(status)
     status = nf_inq_varid(ncid, "tide_Ephase", varid)
     call check_err(status)
     status = nf_put_vara_real(ncid, varid, (/ 1, 1, k /), (/ imax+2, jmax+2, 1 /), tide_Ephase(0:imax+1,0:jmax+1))
     call check_err(status)
     status = nf_inq_varid(ncid, "tide_Cmax", varid)
     call check_err(status)
     status = nf_put_vara_real(ncid, varid, (/ 1, 1, k /), (/ imax+2, jmax+2, 1 /), tide_Cmax(0:imax+1,0:jmax+1))
     call check_err(status)
     status = nf_inq_varid(ncid, "tide_Cmin", varid)
     call check_err(status)
     status = nf_put_vara_real(ncid, varid, (/ 1, 1, k /), (/ imax+2, jmax+2, 1 /), tide_Cmin(0:imax+1,0:jmax+1))
     call check_err(status)

     status = nf_inq_varid(ncid, "tide_Cangle", varid)
     call check_err(status)
     status = nf_put_vara_real(ncid, varid, (/ 1, 1, k /), (/ imax+2, jmax+2, 1 /), tide_Cangle(0:imax+1,0:jmax+1))
     call check_err(status)
     status = nf_inq_varid(ncid, "tide_Cphase", varid)
     call check_err(status)
     status = nf_put_vara_real(ncid, varid, (/ 1, 1, k /), (/ imax+2, jmax+2, 1 /), tide_Cphase(0:imax+1,0:jmax+1))
     call check_err(status)

  end do ! k

  status = nf_close(ncid)
  call check_err(status)
  write (*, '(/,a,/)') "tidenc2roms: exiting normally"
  ! -------------------------
  ! --- Internal routines ---
  ! -------------------------

end program tidenc2roms

  subroutine extend(A,B,imax,jmax)
    real, dimension(imax,jmax), intent(in) :: A
    real, dimension(0:size(A,1)+1, 0:size(A,2)+1), intent(out) :: B
    integer :: imax, jmax

    B(1:imax, 1:jmax) = A
    B(1:imax, 0)      = A(:,1)
    B(1:imax, jmax+1) = A(:,jmax)
    B(0, 1:jmax)      = A(1,:)
    B(imax+1, 1:jmax) = A(imax,:)
    B(0,0)            = A(1,1)
    B(0,jmax+1)       = A(1,jmax)
    B(imax+1,0)       = A(imax,1)
    B(imax+1,jmax+1)  = A(imax,jmax)
  end subroutine extend

  subroutine To_upper(str)
    character(*), intent(in out) :: str
    integer :: i

    do i = 1, len(str)
       select case(str(i:i))
       case("a":"z")
          str(i:i) = achar(iachar(str(i:i))-32)
       end select
    end do
  end subroutine To_upper

  subroutine To_lower(str)
    character(*), intent(in out) :: str
    integer :: i

    do i = 1, len(str)
       select case(str(i:i))
       case("A":"Z")
          str(i:i) = achar(iachar(str(i:i))+32)
       end select
    end do
  end subroutine To_Lower