module convert
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
! <doc>Convert from complex variable a(d1,d2,d3, ...) to a
! real variable ar(2,d1,d2,d3,...) and back.
! This is necessary for saving complex variables in NetCDF format</doc>
!
!     (c) Copyright 1991 to 1998 by Michael A. Beer, William D. Dorland,
!     P. B. Snyder, Q. P. Liu, and Gregory W. Hammett. ALL RIGHTS RESERVED.
!
   implicit none
   private
   public :: c2r, r2c

   interface c2r
      module procedure x1c2r
      module procedure x2c2r
      module procedure x3c2r
      module procedure x4c2r
      module procedure x5c2r
      module procedure x6c2r
   end interface

   interface r2c
      module procedure x1r2c
      module procedure x2r2c
      module procedure x3r2c
      module procedure x4r2c
      module procedure x5r2c
   end interface

contains
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x5c2r(a, a_ri)

      complex, dimension(:, :, :, :, :), intent(in) :: a
      real, dimension(:, :, :, :, :, :), intent(out) :: a_ri

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x5c2r: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x5c2r: size(a, 2) does not match size(a_ri, 3)')
      if (size(a, 3) /= size(a_ri, 4)) call aborter(6, 'x5c2r: size(a, 3) does not match size(a_ri, 4)')
      if (size(a, 4) /= size(a_ri, 5)) call aborter(6, 'x5c2r: size(a, 4) does not match size(a_ri, 5)')
      if (size(a, 5) /= size(a_ri, 6)) call aborter(6, 'x5c2r: size(a, 5) does not match size(a_ri, 6)')
      a_ri(1, :, :, :, :, :) = real(a(:, :, :, :, :))
      a_ri(2, :, :, :, :, :) = aimag(a(:, :, :, :, :))

   end subroutine x5c2r

   subroutine x6c2r(a, a_ri)

      complex, dimension(:, :, :, :, :, :), intent(in) :: a
      real, dimension(:, :, :, :, :, :, :), intent(out) :: a_ri

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x6c2r: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x6c2r: size(a, 2) does not match size(a_ri, 3)')
      if (size(a, 3) /= size(a_ri, 4)) call aborter(6, 'x6c2r: size(a, 3) does not match size(a_ri, 4)')
      if (size(a, 4) /= size(a_ri, 5)) call aborter(6, 'x6c2r: size(a, 4) does not match size(a_ri, 5)')
      if (size(a, 5) /= size(a_ri, 6)) call aborter(6, 'x6c2r: size(a, 5) does not match size(a_ri, 6)')
      if (size(a, 6) /= size(a_ri, 7)) call aborter(6, 'x6c2r: size(a, 6) does not match size(a_ri, 7)')
      a_ri(1, :, :, :, :, :, :) = real(a(:, :, :, :, :, :))
      a_ri(2, :, :, :, :, :, :) = aimag(a(:, :, :, :, :, :))

   end subroutine x6c2r
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x5r2c(a, a_ri)

      real, dimension(:, :, :, :, :, :), intent(in) :: a_ri
      complex, dimension(:, :, :, :, :), intent(out) :: a

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x5r2c: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x5r2c: size(a, 2) does not match size(a_ri, 3)')
      if (size(a, 3) /= size(a_ri, 4)) call aborter(6, 'x5r2c: size(a, 3) does not match size(a_ri, 4)')
      if (size(a, 4) /= size(a_ri, 5)) call aborter(6, 'x5r2c: size(a, 4) does not match size(a_ri, 5)')
      if (size(a, 5) /= size(a_ri, 6)) call aborter(6, 'x5r2c: size(a, 5) does not match size(a_ri, 6)')
      a(:, :, :, :, :) = cmplx(a_ri(1, :, :, :, :, :), a_ri(2, :, :, :, :, :))

   end subroutine x5r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x4c2r(a, a_ri)

      complex, dimension(:, :, :, :), intent(in) :: a
      real, dimension(:, :, :, :, :), intent(out) :: a_ri

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x4c2r: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x4c2r: size(a, 2) does not match size(a_ri, 3)')
      if (size(a, 3) /= size(a_ri, 4)) call aborter(6, 'x4c2r: size(a, 3) does not match size(a_ri, 4)')
      if (size(a, 4) /= size(a_ri, 5)) call aborter(6, 'x4c2r: size(a, 4) does not match size(a_ri, 5)')
      a_ri(1, :, :, :, :) = real(a(:, :, :, :))
      a_ri(2, :, :, :, :) = aimag(a(:, :, :, :))

   end subroutine x4c2r
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x4r2c(a, a_ri)

      real, dimension(:, :, :, :, :), intent(in) :: a_ri
      complex, dimension(:, :, :, :), intent(out) :: a

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x4r2c: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x4r2c: size(a, 2) does not match size(a_ri, 3)')
      if (size(a, 3) /= size(a_ri, 4)) call aborter(6, 'x4r2c: size(a, 3) does not match size(a_ri, 4)')
      if (size(a, 4) /= size(a_ri, 5)) call aborter(6, 'x4r2c: size(a, 4) does not match size(a_ri, 5)')
      a(:, :, :, :) = cmplx(a_ri(1, :, :, :, :), a_ri(2, :, :, :, :))

   end subroutine x4r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x3c2r(a, a_ri)

      complex, dimension(:, :, :), intent(in) :: a
      real, dimension(:, :, :, :), intent(out) :: a_ri

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x3c2r: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x3c2r: size(a, 2) does not match size(a_ri, 3)')
      if (size(a, 3) /= size(a_ri, 4)) call aborter(6, 'x3c2r: size(a, 3) does not match size(a_ri, 4)')
      a_ri(1, :, :, :) = real(a(:, :, :))
      a_ri(2, :, :, :) = aimag(a(:, :, :))

   end subroutine x3c2r
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x3r2c(a, a_ri)

      real, dimension(:, :, :, :), intent(in) :: a_ri
      complex, dimension(:, :, :), intent(out) :: a

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x3r2c: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x3r2c: size(a, 2) does not match size(a_ri, 3)')
      if (size(a, 3) /= size(a_ri, 4)) call aborter(6, 'x3r2c: size(a, 3) does not match size(a_ri, 4)')
      a(:, :, :) = cmplx(a_ri(1, :, :, :), a_ri(2, :, :, :))

   end subroutine x3r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x2c2r(a, a_ri)

      complex, dimension(:, :), intent(in) :: a
      real, dimension(:, :, :), intent(out) :: a_ri

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x2c2r: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x2c2r: size(a, 2) does not match size(a_ri, 3)')
      a_ri(1, :, :) = real(a(:, :))
      a_ri(2, :, :) = aimag(a(:, :))

   end subroutine x2c2r
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x2r2c(a, a_ri)

      real, dimension(:, :, :), intent(in) :: a_ri
      complex, dimension(:, :), intent(out) :: a

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x2r2c: size(a, 1) does not match size(a_ri, 2)')
      if (size(a, 2) /= size(a_ri, 3)) call aborter(6, 'x2r2c: size(a, 2) does not match size(a_ri, 3)')
      a(:, :) = cmplx(a_ri(1, :, :), a_ri(2, :, :))

   end subroutine x2r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x1c2r(a, a_ri)

      complex, dimension(:), intent(in) :: a
      real, dimension(:, :), intent(out) :: a_ri

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x2c2r: size(a, 1) does not match size(a_ri, 2)')
      a_ri(1, :) = real(a(:))
      a_ri(2, :) = aimag(a(:))

   end subroutine x1c2r
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   subroutine x1r2c(a, a_ri)

      real, dimension(:, :), intent(in) :: a_ri
      complex, dimension(:), intent(out) :: a

      if (size(a, 1) /= size(a_ri, 2)) call aborter(6, 'x2r2c: size(a, 1) does not match size(a_ri, 2)')
      a(:) = cmplx(a_ri(1, :), a_ri(2, :))

   end subroutine x1r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
!
   Subroutine Aborter(iunit, ierrmsg)
!----------------------------------------------------------------------
!  ABORT A PROGRAM AFTER A FATAL ERROR CONDITION IS DETECTED.
!
!
! input: iunit  Unit Number of the file to write error messages to.
!        ierrmsg  An error message to write ilunerr
!
!       The advantage of using this subroutine is that it will
!       generate a traceback showing the chain of subroutines which
!       eventually bombed, and it forces an arithmetic error which
!       the job control system can detect as a fatal error.
!
      character ierrmsg * (*)
      real :: zz0, zz1
      integer :: iunit, ilunerr
      common / abortcmn / zz0, zz1
!
! zz0 is in a common block to prevent an optimizing compiler
! from evaluating 1.0/zz0 during compilation rather than during
! execution.
!
      write (iunit, 1001)
1001  format(//' %ABORTER:  ** FATAL ERROR.  ABORT SUBROUTINE CALLED **'//)

      write (iunit, 1002) ierrmsg
1002  format(1x, a, //)

! on CRAY's and VAXes:
! generate a divide-by-zero error:
      zz1 = 1.0 / zz0         !^
      ilunerr = 5           !^

! on the DecStation:
!^      call exit(1)

      write (ilunerr, 1010) zz0
1010  format(' ?ABORTER-- ZZ0= ', 1PE11.4, ' AND STILL EXECUTING...')

   end subroutine aborter
!------------------------------------------------------------------------------
end module convert
