      SUBROUTINE SSSR2( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            N, LDA, INCX, INCY
      REAL               ALPHA
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  SSSR2 performs the skew-symmetric rank 2 operation
*
*     A := alpha*x*y**T - alpha*y*x**T + A,
*
*  where alpha is a scalar, x and y are n element vectors and A is an n
*  by n skew-symmetric matrix.
*
*  Arguments
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the upper or lower
*           triangular part of the array A is to be referenced as
*           follows:
*
*              UPLO = 'U' or 'u'   Only the upper triangular part of A
*                                  is to be referenced.
*
*              UPLO = 'L' or 'l'   Only the lower triangular part of A
*                                  is to be referenced.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - REAL.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  X      - REAL array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  Y      - REAL array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCY ) ).
*           Before entry, the incremented array Y must contain the n
*           element vector y.
*           Unchanged on exit.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*  A      - REAL array of DIMENSION ( LDA, n ).
*           Before entry with UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array A must contain the upper
*           triangular part of the skew-symmetric matrix and the
*           strictly lower triangular part of A is not referenced.
*           On exit, the upper triangular part of the array A is
*           overwritten by the upper triangular part of the updated
*           matrix.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array A must contain the lower
*           triangular part of the skew-symmetric matrix and the
*           strictly upper triangular part of A is not referenced.
*           On exit, the lower triangular part of the array A is
*           overwritten by the lower triangular part of the updated
*           matrix.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  Further Details
*  ===============
*
*  Level 2 BLAS-like routine.
*
*  SSSR2_SM is modified from SSYR2 in reference BLAS version 3.5.0.
*
*  Written by Meiyue Shao, Lawrence Berkeley National Laboratory.
*  Last change: October 2014
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
      INTEGER            NB
      PARAMETER          ( NB = 64 )
*
*     .. Local Scalars ..
      INTEGER            II, JJ, IC, IX, IY, JC, JX, JY, KX, KY, INFO
      LOGICAL            UPPER
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGER, SSSR2_SM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      UPPER = LSAME( UPLO, 'U' )
      INFO = 0
      IF ( .NOT. UPPER .AND. .NOT. LSAME( UPLO, 'L' ) ) THEN
         INFO = 1
      ELSE IF ( N .LT. 0 ) THEN
         INFO = 2
      ELSE IF ( INCX .EQ. 0 ) THEN
         INFO = 5
      ELSE IF ( INCY .EQ. 0 ) THEN
         INFO = 7
      ELSE IF ( LDA .LT. MAX( 1,N ) ) THEN
         INFO = 9
      END IF
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'SSSR2 ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF ( ( N .EQ. 0 ) .OR. ( ALPHA .EQ. ZERO ) ) RETURN
*
*     Set up the start points in X and Y.
*
      IF ( INCX .GT. 0 ) THEN
         KX = 1
      ELSE
         KX = 1 - (N-1)*INCX
      END IF
      IF ( INCY .GT. 0 ) THEN
         KY = 1
      ELSE
         KY = 1 - (N-1)*INCY
      END IF
*
*     Start the operations.
*
      IF ( UPPER ) THEN
*
*        Form A when A is stored in the upper triangle.
*
         DO JJ = 1, N, NB
            JC = MIN( NB, N-JJ+1 )
            JX = KX + (JJ-1)*INCX
            JY = KY + (JJ-1)*INCY
            IF ( INCX .LT. 0 ) JX = JX + (JC-1)*INCX
            IF ( INCY .LT. 0 ) JY = JY + (JC-1)*INCY
*
*           Call SSSR2_SM for diagonal blocks,
*           and SGER for off-diagonal blocks.
*
            DO II = 1, JJ-NB, NB
               IX = KX + (II-1)*INCX
               IY = KY + (II-1)*INCY
               IF ( INCX .LT. 0 ) IX = IX + (NB-1)*INCX
               IF ( INCY .LT. 0 ) IY = IY + (NB-1)*INCY
               CALL SGER( NB, JC, ALPHA, X( IX ), INCX, Y( JY ), INCY,
     $              A( II, JJ ), LDA )
               CALL SGER( NB, JC, -ALPHA, Y( IY ), INCY, X( JX ), INCX,
     $              A( II, JJ ), LDA )
            END DO
            CALL SSSR2_SM( UPPER, JC, ALPHA, X( JX ), INCX, Y( JY ),
     $           INCY, A( JJ, JJ ), LDA )
         END DO
      ELSE
*
*        Form A when A is stored in the lower triangle.
*
         DO JJ = 1, N, NB
            JC = MIN( NB, N-JJ+1 )
            JX = KX + (JJ-1)*INCX
            JY = KY + (JJ-1)*INCY
            IF ( INCX .LT. 0 ) JX = JX + (JC-1)*INCX
            IF ( INCY .LT. 0 ) JY = JY + (JC-1)*INCY
            CALL SSSR2_SM( UPPER, JC, ALPHA, X( JX ), INCX, Y( JY ),
     $           INCY, A( JJ, JJ ), LDA )
*
*           Call SSSR2_SM for diagonal blocks,
*           and SGER for off-diagonal blocks.
*
            DO II = JJ+NB, N, NB
               IC = MIN( NB, N-II+1 )
               IX = KX + (II-1)*INCX
               IY = KY + (II-1)*INCY
               IF ( INCX .LT. 0 ) IX = IX + (IC-1)*INCX
               IF ( INCY .LT. 0 ) IY = IY + (IC-1)*INCY
               CALL SGER( IC, NB, ALPHA, X( IX ), INCX, Y( JY ), INCY,
     $              A( II, JJ ), LDA )
               CALL SGER( IC, NB, -ALPHA, Y( IY ), INCY, X( JX ), INCX,
     $              A( II, JJ ), LDA )
            END DO
         END DO
      END IF
*
      RETURN
*
*     End of SSSR2.
*
      END
*
*
*
      SUBROUTINE SSSR2_SM( UPPER, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      LOGICAL            UPPER
      INTEGER            N, LDA, INCX, INCY
      REAL               ALPHA
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), X( * ), Y( * )
*     ..
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
*
*     .. Local Scalars ..
      INTEGER            I, J, IX, IY, JX, JY, KX, KY
      REAL               TEMP1, TEMP2
*     ..
*     .. Executable Statements ..
*
*     Set up the start points in X and Y.
*
      IF ( INCX .GT. 0 ) THEN
         KX = 1
      ELSE
         KX = 1 - (N-1)*INCX
      END IF
      IF ( INCY .GT. 0 ) THEN
         KY = 1
      ELSE
         KY = 1 - (N-1)*INCY
      END IF
*
*     Start the operations.
*
      IF ( UPPER ) THEN
*
*        Form A when A is stored in the upper triangle.
*
         IF ( ( INCX .EQ. 1 ) .AND. ( INCY .EQ. 1 ) ) THEN
            DO J = 2, N
               IF ( ( X( J ) .NE. ZERO ) .OR.
     $              ( Y( J ) .NE. ZERO ) ) THEN
                  TEMP1 = ALPHA*Y( J )
                  TEMP2 = ALPHA*X( J )
                  DO I = 1, J-1
                     A( I, J ) = A( I, J ) + X( I )*TEMP1 - Y( I )*TEMP2
                  END DO
               END IF
            END DO
         ELSE
            JX = KX + INCX
            JY = KY + INCY
            DO J = 2, N
               IF ( ( X( JX ) .NE. ZERO ) .OR.
     $              ( Y( JY ) .NE. ZERO ) ) THEN
                  TEMP1 = ALPHA*Y( JY )
                  TEMP2 = ALPHA*X( JX )
                  IX = KX
                  IY = KY
                  DO I = 1, J-1
                     A( I, J ) = A( I, J ) + X( IX )*TEMP1
     $                    - Y( IY )*TEMP2
                     IX = IX + INCX
                     IY = IY + INCY
                  END DO
               END IF
               JX = JX + INCX
               JY = JY + INCY
            END DO
         END IF
      ELSE
*
*        Form A when A is stored in the lower triangle.
*
         IF ( ( INCX .EQ. 1 ) .AND. ( INCY .EQ. 1 ) ) THEN
            DO J = 1, N-1
               IF ( ( X( J ) .NE. ZERO ) .OR.
     $              ( Y( J ) .NE. ZERO ) ) THEN
                  TEMP1 = ALPHA*Y( J )
                  TEMP2 = ALPHA*X( J )
                  DO I = J+1, N
                     A( I, J ) = A( I, J ) + X( I )*TEMP1 - Y( I )*TEMP2
                  END DO
               END IF
            END DO
         ELSE
            JX = KX
            JY = KY
            DO J = 1, N-1
               IF ( ( X( JX ) .NE. ZERO ) .OR.
     $              ( Y( JY ) .NE. ZERO ) ) THEN
                  TEMP1 = ALPHA*Y( JY )
                  TEMP2 = ALPHA*X( JX )
                  IX = JX + INCX
                  IY = JY + INCY
                  DO I = J+1, N
                     A( I, J ) = A( I, J ) + X( IX )*TEMP1
     $                    - Y( IY )*TEMP2
                     IX = IX + INCX
                     IY = IY + INCY
                  END DO
               END IF
               JX = JX + INCX
               JY = JY + INCY
            END DO
         END IF
      END IF
*
      RETURN
*
*     End of SSSR2_SM.
*
      END


! eight_queens.f90 --
!    Program to solve the classical problem of positioning
!    eight queens on a chessboard so that none can reach
!    another in one move.
!
!    This illustrates the use of the backtracking module.
!
module backtracking_data
    implicit none
    type SOLUTION_DATA
        integer, dimension(8) :: row
    end type SOLUTION_DATA

end module backtracking_data

module eight_queens
    use backtracking_data
    implicit none

    type(SOLUTION_DATA), dimension(:), pointer  :: all_solutions
contains

! generate --
!     Subroutine to generate the possible solutions at each stage
! Arguments:
!     base        The basic solution that new solutions will be
!                 derived from
!     stage       Index of the current stage in the construction
!     solutions   Array of new solutions that need to be examined
! Note:
!     The solutions that are returned in the (allocated)
!     array are simply feasible solutions that need to
!     be inspected further.
!     To keep the memory management clear, the subroutine
!     "free" cleans up the array of feasible solutions.
!
subroutine generate( base, stage, solutions )
    type(SOLUTION_DATA), intent(in)             :: base
    integer, intent(in)                         :: stage
    type(SOLUTION_DATA), dimension(:), pointer  :: solutions

    integer :: i

    !
    ! If stage <= 8, there are 8 possible solutions
    !
    if ( stage <= 8 ) then
        allocate( solutions(8) )
    else
        nullify( solutions )
        return
    endif

    !
    ! Construct them (be sure to copy the base
    ! solution first!)
    !
    solutions(:)            = base
    solutions(:)%row(stage) = (/ (i, i=1,8 ) /)
end subroutine generate

! free --
!     Subroutine to clean up the memory used by the intermediate
!     solutions
! Arguments:
!     solutions   Array of solutions that need to be cleaned up
!
subroutine free( solutions )
    type(SOLUTION_DATA), dimension(:), pointer  :: solutions

    deallocate( solutions )

end subroutine free

! acceptable --
!     Function to check if a possible solution is acceptable
! Arguments:
!     solution    The solution to be examined
!     stage       The current stage
! Returns:
!     .true. if the solution is acceptable, .false. otherwise
!
logical function acceptable( solution, stage )
    type(SOLUTION_DATA), intent(in) :: solution
    integer, intent(in)             :: stage

    logical :: clash
    integer  :: i
    integer  :: diff

    !
    ! We need to check the current queen only - all others
    ! have already been checked.
    !
    ! So:
    ! The new queen should not be on the same row as any others
    !
    clash = any( solution%row(1:stage-1) .eq. solution%row(stage) )

    !
    ! Check the diagonals
    !
    do i = 1,stage-1
        diff = abs( solution%row(i)-solution%row(stage) )
        clash = clash .or. ( diff .eq. (stage-i) )
    enddo

    acceptable = .not. clash

end function acceptable

! collect --
!     Subroutine to collect all solutions (or do something else)
! Arguments:
!     solution    Solution that was found
!     stop        Flag that indicates whether to stop or not
!
subroutine collect( solution, stop )
    type(SOLUTION_DATA), intent(in) :: solution
    logical, intent(out)            :: stop

    type(SOLUTION_DATA), dimension(:), pointer  :: new

    stop = .false. ! We want to collect all solutions

    allocate( new(size(all_solutions)+1) )

    new(1:size(all_solutions)) = all_solutions
    new(size(new))             = solution

    deallocate( all_solutions )
    all_solutions => new

end subroutine collect

end module eight_queens

program eightq

    use eight_queens
    use backtracking
    implicit none

    integer                           :: i
    integer                           :: nostage
    type(SOLUTION_DATA), dimension(1) :: base

    !
    ! There is no need to initialise the base solution in this example
    ! so just move on!
    !
    allocate( all_solutions(0) ) ! To be on the safe side

    nostage = 8

    call bt_solve( base, nostage, generate, acceptable, free, collect )

    !
    ! Now print the solutions ...
    !
    write(*,*) 'Number of solutions found: ', size(all_solutions)
    do i = 1,size(all_solutions)
        write(*,'(8i3)' ) all_solutions(i)%row
    enddo
end program


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: cosqb1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE COSQB1 (N,INC,X,WSAVE,WORK,IER)
      DIMENSION       X(INC,*)     ,WSAVE(*)     ,WORK(*)
      IER = 0
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 I=3,N,2
         XIM1 = X(1,I-1)+X(1,I)
         X(1,I) = .5*(X(1,I-1)-X(1,I))
         X(1,I-1) = .5*XIM1
  101 CONTINUE
      X(1,1) = .5*X(1,1)
      MODN = MOD(N,2)
      IF (MODN .NE. 0) GO TO 302
      X(1,N) = .5*X(1,N)
  302 LENX = INC*(N-1)  + 1
      LNSV = N + INT(LOG(REAL(N))) + 4
      LNWK = N
C
      CALL RFFT1B(N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('COSQB1',-5)
        GO TO 400
      ENDIF
C
      DO 102 K=2,NS2
         KC = NP2-K
         WORK(K) = WSAVE(K-1)*X(1,KC)+WSAVE(KC-1)*X(1,K)
         WORK(KC) = WSAVE(K-1)*X(1,K)-WSAVE(KC-1)*X(1,KC)
  102 CONTINUE
      IF (MODN .NE. 0) GO TO 305
      X(1,NS2+1) = WSAVE(NS2)*(X(1,NS2+1)+X(1,NS2+1))
  305 DO 103 K=2,NS2
         KC = NP2-K
         X(1,K) = WORK(K)+WORK(KC)
         X(1,KC) = WORK(K)-WORK(KC)
  103 CONTINUE
      X(1,1) = X(1,1)+X(1,1)
  400 RETURN
      END


!==========================================================================
elemental function gsw_ct_from_t (sa, t, p)
!==========================================================================
!
! Calculates Conservative Temperature from in-situ temperature
!
! sa     : Absolute Salinity                               [g/kg]
! t      : in-situ temperature                             [deg C]
! p      : sea pressure                                    [dbar]
!
! gsw_ct_from_t : Conservative Temperature                 [deg C]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_pt0_from_t

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, t, p

real (r8) :: gsw_ct_from_t

real (r8) :: pt0

pt0 = gsw_pt0_from_t(sa,t,p)
gsw_ct_from_t = gsw_ct_from_pt(sa,pt0)

return
end function

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


C
C
*+ do_log_map

       subroutine do_log_map(map_array,status)
C      ---------------------------------------
C
C Take the logarithm of a map
C
C Given:
C   map data
       real*4        map_array(*)
C Returned:
C   error status word
       integer       status
C
C The natural logarithm of a map is calculated. Only points which
C are above the user specified gate are included. An offset may be
C applied to the map to enable negative data to be mapped into the
C log.
*-

C Local variables
       integer    minirt(8), iu, iv
       integer    imap, ip_map, imapo, ip_mapo
       real*4     gate, offset, blank_value

C check status on entry
       if (status.ne.0) return

C read input map
       call map_getmap('Map : ','Default-Map',
     *                 'READ',imap,status)
       call ennull(blank_value,status)
       call io_getr('Gate : ','0.0',gate,status)
       call io_getr('Offset : ','0.0',offset,status)

C allocate maps
       call map_alloc_in(imap,'SEQUENTIAL',map_array,ip_map,status)
       call map_alloc_out(0,0,'SEQUENTIAL',imapo,ip_mapo,status)
       if (status.ne.0) goto 999

C calculate the logarithm of the map
       if (status.eq.0) then
         call enminirt(minirt,status)
         do iv = minirt(3),minirt(4),-1
           call map_row_read(imap,iv,map_array,ip_map,status)
           do iu = 1,minirt(5)
             if ( (map_array(ip_map+iu-1).eq.blank_value)    .or.
     *            ((map_array(ip_map+iu-1)+offset).le.0.0)   .or.
     *            (map_array(ip_map+iu-1).le.gate)         ) then
               map_array(ip_mapo+iu-1) = blank_value
             else
               map_array(ip_mapo+iu-1) =
     *                             log(map_array(ip_map+iu-1)+offset)
             end if
           end do
           call map_row_write(imapo,iv,map_array,ip_mapo,status)
         end do
       end if

C update the text of the redtape
       call redt_load(imap,status)
       call adredt('created','LOG-MAP',status)

C tidy up, make output map new current map etc.
999    call map_end_alloc(imapo,map_array,status)
       call map_end_alloc(imap,map_array,status)

C check status value
       call cmd_err(status,'LOG-MAP','Failed ')
       end


!*****************************************************************************!
!*****************************************************************************!
!**                        Complex Root Finding Routine                     **!
!*****************************************************************************!
!*****************************************************************************!
!
!------------------------------------------------------------------------------
!                             Copyright,  2005
!                                Greg Howes
!------------------------------------------------------------------------------
!
!------------------------------------------------------------------------------
module gk_complex_root
  implicit none

  private

  public :: rtsec

contains
!------------------------------------------------------------------------------
!                           Greg Howes, 2005
!------------------------------------------------------------------------------
!     NOTE: This routine was adapted from f77 routine by Eliot Quataert
  complex function rtsec(func,x1,x2,xacc,iflag)
    integer, parameter :: maxit=1000
    complex :: func
    complex, intent(in) :: x1, x2
    real, intent(in)    :: xacc
    integer, intent(out), optional :: iflag
    complex :: fl, f, swap, dx, cl, maxr, minr
    complex :: xl
    integer :: j
    logical :: limits=.false.

    !Set limits for solution
    if (limits) then
       maxr=x2*10.
       minr=x1*0.1
    endif

    fl=func(x1)
    f=func(x2)
    if(abs(fl).lt.abs(f))then
       rtsec=x1
       xl=x2
       swap=fl
       fl=f
       f=swap
    else
       xl=x1
       rtsec=x2
    endif
    do  j=1,maxit
       iflag = j
       !        write(*,'(a,i4)')'Iteration ',j
       if (abs(f-fl) .gt. 1.0E-37) then
          dx=(xl-rtsec)*f/(f-fl)
       else
          dx = (x2-x1)/25.0
       end if
       xl=rtsec
       fl=f
       !       if (Real(rtsec + dx) .gt. 0.075 .or. Real(rtsec+dx) .lt. 0) then
       !          rtsec = (x1 + x2)/2.0
       !       else
       !NOTE: Reduce jump by 0.5 to improve convergence GH
       !        rtsec=rtsec+dx
       rtsec=rtsec+dx/2.
       !       end if

       !Enforce limits
       if (limits) then
          !Real limit
          if (real(rtsec) .gt. real(maxr) .or. real(rtsec) .lt. real(minr)) &
               rtsec = cmplx(sqrt(real(minr)*real(maxr)), Aimag(rtsec))
          !NOTE: aimag(rtsec) should be negative!
          if (aimag(rtsec) .lt. aimag(maxr) .or. aimag(rtsec) .gt. aimag(minr)) &
               rtsec = cmplx(real(rtsec), -sqrt(aimag(minr)*aimag(maxr)))
       endif

       !LIMIT: Im(rtsec) < 0.
       !       if (Aimag(rtsec) .gt. 0) then
       !           rtsec = cmplx(Real(rtsec), -Aimag(rtsec))
       !       end if
       !LIMIT: Re(rtsec) > 0.
       !       if (Real(rtsec) .lt. 0) then
       !           rtsec = cmplx(-Real(rtsec), Aimag(rtsec))
       !       end if

       f=func(rtsec)
       if(abs(dx).lt.xacc.or. Abs(f) .eq. 0.) then
          !        write(*,'(a,i4)')'Subroutine rtsec Converged on Iteration ',j
          return
       endif
    enddo
    !    stop
    !        write(*,'(a,i4)')'Subroutine rtsec stopped at iteration ',j
    return
    !     pause 'rtsec exceed maximum iterations'
  end function rtsec
!------------------------------------------------------------------------------
 end module gk_complex_root


!
!************************************************************************
! Fortran 95 OPA Nesting tools						*
!									*
!     Copyright (C) 2005 Florian Lemari�(Florian.Lemarie@imag.fr)	*
!									*
!************************************************************************
!
PROGRAM create_rstrt
  !
  USE NETCDF
  USE bilinear_interp
  USE bicubic_interp
  USE agrif_readwrite
  USE io_netcdf
  USE agrif_extrapolation
  USE agrif_interpolation
  USE agrif_partial_steps
  USE agrif_connect_topo
  !
  IMPLICIT NONE
  !
  !************************************************************************
  ! 									*
  ! PROGRAM  CREATE_RSTRT							*
  !									*
  ! program to interpolate parent grid restart file to child grid		*
  !									*
  !									*
  !Interpolation is carried out using bilinear interpolation		*
  !routine from SCRIP package						*
  !									*
  !http://climate.lanl.gov/Software/SCRIP/				*
  !************************************************************************
  !
  ! variables declaration
  !
  CHARACTER*20,DIMENSION(:),POINTER :: Ncdf_varname => NULL()
  CHARACTER*20 :: vert_coord_name
  CHARACTER*1 :: posvar
  CHARACTER*100 :: Child_file,Childcoordinates,varname,Child_Bathy_Level,Child_Bathy_Meter
  REAL*8, POINTER, DIMENSION(:,:,:) :: tabvar3d => NULL()
  REAL*8, POINTER, DIMENSION(:,:,:,:) :: un,ub,vn,vb,tn,tb,sn,sb,e3t_n,e3t_b => NULL()
  REAL*8, POINTER, DIMENSION(:,:,:) :: sshn,sshb => NULL()
  REAL*8, POINTER, DIMENSION(:,:,:,:) :: tabinterp4d,tabvar1,tabvar2,tabvar3 => NULL()
  REAL*8, POINTER, DIMENSION(:) :: tabtemp1D,nav_lev => NULL()
  REAL*8, POINTER, DIMENSION(:,:) :: tabtemp2D => NULL()
  REAL*8, POINTER, DIMENSION(:,:,:,:) :: tabtemp4D => NULL()
  INTEGER,DIMENSION(:),POINTER :: src_add,dst_add  => NULL()
  REAL*8,DIMENSION(:,:),POINTER :: matrix => NULL()
  LOGICAL,DIMENSION(:,:),POINTER :: masksrc => NULL()
  LOGICAL, DIMENSION(:,:,:), POINTER :: detected_pts
  LOGICAL :: Interpolation,Extrapolation,Pacifique
  INTEGER :: narg,iargc,ncid,x,y,z,z_a,x_a,y_a,z_b,nbvert_lev
  REAL*8 :: now_wght,before_wght
  INTEGER :: status,ii,jk
  CHARACTER(len=20),DIMENSION(4) :: dimnames
  CHARACTER(len=80) :: namelistname
  TYPE(Coordinates) :: G0,G1
  REAL*8 :: tabtemp0dreal
  CHARACTER(len=20) :: timedimname

  LOGICAL, PARAMETER :: conservation = .FALSE.
  !
  !
  narg = iargc()
  IF (narg == 0) THEN
     namelistname = 'namelist.input'
  ELSE
     CALL getarg(1,namelistname)
  ENDIF
  !
  ! read input file
  !
  CALL read_namelist(namelistname)
  !
  IF(TRIM(restart_file) == '') THEN
     WRITE(*,*) 'no restart file specified in ',TRIM(namelistname)
     STOP
  END IF

  IF (iom_activated) THEN
     timedimname = 'time_counter'
  ELSE
     timedimname='time'
  ENDIF

  !
  WRITE(*,*) ''
  WRITE(*,*) 'Interpolation of restart file : ',TRIM(restart_file)
  WRITE(*,*) ''
  !
  CALL Read_Ncdf_VarName(restart_file,Ncdf_varname)
  !
  CALL set_child_name(parent_coordinate_file,Childcoordinates)
  IF( TRIM(parent_bathy_level) /= '' )   CALL set_child_name(parent_bathy_level,Child_Bathy_Level)
  IF( TRIM(parent_bathy_meter) /= '' )   CALL set_child_name(parent_bathy_meter,Child_Bathy_Meter)
  !
  ! create this file
  !
  CALL set_child_name(restart_file,Child_file)
  status = nf90_create(Child_file,NF90_WRITE,ncid)
  status = nf90_close(ncid)
  WRITE(*,*) 'Child grid restart file name = ',TRIM(Child_file)
  WRITE(*,*) ''

  !
  ! read dimensions in parent restart file
  !
  CALL Read_Ncdf_dim('x',restart_file,x)
  CALL Read_Ncdf_dim('y',restart_file,y)
  CALL Read_Ncdf_dim('nav_lev',restart_file,z)
  IF (.NOT.iom_activated) THEN
     CALL Read_Ncdf_dim('x_a',restart_file,x_a)
     CALL Read_Ncdf_dim('y_a',restart_file,y_a)
     CALL Read_Ncdf_dim('z_a',restart_file,z_a)
     CALL Read_Ncdf_dim('z_b',restart_file,z_b)
  ENDIF

  IF( z .NE. N ) THEN
     WRITE(*,*) '***'
     WRITE(*,*) 'Number of vertical levels doesn t match between namelist and restart file'
     WRITE(*,*) 'Please check the values in namelist file'
     STOP
  ENDIF
  !
  ! mask initialization for extrapolation and interpolation
  !
  WRITE(*,*) 'mask initialisation on coarse and fine grids'
  !
  status = Read_Local_Coordinates(parent_coordinate_file,G0,(/jpizoom,jpjzoom/),(/x,y/))
  status = Read_Coordinates(Childcoordinates,G1,Pacifique)
  !
  !longitude modification if child domain covers Pacific ocean area
  !
  IF( Pacifique ) THEN
     !
     WHERE( G0%nav_lon < 0 )
        G0%nav_lon = G0%nav_lon + 360.
     END WHERE
     !
     WHERE( G1%nav_lon < 0 )
        G1%nav_lon = G1%nav_lon + 360.
     END WHERE
     !
  ENDIF
  !
  ! one needs bathy_level
  IF( TRIM(parent_bathy_level) /= '' ) THEN
     status = Read_bathy_level(TRIM(parent_bathy_level),G0)
     status = Read_bathy_level(TRIM(child_bathy_level),G1)
  ELSE
     status = read_bathy_meter(TRIM(parent_bathy_meter),G0)
     status = read_bathy_meter(TRIM(child_bathy_meter),G1)
     CALL meter_to_levels(G0)
     CALL meter_to_levels(G1)
  ENDIF
  ! get masks
  CALL Init_mask(parent_bathy_level,G0,x,y)
  CALL Init_mask(child_bathy_level,G1,1,1)

  G0%tmask = 1.

  DO jk=1,z
     ALLOCATE(tabvar1(x,y,1,1))
     CALL Read_Ncdf_var('sn',TRIM(restart_file),tabvar1,1,jk)
     WHERE( tabvar1(:,:,1,1) == 0. )
        G0%tmask(:,:,jk) = 0.
     END WHERE
     DEALLOCATE(tabvar1)
  END DO
  !
  G0%umask(1:x-1,:,:) = G0%tmask(1:x-1,:,:)*G0%tmask(2:x,:,:)
  G0%umask(x,:,:)     = G0%tmask(x,:,:)
  G0%vmask(:,1:y-1,:) = G0%tmask(:,1:y-1,:)*G0%tmask(:,2:y,:)
  G0%vmask(:,y,:)     = G0%tmask(:,y,:)
  !
  G0%fmask(1:x-1,1:y-1,:) = G0%tmask(1:x-1,1:y-1,:)*G0%tmask(2:x,1:y-1,:)* &
     &                      G0%tmask(1:x-1,2:y,:)*G0%tmask(2:x,2:y,:)
  G0%fmask(x,:,:) = G0%tmask(x,:,:)
  G0%fmask(:,y,:) = G0%tmask(:,y,:)
  !
  !
  ! write dimensions in output file
  WRITE(*,*) 'write dimensions'
  !
  CALL Write_Ncdf_dim('x',Child_file,nxfin)
  CALL Write_Ncdf_dim('y',Child_file,nyfin)
  CALL Write_Ncdf_dim('nav_lev',Child_file,z)
  CALL Write_Ncdf_dim(TRIM(timedimname),Child_file,0)
  IF (.NOT.iom_activated) THEN
     CALL Write_Ncdf_dim('x_a',Child_file,x_a)
     CALL Write_Ncdf_dim('y_a',Child_file,y_a)
     CALL Write_Ncdf_dim('z_a',Child_file,z_a)
     CALL Write_Ncdf_dim('z_b',Child_file,z_b)
  ENDIF
  !
  !
  !
  !
  DO ii = 1,SIZE(Ncdf_varname)
     !
     ! loop on variables names
     varname = TRIM(Ncdf_varname(ii))
     WRITE(*,*) 'var = ',TRIM(varname)
     !
     SELECT CASE (TRIM(varname))
        !
     CASE('nav_lon')
        CALL Read_Ncdf_var('nav_lon',TRIM(Childcoordinates),tabtemp2D)
        CALL Write_Ncdf_var('nav_lon',(/'x','y'/),Child_file,tabtemp2D,'float')
        CALL Copy_Ncdf_att('nav_lon',TRIM(restart_file),Child_file,MINVAL(tabtemp2D),MAXVAL(tabtemp2D))
        DEALLOCATE(tabtemp2D)
        Interpolation = .FALSE.
        !
     CASE('nav_lat')
        CALL Read_Ncdf_var('nav_lat',TRIM(Childcoordinates),tabtemp2D)
        CALL Write_Ncdf_var('nav_lat',(/'x','y'/),Child_file,tabtemp2D,'float')
        CALL Copy_Ncdf_att('nav_lat',TRIM(restart_file),Child_file,MINVAL(tabtemp2D),MAXVAL(tabtemp2D))
        DEALLOCATE(tabtemp2D)
        Interpolation = .FALSE.
        !
     CASE('nav_lev')
        CALL Read_Ncdf_var('nav_lev',TRIM(restart_file),nav_lev)
        CALL Write_Ncdf_var('nav_lev','nav_lev',Child_file,nav_lev,'float')
        CALL Copy_Ncdf_att('nav_lev',TRIM(restart_file),Child_file)
        Interpolation = .FALSE.
        !
     CASE('time')
        CALL Read_Ncdf_var('time',TRIM(restart_file),tabtemp1D)
        CALL Write_Ncdf_var('time',TRIM(timedimname),Child_file,tabtemp1D,'float')
        CALL Copy_Ncdf_att('time',TRIM(restart_file),Child_file)
        DEALLOCATE(tabtemp1D)
        Interpolation = .FALSE.
        !
     CASE('time_counter')
        CALL Read_Ncdf_var('time_counter',TRIM(restart_file),tabtemp1D)
        tabtemp1D = tabtemp1D * rhot
        CALL Write_Ncdf_var('time_counter',TRIM(timedimname),Child_file,tabtemp1D,'double')
        CALL Copy_Ncdf_att('time_counter',TRIM(restart_file),Child_file)
        DEALLOCATE(tabtemp1D)
        Interpolation = .FALSE.
        !
     CASE('kt','ndastp','adatrj','ntime','nn_fsbc','rdt')
        IF (iom_activated) THEN
           CALL Read_Ncdf_var(TRIM(varname),TRIM(restart_file),tabtemp0dreal)
           SELECT CASE (TRIM(varname))
           CASE('rdt')
              tabtemp0dreal = tabtemp0dreal / rhot
           CASE('kt')
              tabtemp0dreal = tabtemp0dreal * rhot
           END SELECT
           CALL Write_Ncdf_var(TRIM(varname),Child_file,tabtemp0dreal,'double')
        ELSE
           CALL Read_Ncdf_var(TRIM(varname),TRIM(restart_file),tabtemp4D)
           dimnames(1)='x_a'
           dimnames(2)='y_a'
           dimnames(3)='z_b'
           dimnames(4)=TRIM(timedimname)
           CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabtemp4D,'double')
           DEALLOCATE(tabtemp4D)
        ENDIF
        CALL Copy_Ncdf_att(TRIM(varname),TRIM(restart_file),Child_file)
        Interpolation = .FALSE.
        !
     CASE('frc_v','frc_t','frc_s')
        CALL Read_Ncdf_var(varname,TRIM(restart_ice_file),tabtemp0dreal)
        CALL Write_Ncdf_var(varname,Child_file,tabtemp0dreal,'double')
        CALL Copy_Ncdf_att(varname,TRIM(restart_ice_file),Child_file)
        Interpolation = .FALSE.
        !
        ! Variable interpolation according to their position on grid
        !
     CASE('ssu_m','utau_b','un_bf','un','ub')
        IF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 4 ) THEN
           vert_coord_name = 'nav_lev'
        ELSEIF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 3 ) THEN
           vert_coord_name = '1'
        ENDIF
        posvar='U'
        Interpolation = .TRUE.
        !
     CASE('ssv_m','vtau_b','vn_bf','vn','vb')
        IF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 4 ) THEN
           vert_coord_name = 'nav_lev'
        ELSEIF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 3 ) THEN
           vert_coord_name = '1'
        ENDIF
        posvar='V'
        Interpolation = .TRUE.
        !
     CASE DEFAULT
        IF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 4 ) THEN
           vert_coord_name = 'nav_lev'
        ELSEIF( Get_NbDims(TRIM(varname),TRIM(restart_file)) == 3 ) THEN
           vert_coord_name = '1'
        ENDIF
        posvar='T'
        Interpolation = .TRUE.
        !
     END SELECT
     !
     ! --- start interpolation --- !
     IF( Interpolation ) THEN
        !
        IF( vert_coord_name == '1' ) THEN
           nbvert_lev = 1
        ELSE
           nbvert_lev = z
        ENDIF
        !

        ALLOCATE(detected_pts(SIZE(G0%tmask,1),SIZE(G0%tmask,2),nbvert_lev))
        ALLOCATE(tabvar1(x,y,1,2))
        ALLOCATE(tabvar2(x,y,1,1))
        ALLOCATE(tabvar3(x,y,1,1))
        ALLOCATE(masksrc(x,y))
        ALLOCATE(tabinterp4d(nxfin,nyfin,1,1))

        !
        DO n = 1,nbvert_lev
           !
           WRITE(*,*) 'interpolate/extrapolate for vertical level = ',n
           !
           CALL Read_Ncdf_var(varname,TRIM(restart_file),tabvar1,1,n)
           IF(n==1) THEN
              !
           ELSE IF (n==2) THEN
              tabvar2(:,:,:,1) = tabvar1(:,:,:,2)
           ELSE
              tabvar3(:,:,:,1) = tabvar2(:,:,:,1)
              tabvar2(:,:,:,1) = tabvar1(:,:,:,2)

           ENDIF
           !
           SELECT CASE(posvar)
              !
           CASE('T')
              !
              IF(MAXVAL(G1%tmask(:,:,n)) == 0.) THEN
                 tabinterp4d = 0.0
                 WRITE(*,*) 'only land points on level ',n
              ELSE

                 CALL extrap_detect(G0,G1,detected_pts(:,:,n),n)

                 CALL correct_field(detected_pts(:,:,n),tabvar1,tabvar2,tabvar3,G0,nav_lev,masksrc,n)

                 ! for the following variables, you do not want to mask the values
                 IF(  TRIM(varname) == 'e3t_n' .OR. TRIM(varname) == 'e3t_b' .OR. TRIM(varname) == 'e3t_m' .OR. &
                    & TRIM(varname) == 'fraqsr_1lev' .OR. TRIM(varname) == 'frq_m' .OR. TRIM(varname) == 'surf_ini' ) THEN
                    masksrc(:,:) = .TRUE.
                 ENDIF

                 SELECT CASE(TRIM(interp_type))
                 CASE('bilinear')
                    CALL get_remap_matrix(G0%nav_lat,G1%nav_lat, &
                       G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add)
                    CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1),nxfin,nyfin, &
                       matrix,src_add,dst_add)
                 CASE('bicubic')
                    CALL get_remap_bicub(G0%nav_lat,G1%nav_lat, &
                       G0%nav_lon,G1%nav_lon,masksrc,matrix,src_add,dst_add)
                    CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,1,1),&
                       nxfin,nyfin,matrix,src_add,dst_add)
                 END SELECT
                 !
                 IF( conservation ) THEN ! clem: it currently does not work
                    CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1), &
                       G0%e1t,G0%e2t,G1%e1t,G1%e2t,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1)
                 ENDIF

              ENDIF

              IF( ALL(masksrc) ) THEN
                 tabinterp4d(:,:,1,1) =  tabinterp4d(:,:,1,1)
              ELSE
                 tabinterp4d(:,:,1,1) =  tabinterp4d(:,:,1,1) * G1%tmask(:,:,n)
              ENDIF
              !
           CASE('U')
              !
              IF(MAXVAL(G1%umask(:,:,n)) == 0) THEN
                 tabinterp4d = 0.0
                 WRITE(*,*) 'only land points on level ',n
              ELSE
                 !
                 CALL extrap_detect(G0,G1,detected_pts(:,:,n),n,'U')
                 CALL correct_field(detected_pts(:,:,n),tabvar1,tabvar2,tabvar3,G0,nav_lev,masksrc,n,'U')
                 !
                 SELECT CASE(TRIM(interp_type))
                 CASE('bilinear')
                    CALL get_remap_matrix(G0%gphiu,G1%gphiu,   &
                       G0%glamu,G1%glamu,masksrc,matrix,src_add,dst_add)
                    CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1),nxfin,nyfin, &
                       matrix,src_add,dst_add)
                 CASE('bicubic')
                    CALL get_remap_bicub(G0%gphiu,G1%gphiu,   &
                       G0%glamu,G1%glamu,masksrc,matrix,src_add,dst_add)
                    CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,1,1),&
                       nxfin,nyfin,matrix,src_add,dst_add)
                 END SELECT
                 !
                 IF( conservation ) THEN ! clem: not coded for U
                    CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1), &
                       G0%e1u,G0%e2u,G1%e1u,G1%e2u,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1)
                 ENDIF
              ENDIF

              tabinterp4d(:,:,1,1) =  tabinterp4d(:,:,1,1) * G1%umask(:,:,n)
              !
           CASE('V')
              !
              IF(MAXVAL(G1%vmask(:,:,n)) == 0) THEN
                 tabinterp4d = 0.0
                 WRITE(*,*) 'only land points on level ',n
              ELSE
                 !

                 CALL extrap_detect(G0,G1,detected_pts(:,:,n),n,'V')

                 CALL correct_field(detected_pts(:,:,n),tabvar1,tabvar2,tabvar3,G0,nav_lev,masksrc,n,'V')
                 !
                 SELECT CASE(TRIM(interp_type))
                 CASE('bilinear')
                    CALL get_remap_matrix(G0%gphiv,G1%gphiv,   &
                       G0%glamv,G1%glamv,masksrc,matrix,src_add,dst_add)
                    CALL make_remap(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1),nxfin,nyfin, &
                       matrix,src_add,dst_add)
                 CASE('bicubic')
                    CALL get_remap_bicub(G0%gphiv,G1%gphiv,   &
                       G0%glamv,G1%glamv,masksrc,matrix,src_add,dst_add)
                    CALL make_bicubic_remap(tabvar1(:,:,1,1),masksrc,tabinterp4d(:,:,1,1),&
                       nxfin,nyfin,matrix,src_add,dst_add)
                 END SELECT
                 !
                 IF( conservation ) THEN ! clem: not coded for V
                    CALL Correctforconservation(tabvar1(:,:,1,1),tabinterp4d(:,:,1,1), &
                       G0%e1v,G0%e2v,G1%e1v,G1%e2v,nxfin,nyfin,posvar,imin-jpizoom+1,jmin-jpjzoom+1)
                 ENDIF
              ENDIF

              tabinterp4d(:,:,1,1) =  tabinterp4d(:,:,1,1) * G1%vmask(:,:,n)
              !
           END SELECT
           !
           !
           dimnames(1)='x'
           dimnames(2)='y'
           IF( vert_coord_name == '1' ) THEN
              dimnames(3)=TRIM(timedimname)

              ALLOCATE(tabvar3d(SIZE(tabinterp4d,1),SIZE(tabinterp4d,2),SIZE(tabinterp4d,3)))
              tabvar3d=tabinterp4d(:,:,:,1)
              CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabvar3d,1,'double')
              DEALLOCATE(tabvar3d)
           ELSE
              dimnames(3)=vert_coord_name
              dimnames(4)=TRIM(timedimname)

              CALL Write_Ncdf_var(TRIM(varname),dimnames,Child_file,tabinterp4d,1,n,'double')
           ENDIF
           !
           !
           CALL Copy_Ncdf_att(TRIM(varname),TRIM(restart_file),Child_file)
           !
           !
           IF(ASSOCIATED(matrix)) DEALLOCATE(matrix,src_add,dst_add)
           !
        END DO
        !
        DEALLOCATE(detected_pts)
        DEALLOCATE(tabinterp4d)
        DEALLOCATE(tabvar1,tabvar2,tabvar3)
        DEALLOCATE(masksrc)
        !
     ENDIF

  END DO

  ! change the before fields
  IF(rhot == 1) THEN
     WRITE(*,*) ''
     WRITE(*,*) 'no time interpolation (time refinement ratio = 1)'
  ELSE
     now_wght = (rhot-1.)/rhot
     before_wght = 1./rhot
     !
     ! --- 4D variables --- !
     CALL Read_Ncdf_var('un',Child_file,un)
     CALL Read_Ncdf_var('vn',Child_file,vn)
     CALL Read_Ncdf_var('ub',Child_file,ub)
     CALL Read_Ncdf_var('vb',Child_file,vb)
     ub = now_wght*un + before_wght*ub
     vb = now_wght*vn + before_wght*vb
     !
     CALL Read_Ncdf_var('tb',Child_file,tb)
     CALL Read_Ncdf_var('tn',Child_file,tn)
     tb = now_wght*tn + before_wght*tb
     !
     CALL Read_Ncdf_var('sb',Child_file,sb)
     CALL Read_Ncdf_var('sn',Child_file,sn)
     sb = now_wght*sn + before_wght*sb
     !
     CALL Read_Ncdf_var('e3t_b',Child_file,e3t_b)
     CALL Read_Ncdf_var('e3t_n',Child_file,e3t_n)
     e3t_b = now_wght*e3t_n + before_wght*e3t_b
     !
     dimnames(1)='x'
     dimnames(2)='y'
     dimnames(3)='nav_lev'
     dimnames(4)=TRIM(timedimname)
     CALL Write_Ncdf_var('ub',dimnames,Child_file,ub,'double')
     CALL Write_Ncdf_var('vb',dimnames,Child_file,vb,'double')
     CALL Write_Ncdf_var('tb',dimnames,Child_file,tb,'double')
     CALL Write_Ncdf_var('sb',dimnames,Child_file,sb,'double')
     CALL Write_Ncdf_var('e3t_b',dimnames,Child_file,e3t_b,'double')
     !
     DEALLOCATE(un,ub,vn,vb,tn,tb,sn,sb,e3t_n,e3t_b)
     !----------------------
     !
     ! --- 3D variables --- !
     CALL Read_Ncdf_var('sshb',Child_file,sshb)
     CALL Read_Ncdf_var('sshn',Child_file,sshn)
     sshb = now_wght*sshn + before_wght*sshb
     !
     dimnames(1)='x'
     dimnames(2)='y'
     dimnames(3)=TRIM(timedimname)
     CALL Write_Ncdf_var('sshb',dimnames,Child_file,sshb,'double')
     !
     DEALLOCATE(sshn,sshb)
     !----------------------
     !
  ENDIF
  !
  !
  WRITE(*,*) ' '
  WRITE(*,*) ' --- list of all the variables that have been interpolated --- '
  WRITE(*,*) Ncdf_varname
  WRITE(*,*) ' '
  WRITE(*,*) '******* restart file successfully created *******'
  WRITE(*,*) ' '
  !
  STOP
END PROGRAM


      SUBROUTINE jacprod(c, h, nots, nb)
      USE vspline
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER nots, nb, jmax
      REAL(rprec), DIMENSION(*) :: c, h
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      REAL(rprec), DIMENSION(nots) ::
     1   aspline, bspline, dspline, dum1
C-----------------------------------------------

!
!       THIS ROUTINE COMPUTES THE INNER PRODUCT COUT(I) = CIN(J)*JACOBIAN(J,I)
!       WHERE JACOBIAN(J,I) = D[G(J)]/D[F(I)]
!       HERE, G(J) ARE SECOND-DERIVATIVE KNOTS, F(I) FUNCTION KNOTS
!
!       COMPUTE COEFFICIENT ARRAY ELEMENTS A*X(I+1) + D*X(I) + B*X(I-1)
!       (TO BE SAFE, RECOMPUTE EACH TIME, SINCE IOTA, P SPLINES MAY
!        DIFFER FROM CALL TO CALL)
!
      aspline(1) = h(1)
      dspline(1) = 2.0*h(1)
      aspline(2:nots-1) = h(2:nots-1)
      bspline(2:nots-1) = h(:nots-2)
      dspline(2:nots-1) = 2.0*(h(2:nots-1)+h(:nots-2))

      jspmin(1) = 2
      IF (nb .eq. ideriv) jspmin(1) = 1
      jmax = nots - 1
      CALL tridslv(aspline,dspline,bspline,c,jspmin,jmax,0,nots,1)
      dum1(1) = 6.0*(c(2)-c(1))/h(1)
      dum1(2:nots) = 6.0*(c(:nots-1)-c(2:nots))/h(:nots-1)
      c(2:nots-1) = dum1(2:nots-1) - dum1(3:nots)
      c(1) = dum1(1)
      c(nots) = dum1(nots)

      END SUBROUTINE jacprod


*DECK DH12
      SUBROUTINE DH12 (MODE, LPIVOT, L1, M, U, IUE, UP, C, ICE, ICV,
     +   NCV)
C***BEGIN PROLOGUE  DH12
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DHFTI, DLSEI and DWNNLS
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (H12-S, DH12-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C      *** DOUBLE PRECISION VERSION OF H12 ******
C
C     C.L.Lawson and R.J.Hanson, Jet Propulsion Laboratory, 1973 Jun 12
C     to appear in 'Solving Least Squares Problems', Prentice-Hall, 1974
C
C     Construction and/or application of a single
C     Householder transformation..     Q = I + U*(U**T)/B
C
C     MODE    = 1 or 2   to select algorithm  H1  or  H2 .
C     LPIVOT is the index of the pivot element.
C     L1,M   If L1 .LE. M   the transformation will be constructed to
C            zero elements indexed from L1 through M.   If L1 GT. M
C            THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
C     U(),IUE,UP    On entry to H1 U() contains the pivot vector.
C                   IUE is the storage increment between elements.
C                                       On exit from H1 U() and UP
C                   contain quantities defining the vector U of the
C                   Householder transformation.   On entry to H2 U()
C                   and UP should contain quantities previously computed
C                   by H1.  These will not be modified by H2.
C     C()    On entry to H1 or H2 C() contains a matrix which will be
C            regarded as a set of vectors to which the Householder
C            transformation is to be applied.  On exit C() contains the
C            set of transformed vectors.
C     ICE    Storage increment between elements of vectors in C().
C     ICV    Storage increment between vectors in C().
C     NCV    Number of vectors in C() to be transformed. If NCV .LE. 0
C            no operations will be done on C().
C
C***SEE ALSO  DHFTI, DLSEI, DWNNLS
C***ROUTINES CALLED  DAXPY, DDOT, DSWAP
C***REVISION HISTORY  (YYMMDD)
C   790101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   900911  Added DDOT to DOUBLE PRECISION statement.  (WRB)
C***END PROLOGUE  DH12
      INTEGER I, I2, I3, I4, ICE, ICV, INCR, IUE, J, KL1, KL2, KLP,
     *     L1, L1M1, LPIVOT, M, MML1P2, MODE, NCV
      DOUBLE PRECISION B, C, CL, CLINV, ONE, UL1M1, SM, U, UP, DDOT
      DIMENSION U(IUE,*), C(*)
C     BEGIN BLOCK PERMITTING ...EXITS TO 140
C***FIRST EXECUTABLE STATEMENT  DH12
         ONE = 1.0D0
C
C     ...EXIT
         IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) GO TO 140
         CL = ABS(U(1,LPIVOT))
         IF (MODE .EQ. 2) GO TO 40
C           ****** CONSTRUCT THE TRANSFORMATION. ******
            DO 10 J = L1, M
               CL = MAX(ABS(U(1,J)),CL)
   10       CONTINUE
            IF (CL .GT. 0.0D0) GO TO 20
C     .........EXIT
               GO TO 140
   20       CONTINUE
            CLINV = ONE/CL
            SM = (U(1,LPIVOT)*CLINV)**2
            DO 30 J = L1, M
               SM = SM + (U(1,J)*CLINV)**2
   30       CONTINUE
            CL = CL*SQRT(SM)
            IF (U(1,LPIVOT) .GT. 0.0D0) CL = -CL
            UP = U(1,LPIVOT) - CL
            U(1,LPIVOT) = CL
         GO TO 50
   40    CONTINUE
C        ****** APPLY THE TRANSFORMATION  I+U*(U**T)/B  TO C. ******
C
         IF (CL .GT. 0.0D0) GO TO 50
C     ......EXIT
            GO TO 140
   50    CONTINUE
C     ...EXIT
         IF (NCV .LE. 0) GO TO 140
         B = UP*U(1,LPIVOT)
C        B  MUST BE NONPOSITIVE HERE.  IF B = 0., RETURN.
C
         IF (B .LT. 0.0D0) GO TO 60
C     ......EXIT
            GO TO 140
   60    CONTINUE
         B = ONE/B
         MML1P2 = M - L1 + 2
         IF (MML1P2 .LE. 20) GO TO 80
            L1M1 = L1 - 1
            KL1 = 1 + (L1M1 - 1)*ICE
            KL2 = KL1
            KLP = 1 + (LPIVOT - 1)*ICE
            UL1M1 = U(1,L1M1)
            U(1,L1M1) = UP
            IF (LPIVOT .NE. L1M1) CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV)
            DO 70 J = 1, NCV
               SM = DDOT(MML1P2,U(1,L1M1),IUE,C(KL1),ICE)
               SM = SM*B
               CALL DAXPY(MML1P2,SM,U(1,L1M1),IUE,C(KL1),ICE)
               KL1 = KL1 + ICV
   70       CONTINUE
            U(1,L1M1) = UL1M1
C     ......EXIT
            IF (LPIVOT .EQ. L1M1) GO TO 140
            KL1 = KL2
            CALL DSWAP(NCV,C(KL1),ICV,C(KLP),ICV)
         GO TO 130
   80    CONTINUE
            I2 = 1 - ICV + ICE*(LPIVOT - 1)
            INCR = ICE*(L1 - LPIVOT)
            DO 120 J = 1, NCV
               I2 = I2 + ICV
               I3 = I2 + INCR
               I4 = I3
               SM = C(I2)*UP
               DO 90 I = L1, M
                  SM = SM + C(I3)*U(1,I)
                  I3 = I3 + ICE
   90          CONTINUE
               IF (SM .EQ. 0.0D0) GO TO 110
                  SM = SM*B
                  C(I2) = C(I2) + SM*UP
                  DO 100 I = L1, M
                     C(I4) = C(I4) + SM*U(1,I)
                     I4 = I4 + ICE
  100             CONTINUE
  110          CONTINUE
  120       CONTINUE
  130    CONTINUE
  140 CONTINUE
      RETURN
      END


! This program fails because return kind is not specified for f1 & f2.

REAL FUNCTION f1(x)
IMPLICIT NONE
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
REAL(KIND=DBL), INTENT(IN) :: x

f1 = 10._DBL * SIN(20._DBL * x)
END FUNCTION f1

REAL FUNCTION f2(x)
IMPLICIT NONE
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
REAL(KIND=DBL), INTENT(IN) :: x
f2 = 77._DBL
END FUNCTION f2

! Placeholder for derivative subroutine
SUBROUTINE derivative(func, x, step_size, result)
IMPLICIT NONE
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
REAL(KIND=DBL), EXTERNAL :: func
REAL(KIND=DBL), INTENT(IN) :: x
REAL(KIND=DBL), INTENT(IN) :: step_size
REAL(KIND=DBL), INTENT(OUT) :: result

result = func(x)
END SUBROUTINE derivative

! Placeholder for derivative function
REAL FUNCTION deriv_func(func, x, step_size)
IMPLICIT NONE
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
REAL(KIND=DBL), EXTERNAL :: func
REAL(KIND=DBL), INTENT(IN) :: x
REAL(KIND=DBL), INTENT(IN) :: step_size

deriv_func = func(x)
END FUNCTION deriv_func

PROGRAM test_derivative
IMPLICIT NONE
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
REAL(KIND=DBL), EXTERNAL :: f2
REAL :: deriv_func
REAL(KIND=DBL) :: x
REAL(KIND=DBL) :: step_size
REAL(KIND=DBL) :: result
step_size = 1._DBL
x = 2._DBL
result = 0._DBL

WRITE(*, '(F20.12)') deriv_func(f2, x, step_size)
END PROGRAM test_derivative


c !DEC$ IF .NOT.DEFINED (CRAY)
      SUBROUTINE sgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)
      USE LAPREC, ONLY: WP => SP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, ML, MU, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: ABD
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      REAL(WP), PARAMETER :: ZERO = 0, ONE = 1
      INTEGER :: I0, J, JU, JZ, J0, J1, K, KP1, L, LM, M, MM, NM1
      REAL(WP) :: T
      INTEGER :: ISAMAX1(1)
C-----------------------------------------------
      EXTERNAL :: SSCAL, SAXPY
c
c     sgbfa factors a REAL band matrix by elimination.
c
c     sgbfa is usually called by sgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     real(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that sgbsl will divide by zero if
c                     called.  use  rcond  in sgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max(1, j-mu)
c                      i2 = min(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy ,sscal
c     fortran max,min
c
c     internal variables
c
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = MIN(n,m) - 1
      DO jz = j0, j1
         i0 = m + 1 - jz
         abd(i0:ml,jz) = zero
      END DO
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      IF (nm1 .ge. 1) THEN
         DO k = 1, nm1
            kp1 = k + 1
c
c        zero next fill-in column
c
            jz = jz + 1
            IF (jz .le. n) THEN
               abd(:ml,jz) = zero
            END IF
c
c        find l = pivot INDEX
c
            lm = MIN(ml,n - k)
            isamax1 = MAXLOC(ABS(abd(m:m+lm,k)))
            l = isamax1(1) + m - 1
!           l = isamax(lm + 1,abd(m,k),1) + m - 1
            ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
            IF (abd(l,k) .ne. zero) THEN
c
c           interchange if necessary
c
               IF (l .ne. m) THEN
                  t = abd(l,k)
                  abd(l,k) = abd(m,k)
                  abd(m,k) = t
               END IF
c
c           compute multipliers
c
               t = -one/abd(m,k)
               CALL sscal (lm, t, abd(m+1,k), 1)
c
c           row elimination with column indexing
c
               ju = MIN(MAX(ju,mu + ipvt(k)),n)
               mm = m
               DO j = kp1, ju
                  l = l - 1
                  mm = mm - 1
                  t = abd(l,j)
                  IF (l .ne. mm) THEN
                     abd(l,j) = abd(mm,j)
                     abd(mm,j) = t
                  END IF
                  CALL saxpy (lm, t, abd(m+1,k), 1, abd(mm+1,j), 1)
               END DO
            ELSE
               info = k
            END IF
         END DO
      END IF
      ipvt(n) = n
      IF (abd(m,n) .eq. zero) info = n

      END SUBROUTINE sgbfa

      SUBROUTINE dgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)
      USE LAPREC, ONLY: WP => DP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, ML, MU, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: ABD
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      REAL(WP), PARAMETER :: ZERO = 0, ONE = 1
      INTEGER :: I0, J, JU, JZ, J0, J1, K, KP1, L, LM, M, MM, NM1
      REAL(WP) :: T
      INTEGER :: ISAMAX1(1)
C-----------------------------------------------
      EXTERNAL :: DSCAL, DAXPY
c
c     sgbfa factors a REAL band matrix by elimination.
c
c     sgbfa is usually called by sgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     real(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that sgbsl will divide by zero if
c                     called.  use  rcond  in sgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max(1, j-mu)
c                      i2 = min(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy ,sscal
c     fortran max,min
c
c     internal variables
c
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = MIN(n,m) - 1
      DO jz = j0, j1
         i0 = m + 1 - jz
         abd(i0:ml,jz) = zero
      END DO
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      IF (nm1 .ge. 1) THEN
         DO k = 1, nm1
            kp1 = k + 1
c
c        zero next fill-in column
c
            jz = jz + 1
            IF (jz .le. n) THEN
               abd(:ml,jz) = zero
            END IF
c
c        find l = pivot INDEX
c
            lm = MIN(ml,n - k)
            isamax1 = MAXLOC(ABS(abd(m:m+lm,k)))
            l = isamax1(1) + m - 1
!           l = isamax(lm + 1,abd(m,k),1) + m - 1
            ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
            IF (abd(l,k) .ne. zero) THEN
c
c           interchange if necessary
c
               IF (l .ne. m) THEN
                  t = abd(l,k)
                  abd(l,k) = abd(m,k)
                  abd(m,k) = t
               END IF
c
c           compute multipliers
c
               t = -one/abd(m,k)
               CALL dscal (lm, t, abd(m+1,k), 1)
c
c           row elimination with column indexing
c
               ju = MIN(MAX(ju,mu + ipvt(k)),n)
               mm = m
               DO j = kp1, ju
                  l = l - 1
                  mm = mm - 1
                  t = abd(l,j)
                  IF (l .ne. mm) THEN
                     abd(l,j) = abd(mm,j)
                     abd(mm,j) = t
                  END IF
                  CALL daxpy (lm, t, abd(m+1,k), 1, abd(mm+1,j), 1)
               END DO
            ELSE
               info = k
            END IF
         END DO
      END IF
      ipvt(n) = n
      IF (abd(m,n) .eq. zero) info = n

      END SUBROUTINE dgbfa
c !DEC$ ENDIF
      SUBROUTINE sgbfa1 (ABD, LDA, N, ML, MU, IPVT, INFO)
      USE LAPREC, ONLY: WP => SP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, ML, MU, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(*) :: ABD

      CALL sgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)

      END SUBROUTINE sgbfa1

      SUBROUTINE dgbfa1 (ABD, LDA, N, ML, MU, IPVT, INFO)
      USE LAPREC, ONLY: WP => DP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, ML, MU, INFO
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(*) :: ABD

      CALL dgbfa (ABD, LDA, N, ML, MU, IPVT, INFO)

      END SUBROUTINE dgbfa1


!-------------------------------------------------------------------!
! SUBROUTINE QPSOLVER                                               !
!-------------------------------------------------------------------!
!
! Users should modify this subroutine in order to have his/her own
! optimization method.
!
! This subroutine uses the adapted trust region derivative-free TRDF
! algorithm for finding a point not in the filter that reduces the
! functional value at restored point.
!

subroutine qpsolver(n,y,l,u,me,mi,evalf_,evalc_,evallc_,evalljac_, &
                    nf,alpha,ffilter,hfilter,filterTest,outiter,   &
                    epsfeas,epsopt,verbose,delta,fy,hynorm,rho,flag)

  use trdf_solver
  use userinterface
  use filters      , only: absfilter

  implicit none

  ! SCALAR ARGUMENTS
  logical :: verbose
  integer :: flag,me,mi,n,nf,outiter
  real(8) :: alpha,delta,epsfeas,epsopt,fy,hynorm,rho

  ! ARRAY ARGUMENTS
  real(8) :: ffilter(nf),hfilter(nf),l(n),u(n),y(n)

  ! EXTERNAL SUBROUTINES
  procedure(evalf)     :: evalf_
  procedure(evalc)     :: evallc_,evalc_
  procedure(evaljac)   :: evalljac_
  procedure(absfilter) :: filterTest

  intent(in   ) :: alpha,epsfeas,epsopt,ffilter,hfilter,l,me,mi,n, &
       nf,outiter,u,verbose
  intent(out  ) :: hynorm,flag
  intent(inout) :: delta,fy,rho,y

  call trdfsolver(n,y,l,u,me,mi,evalf_,evalc_,evallc_,evalljac_, &
       nf,alpha,ffilter,hfilter,filterTest,outiter,epsfeas,  &
       epsopt,verbose,delta,fy,hynorm,rho,flag)

end subroutine qpsolver


	PROGRAM ZETA
C
C	FOR POTENTIAL AROUND AN ELLIPSOID IN ANISOTROPIC PLASMA
C
	COMPLEX LAMBDA,BB,CC,DISC,SDISC,SRATIO,ZETAP,ZETAN
	REAL LOV2R
C
	DATA ROCKR,ROCKL /22.,500./
C	SRATIO IS SIGMA PARALLEL / SIGMA PERP
	DATA SRATIO /-1.E3/
C
C	RATIO OF LENGTH TO DIAMETER OF ROCKET
	LOV2R = .5*ROCKL/ROCKR
	LAMBDA = SRATIO/LOV2R**2
	PRINT*,'SRATIO',SRATIO
	PRINT*,'LAMBDA',LAMBDA
C
	Z = 0.
	R = 0.
	DO 101 I = 1,50
  100	CONTINUE
C	Z = 20.*I + 230.
	R = 20. + 2.*I
C	READ*,R,Z
C	TO FORCE R,Z TO BE ON THE SURFACE OF THE ELLIPSOID
c	R = SQRT(ROCKR**2 - Z**2/LOV2R**2)
	BB = ROCKR**2*(1. + 1./LAMBDA) - R**2 - Z**2/SRATIO
	CC = ROCKR**2*((ROCKR**2 - R**2)/LAMBDA - Z**2/SRATIO)
	DISC = BB**2 - 4.*CC
	SDISC = CSQRT(DISC)
C      PRINT*,'B,C,D,sd',BB,CC,DISC,sdisc
	ZETAP = .5*(-BB + SDISC)
	ZETAN = .5*(-BB - SDISC)
	PRINT 1001,R,Z,ZETAP,ZETAN
 1001	FORMAT(2E12.3,2(E13.3,E12.3))
C	GO TO 100
  101	CONTINUE
	STOP
	END


*DECK HSTCSP
      SUBROUTINE HSTCSP (INTL, A, B, M, MBDCND, BDA, BDB, C, D, N,
     +   NBDCND, BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HSTCSP
C***PURPOSE  Solve the standard five-point finite difference
C            approximation on a staggered grid to the modified Helmholtz
C            equation in spherical coordinates assuming axisymmetry
C            (no dependence on longitude).
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HSTCSP-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SPHERICAL
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     HSTCSP solves the standard five-point finite difference
C     approximation on a staggered grid to the modified Helmholtz
C     equation spherical coordinates assuming axisymmetry (no dependence
C     on longitude).
C
C                  (1/R**2)(d/dR)(R**2(dU/dR)) +
C
C       1/(R**2*SIN(THETA))(d/dTHETA)(SIN(THETA)(dU/dTHETA)) +
C
C            (LAMBDA/(R*SIN(THETA))**2)U  =  F(THETA,R)
C
C     where THETA is colatitude and R is the radial coordinate.
C     This two-dimensional modified Helmholtz equation results from
C     the Fourier transform of the three-dimensional Poisson equation.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C
C            * * * * * *   On Input    * * * * * *
C
C   INTL
C     = 0  On initial entry to HSTCSP or if any of the arguments
C          C, D, N, or NBDCND are changed from a previous call.
C
C     = 1  If C, D, N, and NBDCND are all unchanged from previous
C          call to HSTCSP.
C
C     NOTE:  A call with INTL = 0 takes approximately 1.5 times as much
C            time as a call with INTL = 1.  Once a call with INTL = 0
C            has been made then subsequent solutions corresponding to
C            different F, BDA, BDB, BDC, and BDD can be obtained
C            faster with INTL = 1 since initialization is not repeated.
C
C   A,B
C     The range of THETA (colatitude), i.e. A .LE. THETA .LE. B.  A
C     must be less than B and A must be non-negative.  A and B are in
C     radians.  A = 0 corresponds to the north pole and B = PI
C     corresponds to the south pole.
C
C                  * * *  IMPORTANT  * * *
C
C     If B is equal to PI, then B must be computed using the statement
C
C     B = PIMACH(DUM)
C
C     This insures that B in the user's program is equal to PI in this
C     program which permits several tests of the input parameters that
C     otherwise would not be possible.
C
C                  * * * * * * * * * * * *
C
C   M
C     The number of grid points in the interval (A,B).  The grid points
C     in the THETA-direction are given by THETA(I) = A + (I-0.5)DTHETA
C     for I=1,2,...,M where DTHETA =(B-A)/M.  M must be greater than 4.
C
C   MBDCND
C     Indicates the type of boundary conditions at THETA = A and
C     THETA = B.
C
C     = 1  If the solution is specified at THETA = A and THETA = B.
C          (See notes 1, 2 below)
C
C     = 2  If the solution is specified at THETA = A and the derivative
C          of the solution with respect to THETA is specified at
C          THETA = B (See notes 1, 2 below).
C
C     = 3  If the derivative of the solution with respect to THETA is
C          specified at THETA = A (See notes 1, 2 below) and THETA = B.
C
C     = 4  If the derivative of the solution with respect to THETA is
C          specified at THETA = A (See notes 1, 2 below) and the
C          solution is specified at THETA = B.
C
C     = 5  If the solution is unspecified at THETA = A = 0 and the
C          solution is specified at THETA = B. (See note 2 below)
C
C     = 6  If the solution is unspecified at THETA = A = 0 and the
C          derivative of the solution with respect to THETA is
C          specified at THETA = B (See note 2 below).
C
C     = 7  If the solution is specified at THETA = A and the
C          solution is unspecified at THETA = B = PI.
C
C     = 8  If the derivative of the solution with respect to
C          THETA is specified at THETA = A (See note 1 below)
C          and the solution is unspecified at THETA = B = PI.
C
C     = 9  If the solution is unspecified at THETA = A = 0 and
C          THETA = B = PI.
C
C     NOTES:  1.  If A = 0, do not use MBDCND = 1,2,3,4,7 or 8,
C                 but instead use MBDCND = 5, 6, or 9.
C
C             2.  if B = PI, do not use MBDCND = 1,2,3,4,5 or 6,
C                 but instead use MBDCND = 7, 8, or 9.
C
C             When A = 0  and/or B = PI the only meaningful boundary
C             condition is dU/dTHETA = 0.  (See D. Greenspan, 'Numerical
C             Analysis of Elliptic Boundary Value Problems,' Harper and
C             Row, 1965, Chapter 5.)
C
C   BDA
C     A one-dimensional array of length N that specifies the boundary
C     values (if any) of the solution at THETA = A.  When
C     MBDCND = 1, 2, or 7,
C
C              BDA(J) = U(A,R(J)) ,              J=1,2,...,N.
C
C     When MBDCND = 3, 4, or 8,
C
C              BDA(J) = (d/dTHETA)U(A,R(J)) ,    J=1,2,...,N.
C
C     When MBDCND has any other value, BDA is a dummy variable.
C
C   BDB
C     A one-dimensional array of length N that specifies the boundary
C     values of the solution at THETA = B.  When MBDCND = 1, 4, or 5,
C
C              BDB(J) = U(B,R(J)) ,              J=1,2,...,N.
C
C     When MBDCND = 2,3, or 6,
C
C              BDB(J) = (d/dTHETA)U(B,R(J)) ,    J=1,2,...,N.
C
C     When MBDCND has any other value, BDB is a dummy variable.
C
C   C,D
C     The range of R , i.e. C .LE. R .LE. D.
C     C must be less than D.  C must be non-negative.
C
C   N
C     The number of unknowns in the interval (C,D).  The unknowns in
C     the R-direction are given by R(J) = C + (J-0.5)DR,
C     J=1,2,...,N, where DR = (D-C)/N.  N must be greater than 4.
C
C   NBDCND
C     Indicates the type of boundary conditions at R = C
C     and R = D.
C
C     = 1  If the solution is specified at R = C and R = D.
C
C     = 2  If the solution is specified at R = C and the derivative
C          of the solution with respect to R is specified at
C          R = D. (See note 1 below)
C
C     = 3  If the derivative of the solution with respect to R is
C          specified at R = C and R = D.
C
C     = 4  If the derivative of the solution with respect to R is
C          specified at R = C and the solution is specified at
C          R = D.
C
C     = 5  If the solution is unspecified at R = C = 0 (See note 2
C          below) and the solution is specified at R = D.
C
C     = 6  If the solution is unspecified at R = C = 0 (See note 2
C          below) and the derivative of the solution with respect to R
C          is specified at R = D.
C
C     NOTE 1:  If C = 0 and MBDCND = 3,6,8 or 9, the system of equations
C              to be solved is singular.  The unique solution is
C              determined by extrapolation to the specification of
C              U(THETA(1),C).  But in these cases the right side of the
C              system will be perturbed by the constant PERTRB.
C
C     NOTE 2:  NBDCND = 5 or 6 cannot be used with MBDCND = 1, 2, 4, 5,
C              or 7 (the former indicates that the solution is
C              unspecified at R = 0; the latter indicates that the
C              solution is specified).  Use instead NBDCND = 1 or 2.
C
C   BDC
C     A one dimensional array of length M that specifies the boundary
C     values of the solution at R = C.   When NBDCND = 1 or 2,
C
C              BDC(I) = U(THETA(I),C) ,              I=1,2,...,M.
C
C     When NBDCND = 3 or 4,
C
C              BDC(I) = (d/dR)U(THETA(I),C),         I=1,2,...,M.
C
C     When NBDCND has any other value, BDC is a dummy variable.
C
C   BDD
C     A one-dimensional array of length M that specifies the boundary
C     values of the solution at R = D.  When NBDCND = 1 or 4,
C
C              BDD(I) = U(THETA(I),D) ,              I=1,2,...,M.
C
C     When NBDCND = 2 or 3,
C
C              BDD(I) = (d/dR)U(THETA(I),D) ,        I=1,2,...,M.
C
C     When NBDCND has any other value, BDD is a dummy variable.
C
C   ELMBDA
C     The constant LAMBDA in the modified Helmholtz equation.  If
C     LAMBDA is greater than 0, a solution may not exist.  However,
C     HSTCSP will attempt to find a solution.
C
C   F
C     A two-dimensional array that specifies the values of the right
C     side of the modified Helmholtz equation.  For I=1,2,...,M and
C     J=1,2,...,N
C
C              F(I,J) = F(THETA(I),R(J)) .
C
C     F must be dimensioned at least M X N.
C
C   IDIMF
C     The row (or first) dimension of the array F as it appears in the
C     program calling HSTCSP.  This parameter is used to specify the
C     variable dimension of F.  IDIMF must be at least M.
C
C   W
C     A one-dimensional array that must be provided by the user for
C     work space.  With K = INT(log2(N))+1 and L = 2**(K+1), W may
C     require up to (K-2)*L+K+MAX(2N,6M)+4(N+M)+5 locations.  The
C     actual number of locations used is computed by HSTCSP and is
C     returned in the location W(1).
C
C
C            * * * * * *   On Output   * * * * * *
C
C   F
C     Contains the solution U(I,J) of the finite difference
C     approximation for the grid point (THETA(I),R(J)) for
C     I=1,2,...,M, J=1,2,...,N.
C
C   PERTRB
C     If a combination of periodic, derivative, or unspecified
C     boundary conditions is specified for a Poisson equation
C     (LAMBDA = 0), a solution may not exist.  PERTRB is a con-
C     stant, calculated and subtracted from F, which ensures
C     that a solution exists.  HSTCSP then computes this
C     solution, which is a least squares solution to the
C     original approximation.  This solution plus any constant is also
C     a solution; hence, the solution is not unique.  The value of
C     PERTRB should be small compared to the right side F.
C     Otherwise, a solution is obtained to an essentially different
C     problem.  This comparison should always be made to insure that
C     a meaningful solution has been obtained.
C
C   IERROR
C     An error flag that indicates invalid input parameters.
C     Except for numbers 0 and 10, a solution is not attempted.
C
C     =  0  No error
C
C     =  1  A .LT. 0 or B .GT. PI
C
C     =  2  A .GE. B
C
C     =  3  MBDCND .LT. 1 or MBDCND .GT. 9
C
C     =  4  C .LT. 0
C
C     =  5  C .GE. D
C
C     =  6  NBDCND .LT. 1 or NBDCND .GT. 6
C
C     =  7  N .LT. 5
C
C     =  8  NBDCND = 5 or 6 and MBDCND = 1, 2, 4, 5, or 7
C
C     =  9  C .GT. 0 and NBDCND .GE. 5
C
C     = 10  ELMBDA .GT. 0
C
C     = 11  IDIMF .LT. M
C
C     = 12  M .LT. 5
C
C     = 13  A = 0 and MBDCND =1,2,3,4,7 or 8
C
C     = 14  B = PI and MBDCND .LE. 6
C
C     = 15  A .GT. 0 and MBDCND = 5, 6, or 9
C
C     = 16  B .LT. PI and MBDCND .GE. 7
C
C     = 17  LAMBDA .NE. 0 and NBDCND .GE. 5
C
C     Since this is the only means of indicating a possibly
C     incorrect call to HSTCSP, the user should test IERROR after
C     the call.
C
C   W
C     W(1) contains the required length of W.  Also  W contains
C     intermediate values that must not be destroyed if HSTCSP
C     will be called again with INTL = 1.
C
C *Long Description:
C
C    * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C    Dimension of   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C    Arguments      W(See argument list)
C
C    Latest         June 1979
C    Revision
C
C    Subprograms    HSTCSP,HSTCS1,BLKTRI,BLKTR1,INDXA,INDXB,INDXC,
C    Required       PROD,PRODP,CPROD,CPRODP,PPADD,PSGF,BSRH,PPSGF,
C                   PPSPF,COMPB,TEVLS,R1MACH
C
C    Special        NONE
C    Conditions
C
C    Common         CBLKT
C    Blocks
C
C    I/O            NONE
C
C    Precision      Single
C
C    Specialist     Roland Sweet
C
C    Language       FORTRAN
C
C    History        Written by Roland Sweet at NCAR in May, 1977
C
C    Algorithm      This subroutine defines the finite-difference
C                   equations, incorporates boundary data, adjusts the
C                   right side when the system is singular and calls
C                   BLKTRI which solves the linear system of equations.
C
C    Space          5269(decimal) = 12225(octal) locations on the
C    Required       NCAR Control Data 7600
C
C    Timing and        The execution time T on the NCAR Control Data
C    Accuracy       7600 for subroutine HSTCSP is roughly proportional
C                   to M*N*log2(N), but depends on the input parameter
C                   INTL.  Some values are listed in the table below.
C                      The solution process employed results in a loss
C                   of no more than FOUR significant digits for N and M
C                   as large as 64.  More detailed information about
C                   accuracy can be found in the documentation for
C                   subroutine BLKTRI which is the routine that
C                   actually solves the finite difference equations.
C
C
C                      M(=N)     INTL      MBDCND(=NBDCND)     T(MSECS)
C                      -----     ----      ---------------     --------
C
C                       32        0              1-6             132
C                       32        1              1-6              88
C                       64        0              1-6             546
C                       64        1              1-6             380
C
C    Portability    American National Standards Institute Fortran.
C                   The machine accuracy is set using function R1MACH.
C
C    Required       COS,SIN,ABS,SQRT
C    Resident
C    Routines
C
C    Reference      Swarztrauber, P.N., 'A Direct Method For The
C                   Discrete Solution Of Separable Elliptic Equations,'
C                   SIAM J. Numer. Anal. 11(1974), pp. 1136-1150.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C               P. N. Swarztrauber, A direct method for the discrete
C                 solution of separable elliptic equations, SIAM Journal
C                 on Numerical Analysis 11, (1974), pp. 1136-1150.
C***ROUTINES CALLED  HSTCS1, PIMACH
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HSTCSP
C
C
      DIMENSION       F(IDIMF,*) ,BDA(*)     ,BDB(*)     ,BDC(*)     ,
     1                BDD(*)     ,W(*)
C***FIRST EXECUTABLE STATEMENT  HSTCSP
      PI = PIMACH(DUM)
C
C     CHECK FOR INVALID INPUT PARAMETERS
C
      IERROR = 0
      IF (A.LT.0. .OR. B.GT.PI) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 3
      IF (C .LT. 0.) IERROR = 4
      IF (C .GE. D) IERROR = 5
      IF (NBDCND.LT.1 .OR. NBDCND.GT.6) IERROR = 6
      IF (N .LT. 5) IERROR = 7
      IF ((NBDCND.EQ.5 .OR. NBDCND.EQ.6) .AND. (MBDCND.EQ.1 .OR.
     1    MBDCND.EQ.2 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.5 .OR.
     2                                                     MBDCND.EQ.7))
     3    IERROR = 8
      IF (C.GT.0. .AND. NBDCND.GE.5) IERROR = 9
      IF (IDIMF .LT. M) IERROR = 11
      IF (M .LT. 5) IERROR = 12
      IF (A.EQ.0. .AND. MBDCND.NE.5 .AND. MBDCND.NE.6 .AND. MBDCND.NE.9)
     1    IERROR = 13
      IF (B.EQ.PI .AND. MBDCND.LE.6) IERROR = 14
      IF (A.GT.0. .AND. (MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9))
     1    IERROR = 15
      IF (B.LT.PI .AND. MBDCND.GE.7) IERROR = 16
      IF (ELMBDA.NE.0. .AND. NBDCND.GE.5) IERROR = 17
      IF (IERROR .NE. 0) GO TO 101
      IWBM = M+1
      IWCM = IWBM+M
      IWAN = IWCM+M
      IWBN = IWAN+N
      IWCN = IWBN+N
      IWSNTH = IWCN+N
      IWRSQ = IWSNTH+M
      IWWRK = IWRSQ+N
      IERR1 = 0
      CALL HSTCS1 (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1             ELMBDA,F,IDIMF,PERTRB,IERR1,W,W(IWBM),W(IWCM),
     2             W(IWAN),W(IWBN),W(IWCN),W(IWSNTH),W(IWRSQ),W(IWWRK))
      W(1) = W(IWWRK)+IWWRK-1
      IERROR = IERR1
  101 CONTINUE
      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine current_ms
  use global_variables_ms
  implicit none
  integer :: ikr,ikz,im
  real(8) :: jz_intra,jz_inter
  real(8) :: jz_l(Mx)
  complex(8) :: zfact

  jz_l = 0d0
  do im = Mx_s,Mx_e
    jz_intra = 0d0
    jz_inter = 0d0
    do ikz = -NKz,NKz
      kz(ikz) = kz0(ikz) + Az_new(im)
      do ikr = 1,NKr
        jz_intra = jz_intra + kz(ikz)*abs(zCt(2,ikr,ikz,im))**2*kr(ikr)
        zfact = exp(-zI*deps_int(ikr,ikz,im))
        jz_inter = jz_inter &
          + 2d0*real(zfact*conjg(zCt(1,ikr,ikz,im))*zCt(2,ikr,ikz,im))*kr(ikr)
      end do
    end do

    jz_intra = jz_intra/mass_r*2d0/((2d0*pi)**3)*(2d0*pi*dkr*dkz)
    jz_inter = jz_inter*piz_vc*2d0/((2d0*pi)**3)*(2d0*pi*dkr*dkz)

    jz_l(im) = jz_intra + jz_inter
  end do

  call MPI_ALLREDUCE(jz_l,jz,Mx,MPI_REAL8,MPI_SUM,MPI_COMM_WORLD,ierr)

  return
end subroutine current_ms


*DECK RFFTB1
      SUBROUTINE RFFTB1 (N, C, CH, WA, IFAC)
C***BEGIN PROLOGUE  RFFTB1
C***PURPOSE  Compute the backward fast Fourier transform of a real
C            coefficient array.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (RFFTB1-S, CFFTB1-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C   Subroutine RFFTB1 computes the real periodic sequence from its
C   Fourier coefficients (Fourier synthesis).  The transform is defined
C   below at output parameter C.
C
C   The arrays WA and IFAC which are used by subroutine RFFTB1 must be
C   initialized by calling subroutine RFFTI1.
C
C   Input Arguments
C
C   N       the length of the array R to be transformed.  The method
C           is most efficient when N is a product of small primes.
C           N may change so long as different work arrays are provided.
C
C   C       a real array of length N which contains the sequence
C           to be transformed.
C
C   CH      a real work array of length at least N.
C
C   WA      a real work array which must be dimensioned at least N.
C
C   IFAC    an integer work array which must be dimensioned at least 15.
C
C           The WA and IFAC arrays must be initialized by calling
C           subroutine RFFTI1, and different WA and IFAC arrays must be
C           used for each different value of N.  This initialization
C           does not have to be repeated so long as N remains unchanged.
C           Thus subsequent transforms can be obtained faster than the
C           first.  The same WA and IFAC arrays can be used by RFFTF1
C           and RFFTB1.
C
C   Output Argument
C
C   C       For N even and for I = 1,...,N
C
C                C(I) = C(1)+(-1)**(I-1)*C(N)
C
C                     plus the sum from K=2 to K=N/2 of
C
C                      2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                     -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C           For N odd and for I = 1,...,N
C
C                C(I) = C(1) plus the sum from K=2 to K=(N+1)/2 of
C
C                     2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                    -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C   Notes:  This transform is unnormalized since a call of RFFTF1
C           followed by a call of RFFTB1 will multiply the input
C           sequence by N.
C
C           WA and IFAC contain initialization calculations which must
C           not be destroyed between calls of subroutine RFFTF1 or
C           RFFTB1.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RADB2, RADB3, RADB4, RADB5, RADBG
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from subsidiary to user-callable.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RFFTB1
      DIMENSION CH(*), C(*), WA(*), IFAC(*)
C***FIRST EXECUTABLE STATEMENT  RFFTB1
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDL1 = IDO*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL RADB2 (IDO,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL RADB2 (IDO,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 110
         CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (IDO .EQ. 1) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDO
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      DO 117 I=1,N
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END