!
! Copyright (c) 2013, Intel Corporation
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
! * Redistributions of source code must retain the above copyright
!       notice, this list of conditions and the following disclaimer.
! * Redistributions in binary form must reproduce the above
!       copyright notice, this list of conditions and the following
!       disclaimer in the documentation and/or other materials provided
!       with the distribution.
! * Neither the name of Intel Corporation nor the names of its
!       contributors may be used to endorse or promote products
!       derived from this software without specific prior written
!       permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, ACLUDAG, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. A NO EVENT SHALL THE
! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ADIRECT,
! ACIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (ACLUDAG,
! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSAESS ATERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER A CONTRACT, STRICT
! LIABILITY, OR TORT (ACLUDAG NEGLIGENCE OR OTHERWISE) ARISAG A
! ANY WAY B OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
! *******************************************************************
!
! NAME:    Stencil
!
! PURPOSE: This program tests the efficiency with which a space-invariant,
!          linear, symmetric filter (stencil) can be applied to a square
!          grid or image.
!
! USAGE:   The program takes as input the linear
!          dimension of the grid, and the number of iterations on the grid
!
!                <progname> <iterations> <grid size>
!
!          The output consists of diagnostics to make sure the
!          algorithm worked, and of timing statistics.
!
! FUNCTIONS CALLED:
!
!          Other than standard C functions, the following functions are used in
!          this program:
!          wtime()
!
! HISTORY: - Written by Rob Van der Wijngaart, February 2009.
!          - RvdW: Removed unrolling pragmas for clarity;
!            added constant to array "in" at end of each iteration to force
!            refreshing of neighbor data in parallel versions; August 2013
!          - Converted to Fortran by Jeff Hammond, January-February 2016.
!          - Converted to CAF by Alessandro Fanfarillo, February 2016.
!          - Small fixes for OpenCoarrays `stop 1` issue work around by
!            Izaak "Zaak" Beekman, March 2017
! *************************************************************************

function prk_get_wtime() result(t)
  use iso_fortran_env
  implicit none
  real(kind=REAL64) ::  t
  integer(kind=INT64) :: c, r
  call system_clock(count = c, count_rate = r)
  t = real(c,REAL64) / real(r,REAL64)
end function prk_get_wtime

subroutine initialize_w(is_star,r,W)
  use iso_fortran_env
  implicit none
  logical, intent(in) :: is_star
  integer(kind=INT32), intent(in) :: r
  real(kind=REAL64), intent(inout) :: W(-r:r,-r:r)
  integer(kind=INT32) :: ii, jj
  ! fill the stencil weights to reflect a discrete divergence operator
  W = 0.0d0
  if (is_star) then
    do ii=1,r
      W(0, ii) =  1.0d0/real(2*ii*r,REAL64)
      W(0,-ii) = -1.0d0/real(2*ii*r,REAL64)
      W( ii,0) =  1.0d0/real(2*ii*r,REAL64)
      W(-ii,0) = -1.0d0/real(2*ii*r,REAL64)
    enddo
  else
    ! Jeff: check that this is correct with the new W indexing
    do jj=1,r
      do ii=-jj+1,jj-1
        W( ii, jj) =  1.0d0/real(4*jj*(2*jj-1)*r,REAL64)
        W( ii,-jj) = -1.0d0/real(4*jj*(2*jj-1)*r,REAL64)
        W( jj, ii) =  1.0d0/real(4*jj*(2*jj-1)*r,REAL64)
        W(-jj, ii) = -1.0d0/real(4*jj*(2*jj-1)*r,REAL64)
      enddo
      W( jj, jj)  =  1.0d0/real(4*jj*r,REAL64)
      W(-jj,-jj)  = -1.0d0/real(4*jj*r,REAL64)
    enddo
  endif
end subroutine initialize_w

subroutine apply_stencil(is_star,tiling,tile_size,r,n,W,A,B)
  use iso_fortran_env
  implicit none
  logical, intent(in) :: is_star, tiling
  integer(kind=INT32), intent(in) :: tile_size, r, n
  real(kind=REAL64), intent(in) :: W(-r:r,-r:r)
  real(kind=REAL64), intent(in) :: A(n,n)
  real(kind=REAL64), intent(inout) :: B(n,n)
  integer(kind=INT32) :: i, j, ii, jj, it, jt
  if (is_star) then
    if (.not.tiling) then
      !$omp do
      do j=r,n-r-1
        do i=r,n-r-1
            ! do not use Intel Fortran unroll directive here (slows down)
            do jj=-r,r
              B(i+1,j+1) = B(i+1,j+1) + W(0,jj) * A(i+1,j+jj+1)
            enddo
            do ii=-r,-1
              B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
            enddo
            do ii=1,r
              B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
            enddo
        enddo
      enddo
      !$omp end do
    else ! tiling
      !$omp do
      do jt=r,n-r-1,tile_size
        do it=r,n-r-1,tile_size
          do j=jt,min(n-r-1,jt+tile_size-1)
            do i=it,min(n-r-1,it+tile_size-1)
              do jj=-r,r
                B(i+1,j+1) = B(i+1,j+1) + W(0,jj) * A(i+1,j+jj+1)
              enddo
              do ii=-r,-1
                B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
              enddo
              do ii=1,r
                B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
              enddo
            enddo
          enddo
        enddo
      enddo
      !$omp end do
    endif ! tiling
  else ! grid
    if (.not.tiling) then
      !$omp do
      do j=r,n-r-1
        do i=r,n-r-1
          do jj=-r,r
            do ii=-r,r
              B(i+1,j+1) = B(i+1,j+1) + W(ii,jj) * A(i+ii+1,j+jj+1)
            enddo
          enddo
        enddo
      enddo
      !$omp end do
    else ! tiling
      !$omp do
      do jt=r,n-r-1,tile_size
        do it=r,n-r-1,tile_size
          do j=jt,min(n-r-1,jt+tile_size-1)
            do i=it,min(n-r-1,it+tile_size-1)
              do jj=-r,r
                do ii=-r,r
                  B(i+1,j+1) = B(i+1,j+1) + W(ii,jj) * A(i+ii+1,j+jj+1)
                enddo
              enddo
            enddo
          enddo
        enddo
      enddo
      !$omp end do
    endif ! tiling
  endif ! star
end subroutine apply_stencil

program main
  use iso_fortran_env
  implicit none
  real(kind=REAL64) :: prk_get_wtime
  ! for argument parsing
  integer :: err
  integer :: arglen
  character(len=32) :: argtmp
  ! problem definition
  integer(kind=INT32) :: iterations                     ! number of times to run the pipeline algorithm
  integer(kind=INT32) ::  n                             ! linear grid dimension
  integer(kind=INT32),allocatable :: nc[:,:],nr[:,:]    ! local grid dimension
  integer(kind=INT32) ::  stencil_size                  ! number of points in stencil
  integer(kind=INT32) ::  tile_size                     ! loop nest block factor
  logical :: tiling                                     ! boolean indication loop nest blocking
  logical :: is_star                                    ! true = star, false = grid
  integer(kind=INT32), parameter :: r=RADIUS            ! radius of stencil
  real(kind=REAL64) :: W(-r:r,-r:r)                     ! weights of points in the stencil
  real(kind=REAL64), allocatable :: A(:,:)[:,:], B(:,:) ! grid values
  real(kind=REAL64), parameter :: cx=1.d0, cy=1.d0
  ! runtime variables
  integer(kind=INT32) :: i, j, k
  integer(kind=INT32) :: ii, jj, it, jt
  integer(kind=INT64) :: flops                          ! floating point ops per iteration
  real(kind=REAL64) :: norm[*], reference_norm          ! L1 norm of solution
  integer(kind=INT64) :: active_points                  ! interior of grid with respect to stencil
  real(kind=REAL64) :: t0, t1, stencil_time, avgtime    ! timing parameters
  real(kind=REAL64), parameter ::  epsilon=1.D-8        ! error tolerance
  integer :: me,np,dims(2),coords(2),start_i,end_i,start_j,end_j,nc_g,nr_g
  integer :: nr_t,nc_t,nc_b,nc_l,nr_l,nr_r
  ! ********************************************************************
  ! read and test input parameters
  ! ********************************************************************

  np = num_images()
  me = this_image()
  if (me == 1) then
    write(*,'(a25)') 'Parallel Research Kernels'
    write(*,'(a44)') 'Fortran coarray stencil execution on 2D grid'
  endif

  if (command_argument_count().lt.2) then
    if (me == 1) then
      write(*,'(a17,i1)') 'argument count = ', command_argument_count()
      write(*,'(a32,a29)') 'Usage: ./stencil <# iterations> ', &
                        '<array dimension> [tile_size]'
    endif
    stop 1
  endif

  iterations = 1
  call get_command_argument(1,argtmp,arglen,err)
  if (err.eq.0) read(argtmp,'(i32)') iterations
  if (iterations .lt. 1) then
    if (me == 1) then
      write(*,'(a,i5)') 'ERROR: iterations must be >= 1 : ', iterations
    endif
    stop 1
  endif

  n = 1
  call get_command_argument(2,argtmp,arglen,err)
  if (err.eq.0) read(argtmp,'(i32)') n
  if (n .lt. 1) then
    if (me == 1) then
      write(*,'(a,i5)') 'ERROR: array dimension must be >= 1 : ', n
    endif
    stop 1
  endif

  tiling    = .false.
  tile_size = 0
  if (command_argument_count().gt.2) then
    call get_command_argument(3,argtmp,arglen,err)
    if (err.eq.0) read(argtmp,'(i32)') tile_size
    if ((tile_size .lt. 1).or.(tile_size.gt.n)) then
      write(*,'(a,i5,a,i5)') 'WARNING: tile_size ',tile_size,&
                             ' must be >= 1 and <= ',n
    else
      tiling = .true.
    endif
  endif

  ! TODO: parse runtime input for star/grid
#ifdef STAR
  is_star = .true.
#else
  is_star = .false.
#endif

  ! TODO: parse runtime input for radius

  if (r .lt. 1) then
    if (me == 1) then
      write(*,'(a,i5,a)') 'ERROR: Stencil radius ',r,' should be positive'
    endif
    stop 1
  else if ((2*r+1) .gt. n) then
    if (me == 1) then
      write(*,'(a,i5,a,i5)') 'ERROR: Stencil radius ',r,&
                             ' exceeds grid size ',n
    endif
    stop 1
  endif

!  Collectives are part of Fortran 2015
!  call co_broadcast(n,source_image=1)
!  call co_broadcast(iterations,source_image=1)

  dims(1) = int(sqrt(real(np)))
  dims(2) = int(np/dims(1))

  i=1
  do while(dims(1)*dims(2) /= np)
     dims(1) = int(sqrt(real(np)))+i
     dims(2) = int(np/dims(1))
     if(i<0) then
        i = (i*(-1)) + 1
     else
        i = i * (-1)
     endif
  enddo

  allocate(nr[dims(1),*],nc[dims(1),*])

  nr = n/dims(1)
  nc = n/dims(2)

  coords = this_image(nr)

  nr_g = nr; nc_g = nc

  if(coords(1) <= modulo(n,nr)) nr = nr + 1
  if(coords(2) <= modulo(n,nc)) nc = nc + 1

  if(modulo(n,nr) > 0) nr_g = nr_g + 1
  if(modulo(n,nc) > 0) nc_g = nc_g + 1

  allocate( A(1-r:nr_g+r,1-r:nc_g+r)[dims(1),*], stat=err)
  if (err .ne. 0) then
    write(*,'(a,i3)') 'allocation of A returned ',err
    stop 1
  endif

  allocate( B(1:nr_g,1:nc_g), stat=err )
  if (err .ne. 0) then
    write(*,'(a,i3)') 'allocation of B returned ',err
    stop 1
  endif

  norm = 0.d0
  active_points = int(n-2*r,INT64)**2

  if (me == 1) then
    write(*,'(a,i8)') 'Number of images     = ',num_images()
    write(*,'(a,i8)') 'Number of iterations = ', iterations
    write(*,'(a,i8)') 'Grid size            = ', n
    write(*,'(a,i8)') 'Radius of stencil    = ', r
    if (is_star) then
      write(*,'(a,a)')  'Type of stencil      = star'
      stencil_size = 4*r+1
    else
      write(*,'(a,a)')  'Type of stencil      = grid'
      stencil_size = (2*r+1)**2
    endif
    !write(*,'(a)') 'Data type            = double precision'
    !write(*,'(a)') 'Compact representation of stencil loop body'
    if (tiling) then
      write(*,'(a,i5)') 'Tile size            = ', tile_size
    else
      write(*,'(a)') 'Untiled'
    endif
  endif

  call initialize_w(is_star,r,W)

  ! Getting the remote size of the upper and left images
  ! in order to initialize correctly the local grid A.
  nr_g = 0; nc_g = 0
  do k=1,coords(1)-1
     nr_g = nr_g + nr[k,coords(2)]
  enddo
  do k=1,coords(2)-1
     nc_g = nc_g + nc[coords(1),k]
  enddo

  ! intialize the input and output arrays
  do j=1,nc
    do i=1,nr
      A(i,j) = cx*(i+nr_g)+cy*(j+nc_g)
    enddo
  enddo

  do j=1,nc
    do i=1,nr
      B(i,j) = 0.d0
    enddo
  enddo

  start_i = 0
  start_j = 0
  end_i = nr - 1
  end_j = nc - 1

  if(coords(1) == 1)       start_i = r
  if(coords(1) == dims(1)) end_i = nr - r - 1
  if(coords(2) == 1)       start_j = r
  if(coords(2) == dims(2)) end_j = nc - r - 1

  ! top remote dimensions
  if(coords(1)>1) then
     nr_t = nr[coords(1)-1,coords(2)]
     nc_t = nc[coords(1)-1,coords(2)]
  endif

  ! bottom remote dimension
  if(coords(1)<dims(1)) nc_b = nc[coords(1)+1,coords(2)]

  ! left remote dimensions
  if(coords(2)>1) then
     nr_l = nr[coords(1),coords(2)-1]
     nc_l = nc[coords(1),coords(2)-1]
  endif

  !right remote dimension
  if(coords(2)<dims(2)) nr_r = nr[coords(1),coords(2)+1]

  t0 = 0

  sync all

  do k=0,iterations

     ! exchanging data in y-direction
     !top
     if(coords(1)>1) then
        a(1-r:0,1:nc_t) = a(nr_t-r+1:nr_t,1:nc_t)[coords(1)-1,coords(2)]
     endif
     !bottom
     if(coords(1)<dims(1)) then
        a(nr+1:nr+r,1:nc_b) = a(1:r,1:nc_b)[coords(1)+1,coords(2)]
     endif
     sync all
     !exchanging data in x-direction
     !left
     if(coords(2)>1) then
        a(1-r:nr_l+r,1-r:0) = a(1-r:nr_l+r,nc_l-r+1:nc_l)[coords(1),coords(2)-1]
     endif
     !right
     if(coords(2)<dims(2)) then
        a(1-r:nr_r+r,nc+1:nc+r) = a(1-r:nr_r+r,1:r)[coords(1),coords(2)+1]
     endif

     sync all

    ! start timer after a warmup iteration
    if (k.eq.1) then
       t0 = prk_get_wtime()
       sync all
    endif

    ! Apply the stencil operator
    if (.not.tiling) then
      do j=start_j,end_j
        do i=start_i,end_i
#ifdef STAR
            ! do not use Intel Fortran unroll directive here (slows down)
            do jj=-r,r
              B(i+1,j+1) = B(i+1,j+1) + W(0,jj) * A(i+1,j+jj+1)
            enddo
            do ii=-r,-1
              B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
            enddo
            do ii=1,r
              B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
            enddo
#else
            do jj=-r,r
              do ii=-r,r
                B(i+1,j+1) = B(i+1,j+1) + W(ii,jj) * A(i+ii+1,j+jj+1)
              enddo
            enddo
#endif
        enddo
      enddo
    else ! tiling
      do jt=r,n-r-1,tile_size
        do it=r,n-r-1,tile_size
          do j=jt,min(n-r-1,jt+tile_size-1)
            do i=it,min(n-r-1,it+tile_size-1)
#ifdef STAR
                do jj=-r,r
                  B(i+1,j+1) = B(i+1,j+1) + W(0,jj) * A(i+1,j+jj+1)
                enddo
                do ii=-r,-1
                  B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
                enddo
                do ii=1,r
                  B(i+1,j+1) = B(i+1,j+1) + W(ii,0) * A(i+ii+1,j+1)
                enddo
#else
                do jj=-r,r
                  do ii=-r,r
                    B(i+1,j+1) = B(i+1,j+1) + W(ii,jj) * A(i+ii+1,j+jj+1)
                  enddo
                enddo
#endif
            enddo
          enddo
        enddo
      enddo
    endif ! tiling

    ! add constant to solution to force refresh of neighbor data, if any
    do j=1,nc
      do i=1,nr
        A(i,j) = A(i,j) + 1.d0
      enddo
    enddo

    sync all

  enddo ! iterations

  t1 = prk_get_wtime()

  sync all

  ! compute L1 norm

  start_i = 1
  start_j = 1
  end_i = nr
  end_j = nc

  if(coords(1) == 1)       start_i = r
  if(coords(2) == 1)       start_j = r
  if(coords(1) == dims(1)) end_i = nr - r
  if(coords(2) == dims(2)) end_j = nc - r

  do j=start_j,end_j
    do i=start_i,end_i
      norm = norm + abs(B(i,j))
    enddo
  enddo

  stencil_time = t1 - t0
!  Collectives are part of Fortran 2015
!  call co_sum(norm,result_image=1)
  sync all
  if(me == 1) then
     do i=2,np
        norm = norm + norm[i]
     enddo
     norm = norm / real(active_points,REAL64)
  endif

  !******************************************************************************
  !* Analyze and output results.
  !******************************************************************************

  deallocate( B )
  deallocate( A )

  ! Jeff: valgrind says that this is branching on uninitialized value (norm),
  !       but this is nonsense since norm is initialized to 0 at line 167.

  ! verify correctness
  if(me == 1) then
     reference_norm = real(iterations+1,REAL64) * (cx + cy);
     if (abs(norm-reference_norm) .gt. epsilon) then
        write(*,'(a,f13.6,a,f13.6)') 'ERROR: L1 norm = ', norm, &
             ' Reference L1 norm = ', reference_norm
     else
        write(*,'(a)') 'Solution validates'
#ifdef VERBOSE
        write(*,'(a,f13.6,a,f13.6)') 'VERBOSE: L1 norm = ', norm, &
             ' Reference L1 norm = ', reference_norm
#endif
     endif
  flops = int(2*stencil_size+1,INT64) * active_points
  avgtime = stencil_time/iterations
  write(*,'(a,f13.6,a,f13.6)') 'Rate (MFlops/s): ',1.0d-6*flops/avgtime, &
                               ' Avg time (s): ',avgtime
  endif

end program main


function i4_uniform ( a, b, seed )

!*****************************************************************************80
!
!! I4_UNIFORM returns a scaled pseudorandom I4.
!
!  Discussion:
!
!    An I4 is an integer ( kind = 4 ) value.
!
!    The pseudorandom number will be scaled to be uniformly distributed
!    between A and B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 November 2006
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley Interscience, page 95, 1998.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) A, B, the limits of the interval.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, integer ( kind = 4 ) I4_UNIFORM, a number between A and B.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 4 ) b
  integer ( kind = 4 ) i4_uniform
  integer ( kind = 4 ) k
  real ( kind = 4 ) r
  integer ( kind = 4 ) seed
  integer ( kind = 4 ) value

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'I4_UNIFORM - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop
  end if

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + 2147483647
  end if

  r = real ( seed, kind = 4 ) * 4.656612875E-10
!
!  Scale R to lie between A-0.5 and B+0.5.
!
  r = ( 1.0E+00 - r ) * ( real ( min ( a, b ), kind = 4 ) - 0.5E+00 ) &
    +             r   * ( real ( max ( a, b ), kind = 4 ) + 0.5E+00 )
!
!  Use rounding to convert R to an integer between A and B.
!
  value = nint ( r, kind = 4 )

  value = max ( value, min ( a, b ) )
  value = min ( value, max ( a, b ) )

  i4_uniform = value

  return
end


! Copyright 2005-2018 ECMWF.
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!
!  Description: how to get values using keys.
!
!
program get
use eccodes
implicit none

  integer                                         ::  ifile
  integer                                         ::  iret
  integer                                         ::  igrib
  integer                                         ::  i
  real(kind=8)                                    ::  latitudeOfFirstPointInDegrees
  real(kind=8)                                    ::  longitudeOfFirstPointInDegrees
  real(kind=8)                                    ::  latitudeOfLastPointInDegrees
  real(kind=8)                                    ::  longitudeOfLastPointInDegrees
  real(kind=8)                                    ::  jDirectionIncrementInDegrees
  real(kind=8)                                    ::  iDirectionIncrementInDegrees
  integer(kind = 4)                               ::  numberOfPointsAlongAParallel
  integer(kind = 4)                               ::  numberOfPointsAlongAMeridian
  real(kind=8), dimension(:), allocatable         ::  values
  integer(kind = 4)                               ::  numberOfValues
  real(kind=8)                                    ::  average

  call codes_open_file(ifile, &
       '../../data/reduced_latlon_surface.grib1','r')

  ! A new grib message is loaded from file
  ! igrib is the grib id to be used in subsequent calls
  call  codes_grib_new_from_file(ifile,igrib)

  ! get as a integer
  call codes_get(igrib,'numberOfPointsAlongAParallel', &
                               numberOfPointsAlongAParallel)
  write(*,*) 'numberOfPointsAlongAParallel=', &
              numberOfPointsAlongAParallel

  ! get as a integer
  call codes_get(igrib,'numberOfPointsAlongAMeridian', &
                                       numberOfPointsAlongAMeridian)
  write(*,*) 'numberOfPointsAlongAMeridian=', &
              numberOfPointsAlongAMeridian

  ! get as a real8
  call codes_get(igrib, &
                      'latitudeOfFirstGridPointInDegrees', &
                       latitudeOfFirstPointInDegrees)
  write(*,*) 'latitudeOfFirstGridPointInDegrees=', &
            latitudeOfFirstPointInDegrees

  !     get as a real8
  call codes_get(igrib, &
               'longitudeOfFirstGridPointInDegrees', &
                longitudeOfFirstPointInDegrees)
  write(*,*) 'longitudeOfFirstGridPointInDegrees=', &
      longitudeOfFirstPointInDegrees

  ! get as a real8
  call codes_get(igrib, &
      'latitudeOfLastGridPointInDegrees', &
      latitudeOfLastPointInDegrees)
  write(*,*) 'latitudeOfLastGridPointInDegrees=', &
      latitudeOfLastPointInDegrees

  ! get as a real8
  call codes_get(igrib, &
      'longitudeOfLastGridPointInDegrees', &
      longitudeOfLastPointInDegrees)
  write(*,*) 'longitudeOfLastGridPointInDegrees=', &
              longitudeOfLastPointInDegrees

  ! get as a real8
  call codes_get(igrib, &
                   'jDirectionIncrementInDegrees', &
                    jDirectionIncrementInDegrees)
  write(*,*) 'jDirectionIncrementInDegrees=', &
              jDirectionIncrementInDegrees

  ! get as a real8
  call codes_get(igrib, &
       'iDirectionIncrementInDegrees', &
        iDirectionIncrementInDegrees)
  write(*,*) 'iDirectionIncrementInDegrees=', &
              iDirectionIncrementInDegrees

  ! get the size of the values array
  call codes_get_size(igrib,'values',numberOfValues)
  write(*,*) 'numberOfValues=',numberOfValues

  allocate(values(2*numberOfValues), stat=iret)
  ! get data values
  print*, size(values)
  call codes_get(igrib,'values',values)

  average = 0
  do i=1,numberOfValues
        average = average + values(i);
  enddo

  average =average / numberOfValues

  write(*,*)'There are ',numberOfValues, &
            ' average is ',average

  call codes_release(igrib)

  call codes_close_file(ifile)

  deallocate(values)
end program get


! { dg-do run }
program main
  real, dimension(3,2) :: a
  real, dimension(3) :: bp
  real, dimension(3) :: res1
  real, dimension(:), allocatable :: c3
  real, dimension(2) :: res2

  data a /-2., 3., -5., 7., -11., 13./
  data bp /-23., -31., -41./
  data res2 /158., -353./

  c3 = matmul(bp,a)
  if (size(c3,1) /= 2) call abort
  if (any(c3 /= res2)) call abort

end program main


module pec_scattering
    use bessel_mod
    use legendre_mod
    implicit none

    ! imaginary unit
    complex(8), parameter, private  :: IU = (0.0d0, 1.0d0)

contains
    ! Computes the scattering due to a incident plane wave at
    ! a PEC semisphere on top of an infinite PEC plane, in TM polarization
    subroutine sphere_plane_scattering_TM(xyz_list, k, a, alpha, Eo, n_terms, Es_list)
        real(8), intent(in) :: xyz_list(:, :)  ! list of points = [x1, y1, z1; x2, y2, z2; ...]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: a               ! sphere radius [m]
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        complex(8), intent(in) :: Eo           ! incident electric field amplitud [V/m]
        integer, intent(in) :: n_terms         ! number of terms in Mie series
        complex(8), allocatable, intent(out) :: Es_list(:, :) ! total scattered electric field in V/m
                                                              ![Ex1, Ey1, Ez1; Ex2, Ey2, Ez2; ...]
        complex(8), allocatable :: Ei_mirror(:, :)    ! mirror incident field
        complex(8), allocatable :: Es_mirror(:, :)    ! mirror scattered field

        ! compute scattered field (TM)
        call sphere_scattering(xyz_list, k, a, alpha, Eo, n_terms, .false., Es_list)

        ! compute mirror scattered field (TM)
        call sphere_scattering(xyz_list, k, a, -alpha, Eo, n_terms, .false., Es_mirror)

        ! compute mirror incident field (TM)
        call incident_plane_wave_TM(xyz_list, k, -alpha, Eo, Ei_mirror)

        ! compute total scattered field
        Es_list = Es_list + Es_mirror + Ei_mirror
    end subroutine

    ! Computes the scattering due to a incident plane wave at
    ! a PEC semisphere on top of an infinite PEC plane, in TE polarization
    subroutine sphere_plane_scattering_TE(xyz_list, k, a, alpha, Eo, n_terms, Es_list)
        real(8), intent(in) :: xyz_list(:, :)  ! list of points = [x1, y1, z1; x2, y2, z2; ...]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: a               ! sphere radius [m]
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        complex(8), intent(in) :: Eo           ! incident electric field amplitud [V/m]
        integer, intent(in) :: n_terms         ! number of terms in Mie series
        complex(8), allocatable, intent(out) :: Es_list(:, :) ! total scattered electric field in V/m
                                                              ![Ex1, Ey1, Ez1; Ex2, Ey2, Ez2; ...]
        complex(8), allocatable :: Ei_mirror(:, :)    ! mirror incident field
        complex(8), allocatable :: Es_mirror(:, :)    ! mirror scattered field

        ! compute scattered field (TE)
        call sphere_scattering(xyz_list, k, a, alpha, Eo, n_terms, .true., Es_list)

        ! compute mirror scattered field (TE)
        call sphere_scattering(xyz_list, k, a, -alpha, -Eo, n_terms, .true., Es_mirror)

        ! compute mirror incident field (TE)
        call incident_plane_wave_TE(xyz_list, k, -alpha, -Eo, Ei_mirror)

        ! compute total field
        Es_list = Es_list + Es_mirror + Ei_mirror
    end subroutine

    ! Computes the scattering due to a incident plane wave at
    ! a PEC sphere, in TE or TM polarization
    subroutine sphere_scattering(xyz_list, k, a, alpha, Eo, n_terms, te_mode, Es_list)
        real(8), intent(in) :: xyz_list(:, :)  ! list of points = [x1, y1, z1; x2, y2, z2; ...]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: a               ! sphere radius [m]
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        complex(8), intent(in) :: Eo           ! incident electric field amplitud [V/m]
        integer, intent(in) :: n_terms         ! number of terms in Mie series
        logical, intent(in) :: te_mode         ! .true. to compute TE mode, .false. to compute TM mode
        complex(8), allocatable, intent(out) :: Es_list(:, :) ! scattered electric field in V/m
                                                              ![Ex1, Ey1, Ez1; Ex2, Ey2, Ez2; ...]
        integer :: n
        integer :: n_points         ! number of points in xyz_list

        real(8) :: R1(3, 3)         ! Rotation matrix, from cartesian to rotated cartesian coords (x -> x')

        complex(8) :: an_coeff(1:n_terms)   ! a_n coefficients
        complex(8) :: bn_coeff(1:n_terms)   ! b_n coefficients
        complex(8) :: cn_coeff(1:n_terms)   ! c_n coefficients

        complex(8), allocatable :: Hn(:)     ! Riccati-Bessel-Hankel2_n(k * a)
        complex(8), allocatable :: Hn_d(:)   ! (d/d(ka)) Riccati-Bessel-Hankel2_n(ka)
        complex(8), allocatable :: Hn_dd(:)   ! (d/d(ka))^2 Riccati-Bessel-Hankel2_n(ka)

        ! initialize rotation matrix R1 (column order)
        if (te_mode) then
            ! TE mode
            R1 = reshape([1d0, 0d0, 0d0, &
                          0d0, -sin(alpha), cos(alpha), &
                          0d0, -cos(alpha), -sin(alpha)], &
                          shape=[3, 3])
        else
            ! TM mode
            R1 = reshape([0d0, 1d0, 0d0, &
                          sin(alpha), 0d0, cos(alpha), &
                          cos(alpha), 0d0, -sin(alpha)], &
                          shape=[3, 3])
        end if

        ! compute Riccate-Bessel Hankel, second kind, for n=0,n_term
        ! argument: k * a
        call rb_hankel2(n_terms, k * a, Hn, Hn_d, Hn_dd)

        ! compute coefficients
        an_coeff = [(IU**(-n) * (2*n + 1)/n/(n + 1), n=1,n_terms)]
        bn_coeff = -an_coeff * dreal(Hn_d(1:n_terms)) / Hn_d(1:n_terms)
        cn_coeff = -an_coeff * dreal(Hn(1:n_terms)) / Hn(1:n_terms)

        ! compute scattered field for each point
        n_points = size(xyz_list, 2)
        allocate(Es_list(3, n_points))
        do n = 1, n_points
            call sphere_scattering_point(xyz_list(:, n), k, R1, n_terms,  &
                                            bn_coeff, cn_coeff, Es_list(:, n))
        end do

        ! scale field
        Es_list = Eo * Es_list
    end subroutine

    ! Computes the scattering due to a incident plane wave at
    ! a PEC sphere, in TE or TM polarization, in a single point
    subroutine sphere_scattering_point(xyz, k, R1, n_terms, bn_coeff, cn_coeff, Es_list)
        real(8), intent(in) :: xyz(3)          ! point coordinates = [x, y, z]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: R1(3, 3)        ! rotation matrix, from cartesian to rotated cartesian coords (x -> x')
        integer, intent(in) :: n_terms         ! number of terms in Mie series
        complex(8), intent(in) :: bn_coeff(1:n_terms)  ! b_n coefficients
        complex(8), intent(in) :: cn_coeff(1:n_terms)  ! c_n coefficients
        complex(8), intent(out) :: Es_list(3)  ! scattered electric field in V/m, [Ex, Ey, Ez]

        real(8) xyz_prime(3)              ! rotated cartesian coordinates (x')
        real(8) :: r, kr, r_aux
        real(8) :: sin_theta, cos_theta
        real(8) :: sin_phi, cos_phi

        real(8) :: R2(3, 3)            ! rotation matrix, from rotated cartesian to rotated spherical (x' -> r')

        complex(8), allocatable :: Hn(:)     ! Riccati-Bessel-Hankel2_n(kr)
        complex(8), allocatable :: Hn_d(:)   ! (d/d(kr)) Riccati-Bessel-Hankel2_n(kr)
        complex(8), allocatable :: Hn_dd(:)  ! (d/d(kr))^2 Riccati-Bessel-Hankel2_n(kr)
        real(8), allocatable :: Pn1(:)    ! P_l^1(cos(theta))
        real(8), allocatable :: Pn1_d(:)  ! (d/d(cos theta)) P_l^1(cos theta)

        complex(8) :: Es_r       ! scattered field, radial component
        complex(8) :: Es_theta   ! scattered field, theta component
        complex(8) :: Es_phi     ! scattered field, phi component

        ! cartesian to rotated spherical coordinates
        r = sqrt(xyz(1)**2 + xyz(2)**2 + xyz(3)**2)
        kr = k * r

        xyz_prime = matmul(R1, xyz)
        r_aux = sqrt(r**2 - xyz_prime(3)**2)

        sin_theta = r_aux / r
        cos_theta = xyz_prime(3) / r
        sin_phi = xyz_prime(2) / r_aux
        cos_phi = xyz_prime(1) / r_aux

        ! initialize rotation matrix R2 (column order)
        R2 = reshape([sin_theta * cos_phi, cos_theta * cos_phi, -sin_phi, &
                      sin_theta * sin_phi, cos_theta * sin_phi, cos_phi, &
                      cos_theta, -sin_theta, 0d0], &
                      shape=[3, 3])

        ! compute Riccate-Bessel Hankel, second kind, for n=0, .., n_term
        ! argument: k * r
        call rb_hankel2(n_terms, kr, Hn, Hn_d, Hn_dd)

        ! compute associated Legendre functions, m=1, for l=0, .., n_term
        ! argument: cos(theta)
        call associated_legendre(cos_theta, n_terms, m=1, p_nm=Pn1, p_nm_d=Pn1_d)

        ! compute field in rotated spherical components
        associate(Hn_ => Hn(1:n_terms),       &
                  Hn_d_ => Hn_d(1:n_terms),   &
                  Hn_dd_ => Hn_dd(1:n_terms), &
                  Pn1_ => Pn1(1:n_terms),     &
                  Pn1_d_ => Pn1_d(1:n_terms))

        Es_r = -IU * cos_phi * sum(bn_coeff * (Hn_dd_ + Hn_) * Pn1_)
        Es_theta = cos_phi / kr * sum(IU * bn_coeff * Hn_d_ * sin_theta * Pn1_d_  &
                                      - cn_coeff * Hn_ * Pn1_ / sin_theta)
        Es_phi = sin_phi / kr * sum(IU * bn_coeff * Hn_d_ * Pn1_ / sin_theta  &
                                    - cn_coeff * Hn_ * sin_theta * Pn1_d_)
        end associate

        ! transform field from rotated spherical components
        ! to cartesian components
        block
            complex(8) :: matmul1(3)
            matmul1 = matmul(transpose(R2), [Es_r, Es_theta, Es_phi])
            Es_list = matmul(transpose(R1), matmul1)
        end block
    end subroutine

    ! Computes an incident plane wave, in TE polarization
    subroutine incident_plane_wave_TE(xyz_list, k, alpha, Eo, Ei_list)
        real(8), intent(in) :: xyz_list(:, :)  ! list of points = [x1, y1, z1; x2, y2, z2; ...]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: alpha           ! incidence angle in (-pi, 0)
        complex(8), intent(in) :: Eo           ! incident electric field amplitud [V/m]
        complex(8), allocatable, intent(out) :: Ei_list(:, :) ! incident electric field in V/m
                                                              ![Ex1, Ey1, Ez1; Ex2, Ey2, Ez2; ...]
        integer :: n
        integer :: n_points
        real(8) :: k_sin_alpha, k_cos_alpha
        real(8) :: y, z

        n_points = size(xyz_list, 2)
        k_sin_alpha = k * sin(alpha)
        k_cos_alpha = k * cos(alpha)

        allocate(Ei_list(3, n_points))
        Ei_list = 0d0
        do n = 1, n_points
            y = xyz_list(2, n)
            z = xyz_list(3, n)

            ! field only has x component
            Ei_list(1, n) = exp(-IU * (k_cos_alpha * y - k_sin_alpha * z))
        end do

        ! scale field
        Ei_list = Eo * Ei_list
    end subroutine

    ! Computes an incident plane wave, in TM polarization
    subroutine incident_plane_wave_TM(xyz_list, k, alpha, Eo, Ei_list)
        real(8), intent(in) :: xyz_list(:, :)  ! list of points = [x1, y1, z1; x2, y2, z2; ...]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        complex(8), intent(in) :: Eo           ! incident electric field amplitud [V/m]
        complex(8), allocatable, intent(out) :: Ei_list(:, :) ! incident electric field in V/m
                                                              ![Ex1, Ey1, Ez1; Ex2, Ey2, Ez2; ...]
        integer :: n
        integer :: n_points
        real(8) :: sin_alpha, cos_alpha
        real(8) :: k_sin_alpha, k_cos_alpha
        real(8) :: y, z
        complex(8) :: phase

        n_points = size(xyz_list, 2)
        sin_alpha = sin(alpha)
        cos_alpha = cos(alpha)
        k_sin_alpha = k * sin_alpha
        k_cos_alpha = k * cos_alpha

        allocate(Ei_list(3, n_points))
        Ei_list = 0d0
        do n = 1, n_points
            y = xyz_list(2, n)
            z = xyz_list(3, n)
            phase = exp(-IU * (k_cos_alpha * y - k_sin_alpha * z))

            ! field only has y and z component
            Ei_list(2, n) = sin_alpha * phase
            Ei_list(3, n) = cos_alpha * phase
        end do

        ! scale field
        Ei_list = Eo * Ei_list
    end subroutine

end module


MODULE baroclinic_wave

!=======================================================================
!
!  Date:  July 29, 2015
!
!  Functions for setting up idealized initial conditions for the
!  Ullrich, Melvin, Staniforth and Jablonowski baroclinic instability.
!
!  SUBROUTINE baroclinic_wave_sample(
!    deep,moist,pertt,X,lon,lat,p,z,zcoords,u,v,w,t,phis,ps,rho,q)
!
!  Options:
!     deep    deep atmosphere (1 = yes or 0 = no)
!    moist    include moisture (1 = yes or 0 = no)
!    pertt    type of perturbation (0 = exponential, 1 = stream function)
!        X    Earth scaling factor
!
!  Given a point specified by:
!      lon    longitude (radians)
!      lat    latitude (radians)
!      p/z    pressure (Pa) / height (m)
!  zcoords    1 if z is specified, 0 if p is specified
!
!  the functions will return:
!        p    pressure if z is specified and zcoords = 1 (Pa)
!        u    zonal wind (m s^-1)
!        v    meridional wind (m s^-1)
!        t    temperature (K)
!   thetav    virtual potential temperature (K)
!     phis    surface geopotential (m^2 s^-2)
!       ps    surface pressure (Pa)
!      rho    density (kj m^-3)
!        q    water vapor mixing ratio (kg/kg)
!
!
!  Author: Paul Ullrich
!          University of California, Davis
!          Email: paullrich@ucdavis.edu
!
!=======================================================================

  IMPLICIT NONE
  PUBLIC :: baroclinic_wave_test

!=======================================================================
!    Physical constants
!=======================================================================

  REAL(8), PARAMETER ::               &
       a     = 6371220.0d0,           & ! Reference Earth's Radius (m)
       Rd    = 287.0d0,               & ! Ideal gas const dry air (J kg^-1 K^1)
       g     = 9.80616d0,             & ! Gravity (m s^2)
       cp    = 1004.5d0,              & ! Specific heat capacity (J kg^-1 K^1)
       Lvap  = 2.5d6,                 & ! Latent heat of vaporization of water
       Rvap  = 461.5d0,               & ! Ideal gas constnat for water vapor
       Mvap  = 0.608d0,               & ! Ratio of molar mass of dry air/water
       pi    = 3.14159265358979d0,    & ! pi
       p0    = 100000.0d0,            & ! surface pressure (Pa)
       kappa = 2.d0/7.d0,             & ! Ratio of Rd to cp
       omega = 7.29212d-5,            & ! Reference rotation rate of the Earth (s^-1)
       deg2rad  = pi/180.d0             ! Conversion factor of degrees to radians

!=======================================================================
!    Test case parameters
!=======================================================================
  REAL(8), PARAMETER ::               &
       T0E        = 310.d0     ,      & ! temperature at equatorial surface (K)
       T0P        = 240.d0     ,      & ! temperature at polar surface (K)
       B          = 2.d0       ,      & ! jet half-width parameter
       K          = 3.d0       ,      & ! jet width parameter
       lapse      = 0.005d0             ! lapse rate parameter

  REAL(8), PARAMETER ::               &
       pertu0     = 0.5d0      ,      & ! SF Perturbation wind velocity (m/s)
       pertr      = 1.d0/6.d0  ,      & ! SF Perturbation radius (Earth radii)
       pertup     = 1.0d0      ,      & ! Exp. perturbation wind velocity (m/s)
       pertexpr   = 0.1d0      ,      & ! Exp. perturbation radius (Earth radii)
       pertlon    = pi/9.d0    ,      & ! Perturbation longitude
       pertlat    = 2.d0*pi/9.d0,     & ! Perturbation latitude
       pertz      = 15000.d0   ,      & ! Perturbation height cap
       dxepsilon  = 1.d-5               ! Small value for numerical derivatives

  REAL(8), PARAMETER ::               &
       moistqlat  = 2.d0*pi/9.d0,     & ! Humidity latitudinal width
       moistqp    = 34000.d0,         & ! Humidity vertical pressure width
       moisttr    = 0.1d0,            & ! Vertical cut-off pressure for humidity
       moistqs    = 1.d-12,           & ! Humidity above cut-off
       moistq0    = 0.018d0,          & ! Maximum specific humidity
       moistqr    = 0.9d0,            & ! Maximum saturation ratio
       moisteps   = 0.622d0,          & ! Ratio of gas constants
       moistT0    = 273.16d0,         & ! Reference temperature (K)
       moistE0Ast = 610.78d0            ! Saturation vapor pressure at T0 (Pa)

CONTAINS

!=======================================================================
!    Generate the baroclinic instability initial conditions
!=======================================================================
  SUBROUTINE baroclinic_wave_test(deep,moist,pertt,X,lon,lat,p,z,zcoords,u,v,t,thetav,phis,ps,rho,q) &
    BIND(c, name = "baroclinic_wave_test")

    IMPLICIT NONE

!-----------------------------------------------------------------------
!     input/output params parameters at given location
!-----------------------------------------------------------------------
    INTEGER, INTENT(IN)  :: &
                deep,       & ! Deep (1) or Shallow (0) test case
                moist,      & ! Moist (1) or Dry (0) test case
                pertt         ! Perturbation type

    REAL(8), INTENT(IN)  :: &
                lon,        & ! Longitude (radians)
                lat,        & ! Latitude (radians)
                X             ! Earth scaling parameter

    REAL(8), INTENT(INOUT) :: &
                p,            & ! Pressure (Pa)
                z               ! Altitude (m)

    INTEGER, INTENT(IN) :: zcoords     ! 1 if z coordinates are specified
                                       ! 0 if p coordinates are specified

    REAL(8), INTENT(OUT) :: &
                u,          & ! Zonal wind (m s^-1)
                v,          & ! Meridional wind (m s^-1)
                t,          & ! Temperature (K)
                thetav,     & ! Virtual potential temperature (K)
                phis,       & ! Surface Geopotential (m^2 s^-2)
                ps,         & ! Surface Pressure (Pa)
                rho,        & ! density (kg m^-3)
                q             ! water vapor mixing ratio (kg/kg)

    !------------------------------------------------
    !   Local variables
    !------------------------------------------------
    REAL(8) :: aref, omegaref
    REAL(8) :: T0, constH, constC, scaledZ, inttau2, rratio
    REAL(8) :: inttermU, bigU, rcoslat, omegarcoslat
    REAL(8) :: eta, qratio, qnum, qden

    !------------------------------------------------
    !   Pressure and temperature
    !------------------------------------------------
    if (zcoords .eq. 1) then
      CALL evaluate_pressure_temperature(deep, X, lon, lat, z, p, t)
    else
      CALL evaluate_z_temperature(deep, X, lon, lat, p, z, t)
    end if

    !------------------------------------------------
    !   Compute test case constants
    !------------------------------------------------
    aref = a / X
    omegaref = omega * X

    T0 = 0.5d0 * (T0E + T0P)

    constH = Rd * T0 / g

    constC = 0.5d0 * (K + 2.d0) * (T0E - T0P) / (T0E * T0P)

    scaledZ = z / (B * constH)

    inttau2 = constC * z * exp(- scaledZ**2)

    ! radius ratio
    if (deep .eq. 0) then
      rratio = 1.d0
    else
      rratio = (z + aref) / aref;
    end if

    !-----------------------------------------------------
    !   Initialize surface pressure
    !-----------------------------------------------------
    ps = p0

    !-----------------------------------------------------
    !   Initialize velocity field
    !-----------------------------------------------------
    inttermU = (rratio * cos(lat))**(K - 1.d0) - (rratio * cos(lat))**(K + 1.d0)
    bigU = g / aref * K * inttau2 * inttermU * t
    if (deep .eq. 0) then
      rcoslat = aref * cos(lat)
    else
      rcoslat = (z + aref) * cos(lat)
    end if

    omegarcoslat = omegaref * rcoslat

    u = - omegarcoslat + sqrt(omegarcoslat**2 + rcoslat * bigU)
    v = 0.d0

    !-----------------------------------------------------
    !   Add perturbation to the velocity field
    !-----------------------------------------------------

    ! Exponential type
    if (pertt .eq. 0) then
      u = u + evaluate_exponential(lon, lat, z)

    ! Stream function type
    elseif (pertt .eq. 1) then
      u = u - 1.d0 / (2.d0 * dxepsilon) *                       &
          ( evaluate_streamfunction(lon, lat + dxepsilon, z)    &
          - evaluate_streamfunction(lon, lat - dxepsilon, z))

      v = v + 1.d0 / (2.d0 * dxepsilon * cos(lat)) *            &
          ( evaluate_streamfunction(lon + dxepsilon, lat, z)    &
          - evaluate_streamfunction(lon - dxepsilon, lat, z))
    end if

    !-----------------------------------------------------
    !   Initialize surface geopotential
    !-----------------------------------------------------
    phis = 0.d0

    !-----------------------------------------------------
    !   Initialize density
    !-----------------------------------------------------
    rho = p / (Rd * t)

    !-----------------------------------------------------
    !   Initialize specific humidity
    !-----------------------------------------------------
    if (moist .eq. 1) then
      eta = p/p0

      if (eta .gt. moisttr) then
        q = moistq0 * exp(- (lat/moistqlat)**4)          &
                    * exp(- ((eta-1.d0)*p0/moistqp)**2)
      else
        q = moistqs
      end if

      ! Convert virtual temperature to temperature
      t = t / (1.d0 + Mvap * q)

    else
      q = 0.d0
    end if

    !-----------------------------------------------------
    !   Initialize virtual potential temperature
    !-----------------------------------------------------
    thetav = t * (1.d0 + 0.61d0 * q) * (p0 / p)**(Rd / cp)

  END SUBROUTINE baroclinic_wave_test

!-----------------------------------------------------------------------
!    Calculate pointwise pressure and temperature
!-----------------------------------------------------------------------
  SUBROUTINE evaluate_pressure_temperature(deep, X, lon, lat, z, p, t)

    INTEGER, INTENT(IN)  :: deep ! Deep (1) or Shallow (0) test case

    REAL(8), INTENT(IN)  :: &
                X,          & ! Earth scaling ratio
                lon,        & ! Longitude (radians)
                lat,        & ! Latitude (radians)
                z             ! Altitude (m)

    REAL(8), INTENT(OUT) :: &
                p,          & ! Pressure (Pa)
                t             ! Temperature (K)

    REAL(8) :: aref, omegaref
    REAL(8) :: T0, constA, constB, constC, constH, scaledZ
    REAL(8) :: tau1, tau2, inttau1, inttau2
    REAL(8) :: rratio, inttermT

    !--------------------------------------------
    ! Constants
    !--------------------------------------------
    aref = a / X
    omegaref = omega * X

    T0 = 0.5d0 * (T0E + T0P)
    constA = 1.d0 / lapse
    constB = (T0 - T0P) / (T0 * T0P)
    constC = 0.5d0 * (K + 2.d0) * (T0E - T0P) / (T0E * T0P)
    constH = Rd * T0 / g

    scaledZ = z / (B * constH)

    !--------------------------------------------
    !    tau values
    !--------------------------------------------
    tau1 = constA * lapse / T0 * exp(lapse * z / T0) &
         + constB * (1.d0 - 2.d0 * scaledZ**2) * exp(- scaledZ**2)
    tau2 = constC * (1.d0 - 2.d0 * scaledZ**2) * exp(- scaledZ**2)

    inttau1 = constA * (exp(lapse * z / T0) - 1.d0) &
            + constB * z * exp(- scaledZ**2)
    inttau2 = constC * z * exp(- scaledZ**2)

    !--------------------------------------------
    !    radius ratio
    !--------------------------------------------
    if (deep .eq. 0) then
      rratio = 1.d0
    else
      rratio = (z + aref) / aref;
    end if

    !--------------------------------------------
    !    interior term on temperature expression
    !--------------------------------------------
    inttermT = (rratio * cos(lat))**K &
             - K / (K + 2.d0) * (rratio * cos(lat))**(K + 2.d0)

    !--------------------------------------------
    !    temperature
    !--------------------------------------------
    t = 1.d0 / (rratio**2 * (tau1 - tau2 * inttermT))

    !--------------------------------------------
    !    hydrostatic pressure
    !--------------------------------------------
    p = p0 * exp(- g / Rd * (inttau1 - inttau2 * inttermT))

  END SUBROUTINE evaluate_pressure_temperature

!-----------------------------------------------------------------------
!    Calculate pointwise z and temperature given pressure
!-----------------------------------------------------------------------
  SUBROUTINE evaluate_z_temperature(deep, X, lon, lat, p, z, t)

    INTEGER, INTENT(IN)  :: deep ! Deep (1) or Shallow (0) test case

    REAL(8), INTENT(IN)  :: &
                X,          & ! Earth scaling ratio
                lon,        & ! Longitude (radians)
                lat,        & ! Latitude (radians)
                p             ! Pressure (Pa)

    REAL(8), INTENT(OUT) :: &
                z,          & ! Altitude (m)
                t             ! Temperature (K)

    INTEGER :: ix

    REAL(8) :: z0, z1, z2
    REAL(8) :: p0, p1, p2

    z0 = 0.d0
    z1 = 10000.d0

    CALL evaluate_pressure_temperature(deep, X, lon, lat, z0, p0, t)
    CALL evaluate_pressure_temperature(deep, X, lon, lat, z1, p1, t)

    DO ix = 1, 100
      z2 = z1 - (p1 - p) * (z1 - z0) / (p1 - p0)

      CALL evaluate_pressure_temperature(deep, X, lon, lat, z2, p2, t)

      IF (ABS((p2 - p)/p) .lt. 1.0d-13) THEN
        EXIT
      END IF

      z0 = z1
      p0 = p1

      z1 = z2
      p1 = p2
    END DO

    z = z2

    CALL evaluate_pressure_temperature(deep, X, lon, lat, z, p0, t)

  END SUBROUTINE evaluate_z_temperature

!-----------------------------------------------------------------------
!    Exponential perturbation function
!-----------------------------------------------------------------------
  REAL(8) FUNCTION evaluate_exponential(lon, lat, z)

    REAL(8), INTENT(IN)  :: &
                lon,        & ! Longitude (radians)
                lat,        & ! Latitude (radians)
                z             ! Altitude (meters)

    REAL(8) :: greatcircler, perttaper

    ! Great circle distance
    greatcircler = 1.d0 / pertexpr &
      * acos(sin(pertlat) * sin(lat) + cos(pertlat) * cos(lat) * cos(lon - pertlon))

    ! Vertical tapering of stream function
    if (z < pertz) then
      perttaper = 1.d0 - 3.d0 * z**2 / pertz**2 + 2.d0 * z**3 / pertz**3
    else
      perttaper = 0.d0
    end if

    ! Zonal velocity perturbation
    if (greatcircler < 1.d0) then
      evaluate_exponential = pertup * perttaper * exp(- greatcircler**2)
    else
      evaluate_exponential = 0.d0
    end if

  END FUNCTION evaluate_exponential

!-----------------------------------------------------------------------
!    Stream function perturbation function
!-----------------------------------------------------------------------
  REAL(8) FUNCTION evaluate_streamfunction(lon, lat, z)

    REAL(8), INTENT(IN)  :: &
                lon,        & ! Longitude (radians)
                lat,        & ! Latitude (radians)
                z             ! Altitude (meters)

    REAL(8) :: greatcircler, perttaper, cospert

    ! Great circle distance
    greatcircler = 1.d0 / pertr &
      * acos(sin(pertlat) * sin(lat) + cos(pertlat) * cos(lat) * cos(lon - pertlon))

    ! Vertical tapering of stream function
    if (z < pertz) then
      perttaper = 1.d0 - 3.d0 * z**2 / pertz**2 + 2.d0 * z**3 / pertz**3
    else
      perttaper = 0.d0
    end if

    ! Horizontal tapering of stream function
    if (greatcircler .lt. 1.d0) then
      cospert = cos(0.5d0 * pi * greatcircler)
    else
      cospert = 0.d0
    end if

    evaluate_streamfunction = &
        (- pertu0 * pertr * perttaper * cospert**4)

  END FUNCTION evaluate_streamfunction

END MODULE baroclinic_wave


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mncuev : curev test program                        cc
cc             evaluation of a closed planar curve                    cc
cc                    x = sx(u) , y = sy(u)                           cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real u(20),t(20),c(40),sp(40)
      integer i,idim,i1,i2,ier,j,jn,j1,j2,j3,j4,k,k1,m,mx,n,nc,nk,nk1
      real ai,per
c  we have a planar curve
      idim = 2
c  set up the dimension information
      nc = 40
      mx = 40
c  set up the points where the curve will be evaluated.
      m = 20
      do 10 i=1,m
        ai = i-1
        u(i) = ai*0.5e-01
  10  continue
c  main loop for the different spline degrees.
      do 50 k=1,5
        k1 = k+1
c  n denotes the total number of knots.
        n = 2*k1+4
c  set up the knots of the spline
        t(k1) = 0.
        t(k1+1) = 0.1e0
        t(k1+2) = 0.3e0
        t(k1+3) = 0.4e0
        t(k1+4) = 0.8e0
        t(k1+5) = 0.1e+01
c  fetch the b-spline coefficients for sx(u)
        c(1) = 0.1e+01
        c(2) = 0.3e+01
        c(3) = 0.4e+01
        c(4) = 0.5e+01
        c(5) = -0.1e+01
c  fetch the b-spline coefficients for sy(u)
        c(n+1) = 0.1e+01
        c(n+2) = 0.2e+01
        c(n+3) = -0.3e+01
        c(n+4) = 0.2e+01
        c(n+5) = 0.4e+01
c  incorporate the boundary conditions for periodic splines
        nk = n-k
        per = t(nk)-t(k1)
        do 20 j=1,k
c  the boundary knots
          i1 = nk+j
          i2 = nk-j
          j1 = k1+j
          j2 = k1-j
          t(i1) = t(j1)+per
          t(j2) = t(i2)-per
c  the boundary coefficients
          jn = j+n
          c(j+5) = c(j)
          c(jn+5) = c(jn)
  20    continue
c  evaluate the spline curve
        call curev(idim,t,n,c,nc,k,u,m,sp,mx,ier)
c  print the results.
        write(6,900) k
        write(6,905)
        write(6,910) (t(i),i=1,n)
        write(6,915)
        nk1 = n-k1
        write(6,920) (c(i),i=1,nk1)
        write(6,925)
        i1 = n+1
        i2 = n+nk1
        write(6,920) (c(i),i=i1,i2)
        write(6,930)
        i2 = 0
        j4 = 0
        do 40 j=1,10
          i1 = i2+1
          i2 = i1+1
          j1 = j4+1
          j2 = j1+1
          j3 = j2+1
          j4 = j3+1
          write(6,935) i1,u(i1),sp(j1),sp(j2),i2,u(i2),sp(j3),sp(j4)
  40    continue
  50  continue
      stop
c  format statements.
 900  format(31h0degree of the spline curve k =,i2)
 905  format(1x,21hposition of the knots)
 910  format(5x,12f6.1)
 915  format(1x,30hb-spline coefficients of sx(u))
 920  format(5x,14f5.0)
 925  format(1x,30hb-spline coefficients of sy(u))
 930  format(1x,2(5x,1hi,3x,4hu(i),4x,8hsx(u(i)),4x,8hsy(u(i))))
 935  format(1x,2(i6,f7.2,2f12.5))
      end


subroutine collision()
    use commondata
    implicit none
    integer :: i, j
    integer :: alpha
    !---------------------------
    real(8) :: s(0:8)
    real(8) :: m(0:8)
    real(8) :: m_post(0:8)
    real(8) :: meq(0:8)
    !---------------------------

    do j=1,ny
        do i=1,nx

    m(0) = f(0,i,j)+f(1,i,j)+f(2,i,j)+f(3,i,j)+f(4,i,j)+f(5,i,j)+f(6,i,j)+f(7,i,j)+f(8,i,j)
    m(1) = -4.0d0*f(0,i,j)-f(1,i,j)-f(2,i,j)-f(3,i,j)-f(4,i,j)+2.0d0*(f(5,i,j)+f(6,i,j)+f(7,i,j)+f(8,i,j))
    m(2) = 4.0d0*f(0,i,j)-2.0d0*(f(1,i,j)+f(2,i,j)+f(3,i,j)+f(4,i,j))+f(5,i,j)+f(6,i,j)+f(7,i,j)+f(8,i,j)
    m(3) = f(1,i,j)-f(3,i,j)+f(5,i,j)-f(6,i,j)-f(7,i,j)+f(8,i,j)
    m(4) = -2.0d0*f(1,i,j)+2.0d0*f(3,i,j)+f(5,i,j)-f(6,i,j)-f(7,i,j)+f(8,i,j)
    m(5) = f(2,i,j)-f(4,i,j)+f(5,i,j)+f(6,i,j)-f(7,i,j)-f(8,i,j)
    m(6) = -2.0d0*f(2,i,j)+2.0d0*f(4,i,j)+f(5,i,j)+f(6,i,j)-f(7,i,j)-f(8,i,j)
    m(7) = f(1,i,j)-f(2,i,j)+f(3,i,j)-f(4,i,j)
    m(8) = f(5,i,j)-f(6,i,j)+f(7,i,j)-f(8,i,j)

            meq(0) = rho(i,j)
            meq(1) = rho(i,j)*( -2.0d0+3.0d0*(u(i,j)*u(i,j)+v(i,j)*v(i,j)) )
            meq(2) = rho(i,j)*( 1.0d0-3.0d0*(u(i,j)*u(i,j)+v(i,j)*v(i,j)) )
            meq(3) = rho(i,j)*u(i,j)
            meq(4) = -rho(i,j)*u(i,j)
            meq(5) = rho(i,j)*v(i,j)
            meq(6) = -rho(i,j)*v(i,j)
            meq(7) = rho(i,j)*( u(i,j)*u(i,j)-v(i,j)*v(i,j) )
            meq(8) = rho(i,j)*( u(i,j)*v(i,j) )

            s(0) = 0.0d0      !!s_{\rho}
            s(1) = Snu !!s_{e}
            s(2) = Snu !!s_{\epsilon}
            s(3) = 0.0d0      !!s_{j}
            s(4) = Sq !!s_{q}
            s(5) = 0.0d0      !!s_{j}
            s(6) = Sq       !!s_{q}
            s(7) = Snu !!s_{\nu}
            s(8) = Snu       !!s_{\nu}

            do alpha=0,8
                m_post(alpha) = m(alpha)-s(alpha)*(m(alpha)-meq(alpha))
            enddo

    f_post(0,i,j) = ( m_post(0)-m_post(1)+m_post(2) )/9.0d0
    f_post(1,i,j) = m_post(0)/9.0d0-m_post(1)/36.0d0-m_post(2)/18.0d0+m_post(3)/6.0d0-m_post(4)/6.0d0 &
                    +m_post(7)*0.25d0
    f_post(2,i,j) = m_post(0)/9.0d0-m_post(1)/36.0d0-m_post(2)/18.0d0 &
                    +m_post(5)/6.0d0-m_post(6)/6.0d0-m_post(7)*0.25d0
    f_post(3,i,j) = m_post(0)/9.0d0-m_post(1)/36.0d0-m_post(2)/18.0d0-m_post(3)/6.0d0+m_post(4)/6.0d0 &
                    +m_post(7)*0.25d0
    f_post(4,i,j) = m_post(0)/9.0d0-m_post(1)/36.0d0-m_post(2)/18.0d0 &
                    -m_post(5)/6.0d0+m_post(6)/6.0d0-m_post(7)*0.25d0
    f_post(5,i,j) = m_post(0)/9.0d0+m_post(1)/18.0d0+m_post(2)/36.0d0+m_post(3)/6.0d0+m_post(4)/12.0d0 &
                    +m_post(5)/6.0d0+m_post(6)/12.0d0+m_post(8)*0.25d0
    f_post(6,i,j) = m_post(0)/9.0d0+m_post(1)/18.0d0+m_post(2)/36.0d0-m_post(3)/6.0d0-m_post(4)/12.0d0 &
                    +m_post(5)/6.0d0+m_post(6)/12.0d0-m_post(8)*0.25d0
    f_post(7,i,j) = m_post(0)/9.0d0+m_post(1)/18.0d0+m_post(2)/36.0d0-m_post(3)/6.0d0-m_post(4)/12.0d0 &
                    -m_post(5)/6.0d0-m_post(6)/12.0d0+m_post(8)*0.25d0
    f_post(8,i,j) = m_post(0)/9.0d0+m_post(1)/18.0d0+m_post(2)/36.0d0+m_post(3)/6.0d0+m_post(4)/12.0d0 &
                    -m_post(5)/6.0d0-m_post(6)/12.0d0-m_post(8)*0.25d0
        enddo
    enddo

    return
end subroutine collision

subroutine streaming()
    use commondata
    implicit none
    integer :: i, j
    integer :: ip, jp
    integer :: alpha

    do j=1,ny
        do i=1,nx
            do alpha=0,8
                ip = i-ex(alpha)
                jp = j-ey(alpha)

                f(alpha,i,j) = f_post(alpha,ip,jp)
            enddo
        enddo
    enddo

    return
end subroutine streaming

subroutine macro()
    use commondata
    implicit none
    integer :: i, j

    do j=1,ny
        do i=1,nx
            rho(i,j) = f(0,i,j)+f(1,i,j)+f(2,i,j)+f(3,i,j)+f(4,i,j)+f(5,i,j)+f(6,i,j)+f(7,i,j)+f(8,i,j)
            u(i,j) = ( f(1,i,j)-f(3,i,j)+f(5,i,j)-f(6,i,j)-f(7,i,j)+f(8,i,j) )/rho(i,j)
            v(i,j) = ( f(2,i,j)-f(4,i,j)+f(5,i,j)+f(6,i,j)-f(7,i,j)-f(8,i,j) )/rho(i,j)
        enddo
    enddo

    return
end subroutine macro

subroutine check()
    use mpi
    use commondata
    implicit none
    integer :: i, j
    real(8) :: error1, error2
    real(8) :: total_error1, total_error2

    error1 = 0.0d0
    error2 = 0.0d0

    do j=1,ny
        do i=1,nx
            error1 = error1+(u(i,j)-up(i,j))*(u(i,j)-up(i,j))+(v(i,j)-vp(i,j))*(v(i,j)-vp(i,j))
            error2 = error2+u(i,j)*u(i,j)+v(i,j)*v(i,j)
        enddo
    enddo

    up = u
    vp = v

    call MPI_Barrier(comm2d, rc)

    call MPI_ALLreduce(error1, total_error1, 1, MPI_REAL8, MPI_SUM, comm2d, rc)
    call MPI_ALLreduce(error2, total_error2, 1, MPI_REAL8, MPI_SUM, comm2d, rc)

    errorU = sqrt(total_error1)/sqrt(total_error2)

    if (rank2d == 0) then
        write(*,*) itc,' ',errorU
    endif

    return
end subroutine check


      SUBROUTINE MFFTRP(NN,RW)
*
*  THIS ROUTINE PREPARES THE PHASE FACTOR TABLES TO BE USED IN THE
*  POST-PROCESSING PHASE IN REAL TRANSFORMS, I.E. R2FFT AND R3FFT.
*
*  THE DEFINITION OF PHASE FACTORS WE USE IS THE FOLLOWING
*
*             RW(IV) = -I*EXP(-I*2*PI/NN*IV)
*
*  WHERE THE SYMBOLS ARE:
*
*  I: IMAGINARY UNIT
*  NN : NUMBER OF REAL ELEMENTS
*  IV: RUNNING INDEX FROM 0 TO NN-1
*
*
*
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX RW(0:*)
*
*
      PI2=8*ATAN(1.)
      PHASE=PI2/NN
      RW(0)=(0.,-1.)
*
*
      DO 10 I=1,NN-1
      RW(I)=DCMPLX(-SIN(I*PHASE),-COS(I*PHASE))
 10   CONTINUE
*
*
      END


      subroutine xyz_to_polar_d(x,y,z,dec,ra,r)

      include 'trigd.inc'

      r=SQRT(x**2+y**2+z**2)
      dec=ASIND(z/r)
      ra=ATAN3D(y,x)

      return
      end


!@sum  RES_M23 Resolution info for 23 layer, 4x5 strat model
!@auth Original Development Team
!@ver  1.0

      MODULE RESOLUTION
!@sum  RESOLUTION contains horiz/vert resolution variables
!@auth Original Development Team
!@ver  1.0
      IMPLICIT NONE
      SAVE
!@var IM,JM longitudinal and latitudinal number of grid boxes
!@var LM number of vertical levels
!@var LS1 Layers LS1->LM: constant pressure levels, L<LS1: sigma levels
      INTEGER, PARAMETER :: IM=72,JM=46,LM=23, LS1=12

!@var PSF,PMTOP global mean surface, model top pressure  (mb)
!@var PTOP pressure at interface level sigma/const press coord syst (mb)
      REAL*8, PARAMETER :: PSF=984.d0, PTOP = 150.d0, PMTOP=2.0576514d-3
!@var PSFMPT,PSTRAT pressure due to troposhere,stratosphere
      REAL*8, PARAMETER :: PSFMPT=PSF-PTOP, PSTRAT=PTOP-PMTOP

!@var PLbot pressure levels at bottom of layers (mb)
      REAL*8, PARAMETER, DIMENSION(LM+1) :: PLbot = (/
     t     PSF,   960.d0,  929.d0,  884.d0,  819.d0,    ! Pbot L=1,5
     t  710.d0,   570.d0,  425.d0,  314.d0,  245.d0,    !      L=6,10
     t  192.d0,                                         !      L=11
     1    PTOP,                                         !      L=LS1
     s  117.d0,   86.2d0,  56.2d0,  31.6d0,  17.8d0,    !      L=13-17
     s  10.0d0,   4.63d0,  1.46d0,  0.460995258d0,      !      L=18-21
     s  0.1449994968d0,    3.12002802d-2,    PMTOP /)   !      L=..,LM+1

C**** KEP depends on whether stratos. EP flux diagnostics are calculated
C**** If dummy EPFLUX is used set KEP=0, otherwise KEP=21
!@param KEP number of lat/height E-P flux diagnostics
      INTEGER, PARAMETER :: KEP=21

C**** Based on model top, determine how much of stratosphere is resolved
C****         PMTOP >= 10 mb,    ISTRAT = 0
C**** 1 mb <= PMTOP <  10 mb,    ISTRAT = 1
C****         PMTOP <   1 mb,    ISTRAT = 2
      INTEGER, PARAMETER :: ISTRAT = 2

      END MODULE RESOLUTION

C**** The vertical resolution also determines whether
C**** stratospheric wave drag will be applied or not.
C**** This resolution is for a stratospheric model and so must be used
C**** in conjunction with the strat. modules


C-----------------------------------------------------------------------
      SUBROUTINE SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
     &                  IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP,
     &                  JBEG,JEND,JCPU,
     &                  WAVE,GRIDN,GRIDS,IDIR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPTRAN     PERFORM A SCALAR SPHERICAL TRANSFORM
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-29
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM
C           BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES
C           AND FIELDS ON A GLOBAL CYLINDRICAL GRID.
C           THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
C           THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID
C           (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID.
C           THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING,
C           BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER',
C           I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX.
C           TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY;
C           THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED.
C           IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS
C           MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM.
C           THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT
C           THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED
C           OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY.
C           TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
C           SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C PROGRAM HISTORY LOG:
C   96-02-29  IREDELL
C 1998-12-15  IREDELL  GENERIC FFT USED
C                      OPENMP DIRECTIVES INSERTED
C
C USAGE:    CALL SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
C    &                  IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP,
C    &                  JBEG,JEND,JCPU,
C    &                  WAVE,GRIDN,GRIDS,IDIR)
C   INPUT ARGUMENTS:
C     IROMB    - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     MAXWV    - INTEGER SPECTRAL TRUNCATION
C     IDRT     - INTEGER GRID IDENTIFIER
C                (IDRT=4 FOR GAUSSIAN GRID,
C                 IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
C                 IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
C     IMAX     - INTEGER EVEN NUMBER OF LONGITUDES.
C     JMAX     - INTEGER NUMBER OF LATITUDES.
C     KMAX     - INTEGER NUMBER OF FIELDS TO TRANSFORM.
C     IPRIME   - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN.
C                (DEFAULTS TO 1 IF IPRIME=0)
C     ISKIP    - INTEGER SKIP NUMBER BETWEEN LONGITUDES
C                (DEFAULTS TO 1 IF ISKIP=0)
C     JNSKIP   - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH
C                (DEFAULTS TO IMAX IF JNSKIP=0)
C     JSSKIP   - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH
C                (DEFAULTS TO -IMAX IF JSSKIP=0)
C     KWSKIP   - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS
C                (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0)
C     KGSKIP   - INTEGER SKIP NUMBER BETWEEN GRID FIELDS
C                (DEFAULTS TO IMAX*JMAX IF KGSKIP=0)
C     JBEG     - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM
C                (DEFAULTS TO 1 IF JBEG=0)
C                (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM)
C     JEND     - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM
C                (DEFAULTS TO (JMAX+1)/2 IF JEND=0)
C     JCPU     - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS
C     WAVE     - REAL (*) WAVE FIELDS IF IDIR>0
C     GRIDN    - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0
C     GRIDS    - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0
C     IDIR     - INTEGER TRANSFORM FLAG
C                (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE)
C   OUTPUT ARGUMENTS:
C     WAVE     - REAL (*) WAVE FIELDS IF IDIR<0
C     GRIDN    - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0
C     GRIDS    - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0
C
C SUBPROGRAMS CALLED:
C   SPTRANF      PERFORM A SCALAR SPHERICAL TRANSFORM
C
C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL:
C   DIMENSION                    LINEAR              QUADRATIC
C   -----------------------      ---------           -------------
C   IMAX                         2*MAXWV+2           3*MAXWV/2*2+2
C   JMAX (IDRT=4,IROMB=0)        1*MAXWV+1           3*MAXWV/2+1
C   JMAX (IDRT=4,IROMB=1)        2*MAXWV+1           5*MAXWV/2+1
C   JMAX (IDRT=0,IROMB=0)        2*MAXWV+3           3*MAXWV/2*2+3
C   JMAX (IDRT=0,IROMB=1)        4*MAXWV+3           5*MAXWV/2*2+3
C   JMAX (IDRT=256,IROMB=0)      2*MAXWV+1           3*MAXWV/2*2+1
C   JMAX (IDRT=256,IROMB=1)      4*MAXWV+1           5*MAXWV/2*2+1
C   -----------------------      ---------           -------------
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      REAL WAVE(*),GRIDN(*),GRIDS(*)
!==EM==        integer JC, JCPU
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!==EM==
!        print *, "jjjjjjjcccccccccc  from SPTRAN- before NCPUS", JC
      MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
      IP=IPRIME
      IS=ISKIP
      JN=JNSKIP
      JS=JSSKIP
      KW=KWSKIP
      KG=KGSKIP
      JB=JBEG
      JE=JEND
      JC=JCPU
      IF(IP.EQ.0) IP=1
      IF(IS.EQ.0) IS=1
      IF(JN.EQ.0) JN=IMAX
      IF(JS.EQ.0) JS=-JN
      IF(KW.EQ.0) KW=2*MX
      IF(KG.EQ.0) KG=IMAX*JMAX
      IF(JB.EQ.0) JB=1
      IF(JE.EQ.0) JE=(JMAX+1)/2
      IF(JC.EQ.0) JC=NCPUS()
!	JC=NCPUS()
!==EM==
!        print *, "jjjjjjjjjjjjjjjjjjjjcccccccccc  from SPTRAN", JC
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(IDIR.LT.0.AND.JBEG.EQ.0) THEN
        DO K=1,KMAX
          KWS=(K-1)*KW
          WAVE(KWS+1:KWS+2*MX)=0
        ENDDO
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!==EM==
!        print *, "jjjjjjjcccccccccc  from SPTRANF- before NCPUS", JC
      CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,
     &             IP,IS,JN,JS,KW,KG,JB,JE,JC,
     &             WAVE,GRIDN,GRIDS,IDIR)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


!
! Planck_Functions
!
! Module containing Planck function radiance, temperature, dB/dT, and
! dT/dB routines.
!
!
! CREATION HISTORY:
!       Written by:   Paul van Delst, 14-Oct-1999
!                     paul.vandelst@noaa.gov
!

MODULE Planck_Functions

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Modules used
  USE Type_Kinds           , ONLY: fp
  USE Fundamental_Constants, ONLY: C_1, C_2, &
                                   Fundamental_Constants_Version
  USE Message_Handler      , ONLY: SUCCESS, FAILURE, Display_Message
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Planck_Radiance
  PUBLIC :: Planck_Temperature
  PUBLIC :: Planck_dBdT
  PUBLIC :: Planck_dTdB
  PUBLIC :: Planck_Version

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  ! Numeric literals
  REAL(fp), PARAMETER :: ONE = 1.0_fp
  ! Unit types
  INTEGER, PARAMETER :: N_UNIT_TYPES = 2
  INTEGER, PARAMETER :: FREQUENCY_INDEX  = 1
  INTEGER, PARAMETER :: WAVELENGTH_INDEX = 2
  ! Scale factors. One for each unit type.
  REAL(fp), PARAMETER :: RADIANCE_SCALE_FACTOR(N_UNIT_TYPES) = (/  1000.0_fp, 1.0_fp /)
  REAL(fp), PARAMETER :: C_1_SCALE_FACTOR(N_UNIT_TYPES)      = (/ 1.0e+08_fp, 1.0e+24_fp /)
  REAL(fp), PARAMETER :: C_2_SCALE_FACTOR(N_UNIT_TYPES)      = (/   100.0_fp, 1.0e+06_fp /)

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Planck_Radiance
!
! PURPOSE:
!       Elemental subroutine to calculate the Planck Radiance given the
!       spectral ordinate (frequency or wavelength) and temperature.
!
! CALLING SEQUENCE:
!       CALL Planck_Radiance( x                                , & ! Input
!                             Temperature                      , & ! Input
!                             Radiance                         , & ! Output
!                             Wavelength_Units=Wavelength_Units  ) ! Optional input
!
! INPUTS:
!       x:                  Spectral ordinate.
!                           UNITS:      Inverse centimetres (cm^-1)
!                                         or
!                                       Microns (um).
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Scalar or any rank.
!                           ATTRIBUTES: INTENT(IN)
!
!       Temperature:        Temperature(s) for which the Planck Radiance(s)
!                           is(are) required. Can be a SCALAR or VECTOR.
!                           See Radiance output description for allowed
!                           dimensionality.
!                           UNITS:      Kelvin
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Radiance:           The Planck radiance for the supplied temperature.
!                           UNITS:      mW/(m2.sr.cm-1)
!                                         or
!                                       W/(m2.sr.micron)
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Wavelength_Units:   Set this logical argument to specify the spectral
!                           ordinate and radiance units in terms of wavelength
!                           rather than frequency.
!                           If == .FALSE., Input spectral ordinate units are cm^-1,  [DEFAULT]
!                                          Ouptut Radiance units are mW/(m2.sr.cm-1) [DEFAULT]
!                              == .TRUE.,  Input spectral ordinate units are microns
!                                          Ouptut Radiance units are W/(m2.sr.micron)
!                           If not specified, default is .FALSE.
!                           UNITS:      N/A
!                           TYPE:       LOGICAL
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(IN), OPTIONAL
!
! PROCEDURE:
!       For frequency input, the Planck Radiance is calculated using:
!
!                   c1 * frequency^3
!         B =  ---------------------------
!                  ( c2 * frequency )
!               EXP( -------------- ) - 1
!                  (        T       )
!
!       For wavelength input:
!
!                                    c1
!         B = --------------------------------------------------
!                             [    (        c2      )     ]
!              wavelength^5 * [ EXP( -------------- ) - 1 ]
!                             [    ( wavelength * T )     ]
!
!       c1 and c2 are determined using:
!          c1 = 2*h*c*c  [W.m2]
!          c2 = h*c/k    [K.m]
!
!       A scaling is applied to the Planck Radiance results to return
!       Radiances in the Units of mW/(m2.sr.cm-1) for frequency input
!       or W/(m2.sr.micron) for wavelength input.
!
!       FREQUENCY
!       ---------
!       To alter c1 from W.m2 to W/(m2.cm-4) a multiplier of 1.0e+08
!       is required. The solid angle is dimensionless and implied,
!       i.e. W/(m2.cm-4) => W/(m2.st.cm-4). Similarly for c2, K.m ->
!       K.cm a multiplier of 100 is required. In addition, to return
!       mW rather than W, an additional scaling of 1000 is applied.
!
!       WAVELENGTH
!       ----------
!       To alter c1 from W.m2 to W/(m2.um-4) a multiplier of 1.0e+24
!       is required. The solid angle is dimensionless and implied,
!       i.e. W/(m2.um-4) => W/(m2.sr.um-4). Similarly for c2, K.m ->
!       K.um a multiplier of 1.0e+06 is required.
!
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE Planck_Radiance( &
    x               , &  ! Input
    Temperature     , &  ! Input
    Radiance        , &  ! Output
    Wavelength_Units  )  ! Optional input
    ! Arguments
    REAL(fp),           INTENT(IN)  :: x
    REAL(fp),           INTENT(IN)  :: Temperature
    REAL(fp),           INTENT(OUT) :: Radiance
    LOGICAL , OPTIONAL, INTENT(IN)  :: Wavelength_Units
    ! Local variables
    LOGICAL :: Frequency_Units
    INTEGER :: Unit_Index
    REAL(fp) :: x_c_1, x_c_2
    REAL(fp) :: Exponential

    ! Set spectral units
    Frequency_Units = .TRUE.
    IF ( PRESENT(Wavelength_Units) ) Frequency_Units = .NOT. Wavelength_Units

    ! Calculate spectral parameters
    IF ( Frequency_Units ) THEN
      ! Spectral Units in cm^-1
      Unit_Index = FREQUENCY_INDEX
      x_c_1 = C_1_SCALE_FACTOR(Unit_Index) * C_1 * ( x**3 )
      x_c_2 = C_2_SCALE_FACTOR(Unit_Index) * C_2 * x
    ELSE
      ! Spectral Units in microns
      Unit_Index = WAVELENGTH_INDEX
      x_c_1 = C_1_SCALE_FACTOR(Unit_Index) * C_1 / ( x**5 )
      x_c_2 = C_2_SCALE_FACTOR(Unit_Index) * C_2 / x
    END IF

    ! Calculate radiance
    Exponential = EXP(x_c_2/Temperature)
    Radiance    = RADIANCE_SCALE_FACTOR(Unit_Index) * x_c_1 / ( Exponential - ONE )

  END SUBROUTINE Planck_Radiance

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Planck_Temperature
!
! PURPOSE:
!       Elemental subroutine to calculate the Planck temperature given the
!       spectral ordinate (frequency or wavelength), and radiance.
!
! CALLING SEQUENCE:
!       CALL Planck_Temperature( x                                , & ! Input
!                                Radiance                         , & ! Input
!                                Temperature                      , & ! Output
!                                Wavelength_Units=Wavelength_Units  ) ! Optional input
!
! INPUTS:
!       x:                  Spectral ordinate.
!                           UNITS:      Inverse centimetres (cm^-1) [DEFAULT]
!                                         OR
!                                       Microns (um).
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Scalar or any rank.
!                           ATTRIBUTES: INTENT(IN)
!
!       Radiance:           Planck radiance for which the temperature is
!                           required.
!                           UNITS:      mW/(m2.sr.cm-1) [DEFAULT]
!                                         OR
!                                       W/(m2.sr.micron)
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Temperature:        The brightness temperature corresponding to the
!                           supplied radiance.
!                           UNITS:      Kelvin
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Wavelength_Units:   Set this logical argument to specify the spectral
!                           ordinate and radiance units in terms of wavelength
!                           rather than frequency.
!                           If == .FALSE., Input spectral ordinate units are cm^-1, [DEFAULT]
!                                          Input Radiance units are mW/(m2.sr.cm-1) [DEFAULT]
!                              == .TRUE.,  Input spectral ordinate units are microns
!                                          Input Radiance units are W/(m2.sr.micron)
!                           If not specified, default is .FALSE.
!                           UNITS:      N/A
!                           TYPE:       LOGICAL
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(IN), OPTIONAL
!
! PROCEDURE:
!       For frequency input, the Planck temperature is calculated using:
!
!                    c2 * frequency
!         T = -----------------------------
!                ( c1 * frequency^3      )
!              LN( ---------------- +  1 )
!                (          B            )
!
!       For wavelength input :
!
!                                c2
!          T = -----------------------------------------
!                              (        c1            )
!               wavelength * LN( ---------------- + 1 )
!                              ( wavelength^5 * B     )
!
!       c1 and c2 are determined using:
!          c1 = 2*h*c*c  [W.m2]
!          c2 = h*c/k    [K.m]
!
!       A scaling is applied to the Planck Radiance results to return
!       Radiances in the Units of mW/(m2.sr.cm-1) for frequency input
!       or W/(m2.sr.micron) for wavelength input.
!
!       FREQUENCY
!       ---------
!       To alter c1 from W.m2 to W/(m2.cm-4) a multiplier of 1.0e+08
!       is required. The solid angle is dimensionless and implied,
!       i.e. W/(m2.cm-4) => W/(m2.st.cm-4). Similarly for c2, K.m ->
!       K.cm a multiplier of 100 is required. In addition, to return
!       mW rather than W, an additional scaling of 1000 is applied.
!
!       WAVELENGTH
!       ----------
!       To alter c1 from W.m2 to W/(m2.um-4) a multiplier of 1.0e+24
!       is required. The solid angle is dimensionless and implied,
!       i.e. W/(m2.um-4) => W/(m2.sr.um-4). Similarly for c2, K.m ->
!       K.um a multiplier of 1.0e+06 is required.
!
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE Planck_Temperature( &
    x               , &  ! Input
    Radiance        , &  ! Input
    Temperature     , &  ! output
    Wavelength_Units  )  ! Optional input
    ! Arguments
    REAL(fp),           INTENT(IN)  :: x
    REAL(fp),           INTENT(IN)  :: Radiance
    REAL(fp),           INTENT(OUT) :: Temperature
    LOGICAL , OPTIONAL, INTENT(IN)  :: Wavelength_Units
    ! Local variables
    LOGICAL :: Frequency_Units
    INTEGER :: Unit_Index
    REAL(fp) :: x_c_1, x_c_2
    REAL(fp) :: Logarithm

    ! Set spectral units
    Frequency_Units = .TRUE.
    IF ( PRESENT(Wavelength_Units) ) Frequency_Units = .NOT. Wavelength_Units

    ! Calculate spectral parameters
    IF ( Frequency_Units ) THEN
      ! Spectral Units in cm^-1
      Unit_Index = FREQUENCY_INDEX
      x_c_1 = C_1_SCALE_FACTOR(Unit_Index) * C_1 * ( x**3 )
      x_c_2 = C_2_SCALE_FACTOR(Unit_Index) * C_2 * x
    ELSE
      ! Spectral Units in microns
      Unit_Index = WAVELENGTH_INDEX
      x_c_1 = C_1_SCALE_FACTOR(Unit_Index) * C_1 / ( x**5 )
      x_c_2 = C_2_SCALE_FACTOR(Unit_Index) * C_2 / x
    END IF

    ! Calculate temperature
    Logarithm   = LOG( ( RADIANCE_SCALE_FACTOR(Unit_Index) * x_c_1 / Radiance ) + ONE )
    Temperature = x_c_2 / Logarithm

  END SUBROUTINE Planck_Temperature

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Planck_dBdT
!
! PURPOSE:
!       Elemental subroutine to calculate the derivative of the Planck
!       radiance with respect to temperature given the spectral ordinate
!       (frequency or wavelength) and temperature.
!
! CALLING SEQUENCE:
!       CALL Planck_dBdT( x                                , &  ! Input
!                         Temperature                      , &  ! Input
!                         dBdT                             , &  ! Output
!                         Wavelength_Units=Wavelength_Units  )  ! Optional input
!
! INPUTS:
!       x:                  Spectral ordinate.
!                           UNITS:      Inverse centimetres (cm^-1)
!                                         OR
!                                       Microns (um).
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Scalar or any rank.
!                           ATTRIBUTES: INTENT(IN)
!
!       Temperature:        Temperature for which the radiance derivative
!                           is required.
!                           UNITS:      Kelvin
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       dBdT:               The derivative of the Planck radiance with respect to
!                           temperature at the supplied temperature.
!                           UNITS:      mW/(m2.sr.cm-1.K)
!                                         OR
!                                       W/(m2.sr.um.K)
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Wavelength_Units:   Set this logical argument to specify the spectral
!                           ordinate and radiance units in terms of wavelength
!                           rather than frequency.
!                           If == .FALSE., Input spectral ordinate units are cm^-1, [DEFAULT]
!                                          Output dB/dT units are mW/(m2.sr.cm-1.K) [DEFAULT]
!                              == .TRUE.,  Input spectral ordinate units are microns
!                                          Output dB/dT units are W/(m2.sr.um.K)
!                           If not specified, default is .FALSE.
!                           UNITS:      N/A
!                           TYPE:       LOGICAL
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(IN), OPTIONAL
!
! PROCEDURE:
!       For frequency input, the Planck radiance derivative with respect
!       to temperature is calculated using :
!
!                                              ( c2 * frequency )
!                   c1 * c2 * frequency^4 * EXP( -------------- )
!                                              (        T       )
!          dB/dT = -----------------------------------------------
!                      {     [    ( c2 * frequency )     ] }^2
!                      { T * [ EXP( -------------- ) - 1 ] }
!                      {     [    (        T       )     ] }
!
!
!       For wavelength input :
!                                            (       c2       )
!                               c1 * c2 * EXP( -------------- )
!                                            ( wavelength * T )
!          dB/dT = --------------------------------------------------------
!                                  {     [    (       c2       )     ] }^2
!                   wavelength^6 * { T * [ EXP( -------------- ) - 1 ] }
!                                  {     [    ( wavelength * T )     ] }
!
!       c1 and c2 are determined using:
!          c1 = 2*h*c*c  [W.m2]
!          c2 = h*c/k    [K.m]
!
!       A scaling is applied to the Planck radiance results to return
!       radiances in the units of mW/(m2.sr.cm-1) for frequency input
!       or W/(m2.sr.micron) for wavelength input.
!
!       FREQUENCY
!       ---------
!       To alter c1 from W.m2 to W/(m2.cm-4) a multiplier of 1.0e+08
!       is required. The solid angle is dimensionless and implied,
!       i.e. W/(m2.cm-4) => W/(m2.st.cm-4). Similarly for c2, K.m ->
!       K.cm a multiplier of 100 is required. In addition, to return
!       mW rather than W, an additional scaling of 1000 is applied.
!
!       WAVELENGTH
!       ----------
!       To alter c1 from W.m2 to W/(m2.um-4) a multiplier of 1.0e+24
!       is required. The solid angle is dimensionless and implied,
!       i.e. W/(m2.um-4) => W/(m2.sr.um-4). Similarly for c2, K.m ->
!       K.um a multiplier of 1.0e+06 is required.
!
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE Planck_dBdT( &
    x               , &  ! Input
    Temperature     , &  ! Input
    dBdT            , &  ! Output
    Wavelength_Units  )  ! Optional input
    ! Arguments
    REAL(fp),           INTENT(IN)  :: x
    REAL(fp),           INTENT(IN)  :: Temperature
    REAL(fp),           INTENT(OUT) :: dBdT
    LOGICAL , OPTIONAL, INTENT(IN)  :: Wavelength_Units
    ! Local variables
    LOGICAL :: Frequency_Units
    INTEGER :: Unit_Index
    REAL(fp) :: x_c_1, x_c_2
    REAL(fp) :: Exponential

    ! Set spectral units
    Frequency_Units = .TRUE.
    IF ( PRESENT(Wavelength_Units) ) Frequency_Units = .NOT. Wavelength_Units

    ! Calculate spectral parameters
    IF ( Frequency_Units ) THEN
      ! Spectral Units in cm^-1
      Unit_Index = FREQUENCY_INDEX
      x_c_1 = C_1_SCALE_FACTOR(Unit_Index) * C_1 * &
              C_2_SCALE_FACTOR(Unit_Index) * C_2 * ( x**4 )
      x_c_2 = C_2_SCALE_FACTOR(Unit_Index) * C_2 * x
    ELSE
      ! Spectral Units in microns
      Unit_Index = WAVELENGTH_INDEX
      x_c_1 = C_1_SCALE_FACTOR(Unit_Index) * C_1 * &
              C_2_SCALE_FACTOR(Unit_Index) * C_2 / ( x**6 )
      x_c_2 = C_2_SCALE_FACTOR(Unit_Index) * C_2 / x
    END IF

    ! Calculate dBdT
    Exponential = EXP( x_c_2 / Temperature )
    dBdT        = RADIANCE_SCALE_FACTOR(Unit_Index) * x_c_1 * Exponential / &
                  ( Temperature * ( Exponential - ONE ) )**2

  END SUBROUTINE Planck_dBdT

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Planck_dTdB
!
! PURPOSE:
!       Elemental subroutine to calculate the Planck temperature derivative
!       with respect to radiance given the spectral ordinate (frequency or
!       wavelength) and radiance.
!
! CALLING SEQUENCE:
!       CALL Planck_dTdB( x                                , &  ! Input
!                         Radiance                         , &  ! Input
!                         dTdB                             , &  ! Output
!                         Wavelength_Units=Wavelength_Units  )  ! Optional input
!
!
! INPUTS:
!       x:                  Spectral ordinate.
!                           UNITS:      Inverse centimetres (cm^-1)
!                                         OR
!                                       Microns (um).
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Scalar or any rank.
!                           ATTRIBUTES: INTENT(IN)
!
!       Radiance:           Planck radiance for which the dT/dB derivative is
!                           required.
!                           UNITS:      mW/(m2.sr.cm-1)
!                                         OR
!                                       W/(m2.sr.micron)
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Conformable with the x input argument
!                           ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       dTdB:               The derivative of Planck temperature with respect
!                           to radiance.
!                           UNITS:      (K.m2.sr.cm-1)/mW
!                                         OR
!                                       (K.m2.sr.um)/W
!                           TYPE:       REAL(fp)
!                           DIMENSION:  Conformable with the x input argument.
!                           ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Wavelength_Units:   Set this logical argument to specify the spectral
!                           ordinate and radiance units in terms of wavelength
!                           rather than frequency.
!                           If == .FALSE., Input spectral ordinate units are cm^-1, [DEFAULT]
!                                          Input Radiance units are mW/(m2.sr.cm-1) [DEFAULT]
!                                          Output dT/dB units are (K.m2.sr.cm-1)/mW [DEFAULT]
!                              == .TRUE.,  Input spectral ordinate units are microns
!                                          Input Radiance units are W/(m2.sr.um)
!                                          Output dT/dB units are (K.m2.sr.um)/W
!                           If not specified, default is .FALSE.
!                           UNITS:      N/A
!                           TYPE:       LOGICAL
!                           DIMENSION:  Conformable with x input argument.
!                           ATTRIBUTES: INTENT(IN), OPTIONAL
!
! PROCEDURE:
!       For frequency input, the Planck temperature differential with respect
!       to radiance is calculated using:
!
!                               c1 * c2 * frequency^4
!  dT/dB = ------------------------------------------------------------------
!           { c1 * frequency^3     }   {       ( c1 * frequency^3      ) }^2
!           { ---------------- + 1 } * { B * LN( ---------------- +  1 ) }
!           {         B            }   {       (          B            ) }
!
!
!       For wavelength input:
!
!                                           c1 * c2
!  dT/dB = --------------------------------------------------------------------------------
!                          {        c1            }   {       (        c1            ) }^2
!           wavelength^6 * { ---------------- + 1 } * { B * LN( ---------------- + 1 ) }
!                          { wavelength^5 * B     }   {       ( wavelength^5 * B     ) }
!
!       c1 and c2 are determined using:
!          c1 = 2*h*c*c  [W.m2]
!          c2 = h*c/k    [K.m]
!
!       A scaling is applied to the Planck Radiances such that radiances
!       are in the units of mW/(m2.sr.cm-1) for frequency input or
!       W/(m2.sr.micron) for wavelength input.
!
!       FREQUENCY
!       ---------
!       To alter c1 from W.m2 to W/(m2.cm-4) a multiplier of 1.0e+08
!       is required. The solid angle is dimensionless and implied,
!       i.e. W/(m2.cm-4) => W/(m2.st.cm-4). Similarly for c2, K.m ->
!       K.cm a multiplier of 100 is required. In addition, to return
!       mW rather than W, an additional scaling of 1000 is applied.
!
!       WAVELENGTH
!       ----------
!       To alter c1 from W.m2 to W/(m2.um-4) a multiplier of 1.0e+24
!       is required. The solid angle is dimensionless and implied,
!       i.e. W/(m2.um-4) => W/(m2.sr.um-4). Similarly for c2, K.m ->
!       K.um a multiplier of 1.0e+06 is required.
!
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE Planck_dTdB( &
    x               , &  ! Input
    Radiance        , &  ! Input
    dTdB            , &  ! Output
    Wavelength_Units  )  ! Optional input
    ! Arguments
    REAL(fp),           INTENT(IN)  :: x
    REAL(fp),           INTENT(IN)  :: Radiance
    REAL(fp),           INTENT(OUT) :: dTdB
    LOGICAL , OPTIONAL, INTENT(IN)  :: Wavelength_Units
    ! Local variables
    LOGICAL :: Frequency_Units
    INTEGER :: Unit_Index
    REAL(fp) :: x_c_1, x_c_2
    REAL(fp) :: Scaled_Radiance
    REAL(fp) :: Argument

    ! Set spectral units
    Frequency_Units = .TRUE.
    IF ( PRESENT(Wavelength_Units) ) Frequency_Units = .NOT. Wavelength_Units

    ! Calculate spectral parameters
    IF ( Frequency_Units ) THEN
      ! Spectral Units in cm^-1
      Unit_Index = FREQUENCY_INDEX
      x_c_1 = C_1_SCALE_FACTOR(Unit_Index) * C_1 * ( x**3 )
      x_c_2 = C_2_SCALE_FACTOR(Unit_Index) * C_2 * x
    ELSE
      ! Spectral Units in microns
      Unit_Index = WAVELENGTH_INDEX
      x_c_1 = C_1_SCALE_FACTOR(Unit_Index) * C_1 / ( x**5 )
      x_c_2 = C_2_SCALE_FACTOR(Unit_Index) * C_2 / x
    END IF

    ! Calculate dTdB
    ! ...Radiance in terms of W
    Scaled_Radiance = Radiance / RADIANCE_SCALE_FACTOR(Unit_Index)
    ! ...Common term in dT/dB formulation
    Argument = ( x_c_1 / Scaled_Radiance ) + ONE
    ! ...Calculate dT/dB in (K.....)/W
    dTdB = x_c_1 * x_c_2 / ( Argument * ( Scaled_Radiance * LOG(Argument) )**2 )
    ! ...Convert dT/dB Units to (K...cm-1)/mW if required.
    dTdB = dTdB / RADIANCE_SCALE_FACTOR(Unit_Index)

  END SUBROUTINE Planck_dTdB

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Planck_Version
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL Planck_Version( Id )
!
! OUTPUTS:
!       Id:    Character string containing the version Id information
!              for the module.
!              UNITS:      N/A
!              TYPE:       CHARACTER(*)
!              DIMENSION:  Scalar
!              ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Planck_Version( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    CHARACTER(256) :: fundamental_constants_version_id
    CALL Fundamental_Constants_Version(fundamental_constants_version_id)
    Id = MODULE_VERSION_ID//'; '//TRIM(fundamental_constants_version_id)
  END SUBROUTINE Planck_Version

END MODULE Planck_Functions