      double precision function dpmpar(i)
      integer i
c     **********
c
c     Function dpmpar
c
c     This function provides double precision machine parameters
c     when the appropriate set of data statements is activated (by
c     removing the c from column 1) and all other data statements are
c     rendered inactive. Most of the parameter values were obtained
c     from the corresponding Bell Laboratories Port Library function.
c
c     The function statement is
c
c       double precision function dpmpar(i)
c
c     where
c
c       i is an integer input variable set to 1, 2, or 3 which
c         selects the desired machine parameter. If the machine has
c         t base b digits and its smallest and largest exponents are
c         emin and emax, respectively, then these parameters are
c
c         dpmpar(1) = b**(1 - t), the machine precision,
c
c         dpmpar(2) = b**(emin - 1), the smallest magnitude,
c
c         dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.
c
c     Argonne National Laboratory. MINPACK Project. November 1996.
c     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More'
c
c     **********

      double precision dmach(3)
      dmach(1) = epsilon(1d0)
      dmach(2) = tiny(1d0)
      dmach(3) = huge(1d0)
c
      dpmpar = dmach(i)
      return
c
c     Last card of function dpmpar.
c
      end


      PROGRAM main
      IMPLICIT none
C Constants
      !REAL*8 pi
      !PARAMETER (pi=4.0d0*datan(1.0d0))
C Command line inputs
      CHARACTER*120 ifile
      INTEGER ipoly,isin,iexp
      REAL*8 per(3)
C Observation variables
      INTEGER nobs,OBSMAX
      PARAMETER (OBSMAX=50000)
      REAL*8 obs(OBSMAX,2)

      REAL*8 soln(12)
      !REAL*8 A(OBSMAX,4),b(OBSMAX,1),x(OBSMAX,1)
      !REAL*8 afreq,period
      !INTEGER dimx,dimy,m,n

#ifndef USELAPACK
      write(0,*) 'multifit: compile with LAPACK to use'
      stop
#endif

C----
C Parse command line
C----
      call gcmdln(ifile,ipoly,isin,per,iexp)

C----
C Read in observations
C----
      call readobs(ifile,obs,nobs,OBSMAX)

C----
C Solve least squares problem
C----
      call lstsqr(soln,obs,nobs,OBSMAX,ipoly,isin,per,iexp)

C----
C Print results
C----
C Polynomial coefficients
      if (soln(1).gt.-1.0d98) write(*,1001) 'POLY 0',soln(1)
      if (soln(2).gt.-1.0d98) write(*,1001) 'POLY 1',soln(2)
      if (soln(3).gt.-1.0d98) write(*,1001) 'POLY 2',soln(3)
      if (soln(4).gt.-1.0d98) write(*,1001) 'POLY 3',soln(4)
C Sinusoid amplitude and phase
      if (soln(5).gt.-1.0d98) then
          write(*,1002) 'SINE 1AMP',soln(5)
          write(*,1003) 'SINE 1PHA',soln(6)
      endif
      if (soln(7).gt.-1.0d98) then
          write(*,1002) 'SINE 2AMP',soln(7)
          write(*,1003) 'SINE 2PHA',soln(8)
      endif
      if (soln(9).gt.-1.0d98) then
          write(*,1002) 'SINE 3AMP',soln(9)
          write(*,1003) 'SINE 3PHA',soln(10)
      endif
C Exponential amplitude and constant
      if (soln(11).gt.-1.0d98) then
          write(*,*) 'EXP AMP',soln(11)
          write(*,*) 'EXP CONST',soln(12)
      endif

 1001 format(A,1PE12.3)
 1002 format(A,1PE12.3)
 1003 format(A,F10.4)
      END

C----------------------------------------------------------------------C

      SUBROUTINE readobs(ifile,obs,nobs,OBSMAX)
      IMPLICIT none
      CHARACTER*120 ifile
      INTEGER input
      LOGICAL ex
      INTEGER i,nobs,OBSMAX
      REAL*8 obs(OBSMAX,2)
      if (ifile.eq.'stdin') then
          input = 5
      else
          inquire(file=ifile,exist=ex)
          if (.not.ex) then
              call usage('!! Error: no input file '//trim(ifile))
          endif
          input = 11
          open(unit=input,file=ifile,status='old')
      endif
      i = 1
  101 read(input,*,end=102) obs(i,1),obs(i,2)
          i = i + 1
          if (i.gt.OBSMAX) then
              call usage('!! Error: too many input points')
          endif
          goto 101
  102 continue
      nobs = i - 1
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE lstsqr(soln,obs,nobs,OBSMAX,ipoly,isin,per,iexp)
      IMPLICIT none
      REAL*8 pi
      PARAMETER (pi=4.0d0*datan(1.0d0))
      REAL*8 soln(12)
      INTEGER nobs,OBSMAX
      REAL*8 obs(OBSMAX,2)
      INTEGER ipoly,isin,iexp
      REAL*8 per(3),afreq(3)
      INTEGER i,j
      INTEGER dimx,dimy,n,m
      REAL*8 A(2*OBSMAX,12),b(2*OBSMAX,1),x(2*OBSMAX,1)
      REAL*8 C1,C2
C----
C Compute angular frequency from period
C----
      do 101 i = 1,isin
          afreq(i) = 2.0d0*pi/per(i)
  101 continue

C----
C Load model matrix, A, and observation vector, b
C----
      do 201 i = 1,nobs
          ! Polynomial
          A(i,1) = 1.0d0
          do 202 j = 1,ipoly
              A(i,j+1) = obs(i,1)**ipoly
  202     continue
          ! Sinusoid
          do 203 j = 1,isin
              A(i,ipoly+1+j) = dsin(afreq(j)*obs(i,1))
              A(i,ipoly+1+isin+j) = dcos(afreq(j)*obs(i,1))
  203     continue
          ! Exponential
          if (iexp.eq.1) then
              A(nobs+i,ipoly+1+2*isin+1) = 1.0d0
              A(nobs+i,ipoly+1+2*isin+2) = obs(i,1)
          endif
          ! Observation matrix
          b(i,1) = obs(i,2)
          if (iexp.eq.1) then
              b(nobs+i,1) = dlog(obs(i,2))
          endif
  201 continue

C----
C Solve least squares problem
C----
      dimx = 2*OBSMAX
      dimy = 12
      n    = nobs + nobs*iexp
      m    = 1+ipoly + 2*isin + 2*iexp
      call lsqsolve(A,b,x,dimx,dimy,n,m)

C----
C Save as clean solution vector
C----
      do 206 i = 1,12
          soln(i) = -1.0d99
  206 continue
      do 207 i = 1,ipoly+1
          soln(i) = x(i,1)
  207 continue
      do 208 i = 1,isin
          C1 = x(ipoly+1+i,1)
          C2 = x(ipoly+1+isin+i,1)
          soln(4+2*i-1) = dsqrt(C1*C1+C2*C2)
          soln(4+2*i)   = datan2(C2,C1)
  208 continue
      if (iexp.eq.1) then
          soln(11) = dexp(x(ipoly+1+2*isin+1,1))
          soln(12) = x(ipoly+1+2*isin+2,1)
      endif
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE lsqsolve(Ain,bin,xout,OBSMAX,FLTMAX,nobs,npar)
C----
C Solve generalized least squares problem Ax = b.
C On input, arrays Ain and bin are given maximum dimensions:
C     Ain(OBSMAX,FLTMAX)
C     bin(OBSMAX,1)
C To operate with LAPACK generalized inverse tools, convert arrays from
C maximum size to operating size:
C     Ain --> A(nobs,npar)
C     bin --> b(nobs,1)
C----
      IMPLICIT none
      INTEGER OBSMAX,FLTMAX
      REAL*8 Ain(OBSMAX,FLTMAX),bin(OBSMAX,1),xout(OBSMAX,1)
      INTEGER nobs,npar
      REAL*8 A(nobs,npar),b(nobs,1),x(nobs,1)
      INTEGER i,j
C Load existing arrays into arrays of correct dimensions
      do 432 i = 1,nobs
          b(i,1) = bin(i,1)
          do 431 j = 1,npar
              A(i,j) = Ain(i,j)
  431     continue
  432 continue
C Solve generalized least squares problem using LAPACK tools
      call solve(A,x,b,nobs,npar)
C Print results
      do 433 i = 1,npar
          xout(i,1) = x(i,1)
  433 continue
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE solve(A,x,b,nobs,npar)
C----
C Determine the optimal workspace size for work array in dgels
C Solve least squares problem Ax = b for x using QR or LQ decomposition
C----
      IMPLICIT none
      INTEGER nobs,npar,nrhs,i
      REAL*8 A(nobs,npar),b(nobs,1),btmp(nobs,1),x(npar,1)
      INTEGER lwork
      INTEGER m,n,lda,ldb
      INTEGER info
      CHARACTER*1 trans
      REAL*8 work(100000)
      nrhs = 1
      trans = 'N'     ! A has form (nobs x npar), i.e. not transposed
      m = nobs        ! Number of rows in matrix A
      n = npar        ! Number of columns in matrix A
      lda = m         ! Leading dimension of A  lda >= max(1,m)
      ldb = max(m,n)  ! Leading dimension of b  ldb >= max(1,m,n)
C Compute optimal workspace
      lwork = -1
#ifdef USELAPACK
      call dgels(trans,m,n,nrhs,A,lda,b,ldb,work,lwork,info)
#endif
      lwork = int(work(1))
      !print *,'LWORK',lwork
C Copy observation vector, b to btmp (replaced in dgels)
      do 441 i = 1,nobs
          btmp(i,1) = b(i,1)
  441 continue
C Compute parameter array
#ifdef USELAPACK
      call dgels(trans,m,n,nrhs,a,lda,btmp,ldb,work,lwork,info)
#endif
      do 442 i = 1,npar
          x(i,1) = btmp(i,1)
  442 continue
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE gcmdln(ifile,ipoly,isin,per,iexp)
      IMPLICIT none
      CHARACTER*120 ifile
      INTEGER ipoly,isin,iexp
      REAL*8 per(3)
      INTEGER i,narg
      CHARACTER*80 tag
      ifile = 'none'
      ipoly = 0 ! Order of polynomial (default: compute mean)
      isin  = 0 ! Number of sinusoidal fits
      do 103 i = 1,3
          per(i) = 0.0d0
  103 continue
      iexp  = 0 ! Exponential fit flag
      narg = iargc()
      if (narg.eq.0) call usage('')
      i = 0
  101 i = i + 1
      if (i.gt.narg) goto 102
          call getarg(i,tag)
          if (tag(1:5).eq.'-poly') then
              i = i + 1
              call getarg(i,tag)
              read(tag,*) ipoly
          elseif (tag(1:4).eq.'-sin') then
              isin = isin + 1
              if (isin.gt.3) then
                  call usage('!! Error: max 3 different periods')
              endif
              i = i + 1
              call getarg(i,tag)
              read(tag,*) per(isin)
          elseif (tag(1:4).eq.'-exp') then
              iexp = 1
          elseif (tag(1:2).eq.'-f') then
              i = i + 1
              call getarg(i,ifile)
          else
              call usage('!! Error: No option '//tag)
          endif
          goto 101
  102 continue
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE usage(str)
      IMPLICIT none
      CHARACTER str*(*)
      if (str.ne.'') then
            write(0,*) trim(str)
            write(0,*)
      endif
      write(0,*)
     1 'Usage: multifit -f XYFILE [-poly ORD] [-sin PERIOD] [-exp]'
      write(0,*)
     1 '    -f XYFILE    Input x-y file'
      write(0,*)
     1 '    -poly ORD    Fit a polynomial (up to order 3)'
      write(0,*)
     1 '    -sin PER     Fit a sinusoid with period PER (can be ',
     2                           'repeated up to 3 times with ',
     2                                  'different periods)'
      write(0,*)
     1 '    -exp         Fit an exponential'
      STOP
      END


program vinay
  integer :: a = 100, b = 20

  print *, a  +  (-b) + -a + -b - -200
end program vinay


  !! ----------------------------------------------------------------------- !!
  !>
  !! Set station location.
  !! nst, xst(:), yst(:), ist(:), jst(:) should be set here with memory alloc.
  !<
  block

    integer :: i

    nst = 5

    allocate( ist(nst), jst(nst), xst(nst), yst(nst) )
    allocate( wav(nst,0:nt) )

    xst(:) = (/ 50, 150, 150,  50, 100 /) * 1000 ! m -> km
    yst(:) = (/ 50,  50, 150, 150, 150 /) * 1000 ! m -> km

    !! choose nearest station grid
    !!   xbeg + (ist-1)*dx < xst <= xbeg + (ist) * dx
    !!   ybeg + (jst-1)*dy < yst <= ybeg + (jst) * dy
    do i=1, nst
       ist(i) = ceiling( ( xst(i) - xbeg ) / dx + 0.5 )
       jst(i) = ceiling( ( yst(i) - ybeg ) / dy + 0.5 )
    end do

    wav(:,:) = 0.0

  end block


program cpssetup

  use precision
  use mpi
  use globals
  use conversion
  use misc
  use setup
  use hamiltonian
  use propagate

  implicit none

  complex(cdp), dimension(:, :), allocatable :: wavefn, wavefn_t
  complex(cdp), dimension(:), allocatable :: espectrum
  real(fdp) :: e_start
  integer(idp), dimension(dim) :: nl, nu, trnl, trnu

#ifdef MPI
  call s_mpiinit()
#endif

  open(unit=potdata, status='scratch', form="formatted")

  !
  !  Read the input file and setup initialise global variables
  !

  call s_setup()

#ifdef MPI
  call s_mpiarraysize(nl, nu, trnl, trnu)
#else
  nl = (/ 1, 1 /)
  nu = (/ parameters%n(1), parameters%n(2) /)
  trnl = (/ 1, 1 /)
  trnu = (/ parameters%n(2), parameters%n(1) /)
#endif

  allocate(wavefn(nl(1):nu(1), nl(2):nu(2)), wavefn_t(nl(1):nu(1), nl(2):nu(2)), espectrum(parameters%timesteps))

  !
  !  Initialise the wavefunction
  !

  call s_initialwavefn(wavefn, nl, nu)

  call s_display('================================================================================')
  call s_display('time step= ', char=f_numchar(0)//' / '//f_numchar(parameters%timesteps))

  !
  !  Propagate the wavefunction for t=0s.  This is done to initialise
  !  the potential and various components required for the full
  !  propagation
  !

  call s_propagatewavefn(wavefn, nl, nu, 0.0d0, 0.0d0)

  !
  !  Save the initial wave function to disk in a converted format
  !  for loading into Mathematica
  !

  call s_display('norm= ', realnum=f_norm(real(wavefn*conjg(wavefn)), nl, nu))
  call s_display('system energy= ', realnum=f_wavefnenergy(wavefn, nl, nu))

  if (parameters%plotwfn) then

     call s_write2drarray(real(wavefn*conjg(wavefn)), nl, nu, trim(f_numchar(0)))
#if 1
     call s_write2drarray(real(wavefn), nl, nu, 'real.'//trim(f_numchar(0)))
     call s_write2drarray(aimag(wavefn), nl, nu, 'comp.'//trim(f_numchar(0)))
#endif

  end if

  wavefn_t = wavefn

  call s_c2dfft(wavefn_t, nl, nu, fftfor)

#ifdef MPI
  call s_mpitranspose(wavefn_t, trnl, trnu)
#endif

  call s_cshift(wavefn_t, nl, nu, parameters%n(1)/2, parameters%n(2)/2)

  if (parameters%plotwfnp) then

     call s_write2drarray(real(wavefn_t*conjg(wavefn_t)), nl, nu,&
          & 'p.'//trim(f_numchar(0)), incboundary=.true.)

  end if

  e_start = f_wavefnenergy(wavefn, nl, nu)

  espectrum = 0.0d0

  call s_checkpoint(0, wavefn, wavefn, nl, nu, e_start, espectrum)

  deallocate(wavefn, wavefn_t, espectrum)

  close(potdata)

#ifdef MPI
  call s_mpifinalise()
#endif

end program cpssetup


    program demo_log_gamma
    implicit none
    real :: x = 1.0
       write(*,*)x,log_gamma(x) ! returns 0.0
    end program demo_log_gamma


function quadgs (kv, str1, x1, x2, tmp1, nq1, nq2, wk, xk)

!   This routine computes the integral of the function fun on the interval
!   [0, 1], with up to nq1 iterations, with a target tolerance of 10^nepsilon1.
!   wk and xk are precomputed tables of weights and abscissas, each of size
!   nq2 and of type mp_real.  The function fun is not evaluated at x1 or x2.
!   Modified for the Toolkit.

!   David H Bailey    2004-07-27
!   David H Bailey    2006-11-03   Modifications made for toolkit usage

use mpmodule
use globdata
implicit none
integer i, ierror, ik0, k, j, n, nds, nq1, nq2, nerr, nwp
double precision d1, d2, d3, d4, dplog10q, dpw
type (mp_real) ax, bx, c10, eps1, epsilon1, epsilon2, err, fun, &
  quadgs, tsum, s1, s2, s3, t1, t2, t3, tw1, tw2, twmx, &
  wk(-1:nq2), xk(-1:nq2), x1, x2, xx1, xx2
integer kv, ntmp1
character*2048 str1
character*1 stout(72)
type (mp_real) tmp1(ntmpx)
external dplog10q
parameter (ik0 = 100, dpw = 14.44943979d0)

! nds = mpoud
! mpoud = 56
ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)
epsilon1 = mpreal (10.d0) ** nepsilon1
epsilon2 = mpreal (10.d0) ** nepsilon2
s1 = 0.d0
s2 = 0.d0
c10 = 10.d0

if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quadgs: quadrature arrays have not been initialized; nq1 =',i6)
  nerror = 70
  goto 130
endif

nwp = 8
call mpsetprecwords (nwp)

do k = 1, nq1
  n = 3 * 2 ** (k + 1)
  s3 = s2
  s2 = s1

100 continue

  twmx = 0.d0
  tsum = 0.d0
  i = dble (xk(k))

  do j = 1, n / 2
    i = i + 1
    xx1 = - ax * xk(i) + bx
    xx2 = ax * xk(i) + bx

    if (xx1 > x1) then
      var(kv) = xx1
      call parse (str1, ntmp1, tmp1(1))
      t1 = tmp1(1)
      call mpgetpar ('mpier', ierror)
      if (ierror > 0 .or. nerror > 0) goto 120
      tw1 = t1 * wk(i)
    else
      t1 = 0.d0
      tw1 = 0.d0
    endif

    if (xx2 < x2 .and. j + k > 2) then
      var(kv) = xx2
      call parse (str1, ntmp1, tmp1(1))
      t2 = tmp1(1)
      call mpgetpar ('mpier', ierror)
      if (ierror > 0 .or. nerror > 0) goto 120
      tw2 = t2 * wk(i)
    else
      t2 = 0.d0
      tw2 = 0.d0
    endif

    tsum = tsum + tw1 + tw2
    twmx = max (twmx, abs (tw1), abs (tw2))
  enddo

!   Compute s1 = current integral approximation and err = error estimate.
!   Tsum is the sum of all tw1 and tw2 from the loop above.
!   Twmx is the largest absolute value of tw1 and tw2 from the loop above.

  s1 =  ax * tsum
  eps1 = twmx * mpreal (10.d0) ** nint (22 - dpw * nwp)
  d1 = dplog10q (abs (s1 - s2))
  d2 = dplog10q (abs (s1 - s3))
  d3 = dplog10q (eps1) - 1.d0

  if (k <= 2) then
    err = 1.d0
  elseif (d1 .eq. -9999.d0) then
    err = 0.d0
  else
    nerr = nint (min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3, d4)))
    err = c10 ** nerr
  endif

!   Output current integral approximation and error estimate, to 56 dp.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quadgs: Iteration',i3,' of',i3,'; est error = 10^',i5, &
      '; approx value =')
!    call mpwrite (6, s1)
    call mpeform (s1, 72, 60, stout)
    write (6, '(72a1)') stout
  endif
  if (k >= 3 .and. err < eps1) goto 130

  if (-2 * nerr > nint (dpw * nwp)) then
    nwp = min (2 * nwp, nwords1)
    call mpsetprecwords (nwp)
  endif
enddo

write (6, 3) nint (dplog10q (abs (err))), nquadl
3 format ('quadgs: Estimated error = 10^',i5/&
  'Increase Quadlevel for greater accuracy. Current Quadlevel =',i4)
if (err > 1.d-20) then
  write (6, 4)
4 format ('quadgs: Poor results may be due to singularities at endpoints.'/&
  'If so, try the erf or tanh-sinh quadrature routines (Quadtype = 2 or 3).')
endif
goto 130

120 continue

nerror = ierror + 100
write (6, 6) nerror
6 format ('quadgs: Error in quadrature calculation; code =',i5)
s1 = 0.d0

130 continue

quadgs = s1
! mpoud = nds
call mpsetprecwords (nwords1)
return
end

function quaderf (kv, str1, x1, x2, tmp1, nq1, nq2, wk, xk)

!   This routine computes the integral of the function in fun on the interval
!   [x1, x2], with up to nq1 iterations, with a target tolerance of 10^nepsilon1.
!   xk and wk are precomputed tables of abscissas and weights.  The function
!   fun is not evaluated at x = x1 or x2.  The array x_k contains 1 minus
!   the abscissas; the wk array contains the weights at these abscissas.
!   Modified for the toolkit.

!   David H. Bailey     2004-07-27

use mpmodule
use globdata
implicit none
integer i, ierror, ip(0:100), iz1, iz2, izx, j, k, k1, k2, n, nds, nq1, nq2, &
  nqq1
parameter (izx = 5)
logical log1, log2
real*8 d1, d2, d3, d4, dplog10q, h
type (mp_real) ax, bx, c10, eps1, eps2, epsilon1, epsilon2, err, fun, &
  quaderf, tsum, s1, s2, s3, t1, t2, t3, tw1, tw2, twi1, twi2, twmx, &
  wk(-1:nq2), xk(-1:nq2), x1, x2, xki, xt1, xx1, xx2
integer kv, ntmp1
character*1 stout(72)
character*2048 str1
type (mp_real) tmp1(ntmpx)
external dplog10q

! nds = mpoud
! mpoud = 56
call mpsetprecwords (nwords2)
ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)
call mpsetprecwords (nwords1)
epsilon1 = mpreal (10.d0) ** nepsilon1
epsilon2 = mpreal (10.d0) ** nepsilon2
tsum = 0.d0
s1 = 0.d0
s2 = 0.d0
h = 4.d0
c10 = 10.d0

if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quaderf: quadrature arrays have not been initialized; nq1 =',i6)
  nerror = 70
  goto 140
endif
nqq1 = dble (wk(-1))
n = dble (xk(-1))

do k = 0, nqq1
  ip(k) = 2 ** k
enddo

do k = 1, nq1
  h = 0.5d0 * h
  s3 = s2
  s2 = s1
  k1 = ip(nqq1-k)
  k2 = ip(nqq1-k+1)
  iz1 = 0
  iz2 = 0
  twmx = 0.d0

!   Evaluate function at level k in x, avoiding unnecessary computation.

  do i = 0, n, k1
    if (mod (i, k2) /= 0 .or. k == 1) then
      call mpsetprecwords (nwords2)
      xki = xk(i)
      xt1 = 1.d0 - xki
      xx1 = - ax * xt1 + bx
      xx2 = ax * xt1 + bx
      log1 = xx1 > x1
      log2 = xx2 < x2
      call mpsetprecwords (nwords1)

      if (log1 .and. iz1 < izx) then
        var(kv) = xx1
        call parse (str1, ntmp1, tmp1(1))
        t1 = tmp1(1)
        call mpgetpar ('mpier', ierror)
        if (ierror > 0 .or. nerror > 0) goto 130
        tw1 = t1 * wk(i)
        twi1 = abs (tw1)
        if (twi1 < epsilon1) then
          iz1 = iz1 + 1
        else
          iz1 = 0
        endif
      else
        t1 = 0.d0
        tw1 = 0.d0
      endif

      if (i > 0 .and. log2 .and. iz2 < izx) then
        var(kv) = xx2
        call parse (str1, ntmp1, tmp1(1))
        t2 = tmp1(1)
        call mpgetpar ('mpier', ierror)
        if (ierror > 0 .or. nerror > 0) goto 130
        tw2 = t2 * wk(i)
        twi2 = abs (tw2)
        if (abs (tw2) < epsilon1) then
          iz2 = iz2 + 1
        else
          iz2 = 0
        endif
      else
        t2 = 0.d0
        tw2 = 0.d0
      endif

      tsum = tsum + tw1 + tw2
      twmx = max (twmx, abs (tw1), abs (tw2))
    endif
  enddo

!   Compute s1 = current integral approximation and err = error estimate.
!   Tsum is the sum of all tw1 and tw2 from the loop above.
!   Twmx is the largest absolute value of tw1 and tw2 from the loop above.
!   Twi1 and twi2 are the final nonzero values of abs(tw1) and abs(tw2).

  s1 =  ax * h * tsum
  eps1 = twmx * epsilon1
  eps2 = max (twi1, twi2)
  d1 = dplog10q (abs (s1 - s2))
  d2 = dplog10q (abs (s1 - s3))
  d3 = dplog10q (eps1) - 1.d0
  d4 = dplog10q (eps2) - 1.d0

  if (k <= 2) then
    err = 1.d0
  elseif (d1 .eq. -9999.d0) then
    err = 0.d0
  else
    err = c10 ** nint (min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3, d4)))
  endif

!   Output current integral approximation and error estimate, to 56 dp.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quaderf: Iteration',i3,' of',i3,'; est error = 10^',i5, &
      '; approx value =')
!    call mpwrite (6, s1)
    call mpeform (s1, 72, 60, stout)
    write (6, '(72a1)') stout
  endif

  if (k >= 3 .and. err < eps1) goto 140
  if (k >= 3 .and. err < eps2) goto 120
enddo

write (6, 3) nint (dplog10q (abs (err))), nquadl
3 format ('quaderf: Estimated error = 10^',i5/&
  'Increase Quadlevel for greater accuracy. Current Quadlevel =',i4)
goto 140

120 continue

write (6, 4) nint (dplog10q (abs (err))), ndigits2
4 format ('quaderf: Estimated error = 10^',i5/&
  'Increase secondary prec (Ndigits2) for greater accuracy. Current value =',i4)
goto 140

130 continue

if (ierror > 0) nerror = ierror + 100
write (6, 5) nerror
5 format ('quaderf: Error in quadrature calculation; code =',i5)
s1 = 0.d0

140 continue

quaderf = s1
! mpoud = nds
return
end

function quadts (kv, str1, x1, x2, tmp1, nq1, nq2, wk, xk)

!   This routine computes the integral of the function in fun on the interval
!   [x1, x2], with up to nq1 iterations, with a target tolerance of 10^nepsilon1.
!   wk and xk are precomputed tables of abscissas and weights.  The function
!   fun is not evaluated at x = x1 or x2.  The array x_k contains 1 minus
!   the abscissas; the wk array contains the weights at these abscissas.
!   Modified for the Toolkit.

!   David H. Bailey     2004-07-27

use mpmodule
use globdata
implicit none
integer i, ierror, ip(0:100), iz1, iz2, izx, j, k, k1, k2, n, nds, nq1, nq2, &
  nqq1
parameter (izx = 5)
logical log1, log2
real*8 d1, d2, d3, d4, dplog10q, h
type (mp_real) ax, bx, c10, eps1, eps2, epsilon1, epsilon2, err, fun, &
  quadts, tsum, s1, s2, s3, t1, t2, t3, tw1, tw2, twi1, twi2, twmx, &
  wk(-1:nq2), xk(-1:nq2), x1, x2, xki, xt1, xx1, xx2
integer kv, ntmp1
character*1 stout(72)
character*2048 str1
type (mp_real) tmp1(ntmpx)
external dplog10q

! nds = mpoud
! mpoud = 56
call mpsetprecwords (nwords2)
ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)
call mpsetprecwords (nwords1)
epsilon1 = mpreal (10.d0) ** nepsilon1
epsilon2 = mpreal (10.d0) ** nepsilon2
tsum = 0.d0
s1 = 0.d0
s2 = 0.d0
h = 1.d0
c10 = 10.d0

if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quadts: quadrature arrays have not been initialized; nq1 =',i6)
  nerror = 70
  goto 140
endif
nqq1 = dble (wk(-1))
n = dble (xk(-1))

do k = 0, nqq1
  ip(k) = 2 ** k
enddo

do k = 1, nq1
  h = 0.5d0 * h
  s3 = s2
  s2 = s1
  k1 = ip(nqq1-k)
  k2 = ip(nqq1-k+1)
  iz1 = 0
  iz2 = 0
  twmx = 0.d0

!   Evaluate function at level k in x, avoiding unnecessary computation.

  do i = 0, n, k1
    if (mod (i, k2) /= 0 .or. k == 1) then
      call mpsetprecwords (nwords2)
      xki = xk(i)
      xt1 = 1.d0 - xki
      xx1 = - ax * xt1 + bx
      xx2 = ax * xt1 + bx
      log1 = xx1 > x1
      log2 = xx2 < x2
      call mpsetprecwords (nwords1)

      if (log1 .and. iz1 < izx) then
        var(kv) = xx1
        call parse (str1, ntmp1, tmp1(1))
        t1 = tmp1(1)
        call mpgetpar ('mpier', ierror)
        if (ierror > 0 .or. nerror > 0) goto 130
        tw1 = t1 * wk(i)
        twi1 = abs (tw1)
        if (twi1 < epsilon1) then
          iz1 = iz1 + 1
        else
          iz1 = 0
        endif
      else
        t1 = 0.d0
        tw1 = 0.d0
      endif

      if (i > 0 .and. log2 .and. iz2 < izx) then
        var(kv) = xx2
        call parse (str1, ntmp1, tmp1(1))
        t2 = tmp1(1)
        call mpgetpar ('mpier', ierror)
        if (ierror > 0 .or. nerror > 0) goto 130
        tw2 = t2 * wk(i)
        twi2 = abs (tw2)
        if (abs (tw2) < epsilon1) then
          iz2 = iz2 + 1
        else
          iz2 = 0
        endif
      else
        t2 = 0.d0
        tw2 = 0.d0
      endif

      tsum = tsum + tw1 + tw2
      twmx = max (twmx, abs (tw1), abs (tw2))
    endif
  enddo

!   Compute s1 = current integral approximation and err = error estimate.
!   Tsum is the sum of all tw1 and tw2 from the loop above.
!   Twmx is the largest absolute value of tw1 and tw2 from the loop above.
!   Twi1 and twi2 are the final nonzero values of abs(tw1) and abs(tw2).

  s1 =  ax * h * tsum
  eps1 = twmx * epsilon1
  eps2 = max (twi1, twi2)
  d1 = dplog10q (abs (s1 - s2))
  d2 = dplog10q (abs (s1 - s3))
  d3 = dplog10q (eps1) - 1.d0
  d4 = dplog10q (eps2) - 1.d0

  if (k <= 2) then
    err = 1.d0
  elseif (d1 .eq. -9999.d0) then
    err = 0.d0
  else
    err = c10 ** nint (min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3, d4)))
  endif

!   Output current integral approximation and error estimate, to 56 dp.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quadts: Iteration',i3,' of',i3,'; est error = 10^',i5, &
      '; approx value =')
!    call mpwrite (6, s1)
    call mpeform (s1, 72, 60, stout)
    write (6, '(72a1)') stout
  endif
  if (k >= 3 .and. err < eps1) goto 140
  if (k >= 3 .and. err < eps2) goto 120
enddo

write (6, 3) nint (dplog10q (abs (err))), nquadl
3 format ('quadts: Estimated error = 10^',i5/&
  'Increase Quadlevel for greater accuracy. Current Quadlevel =',i4)
goto 140

120 continue

write (6, 4) nint (dplog10q (abs (err))), ndigits2
4 format ('quadts: Estimated error = 10^',i5/&
  'Increase secondary prec (Ndigits2) for greater accuracy. Current value =',i4)
goto 140

130 continue

if (ierror > 0) nerror = ierror + 100
write (6, 5) nerror
5 format ('quadts: Error in quadrature calculation; code =',i5)
s1 = 0.d0

140 continue

quadts = s1
! mpoud = nds
return
end


Subroutine set_params(pa)

use parameters_site
use parameters_plant
implicit none
real      :: pa(81)

! Initial constants
LOG10CLVI  = pa(1)
LOG10CRESI = pa(2)
LOG10CRTI  = pa(3)
CSTI	   = pa(4)
LOG10LAII  = pa(5)
PHENI	   = pa(6)
TILTOTI	   = pa(7)
FRTILGI	   = pa(8)
LT50I      = pa(9)

! Process parameters
CLAIV     = pa(10)
COCRESMX  =	pa(11)
CSTAVM	  = pa(12)
DAYLB	  =	pa(13)
DAYLP	  =	pa(14)
DLMXGE	  = pa(15)
FSLAMIN   = pa(16)
FSMAX     = pa(17)
HAGERE    =	pa(18)
K         =	pa(19)
LAICR	  = pa(20)
LAIEFT    = pa(21)
LAITIL	  =	pa(22)
LFWIDG	  =	pa(23)
LFWIDV	  = pa(24)
NELLVM	  = pa(25)
PHENCR    = pa(26)
PHY	      =	pa(27)
RDRSCO	  =	pa(28)
RDRSMX	  = pa(29)
RDRTEM    = pa(30)
RGENMX	  =	pa(31)
ROOTDM	  =	pa(32)
RRDMAX	  = pa(33)
RUBISC    = pa(34)
SHAPE	  =	pa(35)
SIMAX1T	  =	pa(36)
SLAMAX    = pa(37)
TBASE     = pa(38)
TCRES     = pa(39)
TOPTGE	  =	pa(40)
TRANCO	  = pa(41)
YG        = pa(42)

LAT       = pa(43)
WCI       = pa(44)
FWCAD     = pa(45)
FWCWP     = pa(46)
FWCFC     = pa(47)
FWCWET    = pa(48)
WCST      = pa(49)
WpoolMax  = pa(50)

Dparam	     = pa(51)
FGAS	     = pa(52)
FO2MX	     = pa(53)
gamma	     = pa(54)
Hparam	     = pa(55)
KRDRANAER    = pa(56)
KRESPHARD    = pa(57)
KRSR3H	     = pa(58)
KRTOTAER     = pa(59)
KSNOW	     = pa(60)
LAMBDAsoil   = pa(61)
LDT50A	     = pa(62)
LDT50B	     = pa(63)
LT50MN	     = pa(64)
LT50MX	     = pa(65)
RATEDMX	     = pa(66)
reHardRedDay = pa(67)
RHOnewSnow	 = pa(68)
RHOpack	     = pa(69)
SWret	     = pa(70)
SWrf	     = pa(71)
THARDMX	     = pa(72)
TmeltFreeze	 = pa(73)
TrainSnow	 = pa(74)
TsurfDiff	 = pa(75)
KLUETILG	 = pa(76)
FRTILGG1I	 = pa(77)
DAYLG1G2     = pa(78)
RGRTG1G2     = pa(79)
RDRTMIN      = pa(80)
TVERN        = pa(81)

! Parameter transformations
CLVI  = 10**LOG10CLVI
CRESI = 10**LOG10CRESI
CRTI  = 10**LOG10CRTI
LAII  = 10**LOG10LAII

WCAD  = FWCAD  * WCST
WCWP  = FWCWP  * WCST
WCFC  = FWCFC  * WCST
WCWET = FWCWET * WCST

return
end


      FUNCTION K33R(J,M,K,L,R,JA)
C BY HAROLD RABBIE
C TYPED BY AX FROM FORTRAN, 1.17.79
C
C ASSUMES THAT THE PROBABILITY OF MY OPPONENT COOPERATING
C DEPENDS ONLY ON MY LAST TWO RESPONSES.
C DETERMINISTIC, NOT NICE
      LOGICAL TWIN
      DIMENSION COOP(4),COUNT(4),P(4),COEFF(6,4),CONST(6)
      DATA CONST/ 0.,4.,6.,6.,8.,12./
      DATA COEFF/36.,16.,0.,12.,0.,0.,
     2      0.,12.,18.,12.,16.,0.,
     3      0.,12.,24.,9.,16.,0.,
     4      0.,0.,0.,9.,12.,48./
C INITIALISE ALL STATE VARIABLES
      K33R=JA       ! Added 7/32/93 to report own old value
      IF(M.GT.1) GO TO 2
      DO 1 JJ=1,4
         COOP(JJ)=0.
         COUNT(JJ)=0.
    1 CONTINUE
      LAST1=1
      LAST2=1
      TWIN=.TRUE.
C UPDATE ESTIMATE OF RELEVANT PROBABILITY
    2 IF(M.LE.2) GO TO3
      COOP(INDEX)=COOP(INDEX)+FLOAT(1-J)
      COUNT(INDEX)=COUNT(INDEX)+1
      P(INDEX)=COOP(INDEX)/COUNT(INDEX)
C COMPUTE INDEX BASED ON MY LAST TWO RESPONSES
    3 INDEX=2*LAST2+LAST1+1
C IDENTIFY MY TWIN
      IF(M.EQ.1) GO TO 4
      IF(J.NE.LAST1) TWIN=.FALSE.
C USE POLICY 4 FOR 22 MOVES
    4 IF(M.LE.22) GO TO 24
C COOPERATE WITH MY TWIN
      IF(TWIN) GO TO 30
C COMPUTE BEST EXPECTED SCORE OVER THE 6 DIFFERENT POLICIES
      BEST=0
      DO 10 II=1,6
         SUM=CONST(II)
         DO 11 JJ=1,4
   11    SUM=SUM+COEFF(II,JJ)*P(JJ)
         IF(SUM.LE.BEST) GO TO 10
         BEST=SUM
         IPOL=II
   10 CONTINUE
C EXECUTE THE BEST POLICY
      GO TO (21,22,23,24,25,26), IPOL
C DISPATCH ACCORDING TO THE LAST TWO MOVES
   21 GO TO (30,30,30,30),INDEX
   22 GO TO (40,30,30,30),INDEX
   23 GO TO (40,30,40,30),INDEX
   24 GO TO (40,40,30,30),INDEX
   25 GO TO (40,40,40,30),INDEX
   26 GO TO (40,40,40,40),INDEX
C COOPERATE
   30 K33R=0
      GO TO 50
C DEFECT
   40 K33R=1
C UPDATE HISTORY
   50 LAST2=LAST1
      LAST1=K33R
      RETURN
      END


      PROGRAM trace

C     ********************************************************************
C     *                                                                  *
C     * Pseudo-lidar plots along trajectories                             *
C     *                                                                  *
C     * Heini Wernli       first version:       April 1993               *
C     * Michael Sprenger   major upgrade:       2008-2009                *
C     *                                                                  *
C     ********************************************************************

      implicit none

c     --------------------------------------------------------------------
c     Declaration of parameters
c     --------------------------------------------------------------------

c     Maximum number of levels for input files
      integer   nlevmax
      parameter (nlevmax=100)

c     Maximum number of input files (dates, length of trajectories)
      integer   ndatmax
      parameter (ndatmax=5000)

c     Numerical epsilon (for float comparison)
      real      eps
      parameter (eps=0.001)

c     Conversion factors
      real      pi180                                   ! deg -> rad
      parameter (pi180=3.14159/180.)
      real      deg2km                                  ! deg -> km (at equator)
      parameter (deg2km=111.)

c     Prefix for primary and secondary fields
      character charp
      character chars
      parameter (charp='P')
      parameter (chars='S')

c     --------------------------------------------------------------------
c     Declaration of variables
c     --------------------------------------------------------------------

c     Input and output format for trajectories (see iotra.f)
      integer   inpmode

c     Input parameters
      character*80                           inpfile         ! Input trajectory file
      character*80                           outfile         ! Output netCDF file
      character*80                           outmode         ! Output mode (sum,mean)
      integer                                ntra            ! Number of trajectories
      integer                                ncol            ! Number of columns (including time, lon, lat, p)
      integer                                ntim            ! Number of times per trajectory
      integer                                ntrace0         ! Number of trace variables
      character*80                           tvar(200)       ! Tracing variable name (only the variable)
      character*1                            tfil(200)       ! Filename prefix
      real                                   fac(200)        ! Scaling factor
      integer                                compfl(200)     ! Computation flag (1=compute)
      integer                                numdat          ! Number of input files
      character*11                           dat(ndatmax)    ! Dates of input files
      real                                   timeinc         ! Time increment between input files
      real                                   tst             ! Time shift of start relative to first data file
      real                                   ten             ! Time shift of end relatiev to first data file
      character*20                           startdate       ! First time/date on trajectory
      character*20                           enddate         ! Last time/date on trajectory
      character*80                           timecheck       ! Either 'yes' or 'no'
      character*80                           intmode         ! Interpolation mode ('normal', 'nearest')
	  real                                   pmin,pmax       ! Pressure range for output grid
	  integer                                npre            ! Number of pressure levels in output grid
	  character*80                           centering       ! Centering around trajectory position ('yes','no')
	  character*80                       direction       ! Direction of lidar (vertical,lat,lon,normal)
      character*80                           dumpcoord       ! Dumping coordinates ('yes','no')

c     Trajectories
      real,allocatable, dimension (:,:,:) :: trainp                ! Input trajectories (ntra,ntim,ncol)
      integer                                reftime(6)            ! Reference date
      character*80                           varsinp(100)          ! Field names for input trajectory
      integer                                fid,fod               ! File identifier for inp and out trajectories
      real                                   x0_tra,y0_tra,p0_tra  ! Position of air parcel (physical space)
      real                                   reltpos0              ! Relative time of air parcel
      real                                   xind,yind,pind        ! Position of air parcel (grid space)
      integer                                fbflag                ! Flag for forward (1) or backward (-1) trajectories

c     Meteorological fields from input file
      real,allocatable, dimension (:)     :: spt0,spt1       ! Surface pressure
      real,allocatable, dimension (:)     :: p3t0,p3t1       ! 3d-pressure
      real,allocatable, dimension (:)     :: f3t0,f3t1       ! 3d field for tracing
      character*80                           svars(100)      ! List of variables on S file
      character*80                           pvars(100)      ! List of variables on P file
      integer                                n_svars         ! Number of variables on S file
      integer                                n_pvars         ! Number of variables on P file

c     Input grid description
      real                                   pollon,pollat   ! Longitude/latitude of pole
      real                                   ak(100)         ! Vertical layers and levels
      real                                   bk(100)
      real                                   xmin,xmax       ! Zonal grid extension
      real                                   ymin,ymax       ! Meridional grid extension
      integer                                nx,ny,nz        ! Grid dimensions
      real                                   dx,dy           ! Horizontal grid resolution
      integer                                hem             ! Flag for hemispheric domain
      integer                                per             ! Flag for periodic domain
      real                                   stagz           ! Vertical staggering
      real                                   mdv             ! Missing data value

c	  Output grid  and fields
      real                                   levels(1000)    ! Ouput levels
      real                                   times (5000)    ! Output times
	  real,allocatable, dimension (:,:)   :: out_pos         ! Position of trajectories
	  real,allocatable, dimension (:,:)   :: out_val         ! Output lidar field
	  real,allocatable, dimension (:,:)   :: out_cnt         ! # output lidar sum ups

c     Auxiliary variables
      integer                                i,j,k,l,n,m
      real                                   rd
      character*80                           filename
      real                                   time0,time1,reltpos
      integer                                itime0,itime1
      integer                                stat
      real                                   tstart
      integer                                iloaded0,iloaded1
      real                                   f0
      real                                   frac
      real                                   tload,tfrac
      integer                                isok
      character                              ch
      integer                                ind
      integer                                ind1,ind2,ind3,ind4,ind5
      integer                                ind6,ind7,ind8,ind9,ind0
      integer                                noutside
      real                                   delta
      integer                                itrace0
      character*80                           string
      character*80                           cdfname
      character*80                           varname
      real                                   time
      character*80                           longname
      character*80                           unit
      integer                                ind_time
      integer                                ind_pre
      real                                   rlat,rlon
      real                                   x0,y0,p0
      real                                   vx0,vy0,vx1,vy1
      real                                   rotation,lon,lat

c     Externals
      real                                   int_index4
      external                               int_index4

c     --------------------------------------------------------------------
c     Start of program, Read parameters, get grid parameters
c     --------------------------------------------------------------------

c     Write start message
      print*,'========================================================='
      print*,'              *** START OF PROGRAM LIDAR ***'
      print*

c     Read parameters
      open(10,file='trace.param')
       read(10,*) inpfile
       read(10,*) outfile
       read(10,*) outmode
       read(10,*) startdate
       read(10,*) enddate
       read(10,*) fbflag
       read(10,*) numdat
       if ( fbflag.eq.1) then
          do i=1,numdat
             read(10,'(a11)') dat(i)
          enddo
       else
          do i=numdat,1,-1
             read(10,'(a11)') dat(i)
          enddo
       endif
       read(10,*) timeinc
       read(10,*) tst
       read(10,*) ten
       read(10,*) ntra
       read(10,*) ntim
       read(10,*) ncol
       read(10,*) ntrace0
       do i=1,ntrace0
          read(10,*) tvar(i), fac(i), compfl(i), tfil(i)
       enddo
       read(10,*) n_pvars
       do i=1,n_pvars
          read(10,*) pvars(i)
       enddo
       read(10,*) n_svars
       do i=1,n_svars
          read(10,*) svars(i)
       enddo
       read(10,*) timecheck
       read(10,*) intmode
       read(10,*) pmin,pmax,npre
       read(10,*) centering
       read(10,*) direction
       read(10,*) dumpcoord
      close(10)

c     Check that the direction is ok
      if ( ( direction.ne.'vertical' ).and.
     >     ( direction.ne.'lat'      ).and.
     >     ( direction.ne.'lon'      ).and.
     >     ( direction.ne.'normal'   ) )
     >then
         print*,' ERROR: invalid direction ',trim(direction)
         stop
      endif

c     Remove commented tracing fields
      itrace0 = 1
      do while ( itrace0.le.ntrace0)
         string = tvar(itrace0)
         if ( string(1:1).eq.'#' ) then
            do i=itrace0,ntrace0-1
               tvar(i)   = tvar(i+1)
               fac(i)    = fac(i+1)
               compfl(i) = compfl(i+1)
               tfil(i)   = tfil(i+1)
            enddo
            ntrace0 = ntrace0 - 1
         else
            itrace0 = itrace0 + 1
         endif
      enddo

c     Set the formats of the input  files
      call mode_tra(inpmode,inpfile)
      if (inpmode.eq.-1) inpmode=1

C     Convert time shifts <tst,ten> from <hh.mm> into fractional time
      call hhmm2frac(tst,frac)
      tst = frac
      call hhmm2frac(ten,frac)
      ten = frac

c     Set the time for the first data file (depending on forward/backward mode)
      if (fbflag.eq.1) then
        tstart = -tst
      else
        tstart = tst
      endif

c     Read the constant grid parameters (nx,ny,nz,xmin,xmax,ymin,ymax,pollon,pollat)
c     The negative <-fid> of the file identifier is used as a flag for parameter retrieval
      filename = charp//dat(1)
      varname  = tvar(1)
      call input_open (fid,filename)
      call input_grid (-fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
     >                 tstart,pollon,pollat,rd,rd,nz,rd,rd,rd,timecheck)
      call input_close(fid)

C     Allocate memory for some meteorological arrays
      allocate(spt0(nx*ny),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array spt0 ***'   ! Surface pressure
      allocate(spt1(nx*ny),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array spt1 ***'
      allocate(p3t0(nx*ny*nz),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array p3t0 ***'   ! Pressure
      allocate(p3t1(nx*ny*nz),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array p3t1 ***'
      allocate(f3t0(nx*ny*nz),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array p3t0 ***'   ! Lidar field
      allocate(f3t1(nx*ny*nz),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array p3t1 ***'

c	  Allocate memory for output field
	  allocate(out_pos(ntim,npre),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array out_pos ***'
	  allocate(out_val(ntim,npre),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array out_val ***'
	  allocate(out_cnt(ntim,npre),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array out_cnt ***'

C     Get memory for trajectory arrays
      allocate(trainp(ntra,ntim,ncol),stat=stat)
      if (stat.ne.0) print*,'*** error allocating array tra      ***'

c     Set the flags for periodic domains
      if ( abs(xmax-xmin-360.).lt.eps ) then
         per = 1
      elseif ( abs(xmax-xmin-360.+dx).lt.eps ) then
         per = 2
      else
         per = 0
      endif

C     Set logical flag for periodic data set (hemispheric or not)
      hem = 0
      if (per.eq.0.) then
         delta=xmax-xmin-360.
         if (abs(delta+dx).lt.eps) then               ! Program aborts: arrays must be closed
            print*,' ERROR: arrays must be closed... Stop'
         else if (abs(delta).lt.eps) then ! Periodic and hemispheric
           hem=1
           per=360.
        endif
      else                                            ! Periodic and hemispheric
         hem=1
      endif

c     Write some status information
      print*,'---- INPUT PARAMETERS -----------------------------------'
      print*
      print*,'  Input trajectory file  : ',trim(inpfile)
      print*,'  Format of input file   : ',inpmode
      print*,'  Output netCDF    file  : ',trim(outfile)
      print*,'  Format of output file  : ',trim(outmode)
      print*,'  Forward/backward       : ',fbflag
      print*,'  #tra                   : ',ntra
      print*,'  #col                   : ',ncol
      print*,'  #tim                   : ',ntim
      print*,'  No time check          : ',trim(timecheck)
      print*,'  Interpolation mode     : ',trim(intmode)
      do i=1,ntrace0
         if (compfl(i).eq.0) then
            print*,'  Tracing field          : ',
     >                 trim(tvar(i)), fac(i), ' 0 ', tfil(i)
         else
            print*,'  Tracing field          : ',
     >                trim(tvar(i)),' : online calc not supported'
         endif
      enddo
      print*,'  Output (pmin,pmax,n)   : ',pmin,pmax,npre
      print*,'  Centering              : ',trim(centering)
      print*,'  Orientation            : ',trim(direction)
      print*,'  Coordinate Dump        : ',trim(dumpcoord)
      print*
      print*,'---- INPUT DATA FILES -----------------------------------'
      print*
      call frac2hhmm(tstart,tload)
      print*,'  Time of 1st data file  : ',tload
      print*,'  #input files           : ',numdat
      print*,'  time increment         : ',timeinc
      call frac2hhmm(tst,tload)
      print*,'  Shift of start         : ',tload
      call frac2hhmm(ten,tload)
      print*,'  Shift of end           : ',tload
      print*,'  First/last input file  : ',trim(dat(1)),
     >                                     ' ... ',
     >                                     trim(dat(numdat))
      print*,'  Primary variables      : ',trim(pvars(1))
      do i=2,n_pvars
         print*,'                         : ',trim(pvars(i))
      enddo
      if ( n_svars.ge.1 ) then
         print*,'  Secondary variables    : ',trim(svars(1))
         do i=2,n_svars
            print*,'                         : ',trim(svars(i))
         enddo
      endif
      print*
      print*,'---- CONSTANT GRID PARAMETERS ---------------------------'
      print*
      print*,'  xmin,xmax     : ',xmin,xmax
      print*,'  ymin,ymax     : ',ymin,ymax
      print*,'  dx,dy         : ',dx,dy
      print*,'  pollon,pollat : ',pollon,pollat
      print*,'  nx,ny,nz      : ',nx,ny,nz
      print*,'  per, hem      : ',per,hem
      print*

c     --------------------------------------------------------------------
c     Load the input trajectories
c     --------------------------------------------------------------------

c     Read the input trajectory file
      call ropen_tra(fid,inpfile,ntra,ntim,ncol,reftime,varsinp,inpmode)
      call read_tra (fid,trainp,ntra,ntim,ncol,inpmode)
      call close_tra(fid,inpmode)

c     Check that first four columns correspond to time,lon,lat,p
      if ( (varsinp(1).ne.'time' ).or.
     >     (varsinp(2).ne.'xpos' ).and.(varsinp(2).ne.'lon' ).or.
     >     (varsinp(3).ne.'ypos' ).and.(varsinp(3).ne.'lat' ).or.
     >     (varsinp(4).ne.'ppos' ).and.(varsinp(4).ne.'p'   ) )
     >then
         print*,' ERROR: problem with input trajectories ...'
         stop
      endif
      varsinp(1) = 'time'
      varsinp(2) = 'lon'
      varsinp(3) = 'lat'
      varsinp(4) = 'p'

c     Write some status information of the input trajectories
      print*,'---- INPUT TRAJECTORIES ---------------------------------'
      print*
      print*,' Start date             : ',trim(startdate)
      print*,' End date               : ',trim(enddate)
      print*,' Reference time (year)  : ',reftime(1)
      print*,'                (month) : ',reftime(2)
      print*,'                (day)   : ',reftime(3)
      print*,'                (hour)  : ',reftime(4)
      print*,'                (min)   : ',reftime(5)
      print*,' Time range (min)       : ',reftime(6)
      do i=1,ncol
         print*,' Var                    :',i,trim(varsinp(i))
      enddo
      print*

c     Check that first time is 0 - otherwise the tracing will produce
c     wrong results because later in the code only absolute times are
c     considered: <itime0   = int(abs(tfrac-tstart)/timeinc) + 1>. This
c     will be changed in a future version.
      if ( abs( trainp(1,1,1) ).gt.eps ) then
         print*,' ERROR: First time of trajectory must be 0, i.e. '
         print*,'     correspond to the reference date. Otherwise'
         print*,'     the tracing will give wrong results... STOP'
         stop
      endif

c     If requested, open the coordinate dump file
      if ( dumpcoord.eq.'yes' ) then
         open(10,file=trim(outfile)//'.coord')
      endif

c     --------------------------------------------------------------------
c     Trace the fields (fields available on input files)
c     --------------------------------------------------------------------

      print*
      print*,'---- LIDAR FROM PRIMARY AND SECONDARY DATA FILES ------'

c     Loop over all tracing fields
      do i=1,ntrace0

c	      Skip all fields marked for online calculation
          if ( compfl(i).eq.1 ) goto 110

c	      Init the output fields: position and lidar field
	      do k=1,ntim
	      	do l=1,npre
	      		out_pos(k,l) = 0.
	      	    out_val(k,l) = 0.
	      	    out_cnt(k,l) = 0.
	      	 enddo
	      enddo

c         Write some status information
          print*
          print*,' Now lidaring           : ',
     >         trim(tvar(i)),compfl(i),' ',trim(tfil(i))

c         Reset flags for load manager
          iloaded0 = -1
          iloaded1 = -1

c         Reset the counter for fields outside domain
          noutside = 0

c         Loop over all times
          do j=1,ntim

c            Convert trajectory time from hh.mm to fractional time
             call hhmm2frac(trainp(1,j,1),tfrac)

c            Get the times which are needed
             itime0   = int(abs(tfrac-tstart)/timeinc) + 1
             time0    = tstart + fbflag * real(itime0-1) * timeinc
             itime1   = itime0 + 1
             time1    = time0 + fbflag * timeinc
             if ( itime1.gt.numdat ) then
                itime1 = itime0
                time1  = time0
             endif

c            Load manager: Check whether itime0 can be copied from itime1
             if ( itime0.eq.iloaded1 ) then
                f3t0     = f3t1
                p3t0     = p3t1
                spt0     = spt1
                iloaded0 = itime0
             endif

c            Load manager: Check whether itime1 can be copied from itime0
             if ( itime1.eq.iloaded0 ) then
                f3t1     = f3t0
                p3t1     = p3t0
                spt1     = spt0
                iloaded1 = itime1
             endif

c            Load manager:  Load first time (tracing variable and grid)
             if ( itime0.ne.iloaded0 ) then

                filename = tfil(i)//dat(itime0)
                call frac2hhmm(time0,tload)
                varname  = tvar(i)
                write(*,'(a23,a20,a3,a5,f7.2)')
     >               '    ->  loading          : ',
     >               trim(filename),'  ',trim(varname),tload
                call input_open (fid,filename)
                call input_wind
     >               (fid,varname,f3t0,tload,stagz,mdv,
     >               xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)

                call input_grid
     >               (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
     >                tload,pollon,pollat,p3t0,spt0,nz,ak,bk,stagz,
     >                timecheck)
                call input_close(fid)

                iloaded0 = itime0

             endif

c            Load manager: Load second time (tracing variable and grid)
             if ( itime1.ne.iloaded1 ) then

                filename = tfil(i)//dat(itime1)
                call frac2hhmm(time1,tload)
                varname  = tvar(i)
                write(*,'(a23,a20,a3,a5,f7.2)')
     >               '    ->  loading          : ',
     >               trim(filename),'  ',trim(varname),tload
                call input_open (fid,filename)
                call input_wind
     >               (fid,varname,f3t1,tload,stagz,mdv,
     >               xmin,xmax,ymin,ymax,dx,dy,nx,ny,nz,timecheck)
                call input_grid
     >               (fid,varname,xmin,xmax,ymin,ymax,dx,dy,nx,ny,
     >               tload,pollon,pollat,p3t1,spt1,nz,ak,bk,stagz,
     >               timecheck)
                call input_close(fid)

                iloaded1 = itime1

             endif

c            Loop over all trajectories
             do k=1,ntra

c               Set the trajectory position
                x0_tra = trainp(k,j,2)                          ! Longitude
                y0_tra = trainp(k,j,3)                          ! Latitude
                p0_tra = trainp(k,j,4)                          ! Pressure

c               Get rotation angle - orient normal to trajectory
                if ( direction.eq.'normal' ) then

                   vx0 = 1.
                   vy0 = 0.

                   if ( j.lt.ntim ) then
                      lat =  0.5 * ( trainp(k,j,3) + trainp(k,j+1,3) )
                      vx1 = ( trainp(k,j+1,2) - trainp(k,j,2) ) *
     >                      cos( lat * pi180 )
                      vy1 = ( trainp(k,j+1,3) - trainp(k,j,3) )
                   else
                      lat =  0.5 * ( trainp(k,j,3) + trainp(k,j-1,3) )
                      vx1 = ( trainp(k,j,2) - trainp(k,j-1,2) ) *
     >                      cos( lat * pi180 )
                      vy1 = ( trainp(k,j,3) - trainp(k,j-1,3) )
                   endif

                   if ( vx1.gt.180  ) vx1 = vx1 - 360
                   if ( vx1.lt.-180 ) vx1 = vx1 + 360.

                   call getangle (vx0,vy0,vx1,vy1,rotation)
                   rotation = -rotation

                else
                   rotation = 0.
                endif

c               Set the relative time
                call hhmm2frac(trainp(k,j,1),tfrac)
                reltpos0 = fbflag * (tfrac-time0)/timeinc

c               Loop over pressure profile (or other positions for horizontal mode)
	        do l=1,npre

c                     Vertical
                      if ( direction.eq.'vertical' ) then
                        x0 = x0_tra
                        y0 = y0_tra
                        p0 = pmin + real(l-1)/real(npre-1) * (pmax-pmin)
                        if ( centering.eq.'yes' )then
                           p0 = p0 + trainp(k,j,4)
                        endif

c                     Longitude
                      elseif ( direction.eq.'lon' ) then
                        x0 = pmin + real(l-1)/real(npre-1) * (pmax-pmin)
                        y0 = y0_tra
                        p0 = p0_tra
                        if ( centering.eq.'yes' )then
                           x0 = x0 + x0_tra
                        endif

c                     Latitude
                      elseif ( direction.eq.'lat' ) then
                        x0 = x0_tra
                        y0 = pmin + real(l-1)/real(npre-1) * (pmax-pmin)
                        p0 = p0_tra
                        if ( centering.eq.'yes' )then
                           y0 = y0 + y0_tra
                        endif

c                     Normal to trajerctory
                      elseif ( direction.eq.'normal' ) then

c                        Set the coordinate in the rotated system
                         rlat = pmin +
     >                             real(l-1)/real(npre-1) * (pmax-pmin)
                         rlon = 0.

c                        Transform it back to geographical lon/lat
                         call getenvir_b (x0_tra,y0_tra,rotation,
     >                                              x0,y0,rlon,rlat,1)

c                        Pressure unchanged
                         p0 = p0_tra

                      endif

c                     Handle periodic boundaries in zonal direction
                      if ( (x0.gt.xmax).and.(per.ne.0) ) x0 = x0 - 360.
                      if ( (x0.lt.xmin).and.(per.ne.0) ) x0 = x0 + 360.

c                     Handle pole problems for hemispheric data (taken from caltra.f)
                      if ((hem.eq.1).and.(y0.gt.90.)) then
                         y0=180.-y0
                         x0=x0+per/2.
                      endif
                      if ((hem.eq.1).and.(y0.lt.-90.)) then
                         y0=-180.-y0
                         x0=x0+per/2.
                      endif
                      if (y0.gt.89.99) then
                         y0=89.99
                      endif

c                 If requested, dump the lidar coordinates
                  if ( (dumpcoord.eq.'yes').and.(i.eq.1) ) then
                     write(10,'(3f10.2)') x0,y0,trainp(k,j,1)
                     write(10,'(3f10.2)') x0_tra,y0_tra,5.
                  endif

C                 Get the index where to interpolate (x0,y0,p0)
                  if ( (abs(x0-mdv).gt.eps).and.
     >                 (abs(y0-mdv).gt.eps) )
     >            then
                     call get_index4 (xind,yind,pind,x0,y0,p0,reltpos0,
     >                                p3t0,p3t1,spt0,spt1,3,
     >                                nx,ny,nz,xmin,ymin,dx,dy,mdv)
                  else
                     xind = mdv
                     yind = mdv
                     pind = mdv
                  endif

c                 If requested, apply nearest-neighbor interpolation
                  if ( intmode.eq.'nearest') then

                     xind = real( nint(xind) )
                     yind = real( nint(yind) )
                     pind = real( nint(pind) )

                     if ( xind.lt.1.  ) xind = 1.
                     if ( xind.gt.nx  ) xind = real(nx)
                     if ( yind.lt.1.  ) yind = 1.
                     if ( yind.gt.ny  ) yind = real(ny)

                     if ( pind.lt.1.  ) pind = 1.
                     if ( pind.gt.nz  ) pind = real(nz)

                  endif

c                 Do the interpolation: everthing is ok
                  if ( (xind.ge.1.).and.(xind.le.real(nx)).and.
     >                 (yind.ge.1.).and.(yind.le.real(ny)).and.
     >                 (pind.ge.1.).and.(pind.le.real(nz)) )
     >            then
                     f0 = int_index4(f3t0,f3t1,nx,ny,nz,
     >                               xind,yind,pind,reltpos0,mdv)

c                 Set to missing data
                  else
                     f0       = mdv
                  endif

c	              Save result to output array
                  if (abs(f0-mdv).gt.eps) then
                     out_val(j,l) = out_val(j,l) + f0 * fac(i)
                     out_cnt(j,l) = out_cnt(j,l) + 1.

	              endif

c              End loop over all pressure levels
	           enddo

c	           Save output - time index
	           ind_time = j

c                  Save output - space index for 'no centering'
	           if ( centering.eq.'no' ) then
                      if ( direction.eq.'vertical') then
                         ind_pre  = nint( real(npre) *
     >          	       ( (p0_tra - pmin)/(pmax-pmin) ) + 1.)
                      elseif ( direction.eq.'lon') then
                         ind_pre  = nint( real(npre) *
     >          	       ( (x0_tra - pmin)/(pmax-pmin) ) + 1.)
                      elseif ( direction.eq.'lat') then
                         ind_pre  = nint( real(npre) *
     >          	       ( (y0_tra - pmin)/(pmax-pmin) ) + 1.)
                      endif

c                  Save output - space index for 'centering'
	           else
	           	  ind_pre  = nint( real(npre) *
     >          	       ( (0.            - pmin)/(pmax-pmin) ) + 1.)
	           endif

c                  Update the output array
	           if ( (ind_time.ge.1).and.(ind_time.le.ntim).and.
     >              (ind_pre .ge.1).and.(ind_pre .le.npre) )
     >         then
                    out_pos(ind_time,ind_pre) =
     >                          	out_pos(ind_time,ind_pre) + 1.
	           endif

c	         End loop over all trajectories
             enddo

c	      End loop over all times
          enddo

c	      Write the trajectory position to netCDF file - only once
	      if ( i.eq.1 ) then
	      	  cdfname  = outfile
	      	  varname  = 'POSITION'
	      	  longname = 'position of trajectory points'
	      	  unit     = 'none'
	      	  time     = 0.
              do k=1,npre
              	levels(k) = pmin + real(k-1)/real(npre-1) * (pmax-pmin)
              enddo
              do k=1,ntim
                 times(k) = trainp(1,k,1)
              enddo
              call writecdf2D_cf
     >            (cdfname,varname,longname,unit,out_pos,time,levels,
     >             times,npre,ntim,1,1,direction)
	      endif

c	      If no valid lidar count: set the field to missing data
          do k=1,ntim
          	do l=1,npre
          		if (abs(out_cnt(k,l)).lt.eps) then
          			out_val(k,l) = mdv
          	    endif
          	 enddo
          enddo

c	      If requested, calculate the mean of the lidar field
	      if ( outmode.eq.'mean' ) then
	      	do k=1,ntim
	      		do l=1,npre
	      			if ( (abs(out_val(k,l)-mdv).gt.eps).and.
     >                   (abs(out_cnt(k,l)    ).gt.0. ) )
     >              then
	      				out_val(k,l) = out_val(k,l) / out_cnt(k,l)
	      		    endif
	      		 enddo
	          enddo
	      endif

c	      Write the lidar field and count
	      cdfname  = outfile
	      if (outmode.eq.'sum' ) then
	         varname  = trim(tvar(i))//'_SUM'
	      elseif (outmode.eq.'mean' ) then
	         varname  = trim(tvar(i))//'_MEAN'
	      endif
	      longname = 'sum over all '//trim(tvar(i))//' profiles'
	      unit     = 'not given'
	      time     = 0.
          call writecdf2D_cf
     >            (cdfname,varname,longname,unit,out_val,time,levels,
     >             times,npre,ntim,0,1,direction)

	  	  cdfname  = outfile
	      varname  = trim(tvar(i))//'_CNT'
	      longname = 'counts of all '//trim(tvar(i))//' profiles'
	      unit     = 'not given'
	      time     = 0.
          call writecdf2D_cf
     >            (cdfname,varname,longname,unit,out_cnt,time,levels,
     >             times,npre,ntim,0,1,direction)

c         Exit point for loop over all tracing variables
 110      continue

c	   End loop over all lidar variables
       enddo

c     --------------------------------------------------------------------
c     Write output to netCDF file
c     --------------------------------------------------------------------

c     Write status information
      print*
      print*,'---- WRITE OUTPUT LIDAR FIELDS --------------------------'
      print*

c     Close coord dump file
      print*,' LIDAR written to      : ',trim(outfile)
      if ( dumpcoord.eq.'yes' ) then
        print*,' Coordinates dumped to : ',trim(outfile)//'.coord'
      endif

c     Write some status information, and end of program message
      print*
      print*,'---- STATUS INFORMATION --------------------------------'
      print*
      print*,' ok'
      print*
      print*,'              *** END OF PROGRAM LIDAR ***'
      print*,'========================================================='

      end

c     ********************************************************************
c     * INPUT / OUTPUT SUBROUTINES                                       *
c     ********************************************************************

c     --------------------------------------------------------------------
c     Subroutines to write 2D CF netcdf output file
c     --------------------------------------------------------------------

      subroutine writecdf2D_cf
     >          (cdfname,varname,longname,unit,arr,time,levels,times,
     >           npre,ntim,crefile,crevar,direction)

c     Create and write to the CF netcdf file <cdfname>. The variable
c     with name <varname> and with time <time> is written. The data
c     are in the two-dimensional array <arr>.  The flags <crefile> and
c     <crevar> determine whether the file and/or the variable should
c     be created.

      USE netcdf

      IMPLICIT NONE

c     Declaration of input parameters
      character*80 cdfname
      character*80 varname,longname,unit
      integer      npre,ntim
      real         arr(ntim,npre)
      real         levels(npre)
      real         times (ntim)
      real         time
      integer      crefile,crevar
      character*80 direction

c     Numerical epsilon
      real         eps
      parameter    (eps=1.e-5)

c     Local variables
      integer      ierr
      integer      ncID
      integer      LevDimId,    varLevID
      integer      TimeDimID,   varTimeID
      real         timeindex
      integer      i,j
      integer      nvars,varids(100)
      integer      ndims,dimids(100)
      real         timelist(1000)
      integer      ntimes
      integer      ind
      integer      varID

c     Quick an dirty solution for fieldname conflict
      if ( varname.eq.'time' ) varname = 'TIME'

c     Initially set error to indicate no errors.
      ierr = 0

c     ---- Create the netCDF - skip if <crefile=0> ----------------------
      if ( crefile.ne.1 ) goto 100

c     Create the file
      ierr = nf90_create(trim(cdfname), NF90_CLOBBER, ncID)

c     Define dimensions
      ierr=nf90_def_dim(ncID,'level',npre, LevDimID )
      ierr=nf90_def_dim(ncID,'time' ,ntim, TimeDimID)

c     Define space coordinate
      ierr = nf90_def_var(ncID,'level',NF90_FLOAT,
     >     (/ LevDimID /),varLevID)
      if ( direction.eq.'vertical' ) then
        ierr = nf90_put_att(ncID, varLevID, "standard_name","level")
        ierr = nf90_put_att(ncID, varLevID, "units"        ,"hPa")
      elseif ( direction.eq.'lat' ) then
        ierr = nf90_put_att(ncID, varLevID, "standard_name","latitude")
        ierr = nf90_put_att(ncID, varLevID, "units"        ,"deg")
      elseif ( direction.eq.'lon' ) then
        ierr = nf90_put_att(ncID, varLevID, "standard_name","longitude")
        ierr = nf90_put_att(ncID, varLevID, "units"        ,"deg")
      elseif ( direction.eq.'normal' ) then
        ierr = nf90_put_att(ncID, varLevID, "standard_name","normal")
        ierr = nf90_put_att(ncID, varLevID, "units"        ,"deg")
      endif

c     Define time coordinate
      ierr = nf90_def_var(ncID,'time',NF90_FLOAT,
     >     (/ TimeDimID /), varTimeID)
      ierr = nf90_put_att(ncID, varTimeID, "long_name",    "time")
      ierr = nf90_put_att(ncID, varTimeID, "units",       "hours")

c     Write global attributes
      ierr = nf90_put_att(ncID, NF90_GLOBAL, 'Conventions', 'CF-1.0')
      ierr = nf90_put_att(ncID, NF90_GLOBAL, 'title',
     >     'pseudo-lidar from trajectory file')
      ierr = nf90_put_att(ncID, NF90_GLOBAL, 'source',
     >     'Lagranto Trajectories')
      ierr = nf90_put_att(ncID, NF90_GLOBAL, 'institution',
     >     'ETH Zurich, IACETH')

c     Check whether the definition was successful
      ierr = nf90_enddef(ncID)
      if (ierr.gt.0) then
         print*, 'An error occurred while attempting to ',
     >        'finish definition mode.'
         stop
      endif

c     Write coordinate data
      ierr = nf90_put_var(ncID,varLevID  ,levels)
      ierr = nf90_put_var(ncID,varTimeID ,times )

c     Close netCDF file
      ierr = nf90_close(ncID)

 100  continue

c     ---- Define a new variable - skip if <crevar=0> -----------------------

      if ( crevar.ne.1 ) goto 110

      print*,'Now defining ',trim(varname)

c     Open the file for read/write access
      ierr = nf90_open  (trim(cdfname), NF90_WRITE  , ncID)

c     Get the IDs for dimensions
      ierr = nf90_inq_dimid(ncID,'level', LevDimID )
      ierr = nf90_inq_dimid(ncID,'time' , TimeDimID)

c     Enter define mode
      ierr = nf90_redef(ncID)

c     Write definition and add attributes
      ierr = nf90_def_var(ncID,varname,NF90_FLOAT,
     >                   (/ TimeDimID, LevDimID /),varID)
      ierr = nf90_put_att(ncID, varID, "long_name" , longname )
      ierr = nf90_put_att(ncID, varID, "units"     , unit     )
      ierr = nf90_put_att(ncID, varID, '_FillValue', -999.99  )

c     Check whether definition was successful
      ierr = nf90_enddef(ncID)
      if (ierr.gt.0) then
         print*, 'An error occurred while attempting to ',
     >           'finish definition mode.'
         stop
      endif

c     Close netCDF file
      ierr = nf90_close(ncID)

 110  continue

c     ---- Write data --------------------------------------------------

c     Open the file for read/write access
      ierr = nf90_open  (trim(cdfname), NF90_WRITE , ncID)

c     Get the varID
      ierr = nf90_inq_varid(ncID,varname, varID )
      if (ierr.ne.0) then
         print*,'Variable ',trim(varname),' is not defined on ',
     >          trim(cdfname)
         stop
      endif

c     Write data block
      ierr = nf90_put_var(ncID,varID,arr,
     >                    start = (/ 1, 1 /),
     >                    count = (/ ntim, npre/) )

c     Check whether writing was successful
      ierr = nf90_close(ncID)
      if (ierr.ne.0) then
         write(*,*) trim(nf90_strerror(ierr))
         write(*,*) 'An error occurred while attempting to ',
     >              'close the netcdf file.'
         write(*,*) 'in clscdf_CF'
      endif

      end

c     ********************************************************************************
c     * Coordinate rotation - lidar normal to trajectory                             *
c     ********************************************************************************

c     --------------------------------------------------------------------------------
c     Backward coordinate transformation (Rotated lon/lat -> True lon/lat)
c     --------------------------------------------------------------------------------

      SUBROUTINE getenvir_b (clon,clat,rotation,
     >                       lon,lat,rlon,rlat,n)

      implicit none

c     Declaration of input and output parameters
      integer     n
      real        clon,clat,rotation
      real        lon(n), lat(n)
      real        rlon(n),rlat(n)

c     Auxiliary variables
      real         pollon,pollat
      integer      i
      real         rlon1(n),rlat1(n)

c     Externals
      real         lmstolm,phstoph
      external     lmstolm,phstoph

c     First coordinate transformation (make the local coordinate system parallel to equator)
      pollon=-180.
      pollat=90.+rotation
      do i=1,n
         rlon1(i)=90.+lmstolm(rlat(i),rlon(i)-90.,pollat,pollon)
         rlat1(i)=phstoph(rlat(i),rlon(i)-90.,pollat,pollon)
      enddo

c     Second coordinate transformation (make the local coordinate system parallel to equator)
      pollon=clon-180.
      if (pollon.lt.-180.) pollon=pollon+360.
      pollat=90.-clat
      do i=1,n
         lon(i)=lmstolm(rlat1(i),rlon1(i),pollat,pollon)
         lat(i)=phstoph(rlat1(i),rlon1(i),pollat,pollon)
      enddo

      END

c     ---------------------------------------------------------------------
c     Determine the angle between two vectors
c     ---------------------------------------------------------------------

      SUBROUTINE getangle (vx1,vy1,vx2,vy2,angle)

c     Given two vectors <vx1,vy1> and <vx2,vy2>, determine the angle (in deg)
c     between the two vectors.

      implicit none

c     Declaration of subroutine parameters
      real vx1,vy1
      real vx2,vy2
      real angle

c     Auxiliary variables and parameters
      real len1,len2,len3
      real val1,val2,val3
      real pi
      parameter (pi=3.14159265359)

      len1=sqrt(vx1*vx1+vy1*vy1)
      len2=sqrt(vx2*vx2+vy2*vy2)

      if ((len1.gt.0.).and.(len2.gt.0.)) then
         vx1=vx1/len1
         vy1=vy1/len1
         vx2=vx2/len2
         vy2=vy2/len2

         val1=vx1*vx2+vy1*vy2
         val2=-vy1*vx2+vx1*vy2

         len3=sqrt(val1*val1+val2*val2)

         if ( (val1.ge.0.).and.(val2.ge.0.) ) then
            val3=acos(val1/len3)
         else if ( (val1.lt.0.).and.(val2.ge.0.) ) then
            val3=pi-acos(abs(val1)/len3)
         else if ( (val1.ge.0.).and.(val2.le.0.) ) then
            val3=-acos(val1/len3)
         else if ( (val1.lt.0.).and.(val2.le.0.) ) then
            val3=-pi+acos(abs(val1)/len3)
         endif
      else
         val3=0.
      endif

      angle=180./pi*val3

      END

c     --------------------------------------------------------------------------------
c     Transformation routine: LMSTOLM and PHSTOPH from library gm2em
c     --------------------------------------------------------------------------------

      REAL FUNCTION LMSTOLM (PHIS, LAMS, POLPHI, POLLAM)
C
C**** LMSTOLM  -   FC:BERECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE FUER
C****                 EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C****                 IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C****                 DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C**   AUFRUF   :   LAM = LMSTOLM (PHIS, LAMS, POLPHI, POLLAM)
C**   ENTRIES  :   KEINE
C**   ZWECK    :   BERECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE FUER
C**                EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C**                IM ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C**                DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C**   VERSIONS-
C**   DATUM    :   03.05.90
C**
C**   EXTERNALS:   KEINE
C**   EINGABE-
C**   PARAMETER:   PHIS     REAL   GEOGR. BREITE DES PUNKTES IM ROT.SYS.
C**                LAMS     REAL   GEOGR. LAENGE DES PUNKTES IM ROT.SYS.
C**                POLPHI   REAL   WAHRE GEOGR. BREITE DES NORDPOLS
C**                POLLAM   REAL   WAHRE GEOGR. LAENGE DES NORDPOLS
C**   AUSGABE-
C**   PARAMETER:   WAHRE GEOGRAPHISCHE LAENGE ALS WERT DER FUNKTION
C**                ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C**   COMMON-
C**   BLOECKE  :   KEINE
C**
C**   FEHLERBE-
C**   HANDLUNG :   KEINE
C**   VERFASSER:   D.MAJEWSKI

      REAL        LAMS,PHIS,POLPHI,POLLAM

      DATA        ZRPI18 , ZPIR18  / 57.2957795 , 0.0174532925 /

      ZSINPOL = SIN(ZPIR18*POLPHI)
      ZCOSPOL = COS(ZPIR18*POLPHI)
      ZLAMPOL = ZPIR18*POLLAM
      ZPHIS   = ZPIR18*PHIS
      ZLAMS   = LAMS
      IF(ZLAMS.GT.180.0) ZLAMS = ZLAMS - 360.0
      ZLAMS   = ZPIR18*ZLAMS

      ZARG1   = SIN(ZLAMPOL)*(- ZSINPOL*COS(ZLAMS)*COS(ZPHIS)  +
     1                          ZCOSPOL*           SIN(ZPHIS)) -
     2          COS(ZLAMPOL)*           SIN(ZLAMS)*COS(ZPHIS)
      ZARG2   = COS(ZLAMPOL)*(- ZSINPOL*COS(ZLAMS)*COS(ZPHIS)  +
     1                          ZCOSPOL*           SIN(ZPHIS)) +
     2          SIN(ZLAMPOL)*           SIN(ZLAMS)*COS(ZPHIS)
      IF (ABS(ZARG2).LT.1.E-30) THEN
        IF (ABS(ZARG1).LT.1.E-30) THEN
          LMSTOLM =   0.0
        ELSEIF (ZARG1.GT.0.) THEN
              LMSTOLAM =  90.0
            ELSE
              LMSTOLAM = -90.0
            ENDIF
      ELSE
        LMSTOLM = ZRPI18*ATAN2(ZARG1,ZARG2)
      ENDIF

      RETURN
      END

      REAL FUNCTION PHSTOPH (PHIS, LAMS, POLPHI, POLLAM)
C
C**** PHSTOPH  -   FC:BERECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE FUER
C****                 EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C****                 ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C****                 DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C**   AUFRUF   :   PHI = PHSTOPH (PHIS, LAMS, POLPHI, POLLAM)
C**   ENTRIES  :   KEINE
C**   ZWECK    :   BERECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE FUER
C**                EINEN PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C**                ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C**                DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C**   VERSIONS-
C**   DATUM    :   03.05.90
C**
C**   EXTERNALS:   KEINE
C**   EINGABE-
C**   PARAMETER:   PHIS     REAL   GEOGR. BREITE DES PUNKTES IM ROT.SYS.
C**                LAMS     REAL   GEOGR. LAENGE DES PUNKTES IM ROT.SYS.
C**                POLPHI   REAL   WAHRE GEOGR. BREITE DES NORDPOLS
C**                POLLAM   REAL   WAHRE GEOGR. LAENGE DES NORDPOLS
C**   AUSGABE-
C**   PARAMETER:   WAHRE GEOGRAPHISCHE BREITE ALS WERT DER FUNKTION
C**                ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C**   COMMON-
C**   BLOECKE  :   KEINE
C**
C**   FEHLERBE-
C**   HANDLUNG :   KEINE
C**   VERFASSER:   D.MAJEWSKI

      REAL        LAMS,PHIS,POLPHI,POLLAM

      DATA        ZRPI18 , ZPIR18  / 57.2957795 , 0.0174532925 /

      SINPOL = SIN(ZPIR18*POLPHI)
      COSPOL = COS(ZPIR18*POLPHI)
      ZPHIS  = ZPIR18*PHIS
      ZLAMS  = LAMS
      IF(ZLAMS.GT.180.0) ZLAMS = ZLAMS - 360.0
      ZLAMS  = ZPIR18*ZLAMS
      ARG     = COSPOL*COS(ZPHIS)*COS(ZLAMS) + SINPOL*SIN(ZPHIS)

      PHSTOPH = ZRPI18*ASIN(ARG)

      RETURN
      END

      REAL FUNCTION LMTOLMS (PHI, LAM, POLPHI, POLLAM)
C
C%Z% Modul %M%, V%I% vom %G%, extrahiert am %H%
C
C**** LMTOLMS  -   FC:UMRECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE LAM
C****                 AUF EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C****                 IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C****                 DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C**   AUFRUF   :   LAM = LMTOLMS (PHI, LAM, POLPHI, POLLAM)
C**   ENTRIES  :   KEINE
C**   ZWECK    :   UMRECHNUNG DER WAHREN GEOGRAPHISCHEN LAENGE LAM AUF
C**                EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C**                ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C**                DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C**   VERSIONS-
C**   DATUM    :   03.05.90
C**
C**   EXTERNALS:   KEINE
C**   EINGABE-
C**   PARAMETER:   PHI    REAL BREITE DES PUNKTES IM GEOGR. SYSTEM
C**                LAM    REAL LAENGE DES PUNKTES IM GEOGR. SYSTEM
C**                POLPHI REAL GEOGR.BREITE DES N-POLS DES ROT. SYSTEMS
C**                POLLAM REAL GEOGR.LAENGE DES N-POLS DES ROT. SYSTEMS
C**   AUSGABE-
C**   PARAMETER:   WAHRE GEOGRAPHISCHE LAENGE ALS WERT DER FUNKTION
C**                ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C**   COMMON-
C**   BLOECKE  :   KEINE
C**
C**   FEHLERBE-
C**   HANDLUNG :   KEINE
C**   VERFASSER:   G. DE MORSIER

      REAL        LAM,PHI,POLPHI,POLLAM

      DATA        ZRPI18 , ZPIR18  / 57.2957795 , 0.0174532925 /

      ZSINPOL = SIN(ZPIR18*POLPHI)
      ZCOSPOL = COS(ZPIR18*POLPHI)
      ZLAMPOL =     ZPIR18*POLLAM
      ZPHI    =     ZPIR18*PHI
      ZLAM    = LAM
      IF(ZLAM.GT.180.0) ZLAM = ZLAM - 360.0
      ZLAM    = ZPIR18*ZLAM

      ZARG1   = - SIN(ZLAM-ZLAMPOL)*COS(ZPHI)
      ZARG2   = - ZSINPOL*COS(ZPHI)*COS(ZLAM-ZLAMPOL)+ZCOSPOL*SIN(ZPHI)
      IF (ABS(ZARG2).LT.1.E-30) THEN
        IF (ABS(ZARG1).LT.1.E-30) THEN
          LMTOLMS =   0.0
        ELSEIF (ZARG1.GT.0.) THEN
              LMTOLMS =  90.0
            ELSE
              LMTOLMS = -90.0
            ENDIF
      ELSE
        LMTOLMS = ZRPI18*ATAN2(ZARG1,ZARG2)
      ENDIF

      RETURN
      END

      REAL FUNCTION PHTOPHS (PHI, LAM, POLPHI, POLLAM)
C
C%Z% Modul %M%, V%I% vom %G%, extrahiert am %H%
C
C**** PHTOPHS  -   FC:UMRECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE PHI
C****                 AUF EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS)
C****                 IM ROTIERTEN SYSTEM. DER NORDPOL DES SYSTEMS HAT
C****                 DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C**   AUFRUF   :   PHI = PHTOPHS (PHI, LAM, POLPHI, POLLAM)
C**   ENTRIES  :   KEINE
C**   ZWECK    :   UMRECHNUNG DER WAHREN GEOGRAPHISCHEN BREITE PHI AUF
C**                EINEM PUNKT MIT DEN KOORDINATEN (PHIS, LAMS) IM
C**                ROTIERTEN SYSTEM. DER NORDPOL DIESES SYSTEMS HAT
C**                DIE WAHREN KOORDINATEN (POLPHI, POLLAM)
C**   VERSIONS-
C**   DATUM    :   03.05.90
C**
C**   EXTERNALS:   KEINE
C**   EINGABE-
C**   PARAMETER:   PHI    REAL BREITE DES PUNKTES IM GEOGR. SYSTEM
C**                LAM    REAL LAENGE DES PUNKTES IM GEOGR. SYSTEM
C**                POLPHI REAL GEOGR.BREITE DES N-POLS DES ROT. SYSTEMS
C**                POLLAM REAL GEOGR.LAENGE DES N-POLS DES ROT. SYSTEMS
C**   AUSGABE-
C**   PARAMETER:   ROTIERTE BREITE PHIS ALS WERT DER FUNKTION
C**                ALLE WINKEL IN GRAD (NORDEN>0, OSTEN>0)
C**
C**   COMMON-
C**   BLOECKE  :   KEINE
C**
C**   FEHLERBE-
C**   HANDLUNG :   KEINE
C**   VERFASSER:   G. DE MORSIER

      REAL        LAM,PHI,POLPHI,POLLAM

      DATA        ZRPI18 , ZPIR18  / 57.2957795 , 0.0174532925 /

      ZSINPOL = SIN(ZPIR18*POLPHI)
      ZCOSPOL = COS(ZPIR18*POLPHI)
      ZLAMPOL = ZPIR18*POLLAM
      ZPHI    = ZPIR18*PHI
      ZLAM    = LAM
      IF(ZLAM.GT.180.0) ZLAM = ZLAM - 360.0
      ZLAM    = ZPIR18*ZLAM
      ZARG    = ZCOSPOL*COS(ZPHI)*COS(ZLAM-ZLAMPOL) + ZSINPOL*SIN(ZPHI)

      PHTOPHS = ZRPI18*ASIN(ZARG)

      RETURN
      END


      subroutine grad(gradbs1, gradbs2, gradbs3, gradbs4, irho)
c
c     calculate gradient factors, gradbs1 and gradbs2
c     gradbs1 - due to electron density gradient
c     gradbs2 - due to ion density gradient
c     gradbs3 - due to electron temperature gradient
c     gradbs4 - due to ion temperature gradient
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use parambs
      use vmec0
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer :: irho
      real(rprec) :: gradbs1, gradbs2, gradbs3, gradbs4
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      real(rprec) :: gradbs, de, de1, di, di1, p
C-----------------------------------------------

      gradbs =-2.5_dp*gpsi(irho)*qsafety(irho)*betar(irho)*sign_jacobian
      de = dense(irho)                               !electron density
      de1 = densrho1
      di = dense(irho)/zeff1                         !ion density
      di1 = densrho1/zeff1
      p = de*tempe1(irho) + di*tempi1(irho) + 1.E-36_dp     !plasma pressure
      gradbs1 = gradbs*de1*tempe1(irho)/p  !due to electron density gradient
      gradbs2 = gradbs*di1*tempi1(irho)/p  !due to ion density gradient
c                                     !due to electron temperature gradi
      gradbs3 = alphae*gradbs*temperho1*de/p
c                                       !due to ion temperature gradient
      gradbs4 = alphai*gradbs*tempirho1*di/p

      end subroutine grad


!==========================================================================
elemental function gsw_alpha_wrt_t_ice (t, p)
!==========================================================================
!
!  Calculates the thermal expansion coefficient of ice with respect to
!  in-situ temperature.
!
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  alpha_wrt_t_ice  =  thermal expansion coefficient of ice with respect
!                      to in-situ temperature                       [ 1/K ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs_ice

use gsw_mod_kinds

implicit none

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

real (r8) :: gsw_alpha_wrt_t_ice

gsw_alpha_wrt_t_ice = gsw_gibbs_ice(1,1,t,p)/gsw_gibbs_ice(0,1,t,p)

return
end function

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


!***********************************************************************************************************************************
!**                                       S U B R O U T I N E   T O T A L  D I S S O L V E D  G A S                               **
!***********************************************************************************************************************************

SUBROUTINE TOTAL_DISSOLVED_GAS (NSAT,P,NSG,N,T,C)
  USE TDGAS; USE STRUCTURES; USE GLOBAL; USE MAIN, ONLY: EA; USE TVDC, ONLY: TDEW
  IMPLICIT NONE
  INTEGER      :: N, NSG, NSAT
  REAL(R8)     :: T,P,C
  REAL         :: SAT,DB,DA,TDG

  IF(NSAT==0)THEN    ! DISSOLVED OXYGEN
      SAT = EXP(7.7117-1.31403*(LOG(T+45.93)))*P
  ELSE               ! N2 GAS
  EA = DEXP(2.3026D0*(7.5D0*TDEW(JW)/(TDEW(JW)+237.3D0)+0.6609D0))*0.001316   ! in mm Hg   0.0098692atm=7.5006151mmHg
  !SAT=(1.5568D06*0.79*(P-EA)*(1.8816D-5 - 4.116D-7 * T + 4.6D-9 * T**2))   ! SW 10/27/15
   SAT=(1.5568D06*0.79*(P-EA)*(1.8816D-5 - 4.116D-7 * T + 4.6D-9 * T*T))   ! SW 10/27/15    4/20/16 SPEED
  ENDIF

  IF (NSG == 0) THEN
    IF (EQSP(N) == 1) THEN
      TDG = AGASSP(N)*.035313*QSP(N)+BGASSP(N)
      IF (TDG > 145.0) TDG = 145.0
      C = SAT
      IF (TDG >= 100.0) C = TDG*SAT/100.0
    ELSE IF (EQSP(N) == 2) THEN
      TDG = AGASSP(N)+BGASSP(N)*EXP(0.035313*QSP(N)*CGASSP(N))
      IF (TDG > 145.0)  TDG = 145.0
      C = SAT
      IF (TDG >= 100.0) C = TDG*SAT/100.0
    ELSE
      DA = SAT-C                                                                               ! MM 5/21/2009 DA: Deficit upstream
      DB = DA/(1.0+0.38*AGASSP(N)*BGASSP(N)*CGASSP(N)*(1.0-0.11*CGASSP(N))*(1.0+0.046*T))      ! DB: deficit downstream
      C  = SAT-DB
    END IF
  ELSE IF (EQGT(N) == 1) THEN
    TDG = AGASGT(N)*0.035313*QGT(N)+BGASGT(N)
    IF (TDG > 145.0) TDG = 145.0
    C = SAT
    IF (TDG >= 100.0) C = TDG*SAT/100.0
  ELSE IF (EQGT(N) == 2) THEN
    TDG = AGASGT(N)+BGASGT(N)*EXP(.035313*QGT(N)*CGASGT(N))
    IF (TDG > 145.0) TDG = 145.0
    C = SAT
    IF (TDG >= 100.0) C = TDG*SAT/100.0
  ELSE
    DA = SAT-C                                                                               ! MM 5/21/2009 DA: Deficit upstream
    DB = DA/(1.0+0.38*AGASGT(N)*BGASGT(N)*CGASGT(N)*(1.0-0.11*CGASGT(N))*(1.0+0.046*T))      ! DB: deficit downstream
    C  = SAT-DB
  END IF
END SUBROUTINE TOTAL_DISSOLVED_GAS


      SUBROUTINE slCTFD (IHOUR, IMIN, SEC, DAYS, J)
*+
*     - - - - - -
*      C T F D
*     - - - - - -
*
*  Convert hours, minutes, seconds to days (single precision)
*
*  Given:
*     IHOUR       int       hours
*     IMIN        int       minutes
*     SEC         real      seconds
*
*  Returned:
*     DAYS        real      interval in days
*     J           int       status:  0 = OK
*                                    1 = IHOUR outside range 0-23
*                                    2 = IMIN outside range 0-59
*                                    3 = SEC outside range 0-59.999...
*
*  Notes:
*
*  1)  The result is computed even if any of the range checks
*      fail.
*
*  2)  The sign must be dealt with outside this routine.
*
*  P.T.Wallace   Starlink   November 1984
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    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; either version 2 of the License, or
*    (at your option) any later version.
*
*    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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER IHOUR,IMIN
      REAL SEC,DAYS
      INTEGER J

*  Seconds per day
      REAL D2S
      PARAMETER (D2S=86400.0)

*  Preset status
      J=0

*  Validate sec, min, hour
      IF (SEC.LT.0.0.OR.SEC.GE.60.0) J=3
      IF (IMIN.LT.0.OR.IMIN.GT.59) J=2
      IF (IHOUR.LT.0.OR.IHOUR.GT.23) J=1

*  Compute interval
      DAYS=(60.0*(60.0*REAL(IHOUR)+REAL(IMIN))+SEC)/D2S

      END


subroutine createsegment(ne,etype,elem,nseg,segment)

implicit none

integer, intent(in) :: ne, etype
integer, dimension(etype*ne), intent(in) :: elem

integer, intent(inout) :: nseg
integer, dimension(etype*ne,2), intent(inout) :: segment
!---
integer :: i,j,k,a,b
integer, dimension(etype*ne,2) :: dummy

nseg=0
do i=1,ne
  do j=1,etype
    nseg=nseg+1
    a=elem(etype*(i-1)+j)
    b=elem(etype*(i-1)+mod(j,etype)+1)
    if (a>b) then
      segment(nseg,1)=b
      segment(nseg,2)=a
    else
      segment(nseg,1)=a
      segment(nseg,2)=b
    endif
    dummy(nseg,1)=i
  enddo
enddo

call heapsort2(segment(:,1),segment(:,2),dummy(:,1),nseg)

dummy(:,2)=0
k=1
! remove doubles
do i=2,nseg
  if ((segment(i,1)==segment(k,1)).AND.(segment(i,2)==segment(k,2))) then
    dummy(k,2)=dummy(i,1)
    if (dummy(k,1)>dummy(k,2)) then
      dummy(k,2)=dummy(k,1)
      dummy(k,1)=dummy(i,1)
    endif
  else
    k=k+1
    segment(k,:)=segment(i,:)
    dummy(k,:)=dummy(i,:)
  endif
enddo

nseg=k

end subroutine createsegment


program myprog
  use class_Graph
  use class_Stack
  use utility
  use search_routines

  type(Graph) :: g
  integer :: num_vertices = 30, i, num_edges, percent_edges = 50
  integer, allocatable :: edges(:,:)

  print *, "Hello main"
  num_edges = int(percent_edges * (num_vertices**2 - num_vertices) / 200)
  allocate(edges(num_edges, 2))

  edges = reshape( [(random_int(1, num_vertices), random_int(1, num_vertices), i = 1, num_edges)], [num_edges, 2])

  call g%init(num_vertices, edges, num_edges)
  call dfs(g)

end program myprog


Module m_inspar
Integer, Parameter :: kdp = selected_real_kind(15)
public :: inspar
private :: kdp
private :: R_inspar, I_inspar, D_inspar
interface inspar
  module procedure d_inspar, r_inspar, i_inspar
end interface inspar
contains

Subroutine D_inspar (XDONT, NORD)
!  Sorts partially XDONT, bringing the NORD lowest values at the
!  begining of the array
! __________________________________________________________
!  This subroutine uses insertion sort, limiting insertion
!  to the first NORD values. It does not use any work array
!  and is faster when NORD is very small (2-5), but worst case
!  behavior can happen fairly probably (initially inverse sorted)
!  In many cases, the refined quicksort method is faster.
!  Michel Olagnon - Feb. 2000
! __________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (InOut) :: XDONT
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Real (kind=kdp) :: XWRK, XWRK1
!
      Integer :: ICRS, IDCR
!
      Do ICRS = 2, NORD
         XWRK = XDONT (ICRS)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK >= XDONT(IDCR)) Exit
            XDONT (IDCR+1) = XDONT (IDCR)
         End Do
         XDONT (IDCR+1) = XWRK
      End Do
!
      XWRK1 = XDONT (NORD)
      Do ICRS = NORD + 1, SIZE (XDONT)
         If (XDONT(ICRS) < XWRK1) Then
            XWRK = XDONT (ICRS)
            XDONT (ICRS) = XWRK1
            Do IDCR = NORD - 1, 1, - 1
               If (XWRK >= XDONT(IDCR)) Exit
               XDONT (IDCR+1) = XDONT (IDCR)
            End Do
            XDONT (IDCR+1) = XWRK
            XWRK1 = XDONT (NORD)
         End If
      End Do
!
!
End Subroutine D_inspar

Subroutine R_inspar (XDONT, NORD)
!  Sorts partially XDONT, bringing the NORD lowest values at the
!  begining of the array
! __________________________________________________________
!  This subroutine uses insertion sort, limiting insertion
!  to the first NORD values. It does not use any work array
!  and is faster when NORD is very small (2-5), but worst case
!  behavior can happen fairly probably (initially inverse sorted)
!  In many cases, the refined quicksort method is faster.
!  Michel Olagnon - Feb. 2000
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (InOut) :: XDONT
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Real    :: XWRK, XWRK1
!
      Integer :: ICRS, IDCR
!
      Do ICRS = 2, NORD
         XWRK = XDONT (ICRS)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK >= XDONT(IDCR)) Exit
            XDONT (IDCR+1) = XDONT (IDCR)
         End Do
         XDONT (IDCR+1) = XWRK
      End Do
!
      XWRK1 = XDONT (NORD)
      Do ICRS = NORD + 1, SIZE (XDONT)
         If (XDONT(ICRS) < XWRK1) Then
            XWRK = XDONT (ICRS)
            XDONT (ICRS) = XWRK1
            Do IDCR = NORD - 1, 1, - 1
               If (XWRK >= XDONT(IDCR)) Exit
               XDONT (IDCR+1) = XDONT (IDCR)
            End Do
            XDONT (IDCR+1) = XWRK
            XWRK1 = XDONT (NORD)
         End If
      End Do
!
!
End Subroutine R_inspar
Subroutine I_inspar (XDONT, NORD)
!  Sorts partially XDONT, bringing the NORD lowest values at the
!  begining of the array
! __________________________________________________________
!  This subroutine uses insertion sort, limiting insertion
!  to the first NORD values. It does not use any work array
!  and is faster when NORD is very small (2-5), but worst case
!  behavior can happen fairly probably (initially inverse sorted)
!  In many cases, the refined quicksort method is faster.
!  Michel Olagnon - Feb. 2000
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (InOut)  :: XDONT
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Integer :: XWRK, XWRK1
!
      Integer :: ICRS, IDCR
!
      Do ICRS = 2, NORD
         XWRK = XDONT (ICRS)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK >= XDONT(IDCR)) Exit
            XDONT (IDCR+1) = XDONT (IDCR)
         End Do
         XDONT (IDCR+1) = XWRK
      End Do
!
      XWRK1 = XDONT (NORD)
      Do ICRS = NORD + 1, SIZE (XDONT)
         If (XDONT(ICRS) < XWRK1) Then
            XWRK = XDONT (ICRS)
            XDONT (ICRS) = XWRK1
            Do IDCR = NORD - 1, 1, - 1
               If (XWRK >= XDONT(IDCR)) Exit
               XDONT (IDCR+1) = XDONT (IDCR)
            End Do
            XDONT (IDCR+1) = XWRK
            XWRK1 = XDONT (NORD)
         End If
      End Do
!
!
End Subroutine I_inspar
end module m_inspar


function fmincon(N,fun,X,X0,lb,ub,grad,options,info) result(fval)
!
!   Copyright 2017, Viktor Reshiak, All rights reserved.
!
!
!   Purpose
!   =======
!   Find minimum of the scalar function of several variables.
!
!
!   Method
!   ======
!   John Burkardt's f90 implementation of the TOMS 611 algorithm
!   ( model/trust-region approach and the double-dogleg technique )
!
!
!   IN
!   ==
!   1) N       - dimension of the input vector
!   3) fun     - objective function
!   5) X0      - (optional) initial guess as a separate vector
!   6) grad    - (optional) gradient of the objective function
!   7) options - (optional) struct with options of the solver
!
!
!   INOUT
!   =====
!   4) X       - initial guess / final solution
!
!
!   OUT
!   ===
!   8) info    - (optional) structure with information about solution process
!
	implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! dummy arguments

    procedure(fminunc_objective_fun)                       :: fun
    procedure(fminunc_objective_grad), optional            :: grad

    integer(kind=4), intent(in)                            :: N
       real(kind=8), intent(inout), dimension(N)           :: X
       real(kind=8), intent(in),    dimension(N), optional :: X0
       real(kind=8), intent(in),    dimension(N), optional :: lb, ub

    type (fsolve_options), intent(in),  optional           :: options
    type (fsolve_info),    intent(out), optional           :: info

        real(kind=8) :: fval

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	! parameters of the solver
    integer(kind=4), parameter    :: M = 20, iprint = -1
    integer(kind=4)               :: iwa(3*N)
       real(kind=8)               :: wa(2*M*N+5*N+11*M*M+8*M)
    integer(kind=4), dimension(N) :: bd_type
       real(kind=8), parameter    :: factr = 0.0d0 !1.0d1 ! extremely high accuracy
       real(kind=8), parameter    :: pgtol = 0.0d0
       real(kind=8)               :: f
       real(kind=8), dimension(N) :: df
    character(len=60)             :: task, csave
    logical                       :: lsave(4)
    integer                       :: isave(44)
    real(kind=8)                  :: dsave(29)

    ! dtrnlsp_init
    type(fsolve_options) :: op

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    if ( present(lb) .and. present(ub) ) then
        bd_type = 2
    elseif ( present(lb) ) then
        bd_type = 1
    elseif ( present(ub) ) then
        bd_type = 3
    else
        bd_type = 0
    endif

    if ( present(options) ) then
        op = options
    else
        op = default_fsolve_options
    endif

    if ( present(X0) ) then
        X = X0
    endif

!     f  = fun(N,X)
!     df = gradient(N,X,f)
!     print*, f
!     print*, X

    task = 'START'
    do while( task(1:2).eq.'FG'.or.task.eq.'NEW_X'.or.task.eq.'START')
        call setulb(N,M,X,lb,ub,bd_type,f,df,factr,pgtol,wa,iwa,task,iprint,csave,lsave,isave,dsave)

        if (task(1:2).eq.'FG') then
            f  = fun(N,X)
            df = gradient(N,X,f)
        elseif (task(1:5).eq.'NEW_X') then
            !print*, f
            !print*, X
            if ( isave(34) .ge. op%MaxIter ) then
                task = 'STOP'
            endif
            if ( dsave(13) .le. 1.d-10*(1.0d0 + abs(f)) ) then
                task = 'STOP'
            endif
        endif
    enddo
    fval = fun(N,X)

    contains

    function gradient(dim_x,x,f_x) result(df)
        integer, intent(in)                        :: dim_x
        real(kind=8), dimension(dim_x), intent(in) :: x
        real(kind=8), intent(in)                   :: f_x
        real(kind=8), dimension(dim_x)             :: df

        real(kind=8), dimension(dim_x) :: x1
        integer      :: i
        real(kind=8) :: eps, dx

        eps = sqrt(epsilon(1.d0))

        x1 = x
        df = f_x
        do i = 1, dim_x
            dx    = max(eps*x(i),eps)
            !dx    = 1.d-10
            x1(i) = x(i) + dx
            df(i) = ( fun(dim_x,x1) - df(i) ) / dx
            x1(i) = x(i)
        enddo
    end function gradient

end function fmincon