!***********************************************************************
!                                                                      *
      SUBROUTINE SETMC
!                                                                      *
!   This subprogram sets machine-dependent parameters.                 *
!                                                                      *
!   Call(s) to: [LAPACK]: DLAMCH.                                      *
!                                                                      *
!   Written by Farid A Parpia              Last updated: 06 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:50:37   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE DEBUG_C
      USE DEF_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(DOUBLE) :: DNUM
      REAL(DOUBLE) :: DLAMCH
!-----------------------------------------------
!
!
!   Set the machine-dependent parameters:
!
!   TENMAX - Maximum size of exponent of 10
!
      TENMAX = DLAMCH('L')
!
!   EXPMAX - Maximum size of exponent of e
!
      DNUM = DLAMCH('O')
      EXPMAX = LOG(DNUM)
!
!   EXPMIN - Minimum size of exponent of e
!
      DNUM = DLAMCH('U')
      EXPMIN = LOG(DNUM)
!
!   PRECIS - Machine precision
!
      PRECIS = DLAMCH('E')
!
!   Debug printout
!
      IF (LDBPG(1)) WRITE (99, 300) TENMAX, EXPMAX, EXPMIN, PRECIS
!
      RETURN
!
  300 FORMAT(/,'From SUBROUTINE SETMC:'/,' TENMAX (maximum exponent of 10): ',&
         F5.0,/,' EXPMAX (maximum exponent of e): ',1P,1D19.12,/,&
         ' EXPMIN (minimum exponent of e): ',1D19.12,/,&
         ' PRECIS (machine precision): ',1D19.12)
      RETURN
!
      END SUBROUTINE SETMC


*----------------------------------------------------------------------*
      subroutine eigen_asym(ndim,xmat,eigr,eigi,vecs,xscr,ierr)
*----------------------------------------------------------------------*
*     Solve the eigenvalue problem for an asymmetric matrix
*     Wrapper for eispack call
*     covers some ordering and renormalization issues as needed
*     in GeCCo
*
*     xmat -> matrix to be diagonalised
*     eigr -> real part of the resulting eigenvalues
*     eigi -> imaginary part of the resulting eigenvalues
*     vecs -> resulting eigenvectors
*     xscr -> scratch variable (?)
*     ierr -> error
*----------------------------------------------------------------------*
      implicit none

      integer, intent(in) ::
     &     ndim
      real(8), intent(inout) ::
     &     xmat(ndim,ndim)
      real(8), intent(inout) ::
     &     eigr(ndim), eigi(ndim), vecs(ndim,ndim),
     &     xscr(ndim,ndim)
      integer, intent(inout) ::
     &     ierr

      integer ::
     &     irg, idx,
     &     ivec(ndim)
      real(8) ::
     &     rnorm,
     &     xvec(ndim)

      real(8), external ::
     &     ddot, dnrm2

      irg = 1
      call rg(ndim,ndim,xmat,eigr,eigi,irg,vecs,ivec,xvec,ierr)
      if (ierr.ne.0) return

      ! normalize and re-orthogonalize degenerate pairs
      idx = 1
      do while(idx.le.ndim)
        if (eigi(idx).eq.0d0) then
          rnorm = dnrm2(ndim,vecs(1,idx),1)
          vecs(1:ndim,idx) = (1d0/rnorm)*vecs(1:ndim,idx)
          idx = idx+1
        else
          rnorm = dnrm2(2*ndim,vecs(1,idx),1)
          vecs(1:ndim,idx) = (1d0/rnorm)*vecs(1:ndim,idx)
          vecs(1:ndim,idx+1) = (1d0/rnorm)*vecs(1:ndim,idx+1)
          ! re-ortho. part still missing (cf. lucia_ccrsp, l3110ff)
          idx = idx+2
        end if
      end do

      ! init reordering array
      do idx = 1, ndim
        ivec(idx) = idx
      end do
      ! sort solutions according to real part (ascending)
      ! eigr is resorted on the way
      call idxsortx(eigr,ivec,ndim,+1)

      ! resort eigi as well
      call reovec(xvec,eigi,ivec,ndim)
      eigi(1:ndim) = xvec(1:ndim)

      ! resort vectors
      call reocols(xscr,vecs,ivec,ndim,ndim)
      vecs = xscr

      return
      end


!*********************************************************************
!Written by Rachith Aiyappa at IISc, Bangalore
!Email rachithaiyappa96@gmail.com for any queries
!This module contains the functions for the N fish simulation
!*********************************************************************
!
module fish_func
contains
!*********************************************************************
!function generate_v
!This function generates kicking speeds of the respective focal fish
!Units of BL_tau
!*********************************************************************
function generate_v(r)
	real,parameter :: pi = 3.14159265
	real :: r
	generate_v = sqrt((-16/pi)*log(1-r))
end function generate_v
!---------------------------------------------------------------------
!
!********************************************************************!
!function generate_tau
!This function generates kicking times of the respective focal fish
!Units of BL_tau
!********************************************************************!
function generate_tau(r)
	real,parameter :: pi = 3.14159265
	real :: r
	generate_tau = sqrt((-4/pi)*log(1-r))
end function generate_tau
!--------------------------------------------------------------------
!
!********************************************************************
!function dist_calc
!This function calculates the distance from the focal fish
!********************************************************************
function dist_calc(col,focal_x,focal_y,x_temp,y_temp,N) result(d)
	integer,intent(in) :: col,N
	integer :: i

	real, dimension(N,1) :: d
	real,intent(in),dimension(N,1) :: x_temp,y_temp
	real,intent(in) :: focal_x,focal_y

	!write (*,*) focal_x,x_temp
	do i=1,N,1
		!write(*,*) d(i,col)
		d(i,1) = sqrt(((focal_x-x_temp(i,1))**2)	&
				+ ((focal_y-y_temp(i,1))**2))
		!write(*,*) d(i,col)
	end do
	!write(*,*) d
end function
!--------------------------------------------------------------------
!
!********************************************************************
!function del_phi_att
!This function calculate the change in heading angle due to attraction
!********************************************************************
function del_phi_att(gamma_att,d,psi,delta_phi)
	!a is included to restore anticlockwise angle as positive
	real,parameter :: a=-1.0
	real,parameter :: l_att=5.0,d_zero=1.0
	!real,parameter :: l_att=1.0 !proposed by Clement
	real :: f_att,o_att,e_att
	real,intent(in) :: gamma_att,d,psi,delta_phi

	!write(*,*) gamma_att, d, psi, delta_phi
	!write(*,*)

	!original functions in the paper
	f_att = ((d-d_zero)/d_zero)/(1.0+((d/l_att)**2.0))
	o_att = sin(a*psi)*(1-(0.33*cos(a*psi)))
	e_att = 1.0-(0.48*cos(a*delta_phi))-			    &
				(0.31*cos(2.0*(a*delta_phi)))

	!functions proposed by Clement
	!f_att = (d/d_zero)/(1.0+((d/l_att)**2.0))
	!o_att = sin(a*psi)*(1+cos(a*psi))
	!e_att = 1

	del_phi_att = gamma_att*f_att*o_att*e_att
end function del_phi_att
!---------------------------------------------------------------------

!********************************************************************
!function del_phi_ali
!This function calculate the change in heading angle due to alignment
!********************************************************************
function del_phi_ali(gamma_ali,d,psi,delta_phi)

	!a is included to restore anticlockwise angle as positive
	real,parameter :: a=-1.0
	real,parameter :: l_ali = 5.0
	real :: f_ali,o_ali,e_ali
	real,intent(in) :: gamma_ali,d,psi,delta_phi

	!write(*,*) gamma_ali, d, psi, delta_phi

	!original funcions in the paper
	f_ali = exp(-1.0*((d/l_ali)**2.0))
	e_ali = (1.0) + (0.6*cos(a*psi))-(0.32*cos(2.0*(a*psi)))
	o_ali = (sin(a*delta_phi))*((1.0)+			    &
			(0.30*cos(2.0*(a*delta_phi))))

	!functions proposed by Clement
	!f_ali = exp(-1.0*((d/l_ali)**2.0))
	!o_ali = sin(a*delta_phi)
	!e_ali = 1+cos(a*psi)

	del_phi_ali = gamma_ali*f_ali*o_ali*e_ali
end function del_phi_ali
!---------------------------------------------------------------------

!********************************************************************
!function gaus_rand
!This uses the marsaglia polar method to create (pseudo-optional)
!random number pairs that have a normal distribution. The function
!saves one of the random numbers from the generated pair as a spare
!to be returned from the generated pair for the next call to the func
!Returns a real scalar
!********************************************************************
function gaus_rand()
	real :: gaus_rand
	real :: mean=0,sd=1
	!real,intent(inout) :: x,y
	real :: r,x,y
	real,save :: spare
	logical, save :: has_spare
	call init_random_seed()
	!use a spare saved from a previous run if it exits
	if(has_spare) then
		has_spare = .false.
		gaus_rand = mean + (sd*spare)
		return
	else
		r = 1.0
		do while (r .ge. 1.0)
			!spreading distribution to [-1,1]
			call random_number(x)
			call random_number(y)
			x = (x*2.0)-1.0
			y = (y*2.0)-1.0
			r = (x*x) + (y*y)
		end do

		r = sqrt((-2.0*log(r))/r)
		gaus_rand = mean + (sd*x*r)
		spare = y * r
		has_spare = .true.
		return
	end if
end function
!*********************************************************************
!RANDOM SEED GENERATOR FOR THE RANDOM_NUMBER PROGRAM
!*********************************************************************

subroutine init_random_seed()
	use iso_fortran_env, only: int64
	implicit none
	integer, allocatable :: seed(:)
	integer :: i, n, un, istat, dt(8), pid
	integer(int64) :: t

	call random_seed(size = n)
	allocate(seed(n))
	! First try if the OS provides a random number generator
	open(newunit=un, file="/dev/urandom", access="stream",        &
	form="unformatted", action="read", status="old", iostat=istat)
	if (istat == 0) then
		read(un) seed
		close(un)
	else
		! Fallback to XOR:ing the current time and pid. The PID is
		! useful in case one launches multiple instances of the same
		! program in parallel.
		call system_clock(t)
		if (t == 0) then
			call date_and_time(values=dt)
			t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 &
							* 1000        &
			+ dt(2) * 31_int64 * 24 * 60 * 60 * 1000      &
			+ dt(3) * 24_int64 * 60 * 60 * 1000           &
			+ dt(5) * 60 * 60 * 1000                      &
			+ dt(6) * 60 * 1000 + dt(7) * 1000            &
			+ dt(8)
		end if
		pid = getpid()
		t = ieor(t, int(pid, kind(t)))
		do i = 1, n
			seed(i) = lcg(t)
		end do
		end if
		call random_seed(put=seed)	!value of 'put' is the array used to initialize this thread's seed.
	contains
		! This simple PRNG might not be good enough for real work, but is
		! sufficient for seeding a better PRNG.
		function lcg(s)
			integer :: lcg
			integer(int64) :: s
			if (s == 0) then
				s = 104729
			else
				s = mod(s, 4294967296_int64)
			end if
				s = mod(s * 279470273_int64,          &
				4294967291_int64)
				lcg = int(mod(s, int(huge(0),         &
 				int64)), kind(0))
		end function lcg
end subroutine init_random_seed
!*********************************************************************

end module fish_func


subroutine comp_emcoefs(r1_0,r2_0,r1_2,r2_2,j1,j2,th,nu0,Aji,nsI_tot,nsQ_tot,es_I,es_Q)
use fwigxjpf
!subroutine to compute the emission coefficients
!as of now, only implementation for the ratio nq/ni and eq/ei
!theta angle is required
!tested on a matlab routine

implicit none

integer j1,j2

double precision th,tki,tkq
double precision wjj2_1,wjj2_2
double precision fas,fac1,fac2,w6_1,w6_2
double precision r1_0,r2_0,r1_2,r2_2
double precision g1,g2,nu0,b_to_a,a_to_b
double precision nsI_tot,nsQ_tot
double precision na_I,na_Q,ns_I,ns_Q
double precision es_I,es_Q
double precision pQ,eQ,Aji,Bji,hv_fac

!input
!r1_0,2		-- lower level rank0,2 population
!r2_0,2		-- upper level rank0,2 population
!j1/j2		-- lower/upper level angular momentum
!th		-- propagation-magnetic field angle
!nu0		-- transition frequency

!output
!oQ		-- \eta_Q/\eta_I -factor
!eQ		-- \epsilon_Q / \epsilon_I - factor

!compute the w_{jj'}^k-factors
!only required for k=0 and k=2
!Eq.(38) Landi-84

fas = (-1.d0)**(1.d0 + j1 + j2)
fac1 = dsqrt(3.d0 * (2.d0 * j1 + 1.d0))
fac2 = dsqrt(3.d0 * (2.d0 * j2 + 1.d0))

w6_1 = fwig6jj(2*  1 , 2*  1 , 2*  2 ,&
     &         2* j1,  2*  j1, 2*  j2)

w6_2 = fwig6jj(2*  1 , 2*  1 , 2*  2 ,&
     &         2* j2,  2*  j2, 2*  j1)

wjj2_1 = fas * fac1 * w6_1
wjj2_2 = fas * fac2 * w6_2

!degeneracy
g1 = 2.d0 * j1 + 1.d0
g2 = 2.d0 * j2 + 1.d0

!
!T^K_Q(i,\Omega) rotation elements from Bommier 1997b
tki = (3.d0 * dcos(th)**2.d0 - 1.d0 )/(2.d0 * dsqrt(2.d0))
tkq = -3.d0 * dsin(th)**2.d0 / (2.d0 * dsqrt(2.d0))

!write(*,*)
!write(*,*)tki,tkq
!write(*,*)

!Eqs.(40)-(42) Landi-84
na_I = 1.d0 + wjj2_1 * (r1_2/r1_0) * tki
na_Q = wjj2_1 * (r1_2/r1_0) * tkq

ns_I = 1.d0 + wjj2_2 * (r2_2/r2_0) * tki
ns_Q = wjj2_2 * (r2_2/r2_0) * tkq

a_to_b = 6.781962D49    !best to use L&L relation here
                        !B21 = [c^2 / (2*h * v^3)] * A21
                        !a_to_b = c^2 / (2*h)

!write(*,*)na_I,na_Q
!write(*,*)ns_I,ns_Q

b_to_a = nu0**3.d0 / a_to_b

Bji = Aji / b_to_a
!write(*,*)
!write(*,*)Aji,Bji

es_I = ns_I
es_Q = ns_Q

!now properly substract the absorption and stimulated emission
!so that the proportionalities stay in-tact

!na ~ B_12 * N1
!ns ~ B_21 * N2 = B_12 * g1 * N2 / g2
!N1 ~ sqrt(g1) * r1_0
!N2 ~ sqrt(g2) * r2_0 		--- Eq.(43) Landi-84

nsI_tot = dsqrt(g1)*r1_0 * na_I - dsqrt(g2)*r2_0*ns_I*g1/g2
nsQ_tot = dsqrt(g1)*r1_0 * na_Q - dsqrt(g2)*r2_0*ns_Q*g1/g2

hv_fac = 5.273D-35 * nu0            !(h/4*pi) * nu0

!write(*,*)
!write(*,*)hv_fac

es_I = hv_fac * Aji * es_I * dsqrt(g2) * r2_0
es_Q = hv_fac * Aji * es_Q * dsqrt(g2) * r2_0

nsI_tot = hv_fac * (g2/g1)*Bji * nsI_tot        !g2/g1 * B21 = B12
nsQ_tot = hv_fac * (g2/g1)*Bji * nsQ_tot

!write(*,*)nsI_tot,nsQ_tot
!write(*,*)es_I,es_Q
!stop
end subroutine

subroutine get_rhovec(c_dim,count_array,nlev,j_lev,ntrans,trans,AC_trans,t_int,kmax,Temp,D0,rhovec,extra_info,rates)
!subroutine that obtains the rho-vector of a certain node
!by setting up the SEE and subsequently solving them
implicit none
integer nlev,ntrans,t_int,c_dim
integer i,j,k,jc,ic,INFO,n
integer kmax,extra_info

integer, dimension(nlev) :: j_lev,count_array
integer, dimension(2,ntrans) :: trans
integer, dimension(c_dim) :: IPIV

double precision Temp

double precision, dimension(5,ntrans) :: AC_trans
double precision, dimension(nlev,2:kmax) :: D0
double precision, dimension(c_dim,c_dim) :: Amat
double precision, dimension(c_dim+1) :: yvec
double precision, dimension(c_dim+1,c_dim) :: Bmat
double precision, dimension(c_dim+1) :: dvec
double precision, dimension(c_dim) :: WORK,rhovec
double precision, dimension(c_dim,c_dim) :: C_mat
double precision, dimension(c_dim,c_dim) :: B_mat
double precision, dimension(c_dim,c_dim) :: R_mat
double precision, dimension(3,c_dim) :: rates

!input:
!c_dim          -- dimension of the SEE matrix
!count_array    -- bookkeeping array for the (polarized) levels
!nlev           -- number of levels
!j_lev          -- associated J-angular momentum of the levels
!ntrans         -- number of transitions
!trans          -- associated levels with these transitions
!AC_trans       -- associated rates with these transtions
!t_int          --

call setup_stateq(c_dim,count_array,nlev,j_lev,trans,ntrans,kmax,&
&AC_trans,D0,Temp,Amat,R_mat,B_mat,C_mat)

!like in Hazel, replace the first row with the level constraint
!that is set at 1d7 --- densities we are interested in are
!probably lower, so we'll set 1.d3

Amat(1,:) = 0.d0
do i = 1,nlev
  ic = count_array(i) + 1
  jc = j_lev(i)

  Amat(1,ic) = dsqrt(2.d0 * jc + 1.d0)
end do

!Amat * rhovec = dvec
!dvec(1) = 1.d3 and rest = 0.d0

call DGETRF(c_dim,c_dim,Amat,c_dim,IPIV,INFO)
if (INFO.ne.0) then
  write(*,*)'Density-matrix calculation: failed'
  stop
else
  call DGETRI(c_dim,Amat,c_dim,IPIV,WORK,c_dim,INFO)
  if (INFO.ne.0) then
    write(*,*)'Density-matrix calculation: failed'
    stop
  endif
endif

!see beneath to get all the populations, but we are actually
!interested only in the populations for our levels
!dvec(1) = 1.d3 and rest = 0.d0
do i = 1,c_dim
  rhovec(i) = Amat(i,1)
end do

if (extra_info.eq.1) then
  rates(:,:) = 0.d0
  do i = 1,c_dim
    do j = 1,c_dim
      rates(1,i) = rates(1,i) + dabs(R_mat(i,j))*rhovec(j)
      rates(2,i) = rates(2,i) + dabs(B_mat(i,j))*rhovec(j)
      rates(3,i) = rates(3,i) + dabs(C_mat(i,j))*rhovec(j)
!      write(*,*)j,dabs(C_mat(i,j)),rhovec(j)
    end do
!    stop
  end do
endif

end subroutine


module parameters_IO

  implicit none
  include 'mpif.h'

  integer,parameter :: rprec=kind(1.d0)
  real(rprec),parameter :: pi=3.1415926535897932384626433_rprec

  integer :: p_on_y,p_on_z

  integer :: nx,ny,nz
  integer :: nt
  integer :: lhx,lhy,ldx,ldy

  real(rprec) :: dx,dy,dz
  real(rprec) :: dt

  real(rprec) :: a
  real(rprec) :: lx,ly,lz

  logical :: output
  integer :: step_out
  character(256) :: out_path

  private
  public :: read_parameters

  public :: rprec,pi
  public :: p_on_y,p_on_z,nx,ny,nz,nt,lhx,lhy,ldx,ldy
  public :: dx,dy,dz,dt,a,lx,ly,lz
  public :: output,step_out,out_path

contains

  subroutine read_parameters(me, nproc,ierr)

    implicit none

    integer, intent(inout) :: ierr, me, nproc

    if(me==0)then
       namelist / numerical_param / p_on_y, p_on_z, nx, ny, nz, nt, dt

       namelist / output_param / output, step_out, out_path

       namelist / physical_param / a, lx, ly, lz

       write(*,*) 'Reading parameters...'
       write(*,*) ' '
       write(*,*) '============================================================'
       read(*,numerical_param)
       write(*,numerical_param)
       write(*,*) '============================================================'
       read(*,output_param)
       write(*,output_param)
       write(*,*) '============================================================'
       read(*,physical_param)
       write(*,physical_param)
       write(*,*) '============================================================'
       write(*,*) ' '

       lhx=nx/2+1
       lhy=ny/2+1
       ldx=2*lhx
       ldy=2*lhy

       dx=lx/nx
       dy=ly/ny
       dz=lz/(nz-1)

    endif

    call broadcast_parameters(me, nproc, ierr)

    ! needed so all param are bcast
    call MPI_barrier(MPI_COMM_WORLD, ierr)

  end subroutine read_parameters

  subroutine broadcast_parameters(me, nproc,ierr)

    implicit none
    integer, intent (inout) :: ierr, me, nproc

    integer,parameter :: bufferlength=1000
    integer :: position
    character :: buffer(bufferlength)

    if(me==0)then
       !! on node 0
       position = 0

       call MPI_pack(p_on_y, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(p_on_z, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)

       call MPI_pack(nx, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(ny, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(nz, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(nt, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)

       call MPI_pack(lhx, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(lhy, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(ldx, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(ldy, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)

       call MPI_pack(dx, 1, MPI_DOUBLE_PRECISION, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(dy, 1, MPI_DOUBLE_PRECISION, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(dz, 1, MPI_DOUBLE_PRECISION, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(dt, 1, MPI_DOUBLE_PRECISION, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)

       call MPI_bcast(buffer, bufferlength, MPI_PACKED, 0, MPI_COMM_WORLD, ierr)

    else
       !! on the other nodes
       call MPI_bcast(buffer, bufferlength, MPI_PACKED, 0, MPI_COMM_WORLD, ierr)

       position = 0
       call MPI_unpack(buffer, bufferlength, position, p_on_y, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, p_on_z, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)

       call MPI_unpack(buffer, bufferlength, position, nx, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, ny, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, nz, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, nt, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)

       call MPI_unpack(buffer, bufferlength, position, lhx, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, lhy, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, ldx, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, ldy, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)

       call MPI_unpack(buffer, bufferlength, position, dx, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, dy, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, dz, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, dt, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)

    endif

    if(me==0)then
       !! on node 0
       position = 0
       call MPI_pack(output, 1, MPI_LOGICAL, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(step_out, 1, MPI_INTEGER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(out_path, 256, MPI_CHARACTER, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)

       call MPI_bcast(buffer, bufferlength, MPI_PACKED, 0, MPI_COMM_WORLD, ierr)

    else
       !! on the other nodes
       call MPI_bcast(buffer, bufferlength, MPI_PACKED, 0, MPI_COMM_WORLD, ierr)

       position = 0
       call MPI_unpack(buffer, bufferlength, position, output, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, step_out, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, out_path, 256, MPI_CHARACTER, MPI_COMM_WORLD, ierr)
    endif

    if(me==0)then
       !! on node 0
       position = 0
       call MPI_pack(a, 1, MPI_DOUBLE_PRECISION, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(lx, 1, MPI_DOUBLE_PRECISION, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(ly, 1, MPI_DOUBLE_PRECISION, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)
       call MPI_pack(lz, 1, MPI_DOUBLE_PRECISION, buffer, bufferlength, position, MPI_COMM_WORLD, ierr)

       call MPI_bcast(buffer, bufferlength, MPI_PACKED, 0, MPI_COMM_WORLD, ierr)

    else
       !! on the other nodes
       call MPI_bcast(buffer, bufferlength, MPI_PACKED, 0, MPI_COMM_WORLD, ierr)

       position = 0
       call MPI_unpack(buffer, bufferlength, position, a, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, lx, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, ly, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
       call MPI_unpack(buffer, bufferlength, position, lz, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
    endif

  end subroutine broadcast_parameters

end module parameters_IO


program grid4_to_g15

  parameter (MAXGRID4=32400)
  character*4 w,grid4
  character c1*1,c2*2
  logical is_grid4
  is_grid4(grid4)=len(trim(grid4)).eq.4 .and.                        &
       grid4(1:1).ge.'A' .and. grid4(1:1).le.'R' .and.               &
       grid4(2:2).ge.'A' .and. grid4(2:2).le.'R' .and.               &
       grid4(3:3).ge.'0' .and. grid4(3:3).le.'9' .and.               &
       grid4(4:4).ge.'0' .and. grid4(4:4).le.'9'

  nargs=iargc()
  if(nargs.ne.1) then
     print*,'Convert a 4-character grid, signal report, etc., to a g15 value.'
     print*,'Usage examples:'
     print*,'grid4_to_g15 FN20'
     print*,'grid4_to_g15 -11'
     print*,'grid4_to_g15 +02'
     print*,'grid4_to_g15 RRR'
     print*,'grid4_to_g15 RR73'
     print*,'grid4_to_g15 73'
     print*,'grid4_to_g15 ""'
     go to 999
  endif
  call getarg(1,w)
  if(is_grid4(w) .and. w.ne.'RR73') then
     j1=(ichar(w(1:1))-ichar('A'))*18*10*10
     j2=(ichar(w(2:2))-ichar('A'))*10*10
     j3=(ichar(w(3:3))-ichar('0'))*10
     j4=(ichar(w(4:4))-ichar('0'))
     igrid4=j1+j2+j3+j4
  else
     c1=w(1:1)
     if(c1.ne.'+' .and. c1.ne.'-'.and. trim(w).ne.'RRR' .and. w.ne.'RR73' &
          .and. trim(w).ne.'73' .and. len(trim(w)).ne.0) go to 900
     if(c1.eq.'+' .or. c1.eq.'-') then
        read(w,*,err=900) irpt
        irpt=irpt+35
     endif
     if(len(trim(w)).eq.0) irpt=1
     if(trim(w).eq.'RRR') irpt=2
     if(w.eq.'RR73') irpt=3
     if(trim(w).eq.'73') irpt=4
     igrid4=MAXGRID4 + irpt
  endif

  write(*,1000) w,igrid4,igrid4
1000 format('Encoded word: ',a4,'   g15 in binary: ',b15.15,'   decimal:',i6)
  go to 999

900 write(*,1900)
1900 format('Invalid input')

999 end program grid4_to_g15


!***********************************************************************

      program depth_profile

!-----------------------------------------------------------------------
!
!     computes layer thicknesses for each level for POP ocean code
!
!-----------------------------------------------------------------------

      real, parameter ::
     &  zmax = 5500      ! max depth in meters

      dimension z(0:100),dz(1:100)

      z(0) = 0.0

      open(12,file='in_depths.dat',form='formatted',status='unknown')
      do k = 1,100

        call zeroin(z(k-1),dz(k))

        z(k) = z(k-1) + dz(k)
        if(k.eq.1)then
          zz=z(k)*0.5
        else
          zz = 0.5*(z(k)+z(k-1))
        endif
        write(*,*)k,dz(k),z(k),zz
        write(12,*)dz(k)*100
        if(z(k).gt.zmax) go to 100

      enddo

100   continue
      close(12)

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

      end program depth_profile

!***********************************************************************

      subroutine zeroin(z,x)

      external fz
      data err/1.0e-10/

c     ...linear search

      dx = fz(z)/10.
      x = 0.0
      g = 1.0

      do while (g.gt.0.0)

        xl = x
        x = x + dx
        g = fz(z + x/2.) - x

      enddo

c     ...newton search

      xu = x

      do while (abs(g).gt.err)

        x = 0.5*(xu + xl)
        g = fz(z + x/2.) - x

        if (g.gt.0.0) then
          xl = x
        else
          xu = x
        endif

      enddo

      return
      end

      function fz(z)

c     fz = 300. - 295.*exp(-((z-160)/500.)**2)

c     fz = 500. - 475.*exp(-(z/891.736)**2)
c     fz = 500. - 475.*exp(-(z/1000)**2)
c     fz = 300. - 300./(1. + exp((z-1200.)/500.))

      fz = 250. - 240.*exp(-(z/695.655)**2)    ! NA 40-level

      return
      end


program cubedSphereTest

use NumberKindsModule
use LoggerModule
use PolyMeshOOModule
use ParticlesOOModule
use EdgesOOModule
use FacesOOModule
use SphereGeomModule
use STDIntVectorModule
use OutputWriterModule

#include "LpmConfig.h"

type(PolyMesh2d) :: mesh
integer(kint) :: initNest
integer(kint), parameter :: amrLimit = 0
real(kreal), parameter :: sphRadius = one
integer(kint) :: nedges

type(Logger) :: exeLog

real(kreal), dimension(180) :: lons
real(kreal), dimension(91) :: lats
real(kreal), parameter :: dlambda = 2.0_kreal * PI / 180.0_kreal
real(kreal), dimension(3) :: qpt

integer(kint), dimension(91,180) :: inFace

integer(kint) :: randomVertex
integer(kint) :: randomFace
logical(klog) :: keepGoing
real(kreal) :: randReal
type(STDIntVector) :: edgesAroundFace, adjacentFaces
real(kreal) :: xyz(3)

integer(kint) :: i, j

character(len=MAX_STRING_LENGTH) :: logString
character(len=MAX_STRING_LENGTH) :: fname

call New(exeLog, DEBUG_LOGGING_LEVEL)
call getInput(initNest)

call LogMessage(exelog, TRACE_LOGGING_LEVEL, "CubedSphereMeshTest part 1:", " build an icosahedral triangle sphere mesh.")
call LogMessage(exelog, TRACE_LOGGING_LEVEL, "CubedSphereMeshTest part 2:", " test point query algorithm.")
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "CubedSphereMeshTest part 3:", " test adjacency algorithms.")
call LogMessage(exelog, TRACE_LOGGING_LEVEL, "CubedSphereMeshTest part 4:", " output to paraview/vtk.")

call mesh%init("cubed_sphere", initNest, initNest, amrLimit, sphRadius)
call mesh%logStats(exeLog)

!call mesh%edges%writeMatlab(6)

do j=1,180
    lons(j) = dlambda *(j-1)
enddo
do i=1,91
    lats(i) = -0.5_kreal * PI + dlambda*(i-1)
enddo

do j=1,180
    do i=1,91
        qpt = [cos(lats(i))*cos(lons(j)), cos(lats(i))*sin(lons(j)), sin(lats(i))]
        inFace(i,j) = mesh%locatePointInFace(qpt)
    enddo
enddo
print *, "Uniform mesh points located."

qpt = [cos(-0.25_kreal)*cos(2.95_kreal),cos(-0.25_kreal)*sin(2.95_kreal), sin(-0.25_kreal)]
randomFace = mesh%locatePointInFace(qpt)
print *, "query point located in face ", randomFace

edgesAroundFace = mesh%ccwEdgesAroundFace(randomFace)
print *, "edgesAroundFace ", randomFace, ":"
call edgesAroundFace%print()
adjacentFaces = mesh%ccwAdjacentFaces(randomFace)
print *, "adjacentFaces to ", randomFace, ":"
call adjacentFaces%print()

write(fname,'(A,I1,A)') "cubedSphereTest", initNest, ".m"
open(unit=WRITE_UNIT_1, file=trim(fname), action='write', status='replace')

call writeToMatlab(lons, WRITE_UNIT_1, 'lons')
call writeToMatlab(lats, WRITE_UNIT_1, 'lats')
call writeToMatlab(inFace, WRITE_UNIT_1, 'inFace')
write(WRITE_UNIT_1, '(A,2G15.8,A)') "queryPt = [", 2.95_kreal, -0.25_kreal, "];"
write(WRITE_UNIT_1, '(A,2G15.8,A)') "qInFace = [", longitude(mesh%faces%physCentroid(randomFace, mesH%particles)), &
    latitude(mesH%faces%physCentroid(randomFace, mesh%particles)), "];"
write(WRITE_UNIT_1, '(A)') "edgesAroundFaceLon = ["
do i=1, edgesAroundFace%N
    xyz = mesh%particles%physCoord(mesh%edges%orig(edgesAroundFace%int(i)))
    qpt = mesh%particles%physCoord(mesh%edges%dest(edgesAroundFace%int(i)))
    write(WRITE_UNIT_1,'((G15.8,A))') Longitude(xyz), ", ..."
    write(WRITE_UNIT_1,'(G15.8,A)') longitude(qpt), ", ..."
enddo
xyz = mesh%particles%physCoord(mesh%edges%orig(edgesAroundFace%int(1)))
qpt = mesh%particles%physCoord(mesh%edges%dest(edgesAroundFace%int(1)))
write(WRITE_UNIT_1,'((G15.8,A))') Longitude(xyz), ", ... "
write(WRITE_UNIT_1,'(G15.8,A)') longitude(qpt), "]; "
write(WRITE_UNIT_1, '(A)') "edgesAroundFaceLat = ["
do i=1, edgesAroundFace%N
    xyz = mesh%particles%physCoord(mesh%edges%orig(edgesAroundFace%int(i)))
    qpt = mesh%particles%physCoord(mesh%edges%dest(edgesAroundFace%int(i)))
    write(WRITE_UNIT_1,'((G15.8,A))') latitude(xyz), ", ..."
    write(WRITE_UNIT_1,'(G15.8,A)') latitude(qpt), ", ..."
enddo
xyz = mesh%particles%physCoord(mesh%edges%orig(edgesAroundFace%int(1)))
qpt = mesh%particles%physCoord(mesh%edges%dest(edgesAroundFace%int(1)))
write(WRITE_UNIT_1,'((G15.8,A))') latitude(xyz), ", ..."
write(WRITE_UNIT_1,'(G15.8,A)') latitude(qpt), "];"
write(WRITE_UNIT_1, '(A)', advance='no') "adjFaces = ["
do i=1, adjacentFaces%N-1
    xyz = mesh%faces%physCentroid(adjacentFaces%int(i), mesh%particles)
    write(WRITE_UNIT_1,'(2(G15.8,A))') Longitude(xyz), ", ", latitude(xyz), "; ..."
enddo
xyz = mesh%faces%physCentroid(adjacentFaces%int(adjacentFaces%N), mesh%particles)
write(WRITE_UNIT_1,'(2(G15.8,A))') Longitude(xyz), ", ", latitude(xyz), "];"

write(WRITE_UNIT_1,'(A,I8,A)') "figure(1);clf; hold on; contour(lons, lats, inFace,", mesh%faces%N_Active, "); colorbar;"
write(WRITE_UNIT_1,'(A)') "plot(queryPt(1), queryPt(2),'k.','MarkerSize',20)"
write(WRITE_UNIT_1,'(A)') "plot(qInFace(1), qInFace(2), 'bo', 'MarkerSize',10)"
write(WRITE_UNIT_1,'(A)') "plot(edgesAroundFaceLon, edgesAroundFaceLat,'r-','Linewidth',2)"

close(WRITE_UNIT_1)

write(fname,'(A,I1,A)') "cubedSphereTest", initNest, ".vtp"
open(unit=WRITE_UNIT_1, file=trim(fname), action='write', status='replace')
call mesh%writeVTKSerialStartXML(WRITE_UNIT_1)
call mesh%writeVTKSerialEndXML(WRITE_UNIT_1)
close(WRITE_UNIT_1)

call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "result: ", "PASSED")

contains

subroutine getInput(initNest)
    integer(kint), intent(out) :: initNest
    integer(kint) :: argc
    character(len=MAX_STRING_LENGTH) :: argv
    argc = IARGC()
    if (argc==0) then
        initNest = 0
    else
        call GETARG(1, argv)
        read(argv,*) initNest
    endif
end subroutine

end program


subroutine SHMTDebias (mtdebias, mtspectra, lmax, tapers, lwin, K, nl, lmid, n, taper_wt)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will invert for the global power spectrum given a
!	multitaper spectrum estimate, its associated uncertiainty, the
!	coefficients of the windows used in the mutitaper analysis, and
!	the wieghts used with each window. This routine will only work using
!	tapers obtained from the spherical cap concentration problem. It is assumed
!	that the global power spectrum is constant in bins of nl. It is furthermore
!	assumed that the global spectrum is constant beyond lmax. The inverse problem
!	is solved by SVD as described in Numerical Recipes (pp. 670-672)
!
!	Written by Mark Wieczorek, September 13, 2006
!
!	Copyright (c) 2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: wigner3j

	implicit none
	real*8, intent(out) ::	mtdebias(:,:), lmid(:)
	real*8, intent(in) :: 	mtspectra(:,:), tapers(:,:)
	real*8, intent(in), optional :: taper_wt(:)
	integer, intent(in) :: 	lmax, K, lwin, nl
	integer, intent(out) :: n
	real*8 ::	w3j(lwin+2*lmax+1), sum1, y(lmax+1), ss(lmax+1)
	integer :: 	i, j, l, wmin, wmax, nstart, nstop, info, lwork, m, astat(5), iwork(8*(lmax+lwin+1))
	real*8, allocatable :: work(:), Mmt(:, :), a(:, :), vt(:, :), uu(:, :)

	n = ceiling( dble(lmax+1)/dble(nl) )
	m = lmax+1

	if (size(mtspectra(:,1)) /= 2 .or. size(mtspectra(1,:)) < lmax+1) then
		print*, "Error --- SHMTDebias"
		print*, "MTSPECTRA must be dimensioned as (2, LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(mtspectra(:,1)), size(mtspectra(1,:))
		stop
	elseif (size(mtdebias(:,1)) /= 2 .or. size(mtdebias(1,:)) < lmax+1) then
		print*, "Error --- SHMTDebias"
		print*, "MTDEBIAS must be dimensioned as (2, LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(mtdebias(:,1)), size(mtdebias(1,:))
		stop
	elseif (size(tapers(:,1)) < lwin+1 .or. size(tapers(1,:)) < K) then
		print*, "Error --- SHMTDebias"
		print*, "TAPERS must be dimensioned as (LWIN+1, K) where LWIN and K are ", lwin, k
		print*, "Input array is dimensioned as ", size(tapers(:,1)), size(tapers(1,:))
		stop
	elseif (size(lmid) < n) then
		print*, "Error --- SHMTDebias"
		print*, "LMID must be dimensioned as N=ceiling(dble(lmax+1)/dble(nl), where N is ", n
		print*, "Input array is dimensioned as ", size(lmid)
		stop
	endif

	if (present(taper_wt)) then
		if (size(taper_wt) < K) then
			print*, "Error ---  SHMTDebias"
			print*, "TAPER_WT must be dimensioned as (K) where K is ", k
			print*, "Input array is dimensioned as ", size(taper_wt)
			stop
		endif
	endif

	lwork = 3*min(m,n)*min(m,n) + max(max(m,n),4*min(m,n)*min(m,n)+4*min(m,n))

	allocate(Mmt(lmax+1, lmax+lwin+1), stat = astat(1))
	allocate(a(lmax+1, (lmax+2)/nl), stat = astat(2))
	allocate(vt(lmax+lwin+1, lmax+lwin+1), stat = astat(3))
	allocate(uu(lmax+1, lmax+1), stat = astat(4))
	allocate(work(lwork), stat=astat(5))

	if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 .or. astat(4) /= 0 .or. astat(5) /= 0) then
		print*, "Error --- SHMTDebias"
		print*, "Problem allocating arrays MMT, A, VT, UU and WORK", astat(1), astat(2), astat(3), &
			astat(4), astat(5)
		stop
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Compute coupling matrix, M^(mt)
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(taper_wt)) then

		do i=0, lmax
			do j=0, lmax+lwin
				call Wigner3j(w3j, wmin, wmax, i, j, 0, 0, 0)
				sum1 = 0.0d0
				do l=wmin, min(wmax,lwin), 2
					sum1 = sum1 + dot_product(taper_wt(1:K), tapers(l+1,1:K)**2) * w3j(l-wmin+1)**2
				enddo
				Mmt(i+1,j+1) = sum1 * dble(2*i+1)
			enddo
		enddo

	else

		do i=0, lmax
			do j=0, lmax+lwin
				call Wigner3j(w3j, wmin, wmax, i, j, 0, 0, 0)
				sum1 = 0.0d0
				do l=wmin, min(wmax,lwin), 2
					sum1 = sum1 + sum(tapers(l+1,1:K)**2) * w3j(l-wmin+1)**2
				enddo
				Mmt(i+1,j+1) = sum1 * dble(2*i+1) / dble(K)
			enddo
		enddo

	endif

	! Divide linear equations by their uncertainty.

	do i=1, m
		Mmt(i,:) = Mmt(i,:) / mtspectra(2,i)
		y(i) = mtspectra(1,i) / mtspectra(2,i)
	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Compute matrix A by assuming that the global power spectrum is constant
	!	in intervals of deltal.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	a = 0.0d0

	do j=1, n

		nstart =  1 + (j-1)*nl

		if (j==n) then
			nstop = lmax+lwin+1
		else
			nstop =  nstart + nl - 1
		endif

		lmid(j) = dble(nstart+nstop)/2.0d0 - 1

		do i=1, m
			a(i,j) = sum( Mmt(i,nstart:nstop) )
		enddo

	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Do least squares inversion by SVD
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dgesdd_('a', m, n, a, m, ss, uu, m, vt, lmax+lwin+1, work, lwork, iwork, info)

	if (info /=0) then
		print*, "Error --- SHMTDebias"
		print*, "Problem with DGESDD, INFO = ", info
		print*, "if INFO = -i, the i-th argument had an illegal value."
		print*, "if INFO > 0:  DBDSDC did not converge, updating process failed."
		stop
	endif

	mtdebias = 0.0d0

	do i=1, min(m,n)
		mtdebias(1,1:n) = mtdebias(1,1:n) + dot_product(uu(1:m,i), y(1:m)) * vt(i, 1:n) / ss(i)
	enddo

	do j=1, n
		do i=1, min(m,n)
			mtdebias(2,j) = mtdebias(2,j) + (vt(i,j)/ss(i))**2
		enddo
	enddo

	mtdebias(2,1:n) = sqrt(mtdebias(2,1:n))

	deallocate(Mmt)
	deallocate(a)
	deallocate(vt)
	deallocate(uu)
	deallocate(work)

end subroutine SHMTDebias


      real function resc(xmin1,xmax1,xmin2,xmax2,x111)

      implicit integer (i-n)
      implicit double precision (a-h,o-z)

      real*8 rsc
c
c Simple linear rescaling (get a value in coordinate system "2" given
c a value in "1"):
c
      rsc  = dble((xmax2-xmin2)/(xmax1-xmin1))
      resc = xmin2 + real( dble(x111 - xmin1) * rsc )
      return
      end


	   subroutine degtoutm(utmzone,lat,lon,x0,y0,gsize,j,i)
	   IMPLICIT NONE
	   integer i,j
	   real x0,y0,x,y,gsize
	   integer utmzone,zone
	   real lat,lon
           real sa,inv_flattening,sb
	   real e2,e2cuadrada,c
	   real S,v,a,a1,a2,j2,j4,j6
	   real alfa,beta,gama
	   real bm,b,nab,senoheps
	   real epsi,eps,pi
	   real delt,ta0
	   real deltas,epsilon,latr,lonr,nu,ta
           sa = 6378137.
           sb = 6356752.314245
           e2=(((sa**2)-(sb**2))**0.5)/sb
           e2cuadrada= (e2**2)
           c=(sa**2)/sb
	   pi=atan(1.)*4.
	   latr=lat*pi/180.
	   lonr=lon*pi/180.
	   S=((utmzone*6)-183.)
           deltaS=lonr-(S*(pi/180.))
           a=cos(latr)*sin(deltaS)
           epsilon=0.5*log((1.+a)/(1.-a))
           nu=atan(tan(latr)/cos(deltaS))-latr
           v=(c/((1+(e2cuadrada*(cos(latr))**2.)))**0.5)*0.9996
           ta=(e2cuadrada/2.)*epsilon**2*(cos(latr))**2
           a1=sin(2.*latr)
           a2=a1*(cos(latr))**2.
           j2=latr+(a1/2.)
           j4=((3.*j2)+a2)/4.
           j6=((5.*j4)+(a2*(cos(latr))**2.))/3.
           alfa=(3./4.)*e2cuadrada
           beta=(5./3.)*alfa**2.
           gama=(35./27.)*alfa**3.
           Bm=0.9996*c*(latr-alfa*j2+beta*j4-gama*j6)
           x=epsilon*v*(1+(ta/3.))+500000
           y=nu*v*(1+ta)+Bm
	   i=int((y0-y)/gsize)
	   j=int((x-x0)/gsize)
	   return
	   end


c******************************************************************************
c
c      Flow rate routines
c
c******************************************************************************
c
       SUBROUTINE FLOWVV(A,CD,D0,GAM,P0,PB,V,FLOW)
c
c      Calculates mass flow rate through a valve when no manifold
c------------------------------------------------------------------------------
c      Arguments loaded at call:
c          A       discharge area, m**2
c          CD      discharge coefficient (actual flow/isentropic flow)
c          D0      stagnation density, kg/m**3
c          GAM     specific heat ratio Cp/Cv
c          P0      stagnation pressure, Pa
c          PB      back pressure, PA
c      Arguments returned:
c          V       discharge velocity (isentropic core flow), m/s
c          FLOW    mass flow rate, kg/s
c------------------------------------------------------------------------------
c      Variables used in this subroutine
c          C1      (GAM - 1)/GAM
c          E       (P0 - PE)/P0 ( when small)
c          PE      exit plane pressure, Pa
c          TERM    1 - (PE/P0)**C1
c------------------------------------------------------------------------------
c    check flow regime
       C1 = (GAM - 1)/GAM
       PC = P0/(((GAM+1)/2)**(1/C1))
       IF (PB.GT.PC)  THEN
c            subcritical flow
               PE = PB
           ELSE
c            critical flow
               PE = PC
           ENDIF
c    calculate the driving pressure term
       PR = PE/P0
       IF (PR.LT.0.97)  THEN
               TERM = 1 - PR**C1
           ELSE
c            series expansion for accuracy at small flow rates
               E = (P0 - PE)/P0
               TERM = C1*E*(1 - 0.5*(C1-1)*E*(1 - (C1-2)*E/3))
           ENDIF
c    compute isentropic velocity
       TERM =  2*P0*TERM/(D0*C1)

       if (term.lt.0) write (*,*) 'c8:1 term,c1,e,p0 ',term,c1,e,p0

       V = SQRT(TERM)
c    compute mass flow rate
       FLOW = CD*A*V*D0*PR**(1/GAM)
       RETURN
       END
c******************************************************************************