!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer, 
!                     version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms 
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer 
!version 3 or (at your option) any later version that should be found at: 
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html 
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software; 
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec), 
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
*     subroutine 'setscqr' - sets up common 'comfft8x' required by
*                            cfft8, sfft8, qcfft8, qsfft8
*                                       and
*                            calls setfft8 to set up 'comfft8'
*                            required by ffft8 which is used by 
*                            the 4 previous transforms
*
*author jean cote Sept 99
*
*arguments
*   i      - nf        - number of grid points (length of transform)
*   i      - case      - coded name of desired transform
*                            case = 'COS'  for real cosine         (cfft8)
*                            case = 'SIN'  for real sine           (sfft8)
*                            case = 'QCOS' for real shifted cosine (qcfft8)
*                            case = 'QSIN' for real shifted sine   (qsfft8)
*                            case = 'REAL' for real periodic       (ffft8)
*
**
*

      subroutine setscqr( nf, case ) 1

      implicit none

      integer nf
      character*(*) case

      integer n, m, nstore
      real*8  ssin, ccos, qsin
      pointer ( ptss,ssin(n-m-1) ), ( ptcc,ccos(n-m-1) )
      pointer ( ptqs,qsin(0:m-1) )

      common    / comfft8x / ptss, ptcc, ptqs, n, m, nstore
*
      integer    i, ier
      real *8    del, angle
      character  alloue*17
*
      real*8 zero, half, one, two, four
      parameter( zero  = 0.0 )
      parameter( half  = 0.5 )
      parameter( one   = 1.0 )
      parameter( two   = 2.0 )
      parameter( four  = 4.0 )
*
      data alloue/'PAS ENCORE ALLOUE'/

      if (alloue.ne.'PAS ENCORE ALLOUE') call hpdeallc( ptss,ier,0 )
      if (alloue.ne.'PAS ENCORE ALLOUE') call hpdeallc( ptcc,ier,0 )
      if (alloue.ne.'PAS ENCORE ALLOUE') call hpdeallc( ptqs,ier,0 )
      if (alloue.ne.'PAS ENCORE ALLOUE') alloue = 'DEJA ALLOUE'

*     n  =  length of auxiliary real periodic fourier transform (ffft8)

      if     ( case .eq. 'SIN' ) then
         n = nf + 1
      elseif ( case .eq. 'COS' ) then
         n = nf - 1
      elseif ( case .eq. 'REAL'   .or.
     %         case .eq. 'QSIN'   .or.
     %         case .eq. 'QCOS' ) then
         n = nf
      else
         print *,'ERROR in SETSCQR -> case = ',case
         return
      endif
      
      m      = n/2
      nstore = n + 2

      call hpalloc( ptss, n-m-1, ier, 8 )
      call hpalloc( ptcc, n-m-1, ier, 8 )
      call hpalloc( ptqs,     m, ier, 8 )

      del = acos( - one )/n

*VDIR NODEP
      do i=1,n-m-1

         angle = i * del
         ccos( i ) = cos( angle )
         ssin( i ) = sin( angle )

      enddo

*VDIR NODEP
      do i=0,m-1

         qsin( i ) = sin( ( i + half ) * del )

      enddo

      call setfft8( n )

      return
      end