! Example for the chaboche model
! mpar: E, nu, Y0, Hiso, 1/kinf, Hk1, 1/ainf1, Hk2, 1/ainf2, ....
! ipar: E, nu, Y0, Htot, Ysat, rk1, ra1, rk2, ra2, ...
! Where
!Htot = Hiso + sum(Hki)
!Ysat = Y0 + kinf + sum(ainfi)
!rki = Hki/Htot
!rai = ainfi/(Ysat-Y0)
! Scale all parameters linearly

module util_funs
implicit none
    private
    public :: lin_scale
    public :: lin_scale_back

    contains

    function lin_scale(val, val_max, val_min)
    implicit none
        double precision    :: val, val_max, val_min
        double precision    :: lin_scale

        lin_scale = (val-val_min)/(val_max-val_min)
    end function

    function lin_scale_back(val_scaled, val_max, val_min) result(val)
    implicit none
        double precision    :: val_scaled, val_max, val_min
        double precision    :: val

        val = (val_max-val_min)*val_scaled + val_min
    end function

end module

subroutine xvar_to_mpar(mpar, ipar, xvar, optim, ipar_min, ipar_max)
!DEC$ ATTRIBUTES DLLEXPORT :: xvar_to_mpar
use util_funs
implicit none
    double precision, intent(inout) :: mpar(:)      ! The material parameters (used by umat): To be updated
    double precision, intent(inout) :: ipar(:)      ! Contains the initial input parameters.
    double precision, intent(in)    :: xvar(:)      ! Contains scaled parameters [0,1] that are optimized
    integer, intent(in)             :: optim(:)     ! Contains the position of the optimized parameters in ipar
    double precision, intent(in)    :: ipar_min(:)  ! Min values for input material parameters
    double precision, intent(in)    :: ipar_max(:)  ! Max values for input material parameters
    ! Internal variables
    integer                         :: ind, k1

    ! Convert xvar to ipar first
    do k1=1,size(xvar)
        ind = optim(k1)
        ipar(ind) = lin_scale_back(xvar(k1), ipar_max(k1), ipar_min(k1))
    enddo

    ! Then convert mpar to ipar:
    !       1,  2,  3,    4,      5,   6,       7,   8,       9
    ! mpar: E, nu, Y0, Hiso, 1/kinf, Hk1, 1/ainf1, Hk2, 1/ainf2, ....
    ! ipar: E, nu, Y0, Htot,   Ysat, rk1,     ra1, rk2,     ra2, ...
    mpar = ipar
    ! Plastic modulii
    mpar(4) = ipar(4)*(1.d0 - sum(ipar(6::2)))  ! Isotropic
    mpar(6::2) = ipar(4)*ipar(6::2)             ! Kinematic
    ! Saturation stresses
    mpar(5) = 1.d0/((ipar(5)-ipar(3))*(1.d0 - sum(ipar(7::2))))
    mpar(7::2) = 1.d0/((ipar(5)-ipar(3))*ipar(7::2))

end subroutine

subroutine ipar_to_xvar(ipar, xvar, optim, ipar_min, ipar_max)
!DEC$ ATTRIBUTES DLLEXPORT :: ipar_to_xvar
use util_funs
implicit none
    double precision, intent(in)    :: ipar(:)      ! Contains the current material parameters
    double precision, intent(inout) :: xvar(:)      ! Contains scaled parameters [0,1] that are optimized, to be updated
    integer, intent(in)             :: optim(:)     ! Contains the position of the optimized parameters in mpar
    double precision, intent(in)    :: ipar_min(:)  ! Min values for input material parameters
    double precision, intent(in)    :: ipar_max(:)  ! Max values for input material parameters

    !Internal variables
    integer                         :: ind, k1

    do k1=1,size(xvar)
        ind = optim(k1)
        xvar(k1) = lin_scale(ipar(ind), ipar_max(k1), ipar_min(k1))
    enddo

end subroutine

subroutine xvar_to_ipar(ipar, xvar, optim, ipar_min, ipar_max)
!DEC$ ATTRIBUTES DLLEXPORT :: xvar_to_ipar
use util_funs
implicit none
    ! Convert scaled parameters into input material parameters.
    double precision, intent(inout) :: ipar(:)      ! Contains the initial input parameters, to be updated
    double precision, intent(in)    :: xvar(:)      ! Contains scaled parameters [0,1] that are optimized
    integer, intent(in)             :: optim(:)     ! Contains the position of the optimized parameters in ipar
    double precision, intent(in)    :: ipar_min(:)  ! Min values for input material parameters
    double precision, intent(in)    :: ipar_max(:)  ! Max values for input material parameters

    ! Internal variables
    integer                         :: ind, k1

    do k1=1,size(xvar)
        ind = optim(k1)
        ipar(ind) = lin_scale_back(xvar(k1), ipar_max(k1), ipar_min(k1))
    enddo

end subroutine


      subroutine init_ipib2(n_b1,n_iPI,Nx,res)
      implicit none
      integer i
      integer Nx
      real*8 n_b1(Nx)
      real*8 n_iPI(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = n_iPI(i) * n_b1(i) ** 2
      res(i)=qb
      end do
      END


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

program testieee18flushz
use ieee_arithmetic
real*4 a, ral, rone
real*4 aa1(140), aa2(140)
logical ll1(140), le1(140)
logical luflow
logical lfsav(5), lfset(5)

lfset = .false.
call ieee_get_halting_mode(ieee_all, lfsav)
call ieee_set_halting_mode(ieee_all, lfset)

call ieee_get_underflow_mode(luflow)
call ieee_set_underflow_mode(.false.)

rone = 1.0
rlogb = 0.0
a = rone
do j = 1, 140
  ral = ieee_logb(a)
  aa1(j) = ral
  if (j .le. 127) then
    aa2(j) = rlogb
  else
    aa2(j) = ieee_value(rlogb, ieee_negative_inf)
  end if
  i = int(ieee_rint(ral))
  a = a * 0.5
  rlogb = rlogb - 1.0
end do

do j = 1, 140
  ll1(j) = aa1(j) .eq. aa2(j)
end do

le1 = .true.

call check(ll1, le1, 140)

call ieee_set_underflow_mode(luflow)
call ieee_set_halting_mode(ieee_all, lfsav)
end


MODULE m_interporb_nom

! ----------------------------------------------------------------------
! MODULE: m_interporb.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the interp_orb subroutine used for orbit interpolation
!
! Subroutines contained within the module:
! - interp_orb.f03
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	3 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE interp_orb_nom (fname_sp3, PRN, interv_in, NPint, orbint)

! ----------------------------------------------------------------------
! SUBROUTINE: interp_orb.f90
! ----------------------------------------------------------------------
! Purpose:
!  GNSS sp3 orbit interpolation based on Lagrange polynomials
! ----------------------------------------------------------------------
! Input arguments:
! - fname_sp3:  	Orbit file in sp3 format which contains only position vector
! - PRN:			Satellite PRN number
! - interv_in: 		Interval of the interpolation epochs (in seconds)
! - NPint:			Number of data points to be used for interpolation (defines the order of the polynomial)
! - fname_orbint:	Output file name for writing interpolated orbit array
!
! Output arguments:
! - orbint:   		Interpolated orbit including position and velocity vetors per epoch (allocatable array)
! ----------------------------------------------------------------------
! Note 1:
!  The input orbit file (sp3) is considered to include satellite position vector only
!  as this is the IGS standard product
!  During the orbit interpolation, based on Lagrange polynomials, position
!  and velocity vectors for the selected satellite (PRN) are computed and
!  provided in the output files.
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia
! Created:	5 August 2016
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 14 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 adavantages in dynamic memory allocation
! - Dr. Thomas Papanikolaou, 4 May 2020:
! 	Renamed as m_interporb_nom.f03 in the frame of upgrading the orbit
!	interpolation algorithm for case of orbits with outliers (zero values)
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE m_sp3
      USE m_lagrange
      !USE mdl_arr
      !USE mdl_write
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      CHARACTER (LEN=300), INTENT(IN) :: fname_sp3
      !CHARACTER (LEN=300), INTENT(IN) :: fname_orbint
      INTEGER (KIND = prec_int8), INTENT(IN) :: interv_in, NPint
	  !INTEGER (KIND = 4) :: PRN
      CHARACTER (LEN=3), INTENT(IN) :: PRN
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: orbint
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Nepochs, epoch_i, sz1, sz2, interv
      INTEGER (KIND = prec_int8) :: data_rate, Nepoch_int, Norb_int, NPint_1, NPint_2, Nlimit
	  INTEGER (KIND = prec_int8) :: i, j, i1, i2, ti
	  REAL (KIND = prec_d) :: SecDay_i, MJD_i
	  REAL (KIND = prec_d) :: MJD_tint, tint, Xint, Xint_1, Yint, Yint_1, Zint, Zint_1
	  REAL (KIND = prec_d) :: X, Y, Z, Vx, Vy, Vz
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      CHARACTER (LEN=300) :: fname_write
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: orbsp3
      REAL (KIND = prec_q), DIMENSION(:), ALLOCATABLE :: X_interp
      REAL (KIND = prec_q), DIMENSION(:), ALLOCATABLE :: Y_interp
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: clock_matrix

	  ! Read IGS sp3 orbit data file (position only): orbsp3
      Call sp3 (fname_sp3, PRN, orbsp3, clock_matrix)
	  sz1 = size(orbsp3, DIM = 1)

! ----------------------------------------------------------------------
! Interpolation epoch limits (24h orbit arc or less):
! 1. Interpolation is applied only within the data points (15 min less than 24h arc):  Set Nlimit to 1
! 2. Interpolation is applied also after the last data point's epoch (23h 45min 00sec) in order to cover a 24h arc:  Set Nlimit to 0
Nlimit = 1
! default initial value?
data_rate = 1
! ----------------------------------------------------------------------

	  ! Data rate of sp3 (in sec)
      DO i = 1 , sz1-1
		if ( INT(orbsp3(i+1,1)) - INT(orbsp3(i,1)) == 0 ) then
			data_rate = INT( orbsp3(2,2) - orbsp3(1,2) )
			EXIT
		end if
	  End Do

! ----------------------------------------------------------------------
IF (interv_in < 0 .OR. interv_in > data_rate) THEN
	interv = data_rate
ELSE
	interv = interv_in
END IF
!print *,"interv", interv
! ----------------------------------------------------------------------

      ! Number of points to be interpolated during the span between two epochs of the sp3 file (15min, 5min)
	  Nepoch_int = data_rate / interv - 1

      ! Number of epochs of interpolated orbit (excluding extrapolation at the last point i.e. the start of the next day's sp3: 00h 00min 00sec)
      !Norb_int = (data_rate / interv) * (sz1-1) + 1
      Norb_int = (data_rate / interv) * (sz1 - Nlimit) + Nlimit
	  !Nlimit=1
      !Norb_int = 1 + (data_rate / interv) * (sz1 - Nlimit)
	  !Nlimit=0
      !Norb_int = 1 + (data_rate / interv) * (sz1 - Nlimit) - 1

! Allocatable arrays for Lagrange Interpolation (declared in mdl_arr.f90)
      ALLOCATE (X_interp(NPint), STAT = AllocateStatus)
      ALLOCATE (Y_interp(NPint), STAT = AllocateStatus)
! Allocatable arrays  for the interpolated orbit array
      ALLOCATE (orbint(Norb_int, 8) , STAT = AllocateStatus)

! ----------------------------------------------------------------------
! Number of data points (used for the interpolation) before and after of each epoch of sp3 file
      NPint_1 = INT(NPint/2)
      NPint_2 = NPint - NPint_1

	  epoch_i = 0
      DO i = 1 , sz1
		epoch_i  = epoch_i + 1
		MJD_i    = orbsp3(i,1)
		SecDay_i = orbsp3(i,2)
! ----------------------------------------------------------------------
! Form arrays with data points to be used in the interpolation
		if ( i < NPint_1 ) then
			i1 = i
			i2 = i + (NPint - 1)
			!print *,"sz1, i, epoch_i, i1, i2", sz1, i, epoch_i, i1, i2
		else if ( sz1 - i < NPint_2 ) then
			i2 = sz1
			i1 = i2 - (NPint-1)
			!print *,"sz1, i, epoch_i, i1, i2", sz1, i, epoch_i, i1, i2
		else
			i1 = i - (NPint_1 - 1)
			i2 = i + NPint_2
			!print *,"i,epoch_i,i1,i2", i, epoch_i, i1, i2
		end if

        ! Time array of the data points used for the interpolation: X_interp
!		ti = 1
!		X_interp(1) = orbsp3(i1, 2)
!		Do ti = 2 , NPint
!			X_interp(ti) = X_interp(1) + (ti - 1) * data_rate * 1.D0
!		End Do

		ti = 0
		Do j = i1 , i2
		ti = ti + 1
			X_interp(ti) = SecDay_i + (j-i) * data_rate * 1.D0  !(ti - 1) * data_rate * 1.D0
		End Do
	    j = 0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Data Point: Velocity computation based on interpolation
! ----------------------------------------------------------------------
		! Position Vector: value from the IGS sp3 file
		orbint(epoch_i, 1:5) = orbsp3(i, 1:5)
        X = orbsp3(i,3)
		Y = orbsp3(i,4)
		Z = orbsp3(i,5)

		! Velocity Vector: computation via Lagrange interpolation
		tint = SecDay_i

		! Vx
		Y_interp = orbsp3(i1:i2, 3)
		!Call interp_lag(tint-1, Xint_1)
		Call interp_lag(tint-1, X_interp, Y_interp, Xint_1)
        Vx = X - Xint_1
		! Vy
		Y_interp = orbsp3(i1:i2, 4)
		!Call interp_lag(tint-1, Yint_1)
		Call interp_lag(tint-1, X_interp, Y_interp, Yint_1)
        Vy = Y - Yint_1
		! Vz
		Y_interp = orbsp3(i1:i2, 5)
		!Call interp_lag(tint-1, Zint_1)
		Call interp_lag(tint-1, X_interp, Y_interp, Zint_1)
        Vz = Z - Zint_1

		! Write Velocity to array orbint
		orbint(epoch_i, 6) = Vx
		orbint(epoch_i, 7) = Vy
		orbint(epoch_i, 8) = Vz
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Lagrange Interpolation applied for the new points
! ----------------------------------------------------------------------
! When Nlimit=0 & i=sz1 : Extrapolation is performed after the last data point of the sp3 file (for completing 24h arc)
If (i <= sz1 - Nlimit) then
		DO j = 1 , Nepoch_int
			tint = j * interv * 1.D0 + SecDay_i

		!DO j = t(1) , t(NPint) , interv
			!tint = j * interv + orbsp3(i,2)

		if (1 < 0) then
		!if (i == sz1 .and. j == Nepoch_int) then
		! Avoid computing the last point since this is the start point of the next day's sp3 file
		PRINT *,"i,j", i,j
		PRINT *,"orbint(epoch_i,:)", orbint(epoch_i,:)
		PRINT *,"orbint(epoch_i-1,:)", orbint(epoch_i-1,:)
		EXIT
		end if

		! Position and Velocity Vectors
			! X
			Y_interp = orbsp3(i1:i2, 3)
			!Call interp_lag(tint, Xint)
			Call interp_lag(tint, X_interp, Y_interp, Xint)
			! Vx
			!Call interp_lag(tint-1, Xint_1)
			Call interp_lag(tint-1, X_interp, Y_interp, Xint_1)
            !Vx = Xint_1 - Xint
            Vx = Xint - Xint_1

			! Y
			Y_interp = orbsp3(i1:i2, 4)
			!Call interp_lag(tint, Yint)
			Call interp_lag(tint, X_interp, Y_interp, Yint)
			! Vy
			!Call interp_lag(tint-1, Yint_1)
			Call interp_lag(tint-1, X_interp, Y_interp, Yint_1)
            !Vy = Yint_1 - Yint
            Vy = Yint - Yint_1

			! Z
			Y_interp = orbsp3(i1:i2, 5)
			!Call interp_lag(tint, Zint)
			Call interp_lag(tint, X_interp, Y_interp, Zint)
			! Vz
			!Call interp_lag(tint-1, Zint_1)
			Call interp_lag(tint-1, X_interp, Y_interp, Zint_1)
            !Vz = Zint_1 - Zint
            Vz = Zint - Zint_1

! Next epoch
			epoch_i = epoch_i + 1

! MJD epoch
			MJD_tint = INT(MJD_i) * 1.D0 + tint / 86400.D0

! Write interpolated state vector in array
			! Time arguments at interpolation epoch
			orbint(epoch_i, 1) = MJD_tint

			If (tint > 86400.D0) then
			   tint = tint - 86400.D0
			End If

			orbint(epoch_i, 2) = tint

			! Position vector (interpolated)
			orbint(epoch_i, 3) = Xint
			orbint(epoch_i, 4) = Yint
			orbint(epoch_i, 5) = Zint

			! Velocity vector (interpolated)
			orbint(epoch_i, 6) = Vx
			orbint(epoch_i, 7) = Vy
			orbint(epoch_i, 8) = Vz
		End DO
End IF
! ----------------------------------------------------------------------
      End Do
	  Deallocate (X_interp)
	  Deallocate (Y_interp)
End subroutine

END Module


!! @file gpe.f90
!! @brief This module contains main procedures for the program.

!============================================!
!                                            !
!            Glitching simulation            !
!              by Teppei Sasaki              !
!                                            !
!                updated:2021                !
!                                            !
!============================================!

!> プログラムのメインコード
!! @details 前半がプログラムの初期化と虚時間発展、後半で実時間発展を計算する
program main
    use constants
    use mathf
    use io
    use setting
    !$ use omp_lib
    implicit none
    ! VARIABLES
    complex(kind(0d0)),allocatable :: Phi(:), Phi_old(:)
    double precision  ,allocatable :: Pot(:)
    double precision               :: mu, mu_old
    double precision               :: t1, t2, calc_time
    integer                        :: iter, iter_conv
    double precision               :: E, E_old, energies(1:4)
    double precision,allocatable   :: flux(:,:)
    double precision               :: prob
    double precision               :: OMEGA_avg
    double precision,allocatable   :: OMEGA_z(:), RAND_RATE(:)
    double precision               :: dOMEGA_dt, OMEGA_t
    logical                        :: is_conv
    double precision               :: time
    double precision               :: L_new(1:3), L_old(1:3)
    character(len=7)               :: iter_str
    ! DATA DIRECTORY
    character(len=19)              :: RESULT_DIRECTORY
    character(len=10)              :: UTC
    integer                        :: iz

    call load_config

    ! ALLOCATION
    allocate( density(1:NL) )
    allocate( flux(1:NL,1:3) )
    allocate( Phi(1:NL), Pot(1:NL), Phi_old(1:NL) )
    allocate( old_phi(1:NL), ztemp(1:NL), ztemp2(1:NL), HPhi(1:NL) )
    allocate( i2ix(1:NL), i2iy(1:NL), i2iz(1:NL), ixyz2i(1:Nx, 1:Ny, 1:Nz) )
    allocate( zgrad(1:NL,1:3), drevert(1:NL), ztrans(1:NL), zlap(1:NL), zAbs2Gradient(1:NL) )
    allocate( zLxPhi(1:NL), zLyPhi(1:NL), zLzPhi(1:NL) )
    allocate( OMEGA_z(1:Nz), RAND_RATE(1:Nz) )

    !$ write (*, '(1X,A)') "OpenMP is valid."
    call prepare_mpi
    if ( mpi_num_procs > -1 ) then
        write (*, '(1X,A)') "OpenMPI is valid."
        write (*, '(1X,A,2(I0,A))') "(MPI) ", mpi_rank + 1, " / ", mpi_num_procs, " [rank/procs]"
    else
        write (*, '(1X,A)') "OpenMPI is invalid."
    end if
    !call MPI_Barrier(MPI_COMM_WORLD, mpi_ierr)

    call date_and_time(TIME=UTC)
    write (UTC, '(A)') UTC(1:6)
    write (RESULT_DIRECTORY, '(A)') "data_"//trim(UTC)
    call system("mkdir ./"//trim(RESULT_DIRECTORY))
    call system("mkdir ./"//trim(RESULT_DIRECTORY)//"/latest/")
    call system("mkdir ./"//trim(RESULT_DIRECTORY)//"/latest/wf_real")
    call system("mkdir ./"//trim(RESULT_DIRECTORY)//"/latest/flux_real")
    write (RESULT_DIRECTORY, '(A)') "data_"//trim(UTC)//"/latest/"
    write (*, *) "output folder: data_"//trim(UTC)
    call record_config(trim(RESULT_DIRECTORY))

    if ( mpi_rank == 0 ) then
        write (*, '(A)')                    "Configuration ---------------------------------------------------"
        write (*, '(1X, A, 3(I0, 1X))')     "Nx Ny Nz            (Dimension) = ", Nx, Ny, Nz
        write (*, '(1X, A, F0.7)')          "dh                 (Space step) = ", dh
        write (*, '(1X, A, 2(F0.7, 1X))')   "dt (IMAG) (REAL)    (Time step) = ", dt_imag, dt_real
        write (*, '(1X, A, 3(F0.2, 1X))')   "2xmax 2ymax 2zmax    (Box size) = ", 2*xmax, 2*ymax, 2*zmax
        write (*, '(1X, A, F0.2)')          "R0                (Trap radius) = ", R0
        write (*, '(1X, A, I0)')            "Number of particles             = ", ParticleN
        write (*, '(A)')                    "------------------------------------------------------------------"
    end if

    ! IMAGINARY TIME DEVELOPMENT ------------------------------------------------------------------
    if ( mpi_rank == 0 ) then
        write (*, *) "Imaginary time evolution"
    end if

    ! Set initial potential and wave function
    call initialize(Pot, Phi)
    call prepare_derivative

    ! CREATE VORTEX
    if ( vortex_exists ) then
        call make_vortex(Phi, vortex_kappa, x0_vortex, y0_vortex)
    end if

    ! POTENTIAL & INITIAL WAVEFUNCTION
    if ( mpi_rank == 0 ) then
        call output_potential(RESULT_DIRECTORY // "potential.bin", Pot)
    end if

    ! FILE I/O
    if ( mpi_rank == 0 ) then
        open(10, file=RESULT_DIRECTORY // "energy_imag.bin", form="unformatted", status="replace")
        call output_complex(RESULT_DIRECTORY // "wf_trial.bin", Phi)
    end if

    E       = -128d0
    mu      = -128d0
    is_conv = .false.
    density = abs(Phi)**2
    OMEGA_z = omega_imag

    call cpu_time(t1)
    do iter = 1, 500000
        Phi_old = Phi
        call evolve(Phi, Pot, OMEGA_z, .true.)
        mu_old = mu
        mu     = calc_mu(Phi, Pot, OMEGA_z)
        ! PROGRESS
        if (mod(iter, 1000) == 0 .or. iter == 1) then
            if ( mpi_rank == 0 ) then
                ! plot "energy_imag.bin" binary format="%*int%int%3double%*int" using 1:3 w l
                E = calc_total_energy(Phi, Pot, OMEGA_z)
                write(10) iter, iter*dt_imag, mu, E
                write (*, '(1X, I7, A, F0.8)') iter, &
                &" iterations have passed, Δmu=", abs(mu-mu_old)
            endif
        end if

        ! IS CONVERGED?
        if ( abs(mu-mu_old) < 1d-8 .and. 3000 <= iter ) then
            if ( mpi_rank == 0 ) then
                write (*, '(1X, A, I0, A, F0.8)') "solution converged at iter=", iter, ", Δmu=", abs(mu-mu_old)
            end if
            is_conv = .true.
            iter_conv = iter
            exit
        endif

        ! Mix densities
        density = (1d0 - alpha) * abs(Phi_old)**2 + alpha * abs(Phi)**2
    end do
    call cpu_time(t2)
    calc_time = t2 - t1

    ! WARNING
    if (is_conv .eqv. .false.) then
        if ( mpi_rank == 0 ) then
            write (*, '(X, A, F15.10)') "solution not converged. Δmu=", abs(mu-mu_old)
        endif
        iter_conv = 500000
    end if

    write (*, '(1X, A, 3(I0, A))') "calculation took ", &
    &int( calc_time / 3600 ), " h ", int( mod(calc_time, 3600d0) / 60 ), " m ", int( mod(calc_time, 60d0) ), " s"

    ! FILE I/O
    if ( mpi_rank == 0 ) then
        call output_complex(RESULT_DIRECTORY // "wf_imag.bin", Phi)
        open(60, file=RESULT_DIRECTORY // "wf_imag_raw.bin", form="unformatted")
        write(60) Phi
        close(60)
    end if

    if ( should_calc_real .eqv. .false. ) then
        goto 200
    end if

    if ( mpi_rank == 0 ) then
        energies = calc_energies(Phi, Pot, OMEGA_z)
        L_new    = calc_Lall(Phi)
        write (*, '(1X, A, F0.2, A)') "- Number of particles = ", integrate( abs(Phi)**2 )
        write (*, '(1X, A, F0.2, A)') "- Chemical potential  = ", calc_mu(Phi, Pot, OMEGA_z)
        write (*, '(1X, A, F0.2, A)') "- Total energy        = ", sum( energies )
        write (*, '(1X, 3(A, F0.2))') "- <L_i>               = ", L_new(1), ",", L_new(2), ",", L_new(3)
        write (*, *)
    endif
    ! ---------------------------------------------------------------------------------------------

    ! REAL TIME DEVELOPMENT -----------------------------------------------------------------------
    if ( mpi_rank == 0 ) then
        write (*, *) "Real time evolution"
        open(120, file=RESULT_DIRECTORY // "energy_real.bin", form="unformatted")
    end if

    ! Break z-symmetry
    do iz = 1, Nz
        RAND_RATE(iz) = 1d0 + omega_noise*rand()
    end do
    OMEGA_t = omega_real_init
    OMEGA_z = OMEGA_t * RAND_RATE

    is_conv = .false.
    E = sum( energies )

    call cpu_time(t1)
    do iter = 0, iters_rtime
        time = iter * dt_real

        ! create vortex
        if ( iter == vortex_dyn_iter ) then
            call make_vortex(Phi, vortex_dyn_kappa, x0_vortex_dyn, y0_vortex_dyn)
        end if
        ! create sound wave
        if ( iter == sound_dyn_iter ) then
            call set_pin(Pot, x0_sound_dyn, y0_sound_dyn, z0_sound_dyn, Vsound, delta_sound)
        end if

        call evolve(Phi, Pot, OMEGA_z, .false.)

        ! Warszawskiら(2011)は、グリッチを再現する以前に同じ条件（V_pin=16.6）で量子渦の生成を行っていた
        if ( iter == grid_iter ) then
            call set_grid(Pot, -16.6d0)
            call set_grid(Pot, Vgrid)
        end if

        if ( abs(Nc) > 0d0 .and. torque_iter > -1 .and. iter >= torque_iter ) then
            dOMEGA_dt = - Nc / Ic
        else
            dOMEGA_dt = 0d0
        end if

        if ( feedback_iter > -1 ) then
            L_old  = L_new
            L_new  = calc_Lall(Phi)

            if ( iter >= feedback_iter ) then
                dOMEGA_dt = dOMEGA_dt - (L_new(3) - L_old(3)) / (dt_real * Ic)
            end if
        end if
        OMEGA_t = OMEGA_t + dOMEGA_dt * dt_real
        OMEGA_z = OMEGA_t * RAND_RATE

        if ( mod(iter, iters_rtime_skip) == 0 ) then
            if ( feedback_iter < 0 ) then
                L_old  = L_new
                L_new  = calc_Lall(Phi)
            end if
            prob     = integrate( abs(Phi)**2 )
            energies = calc_energies(Phi, Pot, OMEGA_z)
            E        = sum( energies )
            ! 1:ITER 2:TIME 3:TOTAL_ENERGY 4:PROBABILITY 5:KINETIC 6:POTENTIAL 7:NONLINEAR 8:ROTATION 9:OMEGA 10:Lx 11:Ly 12:Lz
            ! plot "energy_real.bin" binary format="%*int%int%11double%*int" using 1:4 w l
            OMEGA_avg = sum(OMEGA_z) / Nz
            write (120) iter, iter*dt_real, E, prob, energies(1), energies(2), energies(3), energies(4),&
            OMEGA_avg, L_new(1), L_new(2), L_new(3)
            write (*, '(1X,2(A,I0),10(A,F0.2))') &
            &"Iteration=", iter, "/", iters_rtime, " ( ", 100d0*iter/iters_rtime, "% )  E=",&
            & E, " N=", prob, " Ω=", OMEGA_avg, " Lx,Ly,Lz=", L_new(1), ",", L_new(2), ",", L_new(3)

            if ( mpi_rank == 0 ) then
                write (iter_str, '(I0)') iter / iters_rtime_skip
                flux = calc_flux(Phi)
                open(100, file=RESULT_DIRECTORY // "wf_real/frame_" // trim(iter_str) // ".bin", form="unformatted")
                open(110, file=RESULT_DIRECTORY // "flux_real/frame_" // trim(iter_str) // ".bin", form="unformatted")
                call output_complex_unit(100, Phi)
                call output_flux_unit(110, flux)
                close(100)
                close(110)
            end if
        end if
    end do
    call cpu_time(t2)
    calc_time = t2 - t1
    write (*, '(1X, A, 3(I0, A))') "calculation took ", &
    &int( calc_time / 3600 ), " h ", int( mod(calc_time, 3600d0) / 60 ), " m ", int( mod(calc_time, 60d0) ), " s"

    200 continue
    if ( mpi_rank == 0 ) then
        close(120)
        energies = calc_energies(Phi, Pot, OMEGA_z)
        L_new    = calc_Lall(Phi)
        write (*, '(1X, A, F0.2)')    "- Number of particles = ", integrate( abs(Phi)**2 )
        write (*, '(1X, A, F0.2)')    "- Chemical potential  = ", calc_mu(Phi, Pot, OMEGA_z)
        write (*, '(1X, A, F0.2)')    "- Total energy        = ", calc_total_energy(Phi, Pot, OMEGA_z)
        write (*, '(1X, 3(A, F0.2))') "- <L_i>               = ", L_new(1), ",", L_new(2), ",", L_new(3)
        write (*, *) "Saved data into: data_"//trim(UTC)
    end if
    write (*, *)

    call destroy_fftw
    write (*, *) "FFTW variables deallocated"

    !call MPI_Finalize( mpi_ierr )
    deallocate ( density )
    deallocate ( flux )
    deallocate ( Phi, Pot, Phi_old )
    deallocate ( old_phi, ztemp, ztemp2, HPhi )
    deallocate ( i2ix, i2iy, i2iz, ixyz2i )
    deallocate ( zgrad, zLzPhi, drevert, ztrans, zlap, zAbs2Gradient )
    deallocate ( OMEGA_z, RAND_RATE )
    write (*, *) "Temporal variables deallocated"

    write (*, *) "Simulation finished successfully"
end program


*DECK DHELS
      SUBROUTINE DHELS (A, LDA, N, Q, B)
      INTEGER LDA, N
      DOUBLE PRECISION A(LDA,*), B(*), Q(*)
C-----------------------------------------------------------------------
C This is part of the LINPACK routine DGESL with changes
C due to the fact that A is an upper Hessenberg matrix.
C-----------------------------------------------------------------------
C     DHELS solves the least squares problem
C
C           min (b-A*x, b-A*x)
C
C     using the factors computed by DHEQR.
C
C     On entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the output from DHEQR which contains the upper
C                triangular factor R in the QR decomposition of A.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                A is originally an (N+1) by N matrix.
C
C        Q       DOUBLE PRECISION(2*N)
C                The coefficients of the N givens rotations
C                used in the QR factorization of A.
C
C        B       DOUBLE PRECISION(N+1)
C                the right hand side vector.
C
C     On return
C
C        B       the solution vector  x .
C
C     Modification of LINPACK, by Peter Brown, LLNL.
C     Written 1/13/86.  This version dated 6/20/01.
C
C     BLAS called: DAXPY
C-----------------------------------------------------------------------
      INTEGER IQ, K, KB, KP1
      DOUBLE PRECISION C, S, T, T1, T2
C
C        Minimize (b-A*x, b-A*x)
C        First form Q*b.
C
         DO 20 K = 1, N
            KP1 = K + 1
            IQ = 2*(K-1) + 1
            C = Q(IQ)
            S = Q(IQ+1)
            T1 = B(K)
            T2 = B(KP1)
            B(K) = C*T1 - S*T2
            B(KP1) = S*T1 + C*T2
   20    CONTINUE
C
C        Now solve  R*x = Q*b.
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1)
   40    CONTINUE
      RETURN
C----------------------- End of Subroutine DHELS -----------------------
      END


!*==chfrk.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CHFRK + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
!                         C )
!
!       .. Scalar Arguments ..
!       REAL               ALPHA, BETA
!       INTEGER            K, LDA, N
!       CHARACTER          TRANS, TRANSR, UPLO
!       ..
!       .. Array Arguments ..
!       COMPLEX            A( LDA, * ), C( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> Level 3 BLAS like routine for C in RFP Format.
!>
!> CHFRK performs one of the Hermitian rank--k operations
!>
!>    C := alpha*A*A**H + beta*C,
!>
!> or
!>
!>    C := alpha*A**H*A + beta*C,
!>
!> where alpha and beta are real scalars, C is an n--by--n Hermitian
!> matrix and A is an n--by--k matrix in the first case and a k--by--n
!> matrix in the second case.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANSR
!> \verbatim
!>          TRANSR is CHARACTER*1
!>          = 'N':  The Normal Form of RFP A is stored;
!>          = 'C':  The Conjugate-transpose Form of RFP A is stored.
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>           On  entry,   UPLO  specifies  whether  the  upper  or  lower
!>           triangular  part  of the  array  C  is to be  referenced  as
!>           follows:
!>
!>              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
!>                                  is to be referenced.
!>
!>              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
!>                                  is to be referenced.
!>
!>           Unchanged on exit.
!> \endverbatim
!>
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>           On entry,  TRANS  specifies the operation to be performed as
!>           follows:
!>
!>              TRANS = 'N' or 'n'   C := alpha*A*A**H + beta*C.
!>
!>              TRANS = 'C' or 'c'   C := alpha*A**H*A + beta*C.
!>
!>           Unchanged on exit.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>           On entry,  N specifies the order of the matrix C.  N must be
!>           at least zero.
!>           Unchanged on exit.
!> \endverbatim
!>
!> \param[in] K
!> \verbatim
!>          K is INTEGER
!>           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
!>           of  columns   of  the   matrix   A,   and  on   entry   with
!>           TRANS = 'C' or 'c',  K  specifies  the number of rows of the
!>           matrix A.  K must be at least zero.
!>           Unchanged on exit.
!> \endverbatim
!>
!> \param[in] ALPHA
!> \verbatim
!>          ALPHA is REAL
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,ka)
!>           where KA
!>           is K  when TRANS = 'N' or 'n', and is N otherwise. Before
!>           entry with TRANS = 'N' or 'n', the leading N--by--K part of
!>           the array A must contain the matrix A, otherwise the leading
!>           K--by--N part of the array A must contain the matrix A.
!>           Unchanged on exit.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
!>           then  LDA must be at least  max( 1, n ), otherwise  LDA must
!>           be at least  max( 1, k ).
!>           Unchanged on exit.
!> \endverbatim
!>
!> \param[in] BETA
!> \verbatim
!>          BETA is REAL
!>           On entry, BETA specifies the scalar beta.
!>           Unchanged on exit.
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is COMPLEX array, dimension (N*(N+1)/2)
!>           On entry, the matrix A in RFP Format. RFP Format is
!>           described by TRANSR, UPLO and N. Note that the imaginary
!>           parts of the diagonal elements need not be set, they are
!>           assumed to be zero, and on exit they are set to zero.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERcomputational
!
!  =====================================================================
      SUBROUTINE CHFRK(Transr,Uplo,Trans,N,K,Alpha,A,Lda,Beta,C)
      IMPLICIT NONE
!*--CHFRK171
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Arguments ..
      CHARACTER Transr
      CHARACTER Uplo
      CHARACTER Trans
      INTEGER N
      INTEGER K
      REAL Alpha
      COMPLEX A(Lda,*)
      INTEGER Lda
      REAL Beta
      COMPLEX C(*)
!     ..
!
!  =====================================================================
!
!     ..
!     .. Parameters ..
      REAL ONE , ZERO
      COMPLEX CZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
      PARAMETER (CZERO=(0.0E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
      LOGICAL lower , normaltransr , nisodd , notrans
      INTEGER info , nrowa , j , nk , n1 , n2
      COMPLEX calpha , cbeta
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEMM , CHERK , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , CMPLX
!     ..
!     .. Executable Statements ..
!
!
!     Test the input parameters.
!
      info = 0
      normaltransr = LSAME(Transr,'N')
      lower = LSAME(Uplo,'L')
      notrans = LSAME(Trans,'N')
!
      IF ( notrans ) THEN
         nrowa = N
      ELSE
         nrowa = K
      ENDIF
!
      IF ( .NOT.normaltransr .AND. .NOT.LSAME(Transr,'C') ) THEN
         info = -1
      ELSEIF ( .NOT.lower .AND. .NOT.LSAME(Uplo,'U') ) THEN
         info = -2
      ELSEIF ( .NOT.notrans .AND. .NOT.LSAME(Trans,'C') ) THEN
         info = -3
      ELSEIF ( N<0 ) THEN
         info = -4
      ELSEIF ( K<0 ) THEN
         info = -5
      ELSEIF ( Lda<MAX(1,nrowa) ) THEN
         info = -8
      ENDIF
      IF ( info/=0 ) THEN
         CALL XERBLA('CHFRK ',-info)
         RETURN
      ENDIF
!
!     Quick return if possible.
!
!     The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not
!     done (it is in CHERK for example) and left in the general case.
!
      IF ( (N==0) .OR. (((Alpha==ZERO) .OR. (K==0)) .AND. (Beta==ONE)) )&
     &     RETURN
!
      IF ( (Alpha==ZERO) .AND. (Beta==ZERO) ) THEN
         DO j = 1 , ((N*(N+1))/2)
            C(j) = CZERO
         ENDDO
         RETURN
      ENDIF
!
      calpha = CMPLX(Alpha,ZERO)
      cbeta = CMPLX(Beta,ZERO)
!
!     C is N-by-N.
!     If N is odd, set NISODD = .TRUE., and N1 and N2.
!     If N is even, NISODD = .FALSE., and NK.
!
      IF ( MOD(N,2)==0 ) THEN
         nisodd = .FALSE.
         nk = N/2
      ELSE
         nisodd = .TRUE.
         IF ( lower ) THEN
            n2 = N/2
            n1 = N - n2
         ELSE
            n1 = N/2
            n2 = N - n1
         ENDIF
      ENDIF
!
      IF ( nisodd ) THEN
!
!        N is odd
!
         IF ( normaltransr ) THEN
!
!           N is odd and TRANSR = 'N'
!
            IF ( lower ) THEN
!
!              N is odd, TRANSR = 'N', and UPLO = 'L'
!
               IF ( notrans ) THEN
!
!                 N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
!
                  CALL CHERK('L','N',n1,K,Alpha,A(1,1),Lda,Beta,C(1),N)
                  CALL CHERK('U','N',n2,K,Alpha,A(n1+1,1),Lda,Beta,     &
     &                       C(N+1),N)
                  CALL CGEMM('N','C',n2,n1,K,calpha,A(n1+1,1),Lda,A(1,1)&
     &                       ,Lda,cbeta,C(n1+1),N)
!
               ELSE
!
!                 N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
!
                  CALL CHERK('L','C',n1,K,Alpha,A(1,1),Lda,Beta,C(1),N)
                  CALL CHERK('U','C',n2,K,Alpha,A(1,n1+1),Lda,Beta,     &
     &                       C(N+1),N)
                  CALL CGEMM('C','N',n2,n1,K,calpha,A(1,n1+1),Lda,A(1,1)&
     &                       ,Lda,cbeta,C(n1+1),N)
!
               ENDIF
!
!
!              N is odd, TRANSR = 'N', and UPLO = 'U'
!
            ELSEIF ( notrans ) THEN
!
!                 N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
!
               CALL CHERK('L','N',n1,K,Alpha,A(1,1),Lda,Beta,C(n2+1),N)
               CALL CHERK('U','N',n2,K,Alpha,A(n2,1),Lda,Beta,C(n1+1),N)
               CALL CGEMM('N','C',n1,n2,K,calpha,A(1,1),Lda,A(n2,1),Lda,&
     &                    cbeta,C(1),N)
!
            ELSE
!
!                 N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
!
               CALL CHERK('L','C',n1,K,Alpha,A(1,1),Lda,Beta,C(n2+1),N)
               CALL CHERK('U','C',n2,K,Alpha,A(1,n2),Lda,Beta,C(n1+1),N)
               CALL CGEMM('C','N',n1,n2,K,calpha,A(1,1),Lda,A(1,n2),Lda,&
     &                    cbeta,C(1),N)
!
!
            ENDIF
!
!
!           N is odd, and TRANSR = 'C'
!
         ELSEIF ( lower ) THEN
!
!              N is odd, TRANSR = 'C', and UPLO = 'L'
!
            IF ( notrans ) THEN
!
!                 N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
!
               CALL CHERK('U','N',n1,K,Alpha,A(1,1),Lda,Beta,C(1),n1)
               CALL CHERK('L','N',n2,K,Alpha,A(n1+1,1),Lda,Beta,C(2),n1)
               CALL CGEMM('N','C',n1,n2,K,calpha,A(1,1),Lda,A(n1+1,1),  &
     &                    Lda,cbeta,C(n1*n1+1),n1)
!
            ELSE
!
!                 N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
!
               CALL CHERK('U','C',n1,K,Alpha,A(1,1),Lda,Beta,C(1),n1)
               CALL CHERK('L','C',n2,K,Alpha,A(1,n1+1),Lda,Beta,C(2),n1)
               CALL CGEMM('C','N',n1,n2,K,calpha,A(1,1),Lda,A(1,n1+1),  &
     &                    Lda,cbeta,C(n1*n1+1),n1)
!
            ENDIF
!
!
!              N is odd, TRANSR = 'C', and UPLO = 'U'
!
         ELSEIF ( notrans ) THEN
!
!                 N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
!
            CALL CHERK('U','N',n1,K,Alpha,A(1,1),Lda,Beta,C(n2*n2+1),n2)
            CALL CHERK('L','N',n2,K,Alpha,A(n1+1,1),Lda,Beta,C(n1*n2+1),&
     &                 n2)
            CALL CGEMM('N','C',n2,n1,K,calpha,A(n1+1,1),Lda,A(1,1),Lda, &
     &                 cbeta,C(1),n2)
!
         ELSE
!
!                 N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
!
            CALL CHERK('U','C',n1,K,Alpha,A(1,1),Lda,Beta,C(n2*n2+1),n2)
            CALL CHERK('L','C',n2,K,Alpha,A(1,n1+1),Lda,Beta,C(n1*n2+1),&
     &                 n2)
            CALL CGEMM('C','N',n2,n1,K,calpha,A(1,n1+1),Lda,A(1,1),Lda, &
     &                 cbeta,C(1),n2)
!
!
!
         ENDIF
!
!
!        N is even
!
      ELSEIF ( normaltransr ) THEN
!
!           N is even and TRANSR = 'N'
!
         IF ( lower ) THEN
!
!              N is even, TRANSR = 'N', and UPLO = 'L'
!
            IF ( notrans ) THEN
!
!                 N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
!
               CALL CHERK('L','N',nk,K,Alpha,A(1,1),Lda,Beta,C(2),N+1)
               CALL CHERK('U','N',nk,K,Alpha,A(nk+1,1),Lda,Beta,C(1),   &
     &                    N+1)
               CALL CGEMM('N','C',nk,nk,K,calpha,A(nk+1,1),Lda,A(1,1),  &
     &                    Lda,cbeta,C(nk+2),N+1)
!
            ELSE
!
!                 N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
!
               CALL CHERK('L','C',nk,K,Alpha,A(1,1),Lda,Beta,C(2),N+1)
               CALL CHERK('U','C',nk,K,Alpha,A(1,nk+1),Lda,Beta,C(1),   &
     &                    N+1)
               CALL CGEMM('C','N',nk,nk,K,calpha,A(1,nk+1),Lda,A(1,1),  &
     &                    Lda,cbeta,C(nk+2),N+1)
!
            ENDIF
!
!
!              N is even, TRANSR = 'N', and UPLO = 'U'
!
         ELSEIF ( notrans ) THEN
!
!                 N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
!
            CALL CHERK('L','N',nk,K,Alpha,A(1,1),Lda,Beta,C(nk+2),N+1)
            CALL CHERK('U','N',nk,K,Alpha,A(nk+1,1),Lda,Beta,C(nk+1),   &
     &                 N+1)
            CALL CGEMM('N','C',nk,nk,K,calpha,A(1,1),Lda,A(nk+1,1),Lda, &
     &                 cbeta,C(1),N+1)
!
         ELSE
!
!                 N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
!
            CALL CHERK('L','C',nk,K,Alpha,A(1,1),Lda,Beta,C(nk+2),N+1)
            CALL CHERK('U','C',nk,K,Alpha,A(1,nk+1),Lda,Beta,C(nk+1),   &
     &                 N+1)
            CALL CGEMM('C','N',nk,nk,K,calpha,A(1,1),Lda,A(1,nk+1),Lda, &
     &                 cbeta,C(1),N+1)
!
!
         ENDIF
!
!
!           N is even, and TRANSR = 'C'
!
      ELSEIF ( lower ) THEN
!
!              N is even, TRANSR = 'C', and UPLO = 'L'
!
         IF ( notrans ) THEN
!
!                 N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
!
            CALL CHERK('U','N',nk,K,Alpha,A(1,1),Lda,Beta,C(nk+1),nk)
            CALL CHERK('L','N',nk,K,Alpha,A(nk+1,1),Lda,Beta,C(1),nk)
            CALL CGEMM('N','C',nk,nk,K,calpha,A(1,1),Lda,A(nk+1,1),Lda, &
     &                 cbeta,C(((nk+1)*nk)+1),nk)
!
         ELSE
!
!                 N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
!
            CALL CHERK('U','C',nk,K,Alpha,A(1,1),Lda,Beta,C(nk+1),nk)
            CALL CHERK('L','C',nk,K,Alpha,A(1,nk+1),Lda,Beta,C(1),nk)
            CALL CGEMM('C','N',nk,nk,K,calpha,A(1,1),Lda,A(1,nk+1),Lda, &
     &                 cbeta,C(((nk+1)*nk)+1),nk)
!
         ENDIF
!
!
!              N is even, TRANSR = 'C', and UPLO = 'U'
!
      ELSEIF ( notrans ) THEN
!
!                 N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
!
         CALL CHERK('U','N',nk,K,Alpha,A(1,1),Lda,Beta,C(nk*(nk+1)+1),  &
     &              nk)
         CALL CHERK('L','N',nk,K,Alpha,A(nk+1,1),Lda,Beta,C(nk*nk+1),nk)
         CALL CGEMM('N','C',nk,nk,K,calpha,A(nk+1,1),Lda,A(1,1),Lda,    &
     &              cbeta,C(1),nk)
!
      ELSE
!
!                 N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
!
         CALL CHERK('U','C',nk,K,Alpha,A(1,1),Lda,Beta,C(nk*(nk+1)+1),  &
     &              nk)
         CALL CHERK('L','C',nk,K,Alpha,A(1,nk+1),Lda,Beta,C(nk*nk+1),nk)
         CALL CGEMM('C','N',nk,nk,K,calpha,A(1,nk+1),Lda,A(1,1),Lda,    &
     &              cbeta,C(1),nk)
!
!
!
!
      ENDIF
!
!
!     End of CHFRK
!
      END SUBROUTINE CHFRK


SUBROUTINE p92(input_file,output_file)
!--------------------------------------------------------------------------
! Program 9.2 Analysis of the plane steady state Navier-Stokes equation
!             using 8-node rectangular quadrilaterals for velocities
!             coupled to 4-node rectangular quadrilaterals for pressures.
!             Mesh numbered in x- or y-direction. Freedoms numbered in the
!             order u-p-v. Element by element solution using BiCGStab(l).
!             with no preconditioning. No global matrix assembly,
!--------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::cg_iters,cg_limit,cg_tot,ell,fixed_freedoms,i,iel,iters,j,k,    &
   limit,ndim=2,nels,neq,nip=4,nlen,nn,nod=8,nodf=4,nodof=3,nr,ntot=20,   &
   nxe,nye
 REAL(iwp)::alpha,beta,cg_tol,det,error,gama,kappa,norm_r,omega,          &
   one=1.0_iwp,penalty=1.e5_iwp,pt5=0.5_iwp,rho,rho1,r0_norm,tol,ubar,    &
   vbar,visc,x0,zero=0.0_iwp
 LOGICAL::converged,cg_converged
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!------------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::g(:),g_g(:,:),g_num(:,:),nf(:,:),no(:),node(:),     &
   num(:),sense(:)
 REAL(iwp),ALLOCATABLE::b(:),coord(:,:),coordf(:,:),c11(:,:),c12(:,:),    &
   c21(:,:),c23(:,:),c32(:,:),der(:,:),derf(:,:),deriv(:,:),derivf(:,:),  &
   diag(:),fun(:),funf(:),gamma(:),gg(:,:),g_coord(:,:),jac(:,:),kay(:,:),&
   ke(:,:),loads(:),nd1(:,:),nd2(:,:),nfd1(:,:),nfd2(:,:),ndf1(:,:),      &
   ndf2(:,:),oldlds(:),points(:,:),r(:,:),rt(:),s(:),store(:),            &
   storke(:,:,:),u(:,:),uvel(:),value(:),vvel(:),weights(:),x_coords(:),  &
   y(:),y1(:),y_coords(:)
!------------------------input and initialisation-------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,tol,limit,visc,rho,cg_tol,cg_limit,x0,ell,kappa
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(points(nip,ndim),coord(nod,ndim),derivf(ndim,nodf),             &
   jac(ndim,ndim),kay(ndim,ndim),der(ndim,nod),deriv(ndim,nod),           &
   derf(ndim,nodf),funf(nodf),coordf(nodf,ndim),nd1(nod,nod),nd2(nod,nod),&
   ndf1(nod,nodf),ndf2(nod,nodf),nfd1(nodf,nod),nfd2(nodf,nod),           &
   g_g(ntot,nels),c11(nod,nod),c12(nod,nodf),c21(nodf,nod),g(ntot),       &
   ke(ntot,ntot),fun(nod),x_coords(nxe+1),y_coords(nye+1),nf(nodof,nn),   &
   g_coord(ndim,nn),g_num(nod,nels),num(nod),weights(nip),c32(nod,nodf),  &
   c23(nodf,nod),uvel(nod),vvel(nod),storke(ntot,ntot,nels),s(ell+1),     &
   gg(ell+1,ell+1),gamma(ell+1))
   READ(10,*)x_coords,y_coords
 uvel=zero
 vvel=zero
 kay=zero
 kay(1,1)=visc/rho
 kay(2,2)=visc/rho
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 CALL sample(element,points,weights)
!------------------------loop the elements to set up global arrays---------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'x')
   g(:8)=nf(1,num(:8))
   g(9:12)=nf(2,num(1:7:2))
   g(13:20)=nf(3,num(:8))
   g_num(:,iel )=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 WRITE(11,'(A,I5,A)')" There are",neq," equations"
 ALLOCATE(loads(0:neq),rt(0:neq),r(0:neq,ell+1),u(0:neq,ell+1),b(0:neq),  &
   diag(0:neq),oldlds(0:neq),y(0:neq),y1(0:neq))
 READ(10,*)fixed_freedoms
 ALLOCATE(node(fixed_freedoms),sense(fixed_freedoms),                     &
   value(fixed_freedoms),no(fixed_freedoms),store(fixed_freedoms))
 READ(10,*)(node(i),sense(i),value(i),i=1,fixed_freedoms)
 iters=0
 cg_tot=0
 loads=zero
 oldlds=zero
!------------------------iteration loop------------------------------------
 iterations: DO
   iters=iters+1
   converged=.FALSE.
   ke=zero
   diag=zero
   b=zero
!------------------------element stiffness integration and storage --------
   elements_2: DO iel=1,nels
     num=g_num(:,iel)
     coord=TRANSPOSE(g_coord(:,num))
     g=g_g(:,iel)
     coordf=coord(1:7:2,:)
     uvel=(loads(g(:nod))+oldlds(g(:nod)))*pt5
     DO i=nod+nodf+1,ntot
       vvel(i-nod-nodf)=(loads(g(i))+oldlds(g(i)))*pt5
     END DO
     c11=zero
     c12=zero
     c21=zero
     c23=zero
     c32=zero
     gauss_points_1: DO i=1,nip
!------------------------velocity contribution-----------------------------
       CALL shape_fun(fun,points,i)
       CALL shape_der(der,points,i)
       jac=MATMUL(der,coord)
       det=determinant(jac)
       CALL invert(jac)
       deriv=MATMUL(jac,der)
       ubar=DOT_PRODUCT(fun,uvel)
       vbar=DOT_PRODUCT(fun,vvel)
       IF(iters==1)THEN
         ubar=one
         vbar=zero
       END IF
       CALL cross_product(fun,deriv(1,:),nd1)
       CALL cross_product(fun,deriv(2,:),nd2)
       c11=c11+det*weights(i)*(MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)+ &
         nd1*ubar+nd2*vbar)
!------------------------pressure contribution-----------------------------
       CALL shape_fun(funf,points,i)
       CALL shape_der(derf,points,i)
       jac=MATMUL(derf,coordf)
       det=determinant(jac)
       CALL invert(jac)
       derivf=MATMUL(jac,derf)
       CALL cross_product(fun,derivf(1,:),ndf1)
       CALL cross_product(fun,derivf(2,:),ndf2)
       CALL cross_product(funf,deriv(1,:),nfd1)
       CALL cross_product(funf,deriv(2,:),nfd2)
       c12=c12+ndf1*det*weights(i)/rho
       c32=c32+ndf2*det*weights(i)/rho
       c21=c21+nfd1*det*weights(i)
       c23=c23+nfd2*det*weights(i)
     END DO gauss_points_1
     CALL formupv(ke,c11,c12,c21,c23,c32)
     storke(:,:,iel)=ke
     DO k=1,ntot
       diag(g(k))=diag(g(k))+ke(k,k)
     END DO
   END DO elements_2
!------------------------specify pressure and velocity boundary values-----
   DO i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   diag(no)=diag(no)+penalty
   b(no)=diag(no)*value
   store=diag(no)
!---solve the simultaneous equations element by element using BiCGStab(l)-
!------------------------initialisation phase------------------------------
   IF(iters==1)loads=x0
   loads(0)=zero
   y=loads
   y1=zero
   elements_3: DO iel=1,nels
     g=g_g(:,iel)
     ke=storke(:,:,iel)
     y1(g)=y1(g)+MATMUL(ke,y(g))
   END DO elements_3
   cg_iters=0
   y1(0)=zero
   y1(no)=y(no)*store
   y=y1
   rt=b-y
   r=zero
   r(:,1)=rt
   u=zero
   gama=one
   omega=one
   k=0
   norm_r=norm(rt)
   r0_norm=norm_r
   error=one
!------------------------BiCGStab(l) iterations----------------------------
   bicg_iterations: DO
     cg_iters=cg_iters+1
     cg_converged=error<cg_tol
     IF(cg_iters==cg_limit.OR.cg_converged)EXIT
     gama=-omega*gama
     y=r(:,1)
     DO j=1,ell
       rho1=DOT_PRODUCT(rt,y)
       beta=rho1/gama
       u(:,:j)=r(:,:j)-beta*u(:,:j)
       y=u(:,j)
       y1=zero
       elements_4: DO iel=1,nels
         g=g_g(:,iel)
         ke=storke(:,:,iel)
         y1(g)=y1(g)+MATMUL(ke,y(g))
       END DO elements_4
       y1(0)=zero
       y1(no)=y(no)*store
       y=y1
       u(:,j+1)=y
       gama=DOT_PRODUCT(rt,y)
       alpha=rho1/gama
       loads=loads+alpha*u(:,1)
       r(:,:j)=r(:,:j)-alpha*u(:,2:j+1)
       y=r(:,j)
       y1=zero
       elements_5: DO iel=1,nels
         g=g_g(:,iel)
         ke=storke(:,:,iel)
         y1(g)=y1(g)+MATMUL(ke,y(g))
       END DO elements_5
       y1(0)=zero
       y1(no)=y(no)*store
       y=y1
       r(:,j+1)=y
     END DO
     gg=MATMUL(TRANSPOSE(r),r)
     CALL form_s(gg,ell,kappa,omega,gamma,s)
     loads=loads-MATMUL(r,s)
     r(:,1)=MATMUL(r,gamma)
     u(:,1)=MATMUL(u,gamma)
     norm_r=norm(r(:,1))
     error=norm_r/r0_norm
     k=k+1
   END DO bicg_iterations
   cg_tot=cg_tot+cg_iters
!------------------------end of BiCGStab(l) process-----------------------
   CALL checon(loads,oldlds,tol,converged)
   IF(converged.OR.iters==limit)EXIT
 END DO iterations
 WRITE(11,'(/A)')"  Node     u-velocity  pressure    v-velocity"
 DO k=1,nn
   WRITE(11,'(I5,A,3E12.4)')k,"    ",loads(nf(:,k))
 END DO
 WRITE(11,'(/A,I3,A/A,F6.2,A)')" Converged in",iters," iterations",       &
   " with an average of", REAL(cg_tot/iters), "  BiCGStab(l) iterations."
 CALL vecmsh(loads,nf(1:3:2,:),0.3_iwp,0.05_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p92


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 2011 by UCAR                   *
C     *                                                               *
C     *       University Corporation for Atmospheric Research         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                     FFTPACK  version 5.1                      *
C     *                                                               *
C     *                 A Fortran Package of Fast Fourier             *
C     *                                                               *
C     *                Subroutines and Example Programs               *
C     *                                                               *
C     *                             by                                *
C     *                                                               *
C     *               Paul Swarztrauber and Dick Valent               *
C     *                                                               *
C     *                             of                                *
C     *                                                               *
C     *         the National Center for Atmospheric Research          *
C     *                                                               *
C     *                Boulder, Colorado  (80307)  U.S.A.             *
C     *                                                               *
C     *                   which is sponsored by                       *
C     *                                                               *
C     *              the National Science Foundation                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      SUBROUTINE COSTB1(N,INC,X,WSAVE,WORK,IER)
      REAL       X(INC,*)       ,WSAVE(*)
      DOUBLE PRECISION           DSUM
      IER = 0
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      IF (N-2) 106,101,102
  101 X1H = X(1,1)+X(1,2)
      X(1,2) = X(1,1)-X(1,2)
      X(1,1) = X1H
      RETURN
  102 IF (N .GT. 3) GO TO 103
      X1P3 = X(1,1)+X(1,3)
      X2 = X(1,2)
      X(1,2) = X(1,1)-X(1,3)
      X(1,1) = X1P3+X2
      X(1,3) = X1P3-X2
      RETURN
  103 X(1,1) = X(1,1)+X(1,1)
      X(1,N) = X(1,N)+X(1,N)
      DSUM = X(1,1)-X(1,N)
      X(1,1) = X(1,1)+X(1,N)
      DO 104 K=2,NS2
         KC = NP1-K
         T1 = X(1,K)+X(1,KC)
         T2 = X(1,K)-X(1,KC)
         DSUM = DSUM+WSAVE(KC)*T2
         T2 = WSAVE(K)*T2
         X(1,K) = T1-T2
         X(1,KC) = T1+T2
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) GO TO 124
      X(1,NS2+1) = X(1,NS2+1)+X(1,NS2+1)
  124 LENX = INC*(NM1-1)  + 1
      LNSV = NM1 + INT(LOG(REAL(NM1))/LOG(2.)) + 4
      LNWK = NM1
C
      CALL RFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,
     1            LNWK,IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('COSTB1',-5)
        RETURN
      ENDIF
C
      FNM1S2 = FLOAT(NM1)/2.
      DSUM = .5*DSUM
      X(1,1) = FNM1S2*X(1,1)
      IF(MOD(NM1,2) .NE. 0) GO TO 30
      X(1,NM1) = X(1,NM1)+X(1,NM1)
   30 FNM1S4 = FLOAT(NM1)/4.
      DO 105 I=3,N,2
         XI = FNM1S4*X(1,I)
         X(1,I) = FNM1S4*X(1,I-1)
         X(1,I-1) = DSUM
         DSUM = DSUM+XI
  105 CONTINUE
      IF (MODN .NE. 0) RETURN
         X(1,N) = DSUM
  106 RETURN
      END


MODULE ex1_mod
CONTAINS
SUBROUTINE sumation(a,b,d)
IMPLICIT NONE
INTEGER,INTENT(in) :: a(:)
INTEGER,INTENT(in) :: b(:)
INTEGER,INTENT(out):: d(:)
INTEGER :: i,n

n = size(a)
DO i = 1, n
d(i) = a(i)+b(i)
END DO
END SUBROUTINE sumation
END MODULE ex1_mod

!!==========================================
PROGRAM ex1_presentation
USE ex1_mod
IMPLICIT NONE
INTEGER, PARAMETER :: n=1000
INTEGER :: a(n),b(n),d(n)
a = 10
b = 20

call sumation(a,b,d)

IF(all(d==30)) THEN
      WRITE(* ,*)'**** OK ****'
ELSE
      WRITE(* ,*)'Program Failed'
END IF
END PROGRAM ex1_presentation


!==========================================================================
elemental function gsw_rho_ice (t, p)
!==========================================================================
!
!  Calculates in-situ density of ice from in-situ temperature and pressure.
!  Note that the output, rho_ice, is density, not density anomaly;  that
!  is, 1000 kg/m^3 is not subracted from it.
!
!  t   =  in-situ temperature (ITS-90)                            [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  rho_ice  =  in-situ density of ice (not density anomaly)      [ kg/m^3 ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs_ice

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p

real (r8) :: gsw_rho_ice

gsw_rho_ice = 1.0_r8/gsw_gibbs_ice(0,1,t,p)

return
end function

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


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 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.
!
!     this function enable to determine the discharge coefficient of
!     preswirl nozzles
!
!     author: Yannick Muller
!
      subroutine cd_preswirlnozzle(ps2,pt1,number,curve,x_tab,y_tab,cd)
!
!
!     in : SImultation of the secondary air system of aero engines
!          K.J.KUTZ T.M. SPEER
!          Transactions of the ASME vol.116 April 1994
!
      implicit none
!
      integer id,number,curve,n11
!
      real*8 x_tab(15),y_tab(15)
!
      real*8 cdxp(11)
      data cdxp
     &     /0.4d0,0.45d0,0.50d0,0.55d0,0.60d0,0.65d0,0.70d0,0.75d0,
     &      0.80d0,0.85d0,0.90d0/
!
      real*8 cdyp(11)
      data cdyp
     &     /0.942d0,0.939d0,0.932d0,0.929d0,0.925d0,0.921d0,0.917d0,
     &      0.910d0,0.899d0,0.881d0,0.873d0/
!
      data n11 /11/
!
!     determination of cd with the caracteristics by interpolation
!
      real*8 ps2,pt1,ps2vpt1,cd
!
      ps2vpt1=ps2/pt1
      if(number.eq.0) then
         call ident(cdxp,ps2vpt1,n11,id)
         if(id.eq.0.6d0) then
            cd=cdyp(1)
         elseif(id.ge.1) then
            cd=cdyp(11)
         else
            cd=cdyp(id)+(cdyp(id+1)-cdyp(id))
     &           *(ps2vpt1-cdxp(id))/(cdxp(id+1)-cdxp(id))
         endif
      else
         call ident(x_tab,ps2vpt1,number,id)
         if(id.le.1d0) then
            cd=y_tab(1)
         elseif(id.ge.15) then
            cd=y_tab(15)
         else
            cd=y_tab(id)+(y_tab(id+1)-y_tab(id))
     &           *(ps2vpt1-x_tab(id))/(x_tab(id+1)-x_tab(id))
         endif
      endif
!
      return
      end


!================================================================
!================================================================
!================================================================
!================================================================
subroutine condinit(x,u,dx,nn)
  use amr_parameters
  use hydro_parameters
  implicit none
  integer ::nn                            ! Number of cells
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector,1:nvar)::u ! Conservative variables
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine generates initial conditions for RAMSES.
  ! Positions are in user units:
  ! x(i,1:3) are in [0,boxlen]**ndim.
  ! U is the conservative variable vector. Conventions are here:
  ! U(i,1): d, U(i,2:ndim+1): d.u,d.v,d.w and U(i,ndim+2): E.
  ! Q is the primitive variable vector. Conventions are here:
  ! Q(i,1): d, Q(i,2:ndim+1):u,v,w and Q(i,ndim+2): P.
  ! If nvar >= ndim+3, remaining variables are treated as passive
  ! scalars in the hydro solver.
  ! U(:,:) and Q(:,:) are in user units.
  !================================================================
  integer::ivar
  real(dp),dimension(1:nvector,1:nvar),save::q   ! Primitive variables

  ! Call built-in initial condition generator
  call region_condinit(x,q,dx,nn)

  ! Add here, if you wish, some user-defined initial conditions
  ! ........

  ! Convert primitive to conservative variables
  ! density -> density
  u(1:nn,1)=q(1:nn,1)
  ! velocity -> momentum
  u(1:nn,2)=q(1:nn,1)*q(1:nn,2)
#if NDIM>1
  u(1:nn,3)=q(1:nn,1)*q(1:nn,3)
#endif
#if NDIM>2
  u(1:nn,4)=q(1:nn,1)*q(1:nn,4)
#endif
  ! kinetic energy
  u(1:nn,ndim+2)=0.0d0
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,2)**2
#if NDIM>1
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,3)**2
#endif
#if NDIM>2
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,4)**2
#endif
  ! pressure -> total fluid energy
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+q(1:nn,ndim+2)/(gamma-1.0d0)
#if NVAR > NDIM + 2
  ! passive scalars
  do ivar=ndim+3,nvar
     u(1:nn,ivar)=q(1:nn,1)*q(1:nn,ivar)
  end do
#endif

end subroutine condinit


!------------------------------------------------------------------
! Calendar
!
! Module, supporting the treatment of date and time information, up to
! the resolution of 1s.
!
! Copyright (C) 2004 by Servizi Territorio srl
!
! Written by: M.Favaron
! e-mail:     mafavaron@tin.it
!
!------------------------------------------------------------------
! Statement of Licensing Conditions
!------------------------------------------------------------------
!
!   This library is free software; you can redistribute it and/or
!   modify it under the terms of the GNU Lesser General Public
!   License as published by the Free Software Foundation; either
!   version 2.1 of the License, or (at your option) any later version.
!
!   This library 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
!   Lesser General Public License for more details.
!
!   You should have received a copy of the GNU Lesser General Public
!   License along with this library; if not, write to the Free Software
!   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
!
!------------------------------------------------------------------

MODULE Calendar

    IMPLICIT NONE

    PRIVATE

   ! Public interface
    ! -1- Date oriented routines
    PUBLIC  :: JulianDay
    PUBLIC	:: DayInYear
    PUBLIC  :: UnpackDate
    PUBLIC  :: DayOfWeek
    PUBLIC  :: Season
    ! -1- Date and time oriented routines
    PUBLIC  :: PackTime
    PUBLIC  :: UnpackTime
    ! -1- Date and time formatting and decoding routines
    PUBLIC  :: FormatDate
    PUBLIC  :: FormatTime
    PUBLIC  :: FormatFileTime
    PUBLIC  :: DecodeDate
    PUBLIC  :: DecodeTime
    PUBLIC  :: DecodeHour
    ! -1- Auxiliary procedures
    PUBLIC	:: NumDays
    ! -1- Constants
    INTEGER, PARAMETER  :: HOUR_00_23 = 0
    PUBLIC              :: HOUR_00_23
    INTEGER, PARAMETER  :: HOUR_01_24 = 1
    PUBLIC              :: HOUR_01_24

    ! Internal parameters
    REAL, PARAMETER     :: YEAR_DURATION   = 365.25
    REAL, PARAMETER     :: MONTH_DURATION  = 30.6001
    INTEGER, PARAMETER  :: BASE_DAY        = 2440588    ! 01. 01. 1970

    ! Interfaces
    INTERFACE Season
        MODULE PROCEDURE SeasonA, SeasonB
    END INTERFACE Season

CONTAINS

    FUNCTION JulianDay(iYear, iMonth, iDay) RESULT(iJulianDay)

        ! Routine arguments
        INTEGER, INTENT(IN) :: iYear
        INTEGER, INTENT(IN) :: iMonth
        INTEGER, INTENT(IN) :: iDay
        INTEGER             :: iJulianDay

        ! Locals
        INTEGER     :: iAuxYear
        INTEGER     :: iAuxMonth
        INTEGER     :: iCentury
        INTEGER     :: iTryJulianDay
        INTEGER     :: iNumDays
        INTEGER, PARAMETER  :: DATE_REFORM_DAY = 588829 ! 15 October 1582, with 31-days months
        INTEGER, PARAMETER  :: BASE_DAYS       = 1720995

        ! Check year against invalid values. Only positive
        ! years are supported in this version. Year "0" does
        ! not exist.
        IF(iYear <= 0) THEN
            iJulianDay = -9999
            RETURN
        END IF

        ! Check month and day to look valid (a rough, non-month-aware
        ! test is intentionally adopted in sake of simplicity)
        IF((.NOT.(1<=iMonth .AND. iMonth<=12)) .OR. (.NOT.(1<=iDay .AND. iDay<=31))) THEN
            iJulianDay = -9999
            RETURN
        END IF

        ! Preliminary estimate the Julian day, based on
        ! the average duration of year and month in days.
        IF(iMonth > 2) THEN
            iAuxYear  = iYear
            iAuxMonth = iMonth + 1
        ELSE
            iAuxYear  = iYear - 1
            iAuxMonth = iMonth + 13
        END IF
        iTryJulianDay = FLOOR(YEAR_DURATION * iAuxYear) + &
                        FLOOR(MONTH_DURATION * iAuxMonth) + &
                        iDay + BASE_DAYS

        ! Correct estimate if later than the date reform day
        iNumDays = iDay + 31*iMonth + 372*iYear
        IF(iNumDays >= DATE_REFORM_DAY) THEN
            iCentury = 0.01*iAuxYear
            iJulianDay = iTryJulianDay - iCentury + iCentury/4 + 2
        ELSE
            iJulianDay = iTryJulianDay
        END IF

    END FUNCTION JulianDay

    FUNCTION DayInYear(iYear, iMonth, iDay) RESULT(iDayInYear)

        ! Routine arguments
        INTEGER, INTENT(IN) :: iYear
        INTEGER, INTENT(IN) :: iMonth
        INTEGER, INTENT(IN) :: iDay
        INTEGER             :: iDayInYear

        ! Locals
        INTEGER     :: iFirstJulianDay
        INTEGER     :: iCurrentJulianDay

        ! Compute the information desired
        iFirstJulianDay = JulianDay(iYear, 1, 1)
        iCurrentJulianDay = JulianDay(iYear, iMonth, iDay)
        iDayInYear = iCurrentJulianDay - iFirstJulianDay + 1

    END FUNCTION DayInYear

    SUBROUTINE UnpackDate(iJulianDay, iYear, iMonth, iDay)

        ! Routine arguments
        INTEGER, INTENT(IN)     :: iJulianDay
        INTEGER, INTENT(OUT)    :: iYear
        INTEGER, INTENT(OUT)    :: iMonth
        INTEGER, INTENT(OUT)    :: iDay

        ! Locals
        INTEGER :: iDeviation
        INTEGER :: iPreJulianDay
        INTEGER :: iPostJulianDay
        INTEGER :: iYearIndex
        INTEGER :: iMonthIndex
        INTEGER :: iDayIndex
        INTEGER, PARAMETER  :: LIMIT_JULIAN_DAY = 2299161
        INTEGER, PARAMETER  :: CORRECTION_DAYS  = 1524

        ! Unwind Pope Gregorius' day correction
        IF(iJulianDay >= LIMIT_JULIAN_DAY) THEN
            iDeviation = FLOOR(((iJulianDay-1867216)-0.25)/36524.25)
            iPreJulianDay = iJulianDay + iDeviation - iDeviation/4 + 1
        ELSE
            iPreJulianDay = iJulianDay
        END IF
        iPostJulianDay = iPreJulianDay + CORRECTION_DAYS

        ! Compute time indices
        iYearIndex  = FLOOR(6680+((iPostJulianDay-2439870)-122.1)/YEAR_DURATION)
        iDayIndex   = 365*iYearIndex + iYearIndex/4
        iMonthIndex = FLOOR((iPostJulianDay - iDayIndex)/MONTH_DURATION)

        ! Deduce preliminary date from time indices
        iDay = iPostJulianDay - FLOOR(MONTH_DURATION*iMonthIndex) - iDayIndex
        IF(iMonthIndex > 13) THEN
            iMonth = iMonthIndex - 13
        ELSE
            iMonth = iMonthIndex - 1
        END IF
        iYear = iYearIndex - 4715
        IF(iMonth > 2) iYear = iYear - 1

    END SUBROUTINE UnpackDate

    FUNCTION DayOfWeek(iJulianDay) RESULT(iDayOfWeek)

        ! Routine arguments
        INTEGER, INTENT(IN) :: iJulianDay
        INTEGER         :: iDayOfWeek

        ! Locals
        ! -none-

        ! Compute the desired quantity
        iDayOfWeek = MOD(iJulianDay, 7)

    END FUNCTION DayOfWeek

    FUNCTION SeasonA(iJulianDay) RESULT(iSeason)

        ! Routine arguments
        INTEGER, INTENT(IN) :: iJulianDay
        INTEGER             :: iSeason

        ! Locals
        INTEGER :: iYear
        INTEGER :: iMonth
        INTEGER :: iDay
        INTEGER :: iSpring
        INTEGER :: iSummer
        INTEGER :: iAutumn
        INTEGER :: iWinter

        ! Convert Julian day to date
        CALL UnpackDate(iJulianDay, iYear, iMonth, iDay)
        iSpring = JulianDay(iYear,  3, 21)
        iSummer = JulianDay(iYear,  6, 21)
        iAutumn = JulianDay(iYear,  9, 21)
        iWinter = JulianDay(iYear, 12, 21)

        ! Compute season
        IF(iSpring <= iJulianDay .AND. iJulianDay < iSummer) THEN
            iSeason = 2
        ELSEIF(iSummer <= iJulianDay .AND. iJulianDay < iAutumn) THEN
            iSeason = 3
        ELSEIF(iAutumn <= iJulianDay .AND. iJulianDay < iWinter) THEN
            iSeason = 4
        ELSE
            iSeason = 1
        END IF

    END FUNCTION SeasonA

    FUNCTION SeasonB(iYear, iMonth, iDay) RESULT(iSeason)

        ! Routine arguments
        INTEGER, INTENT(IN) :: iYear
        INTEGER, INTENT(IN) :: iMonth
        INTEGER, INTENT(IN) :: iDay
        INTEGER             :: iSeason

        ! Locals
        INTEGER :: iJulianDay
        INTEGER :: iSpring
        INTEGER :: iSummer
        INTEGER :: iAutumn
        INTEGER :: iWinter

        ! Convert date to Julian day
        iJulianDay = JulianDay(iYear, iMonth, iDay)
        iSpring = JulianDay(iYear,  3, 21)
        iSummer = JulianDay(iYear,  6, 21)
        iAutumn = JulianDay(iYear,  9, 21)
        iWinter = JulianDay(iYear, 12, 21)

        ! Compute season
        IF(iSpring <= iJulianDay .AND. iJulianDay < iSummer) THEN
            iSeason = 2
        ELSEIF(iSummer <= iJulianDay .AND. iJulianDay < iAutumn) THEN
            iSeason = 3
        ELSEIF(iAutumn <= iJulianDay .AND. iJulianDay < iWinter) THEN
            iSeason = 4
        ELSE
            iSeason = 1
        END IF

    END FUNCTION SeasonB

    SUBROUTINE PackTime(iTime, iYear, iMonth, iDay, iInHour, iInMinute, iInSecond)

        ! Routine arguments
        INTEGER, INTENT(OUT)            :: iTime
        INTEGER, INTENT(IN)             :: iYear
        INTEGER, INTENT(IN)             :: iMonth
        INTEGER, INTENT(IN)             :: iDay
        INTEGER, INTENT(IN), OPTIONAL   :: iInHour
        INTEGER, INTENT(IN), OPTIONAL   :: iInMinute
        INTEGER, INTENT(IN), OPTIONAL   :: iInSecond

        ! Locals
        INTEGER :: iHour
        INTEGER :: iMinute
        INTEGER :: iSecond
        INTEGER :: iJulianDay
        INTEGER :: iJulianSecond

        ! Check for optional parameters; assign defaults if necessary
        IF(PRESENT(iInHour)) THEN
            iHour = iInHour
        ELSE
            iHour = 0
        END IF
        IF(PRESENT(iInMinute)) THEN
            iMinute = iInMinute
        ELSE
            iMinute = 0
        END IF
        IF(PRESENT(iInSecond)) THEN
            iSecond = iInSecond
        ELSE
            iSecond = 0
        END IF

        ! Check input parameters for validity
        IF( &
            iHour   < 0 .OR. iHour   > 23 .OR. &
            iMinute < 0 .OR. iMinute > 59 .OR. &
            iSecond < 0 .OR. iSecond > 59 &
        ) THEN
            iTime = -1
            RETURN
        END IF

        ! Compute based Julian day
        iJulianDay = JulianDay(iYear, iMonth, iDay) - BASE_DAY

        ! Convert based Julian day to second, and add seconds from time,
        ! regardless of hour type.
        iJulianSecond = iJulianDay * 24 * 3600
        iTime = iJulianSecond + iSecond + 60*(iMinute + 60*iHour)

    END SUBROUTINE PackTime

    SUBROUTINE UnpackTime(iTime, iYear, iMonth, iDay, iHour, iMinute, iSecond)

        ! Routine arguments
        INTEGER, INTENT(IN)     :: iTime
        INTEGER, INTENT(OUT)    :: iYear
        INTEGER, INTENT(OUT)    :: iMonth
        INTEGER, INTENT(OUT)    :: iDay
        INTEGER, INTENT(OUT)    :: iHour
        INTEGER, INTENT(OUT)    :: iMinute
        INTEGER, INTENT(OUT)    :: iSecond

        ! Locals
        INTEGER :: iJulianDay
        INTEGER :: iTimeSeconds

        ! Check parameter
        IF(iTime < 0) THEN
            iYear   = 1970
            iMonth  = 1
            iDay    = 1
            iHour   = 0
            iMinute = 0
            iSecond = 0
            RETURN
        END IF

        ! Isolate the date and time parts
        iJulianDay = iTime/(24*3600) + BASE_DAY
        iTimeSeconds = MOD(iTime, 24*3600)

        ! Process the date part
        CALL UnpackDate(iJulianDay, iYear, iMonth, iDay)

        ! Extract time from the time part
        iSecond = MOD(iTimeSeconds,60)
        iTimeSeconds = iTimeSeconds/60
        iMinute = MOD(iTimeSeconds,60)
        iHour   = iTimeSeconds/60

    END SUBROUTINE UnpackTime

    FUNCTION FormatDate(iYear, iMonth, iDay, lShortFormIn) RESULT(sDate)

        ! Routine arguments
        INTEGER, INTENT(IN)             :: iYear
        INTEGER, INTENT(IN)             :: iMonth
        INTEGER, INTENT(IN)             :: iDay
        LOGICAL, INTENT(IN), OPTIONAL   :: lShortFormIn
        CHARACTER(LEN=10)               :: sDate

        ! Locals
        LOGICAL :: lShortForm

        ! Format date
        IF(PRESENT(lShortFormIn)) THEN
            lShortForm = lShortFormIn
        ELSE
            lShortForm = .FALSE.
        END IF
        IF(lShortForm) THEN
            WRITE(sDate,"(2(i2.2,'/'),i2.2)") iDay, iMonth, MOD(iYear,100)
        ELSE
            WRITE(sDate,"(2(i2.2,'/'),i4.4)") iDay, iMonth, iYear
        END IF

    END FUNCTION FormatDate

    FUNCTION FormatTime(iYear, iMonth, iDay, iHourIn, iMinuteIn, iSecondIn, lShortFormIn) RESULT(sDate)

        ! Routine arguments
        INTEGER, INTENT(IN)             :: iYear
        INTEGER, INTENT(IN)             :: iMonth
        INTEGER, INTENT(IN)             :: iDay
        INTEGER, INTENT(IN), OPTIONAL   :: iHourIn
        INTEGER, INTENT(IN), OPTIONAL   :: iMinuteIn
        INTEGER, INTENT(IN), OPTIONAL   :: iSecondIn
        LOGICAL, INTENT(IN), OPTIONAL   :: lShortFormIn
        CHARACTER(LEN=19)               :: sDate

        ! Locals
        INTEGER :: iHour
        INTEGER :: iMinute
        INTEGER :: iSecond
        LOGICAL :: lShortForm

        ! Format date
        IF(PRESENT(iHourIn)) THEN
            iHour = iHourIn
        ELSE
            iHour = 0
        END IF
        IF(PRESENT(iMinuteIn)) THEN
            iMinute = iMinuteIn
        ELSE
            iMinute = 0
        END IF
        IF(PRESENT(iSecondIn)) THEN
            iSecond = iSecondIn
        ELSE
            iSecond = 0
        END IF
        IF(PRESENT(lShortFormIn)) THEN
            lShortForm = lShortFormIn
        ELSE
            lShortForm = .FALSE.
        END IF
        IF(lShortForm) THEN
            WRITE(sDate,"(2(i2.2,'/'),i2.2,1x,2(i2.2,':'),i2.2)") iDay, iMonth, MOD(iYear,100), iHour, iMinute, iSecond
        ELSE
            WRITE(sDate,"(2(i2.2,'/'),i4.4,1x,2(i2.2,':'),i2.2)") iDay, iMonth, iYear, iHour, iMinute, iSecond
        END IF

    END FUNCTION FormatTime

    FUNCTION FormatFileTime(iYear, iMonth, iDay, iHour) RESULT(sDate)

        ! Routine arguments
        INTEGER, INTENT(IN) :: iYear
        INTEGER, INTENT(IN) :: iMonth
        INTEGER, INTENT(IN) :: iDay
        INTEGER, INTENT(IN) :: iHour
        CHARACTER(LEN=11)   :: sDate

        ! Locals
        INTEGER :: iTotalYear

        ! Format date
        IF(iYear > 100) THEN
            WRITE(sDate,"(i4.4,2i2.2,'.',i2.2)") iYear, iMonth, iDay, iHour
        ELSE
            IF(iYear < 70) THEN
                iTotalYear = iYear + 2000
            ELSE
                iTotalYear = iYear + 1900
            END IF
            WRITE(sDate,"(i4.4,2i2.2,'.',i2.2)") iTotalYear, iMonth, iDay, iHour
        END IF

    END FUNCTION FormatFileTime

    SUBROUTINE DecodeDate(sDate, iYear, iMonth, iDay)

        ! Routine arguments
        CHARACTER(LEN=*), INTENT(IN)    :: sDate
        INTEGER, INTENT(OUT)            :: iYear
        INTEGER, INTENT(OUT)            :: iMonth
        INTEGER, INTENT(OUT)            :: iDay

        ! Locals
        INTEGER :: iLength
        INTEGER :: iRetCode

        ! Infer type of date from string length
        iLength = LEN_TRIM(sDate)
        SELECT CASE(iLength)
        CASE(8)
            ! Short-form date
            READ(sDate,"(i2,1x,i2,1x,i2)",IOSTAT=iRetCode) iDay, iMonth, iYear
            IF(iRetCode == 0) THEN
                IF(iYear > 70) THEN
                    iYear = iYear + 1900
                ELSE
                    iYear = iYear + 2000
                END IF
            ELSE
                iYear  = -9999
                iMonth = -9999
                iDay   = -9999
            END IF
        CASE(10)
            ! Long-form date
            READ(sDate,"(i2,1x,i2,1x,i4)",IOSTAT=iRetCode) iDay, iMonth, iYear
            IF(iRetCode /= 0) THEN
                iYear  = -9999
                iMonth = -9999
                iDay   = -9999
            END IF
        CASE DEFAULT
            iYear  = -9999
            iMonth = -9999
            iDay   = -9999
        END SELECT

    END SUBROUTINE DecodeDate

    SUBROUTINE DecodeTime(sDate, iYear, iMonth, iDay, iHour, iMinute, iSecond)

        ! Routine arguments
        CHARACTER(LEN=*), INTENT(IN)    :: sDate
        INTEGER, INTENT(OUT)            :: iYear
        INTEGER, INTENT(OUT)            :: iMonth
        INTEGER, INTENT(OUT)            :: iDay
        INTEGER, INTENT(OUT)            :: iHour
        INTEGER, INTENT(OUT)            :: iMinute
        INTEGER, INTENT(OUT)            :: iSecond

        ! Locals
        INTEGER :: iLength
        INTEGER :: iRetCode

        ! Infer type of date from string length
        iLength = LEN_TRIM(sDate)
        SELECT CASE(iLength)
        CASE(8)
            ! Short-form date
            READ(sDate,"(i2,1x,i2,1x,i2)",IOSTAT=iRetCode) iDay, iMonth, iYear
            IF(iRetCode /= 0) THEN
                iYear   = -9999
                iMonth  = -9999
                iDay    = -9999
                iHour   = -9999
                iMinute = -9999
                iSecond = -9999
            ELSE
                iHour   = 0
                iMinute = 0
                iSecond = 0
                IF(iYear > 70) THEN
                    iYear = iYear + 1900
                ELSE
                    iYear = iYear + 2000
                END IF
            END IF
        CASE(10)
            ! Long-form date
            READ(sDate,"(i2,1x,i2,1x,i4)",IOSTAT=iRetCode) iDay, iMonth, iYear
            IF(iRetCode /= 0) THEN
                iYear   = -9999
                iMonth  = -9999
                iDay    = -9999
                iHour   = -9999
                iMinute = -9999
                iSecond = -9999
            ELSE
                iHour   = 0
                iMinute = 0
                iSecond = 0
            END IF
        CASE(17)
            ! Short-form time
            READ(sDate,"(i2,1x,i2,1x,i2,1x,i2,1x,i2,1x,i2)",IOSTAT=iRetCode) iDay, iMonth, iYear, iHour, iMinute, iSecond
            IF(iRetCode /= 0) THEN
                iYear   = -9999
                iMonth  = -9999
                iDay    = -9999
                iHour   = -9999
                iMinute = -9999
                iSecond = -9999
            ELSE
                IF(iYear < 70) THEN
                    iYear = 2000 + iYear
                ELSE
                    iYear = 1900 + iYear
                END IF
            END IF
        CASE(19)
            ! Long-form time
            READ(sDate,"(i2,1x,i2,1x,i4,1x,i2,1x,i2,1x,i2)",IOSTAT=iRetCode) iDay, iMonth, iYear, iHour, iMinute, iSecond
            IF(iRetCode /= 0) THEN
                iYear   = -9999
                iMonth  = -9999
                iDay    = -9999
                iHour   = -9999
                iMinute = -9999
                iSecond = -9999
            END IF
        CASE DEFAULT
            iYear   = -9999
            iMonth  = -9999
            iDay    = -9999
            iHour   = -9999
            iMinute = -9999
            iSecond = -9999
        END SELECT

    END SUBROUTINE DecodeTime

    SUBROUTINE DecodeHour(sTime, iHour, iMinute, iSecond)

        ! Routine arguments
        CHARACTER(LEN=*), INTENT(IN)    :: sTime
        INTEGER, INTENT(OUT)            :: iHour
        INTEGER, INTENT(OUT)            :: iMinute
        INTEGER, INTENT(OUT)            :: iSecond

        ! Locals
        INTEGER :: iLength
        INTEGER :: iRetCode

        ! Infer type of date from string length
        iLength = LEN_TRIM(sTime)
        SELECT CASE(iLength)
        CASE(8)
            ! hh:mm:ss
            READ(sTime,"(i2,1x,i2,1x,i2)",IOSTAT=iRetCode) iHour, iMinute, iSecond
            IF(iRetCode /= 0) THEN
                iHour   = -9999
                iMinute = -9999
                iSecond = -9999
            END IF
        CASE(5)
            ! hh:mm
            READ(sTime,"(i2,1x,i2)",IOSTAT=iRetCode) iHour, iMinute
            IF(iRetCode /= 0) THEN
                iHour   = -9999
                iMinute = -9999
                iSecond = -9999
            ELSE
                iSecond = 0
            END IF
        CASE(2)
            ! hh
            READ(sTime,"(i2)",IOSTAT=iRetCode) iHour
            IF(iRetCode /= 0) THEN
                iHour   = -9999
                iMinute = -9999
                iSecond = -9999
            ELSE
                iMinute = 0
                iSecond = 0
            END IF
        CASE DEFAULT
            iHour   = -9999
            iMinute = -9999
            iSecond = -9999
        END SELECT

    END SUBROUTINE DecodeHour

    FUNCTION NumDays(iYear, iMonthIn) RESULT(iDays)

    	! Routine arguments
    	INTEGER, INTENT(IN)	:: iYear
    	INTEGER, INTENT(IN)	:: iMonthIn
    	INTEGER				:: iDays

    	! Locals
    	INTEGER								:: iMonth
    	INTEGER, DIMENSION(12), PARAMETER	:: ivDaysN = (/ &
    		31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 &
    	/)
    	INTEGER, DIMENSION(12), PARAMETER	:: ivDaysE = (/ &
    		31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 &
    	/)

    	! Compute the number of days in current month
    	iMonth = MAX(MIN(iMonthIn,12),1)
    	IF(MOD(iYear,4)/=0) THEN
    		iDays = ivDaysN(iMonth)
    	ELSE
    		iDays = ivDaysE(iMonth)
    	END IF

    END FUNCTION NumDays

END MODULE Calendar


c***************************************************************************
c			TU4_GETACCB_TP.F
c*************************************************************************
c GETACCB_TP returns the bary. acc. on EACH of ntp test particles
c due to nbod massive objects by direct summation
c
c             Input:
c                 nbod          ==>  number of massive bodies (int scalar)
c                 mass          ==>  mass of planets (real array)
c                 j2rp2,j4rp4   ==>  J2*radii_pl^2 and  J4*radii_pl^4
c                                     (real scalars)
c                 xb,yb,zb      ==>  position of planets in beri coord
c                                    (real arrays)
c                 ntp           ==> number of test particles (int scalar)
c                 xbt,ybt,zbt   ==>  position of test part in beri coord
c                                    (real arrays)
c                 istat         ==>  status of the test paricles
c                                      (integer array)
c                                      istat(i) = 0 ==> active:  = 1 not
c                                    NOTE: it is really a 2d array but
c                                          we only use the 1st row
c
c             Output:
c               axbt,aybt,azbt   ==>  accel in beri coord (real arrays)
c
c Remarks:  Based on Martin's NB4M routines
c Authors:  Martin Duncan
c Date:    3/8/93
c Last revision: 2/24/94

      subroutine tu4_getaccb_tp(nbod,mass,j2rp2,j4rp4,xb,yb,zb,
     &	              ntp,xbt,ybt,zbt,istat,axbt,aybt,azbt)

      include '../swift.inc'

c...  Inputs Only:
      integer nbod,ntp,istat(ntp)
      real*8 mass(nbod),j2rp2,j4rp4
      real*8 xb(nbod),yb(nbod),zb(nbod)
      real*8 xbt(ntp),ybt(ntp),zbt(ntp)

c...  Output
      real*8 axbt(ntp),aybt(ntp),azbt(ntp)

c...  Internals
      real*8 xx,yy,zz,rr2,fac,fac1
      real*8 xht(NTPMAX),yht(NTPMAX),zht(NTPMAX),irht(NTPMAX)
      real*8 aoblxt(NTPMAX),aoblyt(NTPMAX),aoblzt(NTPMAX)
      integer i,j

c----
c...  executable code

c...  first do the Sun

      do i = 1,ntp
         if(istat(i).eq.0.0) then
            xx = xbt(i) - xb(1)
            yy = ybt(i) - yb(1)
            zz = zbt(i) - zb(1)
            rr2 = xx**2 + yy**2 + zz**2
            fac1 = 1.d0/sqrt(rr2)
            fac = mass(1)*fac1/rr2

c..         save for the J2 and J4 calculations
            xht(i) = xx
            yht(i) = yy
            zht(i) = zz
            irht(i) = fac1

            axbt(i) = - fac*xx
            aybt(i) = - fac*yy
            azbt(i) = - fac*zz
	 endif
      enddo

c...  do the rest of the planets

      do i = 1,ntp
         if(istat(i).eq.0.0) then
            do j = 2,nbod
               xx = xbt(i) - xb(j)
               yy = ybt(i) - yb(j)
               zz = zbt(i) - zb(j)
               rr2 = xx**2 + yy**2 + zz**2
               fac = mass(j)/(rr2*sqrt(rr2))
               axbt(i) = axbt(i) - fac*xx
               aybt(i) = aybt(i) - fac*yy
               azbt(i) = azbt(i) - fac*zz
            enddo
	 endif
      enddo

      if(j2rp2.ne.0.0d0) then
         call obl_acc_tp(ntp,istat,mass(1),j2rp2,j4rp4,xht,yht,zht,
     &        irht,aoblxt,aoblyt,aoblzt)
         do i = 1,ntp
            axbt(i) = axbt(i) + aoblxt(i)
            aybt(i) = aybt(i) + aoblyt(i)
            azbt(i) = azbt(i) + aoblzt(i)
         enddo
      endif

      return
      end                       !  tu4_getaccb_tp
c____________________________________________________________________________


module physics
    ! always keep module named 'physics'
    !   even if the file name changes.
    !   - this lets you create different physics for different runs,
    !       and have things like simply by compiling the right physics file
    !       !!! NOTE !!!
    !           - this means you MUST make sure you have a recent,
    !             compiled version of the right physics.

    implicit none
    private calc_energy
    public calc_force, accuracy_check
    integer, parameter           :: precision=8 ! double precision

    type, public :: accuracy_state
            real(kind=precision) :: energy
        contains
            procedure, pass :: initialize => accuracy_state_initialize
    end type accuracy_state

    real(kind=precision), parameter     :: energy_tol           = 1d-4

    real(kind=precision), parameter     :: eccentricity    = .3
    real(kind=precision), parameter     :: energy_initial  = -1
    real(kind=precision), parameter     :: x_max           = exp(energy_initial) &
                                                        / (1 - eccentricity)

    logical, parameter                  :: allow_z_motion = .False. ! for bulirsch_stoer

    contains

    subroutine calc_force(n_bodies, x, v, mass, force)
        ! Calculate gravitational forces given current positions

        ! inputs:
        !   n_bodies    - integer - number of interacting bodies
        !   x           - (n_bodies x 3) float array - positions

        ! outputs:
        !   f           - (n_bodies x 3) float array - forces

        ! side effects:
        !   none (this is enforced)

        ! assumes:

        ! features for later:

        implicit none
        integer,                                      intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision), dimension(n_bodies, 3), intent(out) :: force
        real(kind=precision)                                      :: denominator
        real(kind=precision)                                      :: x1, x2 ! x,y coords
        integer                                                   :: i,j ! loop variables

        do concurrent (i=1:n_bodies)
            x1 = x(i,1)
            x2 = x(i,2)

            denominator = ( (x1**2 + x2**2) &
                - eccentricity * x1 * sqrt(x1**2 + x2**2) )

            force(i,1) = -1 * mass(i) * ( (x1 - eccentricity * sqrt(x1**2 + x2**2)) &
                / denominator )
            force(i,2) = -1 * mass(i) * ( (x2) &
                / denominator )
            force(i,3) = 0.
        end do

    end subroutine calc_force

    pure function calc_energy(n_bodies, x, v, mass) result(energy)
        implicit none
        integer,                               intent(in)         :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x, v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision)                                      :: energy
        integer                                                   :: i,j ! loop variables

        energy = 0.

        do concurrent (i=1:n_bodies, j=1:3)
            energy = energy + 1./2 * mass(i) * v(i,j)**2
        end do

        do concurrent (i=1:n_bodies)
            energy  = energy + log( sqrt(x(i,1)**2 + x(i,2)**2) &
                - eccentricity * x(i,1) )
        end do

    end function calc_energy

    subroutine calc_initial_velocity(n_bodies, x, v)
        ! Sets x velocity = 0, then:
        !
        ! Calculates the initial y velocities,
        !   assuming:
        !       - 0 < x < x_max
        !           - where x_max is maximum allowed at energy_initial=-1
        !       - x velocity = 0
        !       - y          = 0
        !       - z          = 0 (always)
        !       - z velocity = 0

        ! inputs:
        !   n_bodies    - integer - number of interacting bodies
        !   x           - (n_bodies x 3) float array - positions

        ! outputs:
        !              - (n_bodies x 3) float array - velocities

        ! side effects:
        !   overwrites any value that existed in velocities

        ! assumes:
        !   - see above

        ! features for later:

        implicit none
        integer,                               intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x
        real(kind=precision), dimension(n_bodies, 3), intent(out) :: v
        real(kind=precision)                                      :: x0
        integer                                            :: i,j ! loop variables

        do concurrent (i=1:n_bodies)
            v(i,1) = 0.
            v(i,2) = sqrt( 2 * (energy_initial  &
                - log( x(i,1) * (1 - eccentricity) )) )
            v(i,3) = 0.
        end do

    end subroutine calc_initial_velocity

    function accuracy_check(state_initial, state_current) result (check)
        implicit none
        class(accuracy_state), intent(in) :: state_initial, state_current
        logical :: check
        real(kind=precision) :: energy_err

        energy_err = abs( (state_current%energy - state_initial%energy) &
            / (state_initial%energy) )

        check = .False.
        if (energy_err.lt.energy_tol) then
            check = .True.
        end if

    end function

    subroutine accuracy_state_initialize(state, n_bodies, x, v, mass)
        implicit none
        class(accuracy_state),                 intent(out) :: state
        integer,                               intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x, v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision) :: energy

        energy = calc_energy(n_bodies, x, v, mass)

        state%energy = energy

    end subroutine

end module


*======================================================================*
*
      SUBROUTINE Invert_field(k,i)
*
      INCLUDE 'parameters.f'
      integer k, i
*
************************************************************************
*                                                                      *
*     D,E,F(*,k,4,n,m) contain the D,E,F(n,m) coefficients of a        *
*     Lamb's solution valid inside particle k. This subroutine         *
*     calculates the coefficients A,B,C(n,m) of a series valid         *
*     outside the particle, which has the opposite velocity on the     *
*     surface of the particle. The new coefficients are added to       *
*     A,B,C(*,k,3,n,m).                                                *
*                                                                      *
************************************************************************
*
      integer j,n,m
*
      do j=1,2
         do m=-1,1
            A(j,k,3,1,m) = A(j,k,3,1,m) -
     +           radius(k)**5*F(j,k,3,1,m)/30.d0
            D(j,k,2,1,m) = D(j,k,2,1,m) + D(j,k,3,1,m)
            E(j,k,2,1,m) = E(j,k,2,1,m) + E(j,k,3,1,m)
            F(j,k,2,1,m) = F(j,k,2,1,m) + F(j,k,3,1,m)
         end do
      end do
*
      do j=1,2
         do n=2,NN(k,i)
            do m=-n,n
               A(j,k,3,n,m) = A(j,k,3,n,m) -
     +              n*radius(k)**(2.d0*n+1.d0)/(4.d0*(n+1.d0)*(2*n+3))*
     +              (2.d0*(2*n-1)*(2*n+3)*D(j,k,3,n,m) +
     +              (2*n+1)*radius(k)**2.d0*F(j,k,3,n,m))
               B(j,k,3,n,m) = B(j,k,3,n,m) -
     +              radius(k)**(2.d0*n+1.d0)*E(j,k,3,n,m)
               C(j,k,3,n,m) = C(j,k,3,n,m) -
     +              n*(2*n-1)*radius(k)**(2.d0*n-1.d0)/(2.d0*(n+1))*(
     +              2.d0*(2*n+1)*D(j,k,3,n,m) +
     +              radius(k)**2.d0*F(j,k,3,n,m))
               D(j,k,2,n,m) = D(j,k,2,n,m) + D(j,k,3,n,m)
               E(j,k,2,n,m) = E(j,k,2,n,m) + E(j,k,3,n,m)
               F(j,k,2,n,m) = F(j,k,2,n,m) + F(j,k,3,n,m)
            end do
         end do
      end do
*
      end
*
*======================================================================*
*
      SUBROUTINE Translate_field(i,j)
*
      INCLUDE 'parameters.f'
      integer i,j
*
************************************************************************
*                                                                      *
*     A field which is valid outside particle i is expressed in the    *
*     coefficients A,B,C(*,i,3+j,n,m). This subroutine converts it     *
*     into one valid inside particle j. The result of the process is   *
*     stored in the coefficients D,E,F(*,j,3+i,n,m).                   *
*                                                                      *
************************************************************************
*
      integer nu,n,m,ninit,p
      real*8 sign
*
      if (r(i,j) .LT. 0.d0) then
         sign = 1.d0
      else
         sign = -1.d0
      end if
*
      do nu=1,NN(i,j)
         do m=-nu,nu
            do p=1,2
               D(p,j,3+i,nu,m) = 0.d0
               E(p,j,3+i,nu,m) = 0.d0
               F(p,j,3+i,nu,m) = 0.d0
            end do
            if (m .EQ. 0) then
               ninit = 1
            else
               ninit = iabs(m)
            end if
            do n=ninit,NN(i,j)
               D(1,j,3+i,nu,m) = D(1,j,3+i,nu,m) +
     +              (-1.d0)**(n+m)*sign**(n+nu)*(FracH(n,nu,m))/
     +              (dabs(r(i,j))**(n+nu+1))*(
     +              g(nu,n,m)*A(1,i,3+j,n,m) +
     +              m*g(nu,n,m)*r(i,j)*B(2,i,3+j,n,m)/nu +
     +              (g(nu-1,n,m)*(nu-iabs(m))*
     +              ((nu-1)*(n-2) - (n+1))/
     +              (nu*(2*nu-1)) - g(nu,n,m)*(n-2)/2.d0)*
     +              dabs(r(i,j))**2.d0*C(1,i,3+j,n,m)/
     +              (n*(2.d0*n-1.d0)))
               D(2,j,3+i,nu,m) = D(2,j,3+i,nu,m) +
     +              (-1.d0)**(n+m)*sign**(n+nu)*(FracH(n,nu,m))/
     +              (dabs(r(i,j))**(n+nu+1))*(
     +              g(nu,n,m)*A(2,i,3+j,n,m) -
     +              m*g(nu,n,m)*r(i,j)*B(1,i,3+j,n,m)/nu +
     +              (g(nu-1,n,m)*(nu-iabs(m))*
     +              ((nu-1)*(n-2) - (n+1))/
     +              (nu*(2*nu-1)) - g(nu,n,m)*(n-2)/2.d0)*
     +              dabs(r(i,j))**2.d0*C(2,i,3+j,n,m)/
     +              (n*(2.d0*n-1.d0)))
               E(1,j,3+i,nu,m) = E(1,j,3+i,nu,m) +
     +              (-1.d0)**(n+m)*sign**(n+nu)*
     +              g(nu,n,m)*(FracH(n,nu,m))/
     +              (dabs(r(i,j))**(n+nu+1))*(
     +              -(n/(1.d0+nu))*B(1,i,3+j,n,m) +
     +              m*r(i,j)*C(2,i,3+j,n,m)/
     +              ((1.d0+nu)*n*nu))
               E(2,j,3+i,nu,m) = E(2,j,3+i,nu,m) +
     +              (-1.d0)**(n+m)*sign**(n+nu)*
     +              g(nu,n,m)*(FracH(n,nu,m))/
     +              (dabs(r(i,j))**(n+nu+1))*(
     +              -(n/(1.d0+nu))*B(2,i,3+j,n,m) -
     +              m*r(i,j)*C(1,i,3+j,n,m)/
     +              ((1.d0+nu)*n*nu))
               F(1,j,3+i,nu,m) = F(1,j,3+i,nu,m) +
     +              (-1.d0)**(n+m)*sign**(n+nu)*(FracH(n,nu,m))/
     +              (dabs(r(i,j))**(1+n+nu))*
     +              g(nu,n,m)*C(1,i,3+j,n,m)
               F(2,j,3+i,nu,m) = F(2,j,3+i,nu,m) +
     +              (-1.d0)**(n+m)*sign**(n+nu)*(FracH(n,nu,m))/
     +              (dabs(r(i,j))**(1+n+nu))*
     +              g(nu,n,m)*C(2,i,3+j,n,m)
            end do
         end do
      end do
*
      end
*
*======================================================================*