convert.f90 Source File

!> 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.
module convert
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
     
  implicit none
  private
  public :: c2r, r2c

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

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

contains
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
  
  !> FIXME : Add documentation
  subroutine x5c2r(a, a_ri)
    implicit none
    complex, dimension(:,:,:,:,:), intent(in) :: a
    real, dimension(:,:,:,:,:,:), intent(out) :: a_ri

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

  end subroutine x5c2r
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
! 
  !> FIXME : Add documentation
  subroutine x5r2c(a, a_ri)
    implicit none
    real, dimension(:,:,:,:,:,:), intent(in) :: a_ri
    complex, dimension(:,:,:,:,:), intent(out) :: a

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

  end subroutine x5r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
! 
  !> FIXME : Add documentation
  subroutine x4c2r(a, a_ri)
    implicit none
    complex, dimension(:,:,:,:), intent(in) :: a
    real, dimension(:,:,:,:,:), intent(out) :: a_ri

    if(size(a, 1) /= size(a_ri, 2)) call aborter('x4c2r: size(a, 1) does not match size(a_ri, 2)')
    if(size(a, 2) /= size(a_ri, 3)) call aborter('x4c2r: size(a, 2) does not match size(a_ri, 3)')
    if(size(a, 3) /= size(a_ri, 4)) call aborter('x4c2r: size(a, 3) does not match size(a_ri, 4)')
    if(size(a, 4) /= size(a_ri, 5)) call aborter('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
!------------------------------------------------------------------------------
! 
  !> FIXME : Add documentation  
  subroutine x4r2c(a, a_ri)
    implicit none
    real, dimension(:,:,:,:,:), intent(in) :: a_ri
    complex, dimension(:,:,:,:), intent(out) :: a

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

  end subroutine x4r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
! 
  !> FIXME : Add documentation
  subroutine x3c2r(a, a_ri)
    implicit none
    complex, dimension(:,:,:), intent(in) :: a
    real, dimension(:,:,:,:), intent(out) :: a_ri

    if(size(a, 1) /= size(a_ri, 2)) call aborter('x3c2r: size(a, 1) does not match size(a_ri, 2)')
    if(size(a, 2) /= size(a_ri, 3)) call aborter('x3c2r: size(a, 2) does not match size(a_ri, 3)')
    if(size(a, 3) /= size(a_ri, 4)) call aborter('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
!------------------------------------------------------------------------------
! 
  !> FIXME : Add documentation
  subroutine x3r2c(a, a_ri)
    implicit none
    real, dimension(:,:,:,:), intent(in) :: a_ri
    complex, dimension(:,:,:), intent(out) :: a

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

  end subroutine x3r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
! 

  !> FIXME : Add documentation  
  subroutine x2c2r(a, a_ri)
    implicit none
    complex, dimension(:,:), intent(in) :: a
    real, dimension(:,:,:), intent(out) :: a_ri

    if(size(a, 1) /= size(a_ri, 2)) call aborter('x2c2r: size(a, 1) does not match size(a_ri, 2)')
    if(size(a, 2) /= size(a_ri, 3)) call aborter('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
!------------------------------------------------------------------------------
! 

  !> FIXME : Add documentation  
  subroutine x2r2c(a, a_ri)
    implicit none
    real, dimension(:,:,:), intent(in) :: a_ri
    complex, dimension(:,:), intent(out) :: a

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

  end subroutine x2r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
! 

  !> FIXME : Add documentation  
  subroutine x1c2r(a, a_ri)
    implicit none
    complex, dimension(:), intent(in) :: a
    real, dimension(:,:), intent(out) :: a_ri

    if(size(a, 1) /= size(a_ri, 2)) call aborter('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
!------------------------------------------------------------------------------
! 

  !> FIXME : Add documentation
  subroutine x1r2c(a, a_ri)
    implicit none
    real, dimension(:,:), intent(in) :: a_ri
    complex, dimension(:), intent(out) :: a

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

  end subroutine x1r2c
!------------------------------------------------------------------------------
!                              AstroGK, 2009
!------------------------------------------------------------------------------
! 

  !> ABORTS A PROGRAM AFTER A FATAL ERROR CONDITION IS DETECTED.
  subroutine aborter(ierrmsg)
    implicit none
    !> Error message
    character(*), intent(in) :: ierrmsg

    write(*, 1001)
1001 format(//' %ABORTER:  ** FATAL ERROR.  ABORT SUBROUTINE CALLED **'//)
  
    write(*, 1002) ierrmsg
1002 format(1x,a,//)

    error stop
  end subroutine aborter
end module convert