!
! Copyright (C) 2001-2012 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!--------------------------------------------------------------------------!
! FFT scalar drivers Module - contains machine-dependent routines for:     !
! FFTW, FFTW3, ESSL, LINUX_ESSL, SCSL, SUNPERF, NEC ASL libraries          !
! (both 3d for serial execution and 1d+2d FFTs for parallel execution,     !
! excepted NEC ASL, 3d only, no parallel execution)                        !
! Written by Carlo Cavazzoni, modified by P. Giannozzi, contributions      !
! by Martin Hilgemans, Guido Roma, Pascal Thibaudeau, Stephane Lefranc,    !
! Nicolas Lacorne, Filippo Spiga - Last update Aug 2012                    !
!--------------------------------------------------------------------------!

#include "fft_defs.h"
!=----------------------------------------------------------------------=!
   MODULE fft_scalar
!=----------------------------------------------------------------------=!
       USE kinds

        IMPLICIT NONE
        SAVE

        PRIVATE
        PUBLIC :: cft_1z, cft_2xy
        PUBLIC :: good_fft_dimension, allowed, good_fft_order
        PUBLIC :: cft_b

! ...   Local Parameter

        !   ndims   Number of different FFT tables that the module
        !           could keep into memory without reinitialization
        !   nfftx   Max allowed fft dimension

        INTEGER, PARAMETER :: ndims = 3, nfftx = 2049

        !   Workspace that is statically allocated is defined here
        !   in order to avoid multiple copies of the same workspace
        !   lwork:   Dimension of the work space array (if any)

        !  Only FFTW_ESTIMATE is actually used

#define  FFTW_MEASURE  0
#define  FFTW_ESTIMATE 64

!=----------------------------------------------------------------------=!
   CONTAINS
!=----------------------------------------------------------------------=!

!
!=----------------------------------------------------------------------=!
!
!
!
!         FFT along "z"
!
!
!
!=----------------------------------------------------------------------=!
!

   SUBROUTINE cft_1z(c, nsl, nz, ldz, isign, cout)

!     driver routine for nsl 1d complex fft's of length nz
!     ldz >= nz is the distance between sequences to be transformed
!     (ldz>nz is used on some architectures to reduce memory conflicts)
!     input  :  c(ldz*nsl)   (complex)
!     output : cout(ldz*nsl) (complex - NOTA BENE: transform is not in-place!)
!     isign > 0 : forward (f(G)=>f(R)), isign <0 backward (f(R) => f(G))
!     Up to "ndims" initializations (for different combinations of input
!     parameters nz, nsl, ldz) are stored and re-used if available

     INTEGER, INTENT(IN) :: isign
     INTEGER, INTENT(IN) :: nsl, nz, ldz

     COMPLEX (DP) :: c(:), cout(:)

     REAL (DP)  :: tscale
     INTEGER    :: i, err, idir, ip
     INTEGER, SAVE :: zdims( 3, ndims ) = -1
     INTEGER, SAVE :: icurrent = 1
     LOGICAL :: done

#if defined __HPM
     INTEGER :: OMP_GET_THREAD_NUM
#endif
     INTEGER :: tid

     ! ...   Machine-Dependent parameters, work arrays and tables of factors

     !   ltabl   Dimension of the tables of factors calculated at the
     !           initialization stage

#if defined __OPENMP
     INTEGER :: offset, ldz_t
     INTEGER :: omp_get_max_threads
     EXTERNAL :: omp_get_max_threads
#endif

     !   Pointers to the "C" structures containing FFT factors ( PLAN )
     !   C_POINTER is defined in include/fft_defs.h
     !   for 32bit executables, C_POINTER is integer(4)
     !   for 64bit executables, C_POINTER is integer(8)

     C_POINTER, SAVE :: fw_planz( ndims ) = 0
     C_POINTER, SAVE :: bw_planz( ndims ) = 0

     IF( nsl < 0 ) THEN
       CALL errore(" fft_scalar: cft_1z ", " nsl out of range ", nsl)
     END IF

     !
     !   Here initialize table only if necessary
     !

     DO ip = 1, ndims

        !   first check if there is already a table initialized
        !   for this combination of parameters

        done = ( nz == zdims(1,ip) )

        done = done .AND. ( nsl == zdims(2,ip) ) .AND. ( ldz == zdims(3,ip) )
        IF (done) EXIT
     END DO

     IF( .NOT. done ) THEN

       !   no table exist for these parameters
       !   initialize a new one

       ! WRITE( stdout, fmt="('DEBUG cft_1z, reinitializing tables ', I3)" ) icurrent

       IF( fw_planz( icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_planz( icurrent) )
       IF( bw_planz( icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_planz( icurrent) )
       idir = -1
       CALL dfftw_plan_many_dft( fw_planz( icurrent), 1, nz, nsl, c, &
            (/SIZE(c)/), 1, ldz, cout, (/SIZE(cout)/), 1, ldz, idir, FFTW_ESTIMATE)
       idir = 1
       CALL dfftw_plan_many_dft( bw_planz( icurrent), 1, nz, nsl, c, &
            (/SIZE(c)/), 1, ldz, cout, (/SIZE(cout)/), 1, ldz, idir, FFTW_ESTIMATE)

       zdims(1,icurrent) = nz; zdims(2,icurrent) = nsl; zdims(3,icurrent) = ldz;
       ip = icurrent
       icurrent = MOD( icurrent, ndims ) + 1

     END IF

     !
     !   Now perform the FFTs using machine specific drivers
     !

#if defined __FFT_CLOCKS
     CALL start_clock( 'cft_1z' )
#endif

     IF (isign < 0) THEN
        CALL dfftw_execute_dft( fw_planz( ip), c, cout)
        tscale = 1.0_DP / nz
        cout( 1 : ldz * nsl ) = cout( 1 : ldz * nsl ) * tscale
     ELSE IF (isign > 0) THEN
        CALL dfftw_execute_dft( bw_planz( ip), c, cout)
     END IF

#if defined __FFT_CLOCKS
     CALL stop_clock( 'cft_1z' )
#endif

     RETURN
   END SUBROUTINE cft_1z

!
!
!=----------------------------------------------------------------------=!
!
!
!
!         FFT along "x" and "y" direction
!
!
!
!=----------------------------------------------------------------------=!
!
!

   SUBROUTINE cft_2xy(r, nzl, nx, ny, ldx, ldy, isign, pl2ix)

!     driver routine for nzl 2d complex fft's of lengths nx and ny
!     input : r(ldx*ldy)  complex, transform is in-place
!     ldx >= nx, ldy >= ny are the physical dimensions of the equivalent
!     2d array: r2d(ldx, ldy) (x first dimension, y second dimension)
!     (ldx>nx, ldy>ny used on some architectures to reduce memory conflicts)
!     pl2ix(nx) (optional) is 1 for columns along y to be transformed
!     isign > 0 : forward (f(G)=>f(R)), isign <0 backward (f(R) => f(G))
!     Up to "ndims" initializations (for different combinations of input
!     parameters nx,ny,nzl,ldx) are stored and re-used if available

     IMPLICIT NONE

     INTEGER, INTENT(IN) :: isign, ldx, ldy, nx, ny, nzl
     INTEGER, OPTIONAL, INTENT(IN) :: pl2ix(:)
     COMPLEX (DP) :: r( : )
     INTEGER :: i, k, j, err, idir, ip, kk
     REAL(DP) :: tscale
     INTEGER, SAVE :: icurrent = 1
     INTEGER, SAVE :: dims( 4, ndims) = -1
     LOGICAL :: dofft( nfftx ), done
     INTEGER, PARAMETER  :: stdout = 6

#if defined __HPM
     INTEGER :: OMP_GET_THREAD_NUM
#endif
#if defined __OPENMP
     INTEGER :: offset
     INTEGER :: nx_t, ny_t, nzl_t, ldx_t, ldy_t
     INTEGER  :: itid, mytid, ntids
     INTEGER  :: omp_get_thread_num, omp_get_num_threads
     EXTERNAL :: omp_get_thread_num, omp_get_num_threads
#endif

     C_POINTER, SAVE :: fw_plan( 2, ndims ) = 0
     C_POINTER, SAVE :: bw_plan( 2, ndims ) = 0

     dofft( 1 : nx ) = .TRUE.
     IF( PRESENT( pl2ix ) ) THEN
       IF( SIZE( pl2ix ) < nx ) &
         CALL errore( ' cft_2xy ', ' wrong dimension for arg no. 8 ', 1 )
       DO i = 1, nx
         IF( pl2ix(i) < 1 ) dofft( i ) = .FALSE.
       END DO
     END IF

     ! WRITE( stdout,*) 'DEBUG: ', COUNT( dofft )

     !
     !   Here initialize table only if necessary
     !

     DO ip = 1, ndims

       !   first check if there is already a table initialized
       !   for this combination of parameters

       done = ( ny == dims(1,ip) ) .AND. ( nx == dims(3,ip) )
        !   The initialization in ESSL and FFTW v.3 depends on all four parameters
       done = done .AND. ( ldx == dims(2,ip) ) .AND.  ( nzl == dims(4,ip) )
       IF (done) EXIT
     END DO

     IF( .NOT. done ) THEN

       !   no table exist for these parameters
       !   initialize a new one

       ! WRITE( stdout, fmt="('DEBUG cft_2xy, reinitializing tables ', I3)" ) icurrent

       IF ( ldx /= nx .OR. ldy /= ny ) THEN
          IF( fw_plan(2,icurrent) /= 0 )  CALL dfftw_destroy_plan( fw_plan(2,icurrent) )
          IF( bw_plan(2,icurrent) /= 0 )  CALL dfftw_destroy_plan( bw_plan(2,icurrent) )
          idir = -1
          CALL dfftw_plan_many_dft( fw_plan(2,icurrent), 1, ny, 1, r(1:), &
               (/ldx*ldy/), ldx, 1, r(1:), (/ldx*ldy/), ldx, 1, idir, &
               FFTW_ESTIMATE)
          idir =  1
          CALL dfftw_plan_many_dft( bw_plan(2,icurrent), 1, ny, 1, r(1:), &
               (/ldx*ldy/), ldx, 1, r(1:), (/ldx*ldy/), ldx, 1, idir, &
               FFTW_ESTIMATE)

          IF( fw_plan(1,icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_plan(1,icurrent) )
          IF( bw_plan(1,icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_plan(1,icurrent) )
          idir = -1
          CALL dfftw_plan_many_dft( fw_plan(1,icurrent), 1, nx, ny, r(1:), &
               (/ldx*ldy/), 1, ldx, r(1:), (/ldx*ldy/), 1, ldx, idir, &
               FFTW_ESTIMATE)
          idir =  1
          CALL dfftw_plan_many_dft( bw_plan(1,icurrent), 1, nx, ny, r(1:), &
               (/ldx*ldy/), 1, ldx, r(1:), (/ldx*ldy/), 1, ldx, idir, &
               FFTW_ESTIMATE)
       ELSE
          IF( fw_plan( 1, icurrent) /= 0 ) CALL dfftw_destroy_plan( fw_plan( 1, icurrent) )
          IF( bw_plan( 1, icurrent) /= 0 ) CALL dfftw_destroy_plan( bw_plan( 1, icurrent) )
          idir = -1
          CALL dfftw_plan_many_dft( fw_plan( 1, icurrent), 2, (/nx, ny/), nzl,&
               r(1:), (/nx, ny/), 1, nx*ny, r(1:), (/nx, ny/), 1, nx*ny, idir,&
               FFTW_ESTIMATE)
          idir = 1
          CALL dfftw_plan_many_dft( bw_plan( 1, icurrent), 2, (/nx, ny/), nzl,&
               r(1:), (/nx, ny/), 1, nx*ny, r(1:), (/nx, ny/), 1, nx*ny, idir,&
               FFTW_ESTIMATE)
       END IF

       dims(1,icurrent) = ny; dims(2,icurrent) = ldx;
       dims(3,icurrent) = nx; dims(4,icurrent) = nzl;
       ip = icurrent
       icurrent = MOD( icurrent, ndims ) + 1

     END IF

     !
     !   Now perform the FFTs using machine specific drivers
     !

#if defined __FFT_CLOCKS
     CALL start_clock( 'cft_2xy' )
#endif

     IF ( ldx /= nx .OR. ldy /= ny ) THEN
        IF( isign < 0 ) THEN
           do j = 0, nzl-1
              CALL dfftw_execute_dft( fw_plan (1, ip), &
                   r(1+j*ldx*ldy:), r(1+j*ldx*ldy:))
           end do
           do i = 1, nx
              do k = 1, nzl
                 IF( dofft( i ) ) THEN
                    j = i + ldx*ldy * ( k - 1 )
                    call dfftw_execute_dft( fw_plan ( 2, ip), r(j:), r(j:))
                 END IF
              end do
           end do
           tscale = 1.0_DP / ( nx * ny )
           CALL ZDSCAL( ldx * ldy * nzl, tscale, r(1), 1)
        ELSE IF( isign > 0 ) THEN
           do i = 1, nx
              do k = 1, nzl
                 IF( dofft( i ) ) THEN
                    j = i + ldx*ldy * ( k - 1 )
                    call dfftw_execute_dft( bw_plan ( 2, ip), r(j:), r(j:))
                 END IF
              end do
           end do
           do j = 0, nzl-1
              CALL dfftw_execute_dft( bw_plan( 1, ip), &
                   r(1+j*ldx*ldy:), r(1+j*ldx*ldy:))
           end do
        END IF
     ELSE
        IF( isign < 0 ) THEN
           call dfftw_execute_dft( fw_plan( 1, ip), r(1:), r(1:))
           tscale = 1.0_DP / ( nx * ny )
           CALL ZDSCAL( ldx * ldy * nzl, tscale, r(1), 1)
        ELSE IF( isign > 0 ) THEN
           call dfftw_execute_dft( bw_plan( 1, ip), r(1:), r(1:))
        END IF
     END IF

#if defined __FFT_CLOCKS
     CALL stop_clock( 'cft_2xy' )
#endif

     RETURN

   END SUBROUTINE cft_2xy

   SUBROUTINE cft_b ( f, nx, ny, nz, ldx, ldy, ldz, imin3, imax3, sgn )

!     driver routine for 3d complex fft's on box grid, parallel case
!     fft along xy is done only on planes that correspond to dense grid
!     planes on the current processor, i.e. planes with imin3 <= nz <= imax3
!     implemented for essl, fftw, scsl, complib, only for sgn=1 (f(R) => f(G))
!     (beware: here the "essl" convention for the sign of the fft is used!)
!
      implicit none
      integer nx,ny,nz,ldx,ldy,ldz,imin3,imax3,sgn
      complex(dp) :: f(:)

      integer isign, naux, ibid, nplanes, nstart, k
      real(DP) :: tscale

      integer :: ip, i
      integer, save :: icurrent = 1
      integer, save :: dims( 4, ndims ) = -1

      C_POINTER, save :: bw_planz(  ndims ) = 0
      C_POINTER, save :: bw_planx(  ndims ) = 0
      C_POINTER, save :: bw_plany(  ndims ) = 0
      C_POINTER, save :: bw_planxy( ndims ) = 0

      isign = -sgn
      tscale = 1.0_DP

      if ( isign > 0 ) then
         call errore('cft_b','not implemented',isign)
      end if
!
! 2d fft on xy planes - only needed planes are transformed
! note that all others are left in an unusable state
!
      nplanes = imax3 - imin3 + 1
      nstart  = ( imin3 - 1 ) * ldx * ldy + 1

      !
      !   Here initialize table only if necessary
      !

      ip = -1
      DO i = 1, ndims

        !   first check if there is already a table initialized
        !   for this combination of parameters

        IF ( ( nx == dims(1,i) ) .and. ( ny == dims(2,i) ) .and. &
             ( nz == dims(3,i) ) .and. ( nplanes == dims(4,i) ) ) THEN
           ip = i
           EXIT
        END IF

      END DO

      IF( ip == -1 ) THEN

        !   no table exist for these parameters
        !   initialize a new one

        if ( bw_planz(icurrent) /= 0 ) &
             call dfftw_destroy_plan(bw_planz(icurrent))
        call dfftw_plan_many_dft( bw_planz(icurrent), 1, nz, ldx*ldy, &
             f(1:), (/SIZE(f)/), ldx*ldy, 1, f(1:), (/SIZE(f)/), ldx*ldy, 1, &
             1, FFTW_ESTIMATE )

        if ( bw_planxy(icurrent) /= 0 ) &
             call dfftw_destroy_plan(bw_planxy(icurrent))
        call dfftw_plan_many_dft( bw_planxy(icurrent), 2, (/nx, ny/), nplanes,&
             f(nstart:),  (/ldx, ldy/), 1, ldx*ldy, f(nstart:), (/ldx, ldy/), &
             1, ldx*ldy, 1, FFTW_ESTIMATE )

        dims(1,icurrent) = nx; dims(2,icurrent) = ny
        dims(3,icurrent) = nz; dims(4,icurrent) = nplanes
        ip = icurrent
        icurrent = MOD( icurrent, ndims ) + 1

      END IF

      call dfftw_execute_dft(bw_planz(ip), f(1:), f(1:))
      call dfftw_execute_dft(bw_planxy(ip), f(nstart:), f(nstart:))

     RETURN
   END SUBROUTINE cft_b
!!$
!!$!
!!$!=----------------------------------------------------------------------=!
!!$!
!!$!
!!$!
!!$!   3D parallel FFT on sub-grids, to be called inside OpenMP region
!!$!
!!$!
!!$!
!!$!=----------------------------------------------------------------------=!
!!$!

!
!=----------------------------------------------------------------------=!
!
!
!
!         FFT support Functions/Subroutines
!
!
!
!=----------------------------------------------------------------------=!
!

!
integer &
function good_fft_dimension (n)
  !
  ! Determines the optimal maximum dimensions of fft arrays
  ! Useful on some machines to avoid memory conflicts
  !
  USE kinds, only : DP
  IMPLICIT NONE
  INTEGER :: n, nx
  REAL(DP) :: log2n
  !
  ! this is the default: max dimension = fft dimension
  nx = n
  !
  !
  good_fft_dimension = nx
  return
end function good_fft_dimension

!=----------------------------------------------------------------------=!

function allowed (nr)

  ! find if the fft dimension is a good one
  ! a "bad one" is either not implemented (as on IBM with ESSL)
  ! or implemented but with awful performances (most other cases)

  USE kinds

  implicit none
  integer :: nr

  logical :: allowed
  integer :: pwr (5)
  integer :: mr, i, fac, p, maxpwr
  integer :: factors( 5 ) = (/ 2, 3, 5, 7, 11 /)

  ! find the factors of the fft dimension

  mr  = nr
  pwr = 0
  factors_loop: do i = 1, 5
     fac = factors (i)
     maxpwr = NINT ( LOG( DBLE (mr) ) / LOG( DBLE (fac) ) ) + 1
     do p = 1, maxpwr
        if ( mr == 1 ) EXIT factors_loop
        if ( MOD (mr, fac) == 0 ) then
           mr = mr / fac
           pwr (i) = pwr (i) + 1
        endif
     enddo
  end do factors_loop

  IF ( nr /= ( mr * 2**pwr (1) * 3**pwr (2) * 5**pwr (3) * 7**pwr (4) * 11**pwr (5) ) ) &
     CALL errore (' allowed ', ' what ?!? ', 1 )

  if ( mr /= 1 ) then

     ! fft dimension contains factors > 11 : no good in any case

     allowed = .false.

  else

     ! fftw and all other cases: no factors 7 and 11

     allowed = ( ( pwr(4) == 0 ) .and. ( pwr(5) == 0 ) )

  endif

  return
end function allowed

!=----------------------------------------------------------------------=!

   INTEGER &
   FUNCTION good_fft_order( nr, np )

!
!    This function find a "good" fft order value greater or equal to "nr"
!
!    nr  (input) tentative order n of a fft
!
!    np  (optional input) if present restrict the search of the order
!        in the ensamble of multiples of np
!
!    Output: the same if n is a good number
!         the closest higher number that is good
!         an fft order is not good if not implemented (as on IBM with ESSL)
!         or implemented but with awful performances (most other cases)
!

     IMPLICIT NONE
     INTEGER, INTENT(IN) :: nr
     INTEGER, OPTIONAL, INTENT(IN) :: np
     INTEGER :: new

     new = nr
     IF( PRESENT( np ) ) THEN
       DO WHILE( ( ( .NOT. allowed( new ) ) .OR. ( MOD( new, np ) /= 0 ) ) .AND. ( new <= nfftx ) )
         new = new + 1
       END DO
     ELSE
       DO WHILE( ( .NOT. allowed( new ) ) .AND. ( new <= nfftx ) )
         new = new + 1
       END DO
     END IF

     IF( new > nfftx ) &
       CALL errore( ' good_fft_order ', ' fft order too large ', new )

     good_fft_order = new

     RETURN
   END FUNCTION good_fft_order

!=----------------------------------------------------------------------=!
   END MODULE fft_scalar
!=----------------------------------------------------------------------=!


	FUNCTION SIGMA_INDOUS(X)

c	Returns resolution (sigma) of IndoUS library at wavelength X in A.
c	Fit provided by the P. Coelho as FWHM vs lambda.

c	compute FWHM = d at wavelength X
	if (x.lt.3600.) then
c		d = 1.6
c		Updated 26/5/06 by Paula
		d = 1.57
	else
c		d = 2.15 - 1.54E-4*x
c		Updated 26/5/06 by Paula
		d = 1.92 - 9.84E-05*x
	endif
	c=2.*sqrt(2.*alog(2.))
	sigma_indous=d/c
	return
	end

	FUNCTION FWHM_INDOUS(X)

c	Returns resolution (FWHM) of IndoUS library at wavelength X in A.
c	Fit provided by the P. Coelho as FWHM vs lambda.

c	compute FWHM = d at wavelength X
	if (x.lt.3600.) then
c		d = 1.6
c		Updated 26/5/06 by Paula
		d = 1.57
	else
c		d = 2.15 - 1.54E-4*x
c		Updated 26/5/06 by Paula
		d = 1.92 - 9.84E-05*x
	endif
	fwhm_indous=d
	return
	end


      subroutine jac2 (neq, t, y, ml, mu, pd, nrowpd)
      integer neq, ml, mu, nrowpd
      double precision t, y, pd
      dimension y(2), pd(nrowpd,2)
      dimension neq(*)
      pd(1,1) = 0.0d0
      pd(1,2) = 1.0d0
      pd(2,1) = -200.0d0*y(1)*y(2) - 1.0d0
      pd(2,2) = 100.0d0*(1.0d0 - y(1)*y(1))
      return
      end


*###[ ffxb2p:
	subroutine ffxb2p(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,piDpj,ier)
***#[*comment:***********************************************************
*									*
*	Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu)	*
*	of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2)	*
*	originally based on aaxbx by Andre Aeppli.			*
*									*
*	Input:	cb1	   complex	vector two point function	*
*		cb0	   complex	scalar two point function	*
*		ca0i(2)	   complex	scalar onepoint function with	*
*						m1,m2			*
*		xp	   real		p.p in B&D metric		*
*		xm1,2	   real		m_1^2,m_2^2			*
*		piDpj(3,3) real		dotproducts between s1,s2,p	*
*		ier	   integer	digits lost so far		*
*									*
*	Output:	cb2i(2)	   complex	B21,B22: coeffs of p*p, g in B2	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	DOUBLE PRECISION xp,xm1,xm2,piDpj(3,3)
	DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
*
*	local variables
*
	DOUBLE PRECISION dm1m2
*
*  #] declarations:
*  #[ work:
*
	dm1m2= xm1 - xm2
	call ffxb2q(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,dm1m2,piDpj,ier)
*
*  #] work:
*###] ffxb2p:
	end

*###[ ffxb2q:
	subroutine ffxb2q(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,dm1m2,piDpj,ier)
***#[*comment:***********************************************************
*									*
*	Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu)	*
*	of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2)	*
*	originally based on aaxbx by Andre Aeppli.			*
*									*
*	Input:	cb1	   complex	vector two point function	*
*		cb0	   complex	scalar two point function	*
*		ca0i(2)	   complex	scalar onepoint function with	*
*						m1,m2			*
*		xp	   real		p.p in B&D metric		*
*		xm1,2	   real		m_1^2,m_2^2			*
*		piDpj(3,3) real		dotproducts between s1,s2,p	*
*		ier	   integer	digits lost so far		*
*									*
*	Output:	cb2i(2)	   complex	B21,B22: coeffs of p*p, g in B2	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	DOUBLE PRECISION xp,xm1,xm2,dm1m2,piDpj(3,3)
	DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
*
*	local variables
*
	integer i,ier0,ier1
	logical llogmm
	DOUBLE PRECISION xmax,absc,xlam,slam,bet,xmxp,dfflo3,xlo3,
     +		xmxsav,xnoe,xnoe2,xlogmm,dfflo1
	DOUBLE COMPLEX cs(16),cc,csom,clo3,zfflo3
	external dfflo1,dfflo3,zfflo3
*
*	common blocks
*
	include 'ff.h'
*
*	statement function
*
	absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
*  #] declarations:
*  #[ normal case:
	ier0 = ier
	ier1 = ier
*
*	with thanks to Andre Aeppli, off whom I stole the original
*
	if ( xp .ne. 0) then
	    cs(1) = ca0i(2)
	    cs(2) = DBLE(xm1)*cb0
	    cs(3) = DBLE(2*piDpj(1,3))*cb1
	    cs(4) = (xm1+xm2)/2
	    cs(5) = -xp/6
	    cb2i(1) = cs(1) - cs(2) + 2*cs(3) - cs(4) - cs(5)
	    cb2i(2) = cs(1) + 2*cs(2) - cs(3) + 2*cs(4) + 2*cs(5)
	    xmax = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
	    xmxsav = xmax
	    if ( absc(cb2i(1)) .ge. xloss*xmax ) goto 100
*  #] normal case:
*  #[   improve: m1=m2:
*
*	    a relatively simple case: dm1m2 = 0 (bi0.frm)
*
	    if ( dm1m2.eq.0 .and. xm1.ne.0 ) then
		if ( xp.lt.0 ) then
		    slam = sqrt(xp**2-4*xm1*xp)
		    xlo3 = dfflo3((xp-slam)/(2*xm1),ier)
		    cs(1) = xp*(-1/DBLE(3) + slam/(4*xm1))
		    cs(2) = xp**2*(-slam/(4*xm1**2) - 3/(4*xm1))
		    cs(3) = xp**3/(4*xm1**2)
		    cs(4) = DBLE(xp/xm1)*ca0i(1)
		    cs(5) = xlo3/xp*(-xm1*slam)
		    cs(6) = xlo3*slam
		else
		    slam = isgnal*sqrt(-xp**2+4*xm1*xp)
		    clo3 = zfflo3(DCMPLX(DBLE(xp/(2*xm1)),
     +			DBLE(-slam/(2*xm1))),ier)
		    cs(1) = DBLE(xp)*DCMPLX(-1/DBLE(3),
     +			DBLE(slam/(4*xm1)))
		    cs(2) = DBLE(xp**2)*DCMPLX(DBLE(-3/(4*xm1)),
     +			DBLE(-slam/(4*xm1**2)))
		    cs(3) = DBLE(xp**3/(4*xm1**2))
		    cs(4) = DBLE(xp/xm1)*ca0i(1)
		    cs(5) = clo3*DCMPLX(DBLE(0),DBLE(-xm1*slam/xp))
		    cs(6) = clo3*DCMPLX(DBLE(0),DBLE(slam))
		endif
		csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) + cs(6)
		xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
     +			absc(cs(5)),absc(cs(6)))
*
*		get rid of noise in the imaginary part
*
		if ( xloss*abs(DIMAG(csom)).lt.precc*abs(DBLE(csom)) )
     +			csom = DCMPLX(DBLE(csom),DBLE(0))
		if ( xmxp.lt.xmax ) then
		    cb2i(1) = csom
		    xmax = xmxp
		endif
		if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
	    endif
*  #]   improve: m1=m2:
*  #[   improve: |xp| < xm1 < xm2:
*
*	    try again (see bi.frm)
*
	    xlam =  4*(piDpj(1,3)**2 - xm1*xp)
	    if ( xm1.eq.0 .or. xm2.eq.0 ) then
	    	xlogmm = 0
	    elseif ( abs(dm1m2).lt.xloss*xm1 ) then
	    	xlogmm = dfflo1(dm1m2/xm1,ier)
	    else
	    	xlogmm = log(xm2/xm1)
	    endif
	    if ( xlam.gt.0 .and. abs(xp).lt.xloss*xm2 .and.
     +			xm1.lt.xm2 ) then
		slam = sqrt(xlam)
		bet = 4*xm1*xp/(2*piDpj(1,3)+slam)
		cs(1) = DBLE(xp/xm2)*ca0i(2)
		cs(2) = xlogmm*bet*(-2*xm1**2*xm2 - 2*xm1**3)
     +		/((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
		cs(3) = xlogmm*(-4*xp*xm1**3)
     +		/((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
		xnoe = 1/(2*piDpj(2,3)+slam)
		xnoe2 = xnoe**2
		cs(4) = xnoe2*xm1*bet*(xp-4*xm2)
		cs(5) = xnoe2*xm1*2*xp*xm2
		cs(6) = xnoe2*xm1**2*bet
		cs(7) = xnoe2*xm1**2*4*xp
		cs(8) = xnoe2*bet*(xp*xm2+3*xm2**2)
		cs(9) = xnoe2*(-6*xp*xm2**2)
		cs(10)= xp*(7/6.d0 - 2*xm1*slam*xnoe2 +
     +			4*xm2*slam*xnoe2 - 2*slam*xnoe)
		cs(11)= xp**2*( -2*slam*xnoe2 )
		xlo3 = dfflo3(2*xp*xnoe,ier)
		cs(12) = xlo3*dm1m2**2*slam/xp**2
		cs(13) = xlo3*(xm1 - 2*xm2)*slam/xp
		cs(14) = xlo3*slam
		csom = 0
		xmxp = 0
		do 50 i=1,14
		    csom = csom + cs(i)
		    xmxp = max(xmxp,absc(cs(i)))
   50		continue
		if ( xmxp.lt.xmax ) then
		    cb2i(1) = csom
		    xmax = xmxp
		endif
		if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
	    endif
*  #]   improve: |xp| < xm1 < xm2:
*  #[   improve: |xp| < xm2 < xm1:
	    if ( xlam.gt.0 .and. abs(xp).lt.xloss*xm1 .and.
     +			xm2.lt.xm1 ) then
		slam = sqrt(xlam)
		bet = 4*xm2*xp/(-2*piDpj(2,3)+slam)
		xnoe = 1/(-2*piDpj(1,3)+slam)
		xnoe2 = xnoe**2
		cs(1) = DBLE(xp/xm1)*ca0i(1)
		cs(2) = -xlogmm*bet*(12*xp*xm1*xm2+6*xp*xm2**2-
     +		6*xp**2*xm2-2*xm1*xm2**2-2*xm2**3)
     +		/((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
		cs(3) = -xlogmm*(-24*xp*xm1**2*xm2-4*xp*xm2**3+36*
     +		xp**2*xm1*xm2+12*xp**2*xm2**2-12*xp**3*xm2)
     +		/((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
		cs(4) = xnoe2*xm2*bet*(xp-4*xm1)
		cs(5) = xnoe2*xm2*(-10*xp*xm1)
		cs(6) = xnoe2*xm2**2*bet
		cs(7) = xnoe2*xm2**2*4*xp
		cs(8) = xnoe2*bet*(xp*xm1+3*xm1**2)
		cs(9) = xnoe2*6*xp*xm1**2
		cs(10)= xp*(7/6.d0 - 2*xm1*slam*xnoe2 +
     +			4*xm2*slam*xnoe2 - 2*slam*xnoe)
		cs(11)= xp**2*( -2*slam*xnoe2 )
		xlo3 = dfflo3(2*xp*xnoe,ier)
		cs(12) = xlo3*dm1m2**2*slam/xp**2
		cs(13) = xlo3*(xm1 - 2*xm2)*slam/xp
		cs(14) = xlo3*slam
		csom = 0
		xmxp = 0
		do 60 i=1,14
		    csom = csom + cs(i)
		    xmxp = max(xmxp,absc(cs(i)))
   60		continue
		if ( xmxp.lt.xmax ) then
		    cb2i(1) = csom
		    xmax = xmxp
		endif
		if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
	    endif
*  #]   improve: |xp| < xm2 < xm1:
*  #[   wrap up:
  100	    continue
	    xmax = xmxsav
	    cb2i(1) = DBLE(1/(3*xp)) * cb2i(1)
	    cb2i(2) = DBLE(1/6.d0)   * cb2i(2)
*  #]   wrap up:
*  #[ xp=0, m1!=m2:
	elseif (dm1m2 .ne. 0) then
*		#[ B21:
		llogmm = .FALSE.
*
*		B21 (see thesis, b21.frm)
*
		cs(1) = DBLE(xm1**2/3/dm1m2**3)*ca0i(1)
		cs(2) = DBLE((-xm1**2 + xm1*xm2 - xm2**2/3)/dm1m2**3)*
     +			ca0i(2)
		cs(3) = (5*xm1**3/18 - xm1*xm2**2/2 + 2*xm2**3/9)
     +			/dm1m2**3
		cb2i(1) = cs(1)+cs(2)+cs(3)
		xmax = max(absc(cs(2)),absc(cs(3)))
		if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
*
*		ma ~ mb
*
		if ( abs(dm1m2).lt.xloss*xm1 ) then
		    xlogmm = dfflo1(dm1m2/xm1,ier)
		else
		    xlogmm = log(xm2/xm1)
		endif
		llogmm = .TRUE.
		cs(1) = (xm1/dm1m2)/6
		cs(2) = (xm1/dm1m2)**2/3
		cs(3) = (xm1/dm1m2)**3*xlogmm/3
		cs(4) = -2/DBLE(9) + ca0i(1)*DBLE(1/(3*xm1))
		cs(5) = -xlogmm/3
		csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
		xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
     +			absc(cs(5)))
		if ( xmxp.lt.xmax ) then
		    xmax = xmxp
		    cb2i(1) = csom
		    if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
		endif
*
*		and last try
*
		xlo3 = dfflo3(dm1m2/xm1,ier)
		cs(1) = (dm1m2/xm1)**2/6
		cs(2) = (dm1m2/xm1)/3
		cs(3) = xlo3/(3*(dm1m2/xm1)**3)
*same		cs(4) = -2/DBLE(9) + ca0i(1)*DBLE(1/(3*xm1))
		cs(5) = -xlo3/3
		csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
		xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
     +			absc(cs(5)))
		if ( xmxp.lt.xmax ) then
		    xmax = xmxp
		    cb2i(1) = csom
		    if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
		endif
*
*		give up
*
  160		continue
*		#] B21:
*		#[ B22:
*
*		B22
*
		cs(1) = +DBLE(xm1/(4*dm1m2))*ca0i(1)
		cs(2) = -DBLE(xm2/(4*dm1m2))*ca0i(2)
		cs(3) = (xm1+xm2)/8
		cb2i(2) = cs(1) + cs(2) + cs(3)
		xmax = max(absc(cs(2)),absc(cs(3)))
		if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
*
*		second try, close together
*
		if ( .not.llogmm ) then
		    if ( abs(dm1m2).lt.xloss*xm1 ) then
		    	xlogmm = dfflo1(dm1m2/xm1,ier)
		    else
		    	xlogmm = log(xm2/xm1)
		    endif
		endif
		cs(1) = dm1m2*( -1/DBLE(8) - ca0i(1)*DBLE(1/(4*xm1)) )
		cs(2) = dm1m2*xlogmm/4
		cs(3) = xm1*(xm1/dm1m2)/4*xlogmm
		cs(4) = xm1*( 1/DBLE(4) + ca0i(1)*DBLE(1/(2*xm1)) )
		cs(5) = -xm1*xlogmm/2
		csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
		xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
     +			absc(cs(5)))
		if ( xmxp.lt.xmax ) then
		    xmax = xmxp
		    cb2i(2) = csom
		endif
		if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
*
*		give up
*
  210		continue
*		#] B22:
*  #] xp=0, m1!=m2:
*  #[ xp=0, m1==m2:
	else
*
*	    taken over from ffxb2a, which in turns stem from my thesis GJ
*
	    cb2i(1) = cb0/3
	    cb2i(2) = DBLE(xm1/2)*(cb0 + 1)
	endif
*  #] xp=0, m1==m2:
*  #[ finish up:
	ier = max(ier0,ier1)
*  #] finish up:
*###] ffxb2q:
	end


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
C	This program accepts either (a) the two 11x11 lat/long arrays
C	associated with ASTER scenes, and included in the ASTER hdf files,
C	or (b) the corner point latitude and longitude coordinates input
C	as parameters.  From this, a pair of full size images is created,
C	which give the latitude and longitude for each ASTER scene pixel.
C
C	5/14/01  ...rea... Initial release
C
	IMPLICIT NONE
	REAL*8 CORNER(2,4),XLATIN(11,11),XLONGIN(11,11),CONV
	REAL*8 CONVFAC/0.99330562/
	INTEGER NLO,NSO,NINP,ICOUNT,IDEF,INUNIT1,INUNIT2,ISTAT,NBANDS
	INTEGER ILINE,IOUT
	LOGICAL XVPTST
C
	CALL XVMESSAGE('ASTERGEO Version: May 18, 2001',' ')
C							   determine output size
	IF (XVPTST('VNIR')) THEN
	    NLO = 4200
	    NSO = 4980
	ELSE IF (XVPTST('SWIR')) THEN
	    NLO = 2100
	    NSO = 2490
	ELSE
	    NLO = 700
	    NSO = 830
	END IF
C					     is coordinate conversion requested?
	IF (XVPTST('GEODETIC')) THEN
	    CONV = 1.0 / CONVFAC
	ELSE IF (XVPTST('GEOCENTRIC')) THEN
	    CONV = CONVFAC
	ELSE
	    CONV = 1.0
	END IF
C						   get input files or parameters
	CALL XVPCNT('INP',NINP)
	IF (NINP .EQ. 0) THEN
	    CALL XVPARMD('UL',CORNER(1,1),ICOUNT,IDEF,2)
	    IF (ICOUNT .NE. 2) THEN
		CALL XVMESSAGE('Two UL values or input file needed',' ')
		CALL ABEND
	    ENDIF
	    CALL XVPARMD('UR',CORNER(1,2),ICOUNT,IDEF,2)
	    IF (ICOUNT .NE. 2) THEN
		CALL XVMESSAGE('Two UR values needed',' ')
		CALL ABEND
	    ENDIF
	    CALL XVPARMD('LL',CORNER(1,3),ICOUNT,IDEF,2)
	    IF (ICOUNT .NE. 2) THEN
		CALL XVMESSAGE('Two LL values needed',' ')
		CALL ABEND
	    ENDIF
	    CALL XVPARMD('LR',CORNER(1,4),ICOUNT,IDEF,2)
	    IF (ICOUNT .NE. 2) THEN
		CALL XVMESSAGE('Two LR values needed',' ')
		CALL ABEND
	    ENDIF
	ELSE IF (NINP .EQ. 1) THEN
	    CALL XVUNIT(INUNIT1,'INP',1,ISTAT,' ')
	    CALL XVOPEN(INUNIT1,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     +		    'U_FORMAT','DOUB',' ')
	    CALL XVGET(INUNIT1,ISTAT,'NB',NBANDS,' ')
	    IF (NBANDS .LT. 2) THEN
		CALL XVMESSAGE(
     +	'If one input file, it must contain both lat and long bands',' ')
		CALL ABEND
	    ENDIF
	    DO ILINE=1,11
		CALL XVREAD(INUNIT1,XLATIN(1,ILINE),ISTAT,'LINE',ILINE,
     +			    'BAND',1,' ')
		CALL XVREAD(INUNIT1,XLONGIN(1,ILINE),ISTAT,'LINE',ILINE,
     +			    'BAND',2,' ')
	    END DO
	ELSE
	    CALL XVUNIT(INUNIT1,'INP',1,ISTAT,' ')
	    CALL XVOPEN(INUNIT1,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     +		    'U_FORMAT','DOUB',' ')
	    CALL XVUNIT(INUNIT2,'INP',2,ISTAT,' ')
	    CALL XVOPEN(INUNIT2,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     +		    'U_FORMAT','DOUB',' ')
	    DO ILINE=1,11
		CALL XVREAD(INUNIT1,XLATIN(1,ILINE),ISTAT,'LINE',ILINE,
     +			    ' ')
		CALL XVREAD(INUNIT2,XLONGIN(1,ILINE),ISTAT,'LINE',ILINE,
     +			    ' ')
	    END DO
	END IF
C							        open output file
	CALL XVUNIT(IOUT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUT,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     &		'U_NL',NLO,'U_NS',NSO,'U_ORG','BIL','OP','WRITE',
     &		'U_FORMAT','DOUB','O_FORMAT','DOUB','U_NB',2,' ')
C
	IF (NINP .EQ. 0) THEN
	    CALL FILL2(IOUT,NLO,NSO,CORNER,CONV)
	ELSE
	    CALL FILL11(IOUT,NLO,NSO,XLATIN,XLONGIN,CONV)
	END IF
C
	RETURN
	END
C*******************************************************************************
	SUBROUTINE FILL2(IOUT,NLO,NSO,CORNER,CONV)
C
C	This routine creates the output dataset, from the corner points
C	that have been input by the user. Bilinear interpolation is used.
C
	IMPLICIT NONE
	REAL*8 CORNER(2,4),XLATOUT(4980),XLONGOUT(4980),CONV
	REAL*8 XNL,XNS,X,FRAC1,FRAC2
	INTEGER IOUT,NLO,NSO,ILINE,ISAMP,ISTAT
	REAL*8 PI/3.141592653589793D0/

C						 if requested, convert latitudes
	IF (CONV .NE. 1.0) THEN
	    DO ILINE=1,4
		X = CONV*TAN(CORNER(1,ILINE)*PI/180.)
		CORNER(1,ILINE) = ATAN(X)*180./PI
	    END DO
	END IF
C
	XNL = NLO
	XNS = NSO
C
	DO ILINE=1,NLO
	    X = ILINE - 1
	    FRAC1 = X/XNL
	    DO ISAMP=1,NSO
		X = ISAMP - 1
		FRAC2 = X/XNS
		XLATOUT(ISAMP) = (1.0-FRAC1)*(1.0-FRAC2)*CORNER(1,1) +
     +				 (1.0-FRAC1)*FRAC2*CORNER(1,2) +
     +				 FRAC1*(1.0-FRAC2)*CORNER(1,3) +
     +				 FRAC1*FRAC2*CORNER(1,4)
		XLONGOUT(ISAMP) = (1.0-FRAC1)*(1.0-FRAC2)*CORNER(2,1) +
     +				  (1.0-FRAC1)*FRAC2*CORNER(2,2) +
     +				  FRAC1*(1.0-FRAC2)*CORNER(2,3) +
     +				  FRAC1*FRAC2*CORNER(2,4)
	    END DO
	    CALL XVWRIT(IOUT,XLATOUT,ISTAT,' ')
	    CALL XVWRIT(IOUT,XLONGOUT,ISTAT,' ')
	END DO
C
	RETURN
	END
C*******************************************************************************
	SUBROUTINE FILL11(IOUT,NLO,NSO,XLATIN,XLONGIN,CONV)
C
C	This routine creates the output dataset, from the 11x11 latitude
C	and longitude arrays. Bilinear interpolation is used.
C
	IMPLICIT NONE
	REAL*8 XLATIN(11,11),XLONGIN(11,11),XLAT(11),XLONG(11)
	REAL*8 CONV,XNL,XNS,X,FRAC,XLATOUT(4980),XLONGOUT(4980)
	INTEGER IOUT,NLO,NSO,ILINE,ISAMP,INDEX,IX,ISTAT
	REAL*8 PI/3.141592653589793D0/
C
	XNL = NLO
	XNS = NSO
C						 if requested, convert latitudes
	IF (CONV .NE. 1.0) THEN
	    DO ILINE=1,11
		DO ISAMP=1,11
		    X = CONV*TAN(XLATIN(ISAMP,ILINE)*PI/180.)
		    XLATIN(ISAMP,ILINE) = ATAN(X)*180./PI
		END DO
	    END DO
	END IF
C
	DO ILINE=1,NLO
	    X = 10 * (ILINE - 1)
	    FRAC = X/XNL
	    INDEX = INT(FRAC)
	    FRAC = FRAC - INDEX
	    INDEX = INDEX + 1
	    DO IX=1,11
		XLAT(IX) = (1.0-FRAC)*XLATIN(IX,INDEX) +
     +			   FRAC*XLATIN(IX,INDEX+1)
		XLONG(IX) = (1.0-FRAC)*XLONGIN(IX,INDEX) +
     +			    FRAC*XLONGIN(IX,INDEX+1)
	    END DO
	    DO ISAMP=1,NSO
		X = 10 * (ISAMP - 1)
		FRAC = X/XNS
		INDEX = INT(FRAC)
		FRAC = FRAC - INDEX
		INDEX = INDEX + 1
		XLATOUT(ISAMP) = (1.0-FRAC)*XLAT(INDEX) +
     +				 FRAC*XLAT(INDEX+1)
		XLONGOUT(ISAMP) = (1.0-FRAC)*XLONG(INDEX) +
     +				  FRAC*XLONG(INDEX+1)
	    END DO
	    CALL XVWRIT(IOUT,XLATOUT,ISTAT,' ')
	    CALL XVWRIT(IOUT,XLONGOUT,ISTAT,' ')
	END DO
C
	RETURN
	END


!> @file rbcg.f90
!! Defines the Restricted B-preconditioned style conjugate gradient
!<

!> @brief Restricted B-preconditioned style conjugate gradient(RBCG) module
!!
!<
module rbcg
    use debug_tools
    use com_tools
implicit none

contains

    !> @brief Solve the Ensemble Kalman Filter system for one member using RBCG
    !! @param [in] td_ep exchange parameter data structure
    !! @param [in] obs_std vector of standard deviation of observation error
    !! @param [in] d right hand side
    !! @param [in,out] x solution of the system
    !! @param [in] matrixmult procedure that does the matric multiplication
    !! @param [in] nItrMax maximum number of iterations
    !! @param [in] tol stopping criteria based on the B-norm of the gradient
    !!
    !! @details
    !! This algorithm solve a system of the form (A+R)x = d
    !! where A and R (obs_std) are symmetric positive (semi-)definite matrices
    !! This implementation considers R to be diagonal
    !! @note
    !!   for now, there is no size or shape check on the array variables
    !<
    subroutine rbcg_solve(td_ep, obs_std, d, x, matrixmult, nItrMax, tol)
        interface
            subroutine matrixmult(ep, r,w,diverged)
                use general_constant
                use com_tools
                type(exchange_param), intent(inout) :: ep
                real(dp), dimension(:), intent(in) :: r
                real(dp), dimension(:), intent(inout) :: w
                logical, intent(out) :: diverged
            end subroutine matrixmult
        end interface
        type(exchange_param), intent(inout) :: td_ep
        real(dp), dimension(:), intent(in) :: obs_std
        real(dp), dimension(:), intent(in) :: d
        real(dp), dimension(:), intent(in out) :: x
        integer, intent(in) :: nItrMax
        real(dp), intent(in) :: tol
        ! local variables
        ! RBCG variables
        real(dp) :: cg_r(size(d))
        real(dp) :: cg_lambda(size(d))
        real(dp) :: cg_t(size(d))
        real(dp) :: cg_p(size(d))
        real(dp) :: cg_w(size(d))
        real(dp) :: cg_q(size(d))
        real(dp) :: cg_alpha
        real(dp) :: cg_beta
        ! others
        real(dp) :: r0_norm ! B-norm of the residue at the zeroth iteration
        real(dp) :: ri_norm ! B-norm of the residue at the current iteration
        real(dp) :: cg_wTr ! dot product w by r (i)
        real(dp) :: cg_qTt ! dot product q by t
        real(dp) :: cg_wTrp1 ! dot product w by r (i+1)
        real(dp) :: cg_omega, cg_epsilon
        integer :: cg_itr
        logical :: converged, hv_diverged
        character(*), parameter :: fmt0= "('*** RBCG   Iter ***',I3,' -- |r_0|=',ES14.5E3)"
        character(*), parameter :: fmti= "('*** RBCG   Iter ***',I3,' -- |r|/|r_0|=',ES14.5E3)"
        !
        call debug(tol, "RBCG - tol", tag=dALLWAYS)
        call debug(nItrMax, "RBCG - nItrMax", tag=dALLWAYS)
        cg_epsilon = epsilon(1.0_dp)
        cg_itr = 0
        cg_lambda = 0.0
        cg_r = d/obs_std**2
        cg_p = cg_r
        ! Computing w = HA(HA)^Tr
        call matrixmult(td_ep, cg_r, cg_w, hv_diverged)
        cg_t = cg_w

        cg_wTr = dot_product(cg_w, cg_r)
        ri_norm = sqrt(cg_wTr)
        r0_norm    = ri_norm
        cg_omega= ri_norm/r0_norm
        write(*,fmt=fmt0)cg_itr,r0_norm
        cg_itr = 1
        converged = .false.

        do while( (cg_itr<= nItrMax).and.(.not.converged) )
            cg_q = cg_t/obs_std**2 + cg_p
            ! The following two quantities are used as denominator
            ! So if one is zero, either, there is convergence
            !  or something is wrong.
            ! In addition, cg_wTr is the result of an inner product,
            ! so it must be greater than zero.
            ! Below we check is abs(cg_qTt) is two small
            ! and only check if cg_wTr is two small (it is already positive)
            cg_wTr = dot_product(cg_w, cg_r)
            cg_qTt = dot_product(cg_q, cg_t)
            if( (abs(cg_qTt)>cg_epsilon).and.(cg_wTr>cg_epsilon) )then
                cg_alpha = cg_wTr/cg_qTt
                cg_lambda = cg_lambda + cg_alpha*cg_p
                cg_r = cg_r - cg_alpha*cg_q
                !re-conjugate r
                call matrixmult(td_ep, cg_r, cg_w, hv_diverged)
                cg_wTrp1 = dot_product(cg_w, cg_r)
                cg_beta = cg_wTrp1/cg_wTr
                if( abs(cg_beta)<cg_epsilon )then
                    converged = .true.
                end if
                cg_p = cg_r + cg_beta*cg_p
                cg_t = cg_w + cg_beta*cg_t
                ri_norm = sqrt(cg_wTrp1)
                cg_omega= ri_norm/r0_norm
                call debug(cg_omega, "In loop, cg_omega", tag=dALLWAYS)

                !Check the convergence
                if (cg_omega > tol) then
                    write(*,fmt=fmti)cg_itr,cg_omega
                else
                    converged = .true.
                endif
                !
                !Moving to the next iteration
                !
                cg_itr=cg_itr+1
            else
                converged = .true. ! the denominator of alpha is zero or the denominator of beta is zero
            end if
        end do

        if( .not.converged ) then
            call debug( nItrMax, "Maximum number of iterations reached", tag=dALLWAYS )
        else
            call debug(cg_itr, "RBCG converged, total nb iterations", tag=dALLWAYS)
            call debug(r0_norm, "  r0_norm", tag=dALLWAYS)
            call debug(cg_wTrp1, "  cg_wTrp1", tag=dALLWAYS)
            call debug(cg_wTr, "  cg_wTr", tag=dALLWAYS)
            call debug(cg_qTt, "  cg_qTt", tag=dALLWAYS)
            call debug(cg_beta, "  cg_beta", tag=dALLWAYS)
            call debug(cg_omega, "RBCG converged, cg_omega", tag=dALLWAYS)
            call debug(sum(abs(cg_lambda)), "Solution sum(abs(cg_lambda))")
            if(abs(cg_qTt)<=cg_epsilon)call debug(cg_qTt, "q*t is too small", tag=dALLWAYS)
            if(abs(cg_wTr)<=cg_epsilon)call debug(cg_wTr, "w*r is too small", tag=dALLWAYS)
            if(abs(cg_beta)<=cg_epsilon)call debug(cg_beta, "beta is too small", tag=dALLWAYS)
        end if

        x = cg_lambda
    end subroutine rbcg_solve

    !> @brief Solve the linear system using Conjugate gradient
    !! @param [in] td_ep exchange parameter data structure
    !! @param [in] obs_std vector of standard deviation of observation error
    !! @param [in] d right hand side
    !! @param [in,out] x solution of the system
    !! @param [in] matrixmult procedure that does the matric multiplication
    !! @param [in] nItrMax maximum number of iterations
    !! @param [in] tol stopping criteria based on the B-norm of the gradient
    !!
    !! @details
    !! This algorithm solve a system of the form (A+R)x = d
    !! where A and R (obs_std) are symmetric positive (semi-)definite matrices
    !! This implementation considers R to be diagonal
    !! @note
    !!   for now, there is no size or shape check on the array variables
    !<
    subroutine cg_solve(td_ep, obs_std, d, x, matrixmult, nItrMax, tol)
        interface
            subroutine matrixmult(ep, r,w,diverged)
                use general_constant
                use com_tools
                type(exchange_param), intent(inout) :: ep
                real(dp), dimension(:), intent(in) :: r
                real(dp), dimension(:), intent(inout) :: w
                logical, intent(out) :: diverged
            end subroutine matrixmult
        end interface
        type(exchange_param), intent(inout) :: td_ep
        real(dp), dimension(:), intent(in) :: obs_std
        real(dp), dimension(:), intent(in) :: d
        real(dp), dimension(:), intent(in out) :: x
        integer, intent(in) :: nItrMax
        real(dp), intent(in) :: tol
        ! local variables
        ! RBCG variables
        real(dp) :: cg_r(size(d))
        real(dp) :: cg_lambda(size(d))
        real(dp) :: cg_p(size(d))
        real(dp) :: cg_q(size(d))
        real(dp) :: cg_alpha
        real(dp) :: cg_beta
        ! others
        real(dp) :: r0_norm ! norm of the residue at the zeroth iteration
        real(dp) :: ri_norm ! norm of the residue at the current iteration
        real(dp) :: cg_rTr ! dot product r by r (i)
        real(dp) :: cg_qTp ! dot product q by p
        real(dp) :: cg_rTrp1 ! dot product r by r (i+1)
        real(dp) :: cg_omega, cg_epsilon
        integer :: cg_itr
        logical :: converged, hv_diverged
        character(*), parameter :: fmt0= "('*** CG   Iter ***',I3,' -- |r_0|=',ES14.5E3)"
        character(*), parameter :: fmti= "('*** CG   Iter ***',I3,' -- |r|/|r_0|=',ES14.5E3)"
        !
        call debug(tol, "RBCG - tol", tag=dALLWAYS)
        call debug(nItrMax, "RBCG - nItrMax", tag=dALLWAYS)
        cg_epsilon = epsilon(1.0_dp)
        cg_itr = 0
        cg_lambda = 0.0
        cg_r = d
        cg_p = cg_r

        cg_rTr = dot_product(cg_r, cg_r)
        ri_norm = sqrt(cg_rTr)
        r0_norm    = ri_norm
        cg_omega= ri_norm/r0_norm
        write(*,fmt=fmt0)cg_itr,r0_norm
        cg_itr = 1
        converged = .false.

        do while( (cg_itr<= nItrMax).and.(.not.converged) )
            call matrixmult(td_ep, cg_p, cg_q, hv_diverged)
            cg_q = cg_q + obs_std*cg_p
            ! The following two quantities are used as denominator
            ! So if one is zero, either, there is convergence
            !  or something is wrong.
            ! In addition, cg_rTr is the result of an inner product,
            ! so it must be greater than zero.
            ! Below we check is abs(cg_qTr) is two small
            ! and only check if cg_wTr is two small (it is already positive)
            cg_rTr = dot_product(cg_r, cg_r)
            cg_qTp = dot_product(cg_q, cg_p)
            if( (abs(cg_qTp)>cg_epsilon).and.(cg_rTr>cg_epsilon) )then
                cg_alpha = cg_rTr/cg_qTp
                cg_lambda = cg_lambda + cg_alpha*cg_p
                cg_r = cg_r - cg_alpha*cg_q
                !re-conjugate r
                cg_rTrp1 = dot_product(cg_r, cg_r)
                cg_beta = cg_rTrp1/cg_rTr
                if( abs(cg_beta)<cg_epsilon )then
                    converged = .true.
                end if
                cg_p = cg_r + cg_beta*cg_p
                ri_norm = sqrt(cg_rTrp1)
                cg_omega= ri_norm/r0_norm

                !Check the convergence
                if (cg_omega > tol) then
                    write(*,fmt=fmti)cg_itr,cg_omega
                else
                    converged = .true.
                endif
                !
                !Moving to the next iteration
                !
                cg_itr=cg_itr+1
            else
                converged = .true. ! the denominator of alpha is zero or the denominator of beta is zero
            end if
        end do

        if( .not.converged ) then
            call debug( nItrMax, "Maximum number of iterations reached", tag=dALLWAYS )
        else
            call debug(cg_itr, "CG converged, total nb iterations", tag=dALLWAYS)
            call debug(r0_norm, "  r0_norm", tag=dALLWAYS)
            call debug(cg_rTrp1, "  cg_wTrp1", tag=dALLWAYS)
            call debug(cg_rTr, "  cg_wTr", tag=dALLWAYS)
            call debug(cg_qTp, "  cg_qTt", tag=dALLWAYS)
            call debug(cg_beta, "  cg_beta", tag=dALLWAYS)
            call debug(cg_omega, "CG converged, cg_omega", tag=dALLWAYS)
            call debug(sum(abs(cg_lambda)), "Solution sum(abs(cg_lambda))")
            if(abs(cg_qTp)<=cg_epsilon)call debug(cg_qTp, "q*p is too small", tag=dALLWAYS)
            if(abs(cg_rTr)<=cg_epsilon)call debug(cg_rTr, "r*r is too small", tag=dALLWAYS)
            if(abs(cg_beta)<=cg_epsilon)call debug(cg_beta, "beta is too small", tag=dALLWAYS)
        end if

        x = cg_lambda
    end subroutine cg_solve
end module rbcg


      program lado
c
c**********************************************************************
c
c     dl_poly routine for 3d radial fourier tranform
c
c     copyright daresbury laboratory 1994
c     author w.smith
c
c**********************************************************************

      implicit real*8(a-h,o-z)
      parameter (pi=3.141592653589793d0)
      parameter (mxd=1000)
      dimension aaa(mxd),bbb(mxd)
      data a0,a1,a2/0.42d0,0.50d0,0.08d0/

c
c     read in data

      do i=1,mxd

         read(*,*,end=100)bbb(i),aaa(i)
         aaa(i)=aaa(i)-1.d0

      enddo
  100 nnn=i-1
      do i=1,nnn-1

         bbb(i)=0.5d0*(bbb(i)+bbb(i+1))
         aaa(i)=0.5d0*(aaa(i)+aaa(i+1))

      enddo
      nnn=nnn-1
c
c     set up window function (blackman function)
c$$$      arg=pi/dble(nnn)
c$$$      do i=1,nnn
c$$$
c$$$         ccc=cos(arg*dble(i+nnn-1))
c$$$         aaa(i)=(a0-a1*ccc+a2*(2.d0*ccc**2-1.d0))*aaa(i)
c$$$
c$$$      enddo
c$$$      aaa(1)=aaa(1)/2.d0

      delr=(bbb(nnn)-bbb(1))/dble(nnn-1)
      write(*,'(a,i6)')'number of data points = ',nnn
      write(*,'(a,1pe12.4)')'radial increment delr = ',delr
      do i=nnn+1,500

         aaa(i)=0.d0

      enddo
      nnn=500

      isw=1
      call radfft(isw,nnn,delr,aaa,bbb)

      delk=pi/(delr*dble(nnn))
      do i=1,nnn

         write(*,'(1p,2e14.6)')delk*dble(i),bbb(i)

      enddo

      stop

      end
      subroutine radfft(isw,nnn,delr,aaa,bbb)
c***********************************************************************
c
c     dl_poly 3D radial fourier transform routine using lado's method
c     reference: j. comput. phys. 8 (1971) 417
c
c     copyright daresbury laboratory 1994
c     author w smith
c
c     note: first data point is i*delr not 0
c
c***********************************************************************

      implicit real*8(a-h,o-z)
      parameter (pi=3.141592653589793d0)

      dimension aaa(nnn),bbb(nnn)

c
c     perform fourier transform

      sw=pi*dble(isw)/dble(nnn)

      do j=1,nnn

         bbb(j)=0.d0

         do i=1,nnn

            bbb(j)=dble(i)*aaa(i)*sin(sw*dble(j)*dble(i))+bbb(j)

         enddo

         bbb(j)=(4.d0*dble(nnn)*delr**3/dble(j))*bbb(j)

      enddo

      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine jacld(l, np, indxp, jndxp)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   compute the lower triangular part of the jacobian matrix
c---------------------------------------------------------------------

      implicit none

      include 'applu.incl'

c---------------------------------------------------------------------
c  input parameters
c---------------------------------------------------------------------
      integer l, np, indxp(*), jndxp(*)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, n
      double precision  r43
      double precision  c1345
      double precision  c34
      double precision  tmp1, tmp2, tmp3

      r43 = ( 4.0d+00 / 3.0d+00 )
      c1345 = c1 * c3 * c4 * c5
      c34 = c3 * c4

      do n = 1, np

         j = jndxp(n)
         i = indxp(n)
	 k = l - i - j

c---------------------------------------------------------------------
c   form the block daigonal
c---------------------------------------------------------------------
               tmp1 = rho_i(i,j,k)
               tmp2 = tmp1 * tmp1
               tmp3 = tmp1 * tmp2

               d(1,1,i,j) =  1.0d+00
     >                       + dt * 2.0d+00 * (   tx1 * dx1
     >                                          + ty1 * dy1
     >                                          + tz1 * dz1 )
               d(1,2,i,j) =  0.0d+00
               d(1,3,i,j) =  0.0d+00
               d(1,4,i,j) =  0.0d+00
               d(1,5,i,j) =  0.0d+00

               d(2,1,i,j) = -dt * 2.0d+00
     >          * (  tx1 * r43 + ty1 + tz1  )
     >          * c34 * tmp2 * u(2,i,j,k)
               d(2,2,i,j) =  1.0d+00
     >          + dt * 2.0d+00 * c34 * tmp1
     >          * (  tx1 * r43 + ty1 + tz1 )
     >          + dt * 2.0d+00 * (   tx1 * dx2
     >                             + ty1 * dy2
     >                             + tz1 * dz2  )
               d(2,3,i,j) = 0.0d+00
               d(2,4,i,j) = 0.0d+00
               d(2,5,i,j) = 0.0d+00

               d(3,1,i,j) = -dt * 2.0d+00
     >           * (  tx1 + ty1 * r43 + tz1  )
     >           * c34 * tmp2 * u(3,i,j,k)
               d(3,2,i,j) = 0.0d+00
               d(3,3,i,j) = 1.0d+00
     >         + dt * 2.0d+00 * c34 * tmp1
     >              * (  tx1 + ty1 * r43 + tz1 )
     >         + dt * 2.0d+00 * (  tx1 * dx3
     >                           + ty1 * dy3
     >                           + tz1 * dz3 )
               d(3,4,i,j) = 0.0d+00
               d(3,5,i,j) = 0.0d+00

               d(4,1,i,j) = -dt * 2.0d+00
     >           * (  tx1 + ty1 + tz1 * r43  )
     >           * c34 * tmp2 * u(4,i,j,k)
               d(4,2,i,j) = 0.0d+00
               d(4,3,i,j) = 0.0d+00
               d(4,4,i,j) = 1.0d+00
     >         + dt * 2.0d+00 * c34 * tmp1
     >              * (  tx1 + ty1 + tz1 * r43 )
     >         + dt * 2.0d+00 * (  tx1 * dx4
     >                           + ty1 * dy4
     >                           + tz1 * dz4 )
               d(4,5,i,j) = 0.0d+00

               d(5,1,i,j) = -dt * 2.0d+00
     >  * ( ( ( tx1 * ( r43*c34 - c1345 )
     >     + ty1 * ( c34 - c1345 )
     >     + tz1 * ( c34 - c1345 ) ) * ( u(2,i,j,k) ** 2 )
     >   + ( tx1 * ( c34 - c1345 )
     >     + ty1 * ( r43*c34 - c1345 )
     >     + tz1 * ( c34 - c1345 ) ) * ( u(3,i,j,k) ** 2 )
     >   + ( tx1 * ( c34 - c1345 )
     >     + ty1 * ( c34 - c1345 )
     >     + tz1 * ( r43*c34 - c1345 ) ) * ( u(4,i,j,k) ** 2 )
     >      ) * tmp3
     >   + ( tx1 + ty1 + tz1 ) * c1345 * tmp2 * u(5,i,j,k) )

               d(5,2,i,j) = dt * 2.0d+00 * tmp2 * u(2,i,j,k)
     > * ( tx1 * ( r43*c34 - c1345 )
     >   + ty1 * (     c34 - c1345 )
     >   + tz1 * (     c34 - c1345 ) )
               d(5,3,i,j) = dt * 2.0d+00 * tmp2 * u(3,i,j,k)
     > * ( tx1 * ( c34 - c1345 )
     >   + ty1 * ( r43*c34 -c1345 )
     >   + tz1 * ( c34 - c1345 ) )
               d(5,4,i,j) = dt * 2.0d+00 * tmp2 * u(4,i,j,k)
     > * ( tx1 * ( c34 - c1345 )
     >   + ty1 * ( c34 - c1345 )
     >   + tz1 * ( r43*c34 - c1345 ) )
               d(5,5,i,j) = 1.0d+00
     >   + dt * 2.0d+00 * ( tx1  + ty1 + tz1 ) * c1345 * tmp1
     >   + dt * 2.0d+00 * (  tx1 * dx5
     >                    +  ty1 * dy5
     >                    +  tz1 * dz5 )

c---------------------------------------------------------------------
c   form the first block sub-diagonal
c---------------------------------------------------------------------
               tmp1 = rho_i(i,j,k-1)
               tmp2 = tmp1 * tmp1
               tmp3 = tmp1 * tmp2

               a(1,1,i,j) = - dt * tz1 * dz1
               a(1,2,i,j) =   0.0d+00
               a(1,3,i,j) =   0.0d+00
               a(1,4,i,j) = - dt * tz2
               a(1,5,i,j) =   0.0d+00

               a(2,1,i,j) = - dt * tz2
     >           * ( - ( u(2,i,j,k-1)*u(4,i,j,k-1) ) * tmp2 )
     >           - dt * tz1 * ( - c34 * tmp2 * u(2,i,j,k-1) )
               a(2,2,i,j) = - dt * tz2 * ( u(4,i,j,k-1) * tmp1 )
     >           - dt * tz1 * c34 * tmp1
     >           - dt * tz1 * dz2
               a(2,3,i,j) = 0.0d+00
               a(2,4,i,j) = - dt * tz2 * ( u(2,i,j,k-1) * tmp1 )
               a(2,5,i,j) = 0.0d+00

               a(3,1,i,j) = - dt * tz2
     >           * ( - ( u(3,i,j,k-1)*u(4,i,j,k-1) ) * tmp2 )
     >           - dt * tz1 * ( - c34 * tmp2 * u(3,i,j,k-1) )
               a(3,2,i,j) = 0.0d+00
               a(3,3,i,j) = - dt * tz2 * ( u(4,i,j,k-1) * tmp1 )
     >           - dt * tz1 * ( c34 * tmp1 )
     >           - dt * tz1 * dz3
               a(3,4,i,j) = - dt * tz2 * ( u(3,i,j,k-1) * tmp1 )
               a(3,5,i,j) = 0.0d+00

               a(4,1,i,j) = - dt * tz2
     >        * ( - ( u(4,i,j,k-1) * tmp1 ) ** 2
     >            + c2 * qs(i,j,k-1) * tmp1 )
     >        - dt * tz1 * ( - r43 * c34 * tmp2 * u(4,i,j,k-1) )
               a(4,2,i,j) = - dt * tz2
     >             * ( - c2 * ( u(2,i,j,k-1) * tmp1 ) )
               a(4,3,i,j) = - dt * tz2
     >             * ( - c2 * ( u(3,i,j,k-1) * tmp1 ) )
               a(4,4,i,j) = - dt * tz2 * ( 2.0d+00 - c2 )
     >             * ( u(4,i,j,k-1) * tmp1 )
     >             - dt * tz1 * ( r43 * c34 * tmp1 )
     >             - dt * tz1 * dz4
               a(4,5,i,j) = - dt * tz2 * c2

               a(5,1,i,j) = - dt * tz2
     >       * ( ( c2 * 2.0d0 * qs(i,j,k-1)
     >       - c1 * u(5,i,j,k-1) )
     >            * u(4,i,j,k-1) * tmp2 )
     >       - dt * tz1
     >       * ( - ( c34 - c1345 ) * tmp3 * (u(2,i,j,k-1)**2)
     >           - ( c34 - c1345 ) * tmp3 * (u(3,i,j,k-1)**2)
     >           - ( r43*c34 - c1345 )* tmp3 * (u(4,i,j,k-1)**2)
     >          - c1345 * tmp2 * u(5,i,j,k-1) )
               a(5,2,i,j) = - dt * tz2
     >       * ( - c2 * ( u(2,i,j,k-1)*u(4,i,j,k-1) ) * tmp2 )
     >       - dt * tz1 * ( c34 - c1345 ) * tmp2 * u(2,i,j,k-1)
               a(5,3,i,j) = - dt * tz2
     >       * ( - c2 * ( u(3,i,j,k-1)*u(4,i,j,k-1) ) * tmp2 )
     >       - dt * tz1 * ( c34 - c1345 ) * tmp2 * u(3,i,j,k-1)
               a(5,4,i,j) = - dt * tz2
     >       * ( c1 * ( u(5,i,j,k-1) * tmp1 )
     >       - c2
     >       * ( qs(i,j,k-1) * tmp1
     >            + u(4,i,j,k-1)*u(4,i,j,k-1) * tmp2 ) )
     >       - dt * tz1 * ( r43*c34 - c1345 ) * tmp2 * u(4,i,j,k-1)
               a(5,5,i,j) = - dt * tz2
     >       * ( c1 * ( u(4,i,j,k-1) * tmp1 ) )
     >       - dt * tz1 * c1345 * tmp1
     >       - dt * tz1 * dz5

c---------------------------------------------------------------------
c   form the second block sub-diagonal
c---------------------------------------------------------------------
               tmp1 = rho_i(i,j-1,k)
               tmp2 = tmp1 * tmp1
               tmp3 = tmp1 * tmp2

               b(1,1,i,j) = - dt * ty1 * dy1
               b(1,2,i,j) =   0.0d+00
               b(1,3,i,j) = - dt * ty2
               b(1,4,i,j) =   0.0d+00
               b(1,5,i,j) =   0.0d+00

               b(2,1,i,j) = - dt * ty2
     >           * ( - ( u(2,i,j-1,k)*u(3,i,j-1,k) ) * tmp2 )
     >           - dt * ty1 * ( - c34 * tmp2 * u(2,i,j-1,k) )
               b(2,2,i,j) = - dt * ty2 * ( u(3,i,j-1,k) * tmp1 )
     >          - dt * ty1 * ( c34 * tmp1 )
     >          - dt * ty1 * dy2
               b(2,3,i,j) = - dt * ty2 * ( u(2,i,j-1,k) * tmp1 )
               b(2,4,i,j) = 0.0d+00
               b(2,5,i,j) = 0.0d+00

               b(3,1,i,j) = - dt * ty2
     >           * ( - ( u(3,i,j-1,k) * tmp1 ) ** 2
     >       + c2 * ( qs(i,j-1,k) * tmp1 ) )
     >       - dt * ty1 * ( - r43 * c34 * tmp2 * u(3,i,j-1,k) )
               b(3,2,i,j) = - dt * ty2
     >                   * ( - c2 * ( u(2,i,j-1,k) * tmp1 ) )
               b(3,3,i,j) = - dt * ty2 * ( ( 2.0d+00 - c2 )
     >                   * ( u(3,i,j-1,k) * tmp1 ) )
     >       - dt * ty1 * ( r43 * c34 * tmp1 )
     >       - dt * ty1 * dy3
               b(3,4,i,j) = - dt * ty2
     >                   * ( - c2 * ( u(4,i,j-1,k) * tmp1 ) )
               b(3,5,i,j) = - dt * ty2 * c2

               b(4,1,i,j) = - dt * ty2
     >              * ( - ( u(3,i,j-1,k)*u(4,i,j-1,k) ) * tmp2 )
     >       - dt * ty1 * ( - c34 * tmp2 * u(4,i,j-1,k) )
               b(4,2,i,j) = 0.0d+00
               b(4,3,i,j) = - dt * ty2 * ( u(4,i,j-1,k) * tmp1 )
               b(4,4,i,j) = - dt * ty2 * ( u(3,i,j-1,k) * tmp1 )
     >                        - dt * ty1 * ( c34 * tmp1 )
     >                        - dt * ty1 * dy4
               b(4,5,i,j) = 0.0d+00

               b(5,1,i,j) = - dt * ty2
     >          * ( ( c2 * 2.0d0 * qs(i,j-1,k)
     >               - c1 * u(5,i,j-1,k) )
     >          * ( u(3,i,j-1,k) * tmp2 ) )
     >          - dt * ty1
     >          * ( - (     c34 - c1345 )*tmp3*(u(2,i,j-1,k)**2)
     >              - ( r43*c34 - c1345 )*tmp3*(u(3,i,j-1,k)**2)
     >              - (     c34 - c1345 )*tmp3*(u(4,i,j-1,k)**2)
     >              - c1345*tmp2*u(5,i,j-1,k) )
               b(5,2,i,j) = - dt * ty2
     >          * ( - c2 * ( u(2,i,j-1,k)*u(3,i,j-1,k) ) * tmp2 )
     >          - dt * ty1
     >          * ( c34 - c1345 ) * tmp2 * u(2,i,j-1,k)
               b(5,3,i,j) = - dt * ty2
     >          * ( c1 * ( u(5,i,j-1,k) * tmp1 )
     >          - c2
     >          * ( qs(i,j-1,k) * tmp1
     >               + u(3,i,j-1,k)*u(3,i,j-1,k) * tmp2 ) )
     >          - dt * ty1
     >          * ( r43*c34 - c1345 ) * tmp2 * u(3,i,j-1,k)
               b(5,4,i,j) = - dt * ty2
     >          * ( - c2 * ( u(3,i,j-1,k)*u(4,i,j-1,k) ) * tmp2 )
     >          - dt * ty1 * ( c34 - c1345 ) * tmp2 * u(4,i,j-1,k)
               b(5,5,i,j) = - dt * ty2
     >          * ( c1 * ( u(3,i,j-1,k) * tmp1 ) )
     >          - dt * ty1 * c1345 * tmp1
     >          - dt * ty1 * dy5

c---------------------------------------------------------------------
c   form the third block sub-diagonal
c---------------------------------------------------------------------
               tmp1 = rho_i(i-1,j,k)
               tmp2 = tmp1 * tmp1
               tmp3 = tmp1 * tmp2

               c(1,1,i,j) = - dt * tx1 * dx1
               c(1,2,i,j) = - dt * tx2
               c(1,3,i,j) =   0.0d+00
               c(1,4,i,j) =   0.0d+00
               c(1,5,i,j) =   0.0d+00

               c(2,1,i,j) = - dt * tx2
     >          * ( - ( u(2,i-1,j,k) * tmp1 ) ** 2
     >       + c2 * qs(i-1,j,k) * tmp1 )
     >          - dt * tx1 * ( - r43 * c34 * tmp2 * u(2,i-1,j,k) )
               c(2,2,i,j) = - dt * tx2
     >          * ( ( 2.0d+00 - c2 ) * ( u(2,i-1,j,k) * tmp1 ) )
     >          - dt * tx1 * ( r43 * c34 * tmp1 )
     >          - dt * tx1 * dx2
               c(2,3,i,j) = - dt * tx2
     >              * ( - c2 * ( u(3,i-1,j,k) * tmp1 ) )
               c(2,4,i,j) = - dt * tx2
     >              * ( - c2 * ( u(4,i-1,j,k) * tmp1 ) )
               c(2,5,i,j) = - dt * tx2 * c2

               c(3,1,i,j) = - dt * tx2
     >              * ( - ( u(2,i-1,j,k) * u(3,i-1,j,k) ) * tmp2 )
     >         - dt * tx1 * ( - c34 * tmp2 * u(3,i-1,j,k) )
               c(3,2,i,j) = - dt * tx2 * ( u(3,i-1,j,k) * tmp1 )
               c(3,3,i,j) = - dt * tx2 * ( u(2,i-1,j,k) * tmp1 )
     >          - dt * tx1 * ( c34 * tmp1 )
     >          - dt * tx1 * dx3
               c(3,4,i,j) = 0.0d+00
               c(3,5,i,j) = 0.0d+00

               c(4,1,i,j) = - dt * tx2
     >          * ( - ( u(2,i-1,j,k)*u(4,i-1,j,k) ) * tmp2 )
     >          - dt * tx1 * ( - c34 * tmp2 * u(4,i-1,j,k) )
               c(4,2,i,j) = - dt * tx2 * ( u(4,i-1,j,k) * tmp1 )
               c(4,3,i,j) = 0.0d+00
               c(4,4,i,j) = - dt * tx2 * ( u(2,i-1,j,k) * tmp1 )
     >          - dt * tx1 * ( c34 * tmp1 )
     >          - dt * tx1 * dx4
               c(4,5,i,j) = 0.0d+00

               c(5,1,i,j) = - dt * tx2
     >          * ( ( c2 * 2.0d0 * qs(i-1,j,k)
     >              - c1 * u(5,i-1,j,k) )
     >          * u(2,i-1,j,k) * tmp2 )
     >          - dt * tx1
     >          * ( - ( r43*c34 - c1345 ) * tmp3 * ( u(2,i-1,j,k)**2 )
     >              - (     c34 - c1345 ) * tmp3 * ( u(3,i-1,j,k)**2 )
     >              - (     c34 - c1345 ) * tmp3 * ( u(4,i-1,j,k)**2 )
     >              - c1345 * tmp2 * u(5,i-1,j,k) )
               c(5,2,i,j) = - dt * tx2
     >          * ( c1 * ( u(5,i-1,j,k) * tmp1 )
     >             - c2
     >             * ( u(2,i-1,j,k)*u(2,i-1,j,k) * tmp2
     >                  + qs(i-1,j,k) * tmp1 ) )
     >           - dt * tx1
     >           * ( r43*c34 - c1345 ) * tmp2 * u(2,i-1,j,k)
               c(5,3,i,j) = - dt * tx2
     >           * ( - c2 * ( u(3,i-1,j,k)*u(2,i-1,j,k) ) * tmp2 )
     >           - dt * tx1
     >           * (  c34 - c1345 ) * tmp2 * u(3,i-1,j,k)
               c(5,4,i,j) = - dt * tx2
     >           * ( - c2 * ( u(4,i-1,j,k)*u(2,i-1,j,k) ) * tmp2 )
     >           - dt * tx1
     >           * (  c34 - c1345 ) * tmp2 * u(4,i-1,j,k)
               c(5,5,i,j) = - dt * tx2
     >           * ( c1 * ( u(2,i-1,j,k) * tmp1 ) )
     >           - dt * tx1 * c1345 * tmp1
     >           - dt * tx1 * dx5

      end do

      return
      end


      subroutine fmc11e(a,n,z,w,ir)
c   multiply a vector z by the inverse of the factors given in a
      implicit double precision (a-h,o-z)
      dimensiona(*),z(n),w(n)
      if(ir.lt.n)return
      w(1)=z(1)
      if(n.gt.1)goto 400
      z(1)=z(1)/a(1)
      return
  400 continue
      do 402 i=2,n
      ij=i
      i1=i-1
      v=z(i)
      do 401 j=1,i1
      v=v-a(ij)*z(j)
  401 ij=ij+n-j
      w(i)=v
  402 z(i)=v
      z(n)=z(n)/a(ij)
      np=n+1
      do 411 nip=2,n
      i=np-nip
      ii=ij-nip
      v=z(i)/a(ii)
      ip=i+1
      ij=ii
      do 410 j=ip,n
      ii=ii+1
  410 v=v-a(ii)*z(j)
  411 z(i)=v
      return
      end


!> Implements the interaction for a spherical particle inside a
!! cylindrical cavity. The particle interacts with the elements in the
!! cavity wall through the Lennard-Jones 12-6 potential. The total
!! interaction is integrated over the volume of the infinitely thick
!! wall of an infinitely long cavity.
!!
!! @see X. Zhang and W. Wang and G. Jiang, "A potential model for
!! interaction between the Lennard-Jones cylindrical wall and fluid
!! molecules". Fluid Phase Equilibria, 218(2), 239-246, 2004.

module ljcylinder
use num_kind
implicit none

interface
   !> Returns the repulsive term of the interaction between a LJ
   !! particle and the smooth wall of the long cylindrical cavity.
   !! @p k = r / rc, where r is the distance from the cavity center
   !! and @p rc is the inner radius of the cavity. The routine works in
   !! reduced LJ units, where distances are in sigma_0:s and energies
   !! in epsilon_0:s.
   pure function repwall2(k, rc)
     use num_kind
     real(dp), intent(in) :: k, rc
     real(dp) :: repwall2
   end function repwall2

   !> Returns the attractive term of the interaction between a LJ
   !! particle and the smooth wall of the long cylindrical cavity.
   !! @p k = r / rc, where r is the distance from the cavity center
   !! and @p rc is the inner radius of the cavity. The routine works in
   !! reduced LJ units, where distances are in sigma_0:s and energies
   !! in epsilon_0:s.
   pure function attwall2(k, rc)
     use num_kind
     real(dp), intent(in) :: k, rc
     real(dp) :: attwall2
   end function attwall2

   !> Returns the repulsive term of the force acting on a LJ
   !! particle by the smooth wall of the long cylindrical cavity.
   !! @p k = r / rc, where r is the distance from the cavity center
   !! and @p rc is the inner radius of the cavity. The routine works in
   !! reduced LJ units, where distances are in sigma_0:s and energies
   !! in epsilon_0:s.
   pure real(dp) function d_repwall(k, rc)
     use num_kind
     real(dp), intent(in) :: k, rc
   end function d_repwall

   !> Returns the attractive term of the force acting on a LJ
   !! particle by the smooth wall of the long cylindrical cavity.
   !! @p k = r / rc, where r is the distance from the cavity center
   !! and @p rc is the inner radius of the cavity. The routine works in
   !! reduced LJ units, where distances are in sigma_0:s and energies
   !! in epsilon_0:s.
   pure real(dp) function d_attwall(k, rc)
     use num_kind
     real(dp), intent(in) :: k, rc
   end function d_attwall
end interface

contains

!> Returns the potential energy for a Lennard-Jones (LJ) site with
!! respect to a cylindrical wall consisting of smoothly and evenly
!! distributed LJ particles.
!!
!! @param eps the parameter for LJ-particle - wall well-depth.
!! @param density the wall density.
!! @param sigma the parameter setting the contact distance between a
!!        wall element and the LJ site.
!! @param alpha controls the amount of attraction with respect to
!!        repulsion. alpha=1 is the regular LJ interaction while
!!        alpha=0 makes the interaction purely repulsive.
!! @param r the distance of LJ site center from the cylinder axis.
!! @param rwall the radius of the cylinder.
!!
pure function ljcylinderpotential(eps, density, sigma, alpha, r, rwall) &
     result(potential)
  real(dp), intent(in) :: eps, density, sigma, alpha, r, rwall
  real(dp) :: potential
  potential = eps * density * sigma**3 * (repwall2(r / rwall, rwall / sigma) &
       - alpha * attwall2(r / rwall, rwall / sigma))
end function

!> Returns the value of force acting on a LJ particle due to a
!! cylindrical wall consisting of smoothly and evenly distributed LJ
!! particles. The direction of the force is from the center of the
!! cavity towards the wall.
!!
!! @param eps the parameter for LJ-particle - wall well-depth
!! @param density the wall density
!! @param sigma the parameter setting the contact distance for the
!!        wall element and the LJ site.
!! @param alpha controls the amount of attraction with respect to
!!        repulsion. alpha=1 is the regular LJ interaction while
!!        alpha=0 makes the interaction purely repulsive.
!! @param r the distance of LJ site center from the cylinder axis.
!! @param rwall the radius of the cylinder.
!!
pure function ljcylinderforce(eps, density, sigma, alpha, r, rwall)
  real(dp), intent(in) :: eps, density, sigma, alpha, r, rwall
  real(dp) :: ljcylinderforce
  ljcylinderforce = eps * density * sigma**3 * &
       (d_repwall(r / rwall, rwall / sigma) - &
       alpha * d_attwall(r / rwall, rwall / sigma)) / rwall
end function

end module


      subroutine rpt2cons_manifold(ixy,maxm,meqn,mwaves,mbc,mx,
     &               ql,qr, aux1,aux2,aux3,imp,asdq,bmasdq,bpasdq)

      implicit none

      integer ixy, maxm, meqn,mwaves,mbc,mx,maux,imp

      double precision     ql(1-mbc:maxm+mbc,meqn)
      double precision     qr(1-mbc:maxm+mbc,meqn)
      double precision   asdq(1-mbc:maxm+mbc,meqn)
      double precision bmasdq(1-mbc:maxm+mbc,meqn)
      double precision bpasdq(1-mbc:maxm+mbc,meqn)
      double precision   aux1(1-mbc:maxm+mbc,*)
      double precision   aux2(1-mbc:maxm+mbc,*)
      double precision   aux3(1-mbc:maxm+mbc,*)

      integer i, i1, k, idir, iface
      double precision vrrot, vlrot, g, vhat
      double precision nv(2), ul(2), ur(2)

c     # idir = direction of normal solve
c     # ixy = 1 --> idir = 0
c     # ixy = 2 --> idir = 1
      idir = ixy-1

c     # iface = 2*(2-ixy)
      if (ixy .eq. 1) then
         iface = 2  !! Bottom edge
      else
         iface = 0  !! left edge
      endif

      do i = 2-mbc, mx+mbc
c         # imp = 1 : i-1   (for apdq)
c         # imp = 2 : i     (for apdq)
          i1 = i-2+imp

c         # -----------------------------------------
c         # Lower faces - cell centered velocities
c         # -----------------------------------------

c         # left/right : 12,13
c         # bottom/top : 14,15
          g = aux2(i1,14-2*idir)

          nv(1) = aux2(i1,8-4*idir)
          nv(2) = aux2(i1,9-4*idir)

          ur(1) = aux2(i1,2)
          ur(2) = aux2(i1,3)

          ul(1) = aux1(i1,2)
          ul(2) = aux1(i1,3)

          vrrot = g*(nv(1)*ur(1) + nv(2)*ur(2))
          vlrot = g*(nv(1)*ul(1) + nv(2)*ul(2))

          vhat = (vrrot + vlrot)/2.0

          bmasdq(i,1) = min(vhat,0.d0)*asdq(i,1)

c         # -----------------------------------------
c         # Upper faces - cell centered velocities
c         # -----------------------------------------

          g = aux3(i1,14-2*idir)
          nv(1) = aux3(i1,8-4*idir)
          nv(2) = aux3(i1,9-4*idir)
          ur(1) = aux2(i1,2)
          ur(2) = aux2(i1,3)

          ul(1) = aux1(i1,2)
          ul(2) = aux1(i1,3)

          vrrot = g*(nv(1)*ur(1) + nv(2)*ur(2))
          vlrot = g*(nv(1)*ul(1) + nv(2)*ul(2))

          vhat = (vrrot + vlrot)/2.0

          bpasdq(i,1) = max(vhat,0.d0)*asdq(i,1)

      enddo

      return
      end


      function fnamidden(r)
      parameter(nrmax=1000)

      common /splines/ rr(0:nrmax),fdrat(0:nrmax),drat2(0:nrmax),
     +     fszrat(0:nrmax), szrat2(0:nrmax), nrspl

      call splintd(rr(0),fdrat(0),drat2(0),nrspl+1,r,fcor)
      fnamidden=diskdensf(r,0.0)*fcor

      return
      end


C
C $Id: pj18dp.f,v 1.5 2008-07-27 00:17:11 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE PJ18DP (COORD,CRDIO,INDIC)
C
C -- M I L L E R   C Y L I N D R I C A L
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      INTEGER INDIC
      DIMENSION GEOG(2),PROJ(2),COORD(2),CRDIO(2)
C **** PARAMETERS **** A,LON0,X0,Y0 ************************************
      COMMON /ERRMZ0/ IERR
        INTEGER IERR
      SAVE   /ERRMZ0/
      COMMON /PRINZ0/ IPEMSG,IPELUN,IPPARM,IPPLUN
        INTEGER IPEMSG,IPELUN,IPPARM,IPPLUN
      SAVE   /PRINZ0/
      COMMON /PC18DP/ A,LON0,X0,Y0
      DATA FORTPI /0.78539816339744833D0/
      DATA ZERO,ONEQ,TWOH /0.0D0,1.25D0,2.5D0/
C
C -- F O R W A R D   . . .
C
      IF (INDIC .EQ. 0) THEN
C
         GEOG(1) = COORD(1)
         GEOG(2) = COORD(2)
         IERR = 0
         LON = ADJLDP (GEOG(1) - LON0)
         PROJ(1) = X0 + A * LON
         PROJ(2) = Y0 + A * LOG (TAN (FORTPI + GEOG(2) / TWOH)) * ONEQ
         CRDIO(1) = PROJ(1)
         CRDIO(2) = PROJ(2)
         RETURN
      END IF
C
C -- I N V E R S E   . . .
C
      IF (INDIC .EQ. 1) THEN
C
         PROJ(1) = COORD(1)
         PROJ(2) = COORD(2)
         IERR = 0
         X = PROJ(1) - X0
         Y = PROJ(2) - Y0
         GEOG(1) = ADJLDP (LON0 + X / A)
         GEOG(2) = TWOH * ATAN (EXP (Y / A / ONEQ)) - FORTPI * TWOH
         CRDIO(1) = GEOG(1)
         CRDIO(2) = GEOG(2)
         RETURN
      END IF
C
      END


subroutine ftester
use fdeclarations

implicit none

call fruler
!write(49,*) ' '
!write(49,*) 'pmatrix'
!do i=1,nn
!write(49,10) (pmatrix(i,j), j=1,w+2)
!end do
write(49,*) ' '
write(49,*) ' Fuzzy memberships matrix depending on the selected scenario'
write(49,*) ' Average, Worst, Optimum'
do i=1,nn
write(49,10) (p22matrix(i,j), j=1,w-2)
end do
write(*,*) 'Development of rules successful!'
write(*,*) ' '
call sleep(2)

write(*,*) 'Fuzzifying inputs...'
ematrix=testmat
z=ee
call fuzzifier
write(*,*) 'Fuzzification successful!'
write(*,*) ' '
write(*,*) 'Applying fuzzy rules...'
write(*,*) ' '
call sleep(2)
allocate(bmatrix(e**(w-1),w-1,ee))
allocate(high(ee))
allocate(good(ee))
allocate(moderate(ee))
allocate(poor(ee))
allocate(bad(ee))
allocate(fmatrix(nn,w-1,ee))
allocate(mmatrix(nn,w,ee))

do i=1,ee !!!!!!!
open(29, file='bmatrix.txt', action='write', status='replace')
write(29,*) nn
call permutator
close(29, status='keep')

open (unit=39, file='bmatrix.txt', status='old', action='read')
read (39,*) nn
do jj=1,nn
read(39,*) (fmatrix(jj,j,i), j=1,w-1)
end do
close(39, status='keep')

write(49,*) 'fmatrix'
do jj=1,nn
write(49,10) (fmatrix(jj,j,i), j=1,w-1)
end do

z=ee
call rules1

write(49,*) ' Fuzzy memberships matrix for each class'
write(49,*) ' H      G      M      P      B'
do jj=1,nn
write(49,10) (mmatrix(jj,j,i), j=1,w)
end do
write(*,*) 'Rules application for observation', i, 'successful'
end do !!!!!!!!!!!!
write(*,*) ' '
write(*,*) 'Rules application successful!'

write (49,*) ' '
write (49,*) ' High habitat suitability membership'
do i=1,z
write(49,10) (high(i))
end do

write (49,*) ' '
write (49,*) ' Good habitat suitability membership'
do i=1,z
write(49,10) (good(i))
end do

write (49,*) ' '
write (49,*) ' Moderate habitat suitability membership'
do i=1,z
write(49,10) (moderate(i))
end do

write (49,*) ' '
write (49,*) ' Poor habitat suitability membership'
do i=1,z
write(49,10) (poor(i))
end do

write (49,*) ' '
write (49,*) ' Bad habitat suitability membership'
do i=1,z
write(49,10) (bad(i))
end do

zz=1
write(*,*)
print *, 'Defuzzifying...'
call sleep(2)
if (dfuzz==1) then
call centroid
else if (dfuzz==2) then
call maxmem
else if (dfuzz==3) then
call waver
else if (dfuzz==4) then
call meanmax
else
call centroid
end if
print *, 'Defuzzification successful!'
print *, ' '

print *, 'Calculating response variable...'
call sleep(2)
write(*,*) ' '

do i=1,ee
if (testmat(i,2)>0) then
if (high(i)<=0 .and. good(i)<=0 .and. moderate(i)<=0 .and. poor(i)<=0 .and. bad(i)<=0) then
s(i,zz)=s(i-1,zz)
cer(i,zz)=0
else
s(i,zz)=s(i,zz)
cer(i,zz)=1
end if
else
s(i,zz)=0
cer(i,zz)=1
end if
end do

open(19, file='output.txt', action='write', status='replace')
do i=1,ee
write(*,*) 'Response variable calculation for test observation', i, 'successful'
write(19,10) (s(i,zz))
end do
write(*,*) ' '
write(*,*) 'Response variable calculation successful!'
10 format (8f7.3)

end subroutine ftester


C
C     FFTE: A FAST FOURIER TRANSFORM PACKAGE
C
C     (C) COPYRIGHT SOFTWARE, 2000-2004, 2008-2011, 2020
C         ALL RIGHTS RESERVED
C                BY
C         DAISUKE TAKAHASHI
C         CENTER FOR COMPUTATIONAL SCIENCES
C         UNIVERSITY OF TSUKUBA
C         1-1-1 TENNODAI, TSUKUBA, IBARAKI 305-8577, JAPAN
C         E-MAIL: daisuke@cs.tsukuba.ac.jp
C
C
C     1-D COMPLEX FFT ROUTINE
C
C     FORTRAN77 SOURCE PROGRAM
C
C     CALL ZFFT1D(A,N,IOPT,B)
C
C     A(N) IS COMPLEX INPUT/OUTPUT VECTOR (COMPLEX*16)
C     B(N*2) IS WORK/COEFFICIENT VECTOR (COMPLEX*16)
C     N IS THE LENGTH OF THE TRANSFORMS (INTEGER*4)
C       -----------------------------------
C         N = (2**IP) * (3**IQ) * (5**IR)
C       -----------------------------------
C     IOPT = 0 FOR INITIALIZING THE COEFFICIENTS (INTEGER*4)
C          = -1 FOR FORWARD TRANSFORM
C          = +1 FOR INVERSE TRANSFORM
C
C     WRITTEN BY DAISUKE TAKAHASHI
C
      SUBROUTINE ZFFT1D(A,N,IOPT,B)
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'param.h'
      COMPLEX*16 A(*),B(*)
      COMPLEX*16 C((NDA2+NP)*NBLK),D(NDA2)
      COMPLEX*16 WX(NDA2),WY(NDA2)
      DIMENSION IP(3),LNX(3),LNY(3)
      SAVE WX,WY
C
      IF (IOPT .EQ. 1) THEN
!$OMP PARALLEL DO
!DIR$ VECTOR ALIGNED
        DO 10 I=1,N
          A(I)=DCONJG(A(I))
   10   CONTINUE
      END IF
C
      IF (N .LE. (L2SIZE/16)/3) THEN
        IF (IOPT .EQ. 0) THEN
          CALL SETTBL(B(N+1),N)
          RETURN
        END IF
C
        CALL FACTOR(N,IP)
C
        CALL FFT235(A,B,B(N+1),N,IP)
      ELSE
        CALL GETNXNY(N,NX,NY)
C
        IF (IOPT .EQ. 0) THEN
          CALL SETTBL(WX,NX)
          CALL SETTBL(WY,NY)
          CALL SETTBL2(B(N+1),NX,NY)
          RETURN
        END IF
C
        CALL FACTOR(NX,LNX)
        CALL FACTOR(NY,LNY)
C
!$OMP PARALLEL PRIVATE(C,D)
        CALL ZFFT1D0(A,A,B,C,C,D,WX,WY,B(N+1),NX,NY,LNX,LNY)
!$OMP END PARALLEL
      END IF
C
      IF (IOPT .EQ. 1) THEN
        DN=1.0D0/DBLE(N)
!$OMP PARALLEL DO
!DIR$ VECTOR ALIGNED
        DO 20 I=1,N
          A(I)=DCONJG(A(I))*DN
   20   CONTINUE
      END IF
      RETURN
      END
      SUBROUTINE ZFFT1D0(A,AYX,B,CX,CY,D,WX,WY,W,NX,NY,LNX,LNY)
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'param.h'
      COMPLEX*16 A(NX,*),AYX(NY,*),B(NX,*)
      COMPLEX*16 CX(NX+NP,*),CY(NY+NP,*),D(*)
      COMPLEX*16 WX(*),WY(*),W(NX,*)
      DIMENSION LNX(*),LNY(*)
C
!$OMP DO PRIVATE(I,J,JJ)
      DO 70 II=1,NX,NBLK
        DO 30 JJ=1,NY,NBLK
          DO 20 I=II,MIN0(II+NBLK-1,NX)
!DIR$ VECTOR ALIGNED
            DO 10 J=JJ,MIN0(JJ+NBLK-1,NY)
              CY(J,I-II+1)=A(I,J)
   10       CONTINUE
   20     CONTINUE
   30   CONTINUE
        DO 40 I=II,MIN0(II+NBLK-1,NX)
          CALL FFT235(CY(1,I-II+1),D,WY,NY,LNY)
   40   CONTINUE
        DO 60 J=1,NY
!DIR$ VECTOR ALIGNED
          DO 50 I=II,MIN0(II+NBLK-1,NX)
            B(I,J)=CY(J,I-II+1)
   50     CONTINUE
   60   CONTINUE
   70 CONTINUE
!$OMP DO PRIVATE(I,J)
      DO 120 JJ=1,NY,NBLK
        DO 90 J=JJ,MIN0(JJ+NBLK-1,NY)
!DIR$ VECTOR ALIGNED
          DO 80 I=1,NX
            CX(I,J-JJ+1)=B(I,J)*W(I,J)
   80     CONTINUE
          CALL FFT235(CX(1,J-JJ+1),D,WX,NX,LNX)
   90   CONTINUE
        DO 110 I=1,NX
!DIR$ VECTOR ALIGNED
          DO 100 J=JJ,MIN0(JJ+NBLK-1,NY)
            AYX(J,I)=CX(I,J-JJ+1)
  100     CONTINUE
  110   CONTINUE
  120 CONTINUE
      RETURN
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
C*PL*ERROR* Comment line too long
c ... file vshifte.f contains code and documentation for subroutine vshifte
c     and its initialization subroutine vshifti
c
c ... required files
c
c     hrfft.f
c
c     subroutine vshifte(ioff,nlon,nlat,uoff,voff,ureg,vreg,
c    +                   wsave,lsave,work,lwork,ierror)
c
c *** purpose
c
c     subroutine vshifte does a highly accurate 1/2 grid increment shift
C*PL*ERROR* Comment line too long
c     in both longitude and latitude of equally spaced vector data on the
c     sphere. data is transferred between the nlon by nlat "offset grid"
C*PL*ERROR* Comment line too long
c     in (uoff,voff) (which excludes poles) and the nlon by nlat+1 "regular
C*PL*ERROR* Comment line too long
c     grid" in (ureg,vreg) (which includes poles).  the transfer can go from
C*PL*ERROR* Comment line too long
c     (uoff,voff) to (ureg,vreg) or vice versa (see ioff).  the grids which
C*PL*ERROR* Comment line too long
c     underly the vector fields are described below.  the north and south
C*PL*ERROR* Comment line too long
c     pole are at 0.5*pi and-0.5*pi radians respectively (pi=4.*atan(1.)).
C*PL*ERROR* Comment line too long
c     uoff and ureg are the east longitudinal vector data components.  voff
c     and vreg are the latitudinal vector data components.
c
c     subroutine sshifte can be used to shift scalar data on the sphere.
C*PL*ERROR* Comment line too long
c     notice that scalar and vector quantities are fundamentally different
C*PL*ERROR* Comment line too long
c     on the sphere.  for example, vectors are discontinuous and multiple
C*PL*ERROR* Comment line too long
c     valued at the poles.  scalars are continuous and single valued at the
C*PL*ERROR* Comment line too long
c     poles. erroneous results would be produced if one attempted to shift
c     vector fields with subroutine sshifte applied to each component of
c     of the vector.
c
c *** grid descriptions
c
c     let dlon = (pi+pi)/nlon and dlat = pi/nlat be the uniform grid
c     increments in longitude and latitude
c
c     offset grid
c
C*PL*ERROR* Comment line too long
c     the "1/2 increment offset" grid (long(j),lat(i)) on which uoff(j,i)
c     and voff(j,i) are given (ioff=0) or generated (ioff=1) is
c
c          long(j) =0.5*dlon + (j-1)*dlon  (j=1,...,nlon)
c
c     and
c
c          lat(i) = -0.5*pi + 0.5*dlat + (i-1)*dlat (i=1,...,nlat)
c
C*PL*ERROR* Comment line too long
c     the data in (uoff,voff) is "shifted" one half a grid increment in both
C*PL*ERROR* Comment line too long
c     longitude and latitude and excludes the poles.  each uoff(j,1),voff(j,1)
c     is given at latitude -pi/2+dlat/2.  uoff(j,nlat),voff(j,nlat) is
c     given at pi/2-dlat/2 (1/2 a grid increment away from the poles).
C*PL*ERROR* Comment line too long
c     uoff(1,i),voff(1,i) is given at longitude dlon/2.  each uoff(nlon,i),
c     voff(nlon,i) is given at longitude 2*pi-dlon/2.
c
c     regular grid
c
c     let dlat,dlon be as above.  then the nlon by nlat+1 grid on which
c     ureg(j,i),vreg(j,i) are generated (ioff=0) or given (ioff=1) is
c
c          lone(j) = (j-1)*dlon (j=1,...,nlon)
c
c      and
c
c          late(i) = -0.5*pi + (i-1)*dlat (i=1,...,nlat+1)
c
c     values in ureg,vreg include the poles and start at zero degrees
c     longitude and at the south pole this is the "usual" equally spaced
c     grid in geophysical coordinates.
c
c *** remark
c
C*PL*ERROR* Comment line too long
c     subroutine vshifte can be used in conjunction with subroutine trvsph
C*PL*ERROR* Comment line too long
c     when transferring vector data from an equally spaced "1/2 increment
C*PL*ERROR* Comment line too long
c     offset" grid to a gaussian or equally spaced grid (which includes poles)
C*PL*ERROR* Comment line too long
c     of any resolution.  this problem (personal communication with dennis
c     shea) is encountered in geophysical modeling and data analysis.
c
c *** method
c
c     fast fourier transform software from spherepack2 and trigonometric
c     identities are used to accurately "shift" periodic vectors half a
c     grid increment in latitude and longitude.  latitudinal shifts are
C*PL*ERROR* Comment line too long
c     accomplished by setting periodic 2*nlat vectors over the pole for each
c     longitude.  vector values must be negated on one side of the pole
c     to maintain periodicity prior to the 2*nlat shift over the poles.
C*PL*ERROR* Comment line too long
c     when nlon is odd, the 2*nlat latitudinal shift requires an additional
C*PL*ERROR* Comment line too long
c     longitude shift to obtain symmetry necessary for full circle shifts
c     over the poles.  finally longitudinal shifts are executed for each
c     shifted latitude.
c
c *** argument description
c
c ... ioff
c
c     ioff = 0 if values on the offset grid in (uoff,voff) are given and
C*PL*ERROR* Comment line too long
c              values on the regular grid in (ureg,vreg) are to be generated.
c
C*PL*ERROR* Comment line too long
c     ioff = 1 if values on the regular grid in (ureg,vreg) are given and
C*PL*ERROR* Comment line too long
c              values on the offset grid in (uoff,voff) are to be generated.
c
c ... nlon
c
c     the number of longitude points on both the "offset" and "regular"
c     uniform grid in longitude (see "grid description" above).  nlon
C*PL*ERROR* Comment line too long
c     is also the first dimension of uoff,voff,ureg,vreg.  nlon determines
C*PL*ERROR* Comment line too long
c     the grid increment in longitude as dlon = 2.*pi/nlon.  for example,
C*PL*ERROR* Comment line too long
c     nlon = 144 for a 2.5 degree grid.  nlon can be even or odd and must
c     be greater than or equal to 4.  the efficiency of the computation
c     is improved when nlon is a product of small primes.
c
c ... nlat
c
C*PL*ERROR* Comment line too long
c     the number of latitude points on the "offset" uniform grid.  nlat+1
C*PL*ERROR* Comment line too long
c     is the number of latitude points on the "regular" uniform grid (see
C*PL*ERROR* Comment line too long
c     "grid description" above).  nlat is the second dimension of uoff,voff.
c     nlat+1 must be the second dimension of ureg,vreg in the program
c     calling vshifte.  nlat determines the grid in latitude as pi/nlat.
C*PL*ERROR* Comment line too long
c     for example, nlat = 36 for a five degree grid.  nlat must be at least 3.
c
c ... uoff
c
c     a nlon by nlat array that contains the east longitudinal vector
c     data component on the offset grid described above.  uoff is a
c     given input argument if ioff=0.  uoff is a generated output
c     argument if ioff=1.
c
c ... voff
c
c     a nlon by nlat array that contains the latitudinal vector data
c     component on the offset grid described above.  voff is a given
c     input argument if ioff=0.  voff is a generated output argument
c     if ioff=1.
c
c ... ureg
c
c     a nlon by nlat+1 array that contains the east longitudinal vector
C*PL*ERROR* Comment line too long
c     data component on the regular grid described above.  ureg is a given
c     input argument if ioff=1.  ureg is a generated output argument
c     if ioff=0.
c
c ... vreg
c
c     a nlon by nlat+1 array that contains the latitudinal vector data
c     component on the regular grid described above.  vreg is a given
c     input argument if ioff=1.  vreg is a generated output argument
c     if ioff=0.
c
c ... wsav
c
c     a real saved work space array that must be initialized by calling
C*PL*ERROR* Comment line too long
c     subroutine vshifti(ioff,nlon,nlat,wsav,ier) before calling vshifte.
c     wsav can then be used repeatedly by vshifte as long as ioff, nlon,
c     and nlat do not change.  this bypasses redundant computations and
c     saves time.  undetectable errors will result if vshifte is called
c     without initializing wsav whenever ioff, nlon, or nlat change.
c
c ... lsav
c
C*PL*ERROR* Comment line too long
c     the length of the saved work space wsav in the routine calling vshifte
C*PL*ERROR* Comment line too long
c     and sshifti.  lsave must be greater than or equal to 2*(2*nlat+nlon+16).
c
c ... work
c
c     a real unsaved work space
c
c ... lwork
c
C*PL*ERROR* Comment line too long
c     the length of the unsaved work space in the routine calling vshifte
c     if nlon is even then lwork must be greater than or equal to
c
c          2*nlon*(nlat+1)
c
c     if nlon is odd then lwork must be greater than or equal to
c
c          nlon*(5*nlat+1)
c
c ... ier
c
c     indicates errors in input parameters
c
c     = 0 if no errors are detected
c
c     = 1 if ioff is not equal to 0 or 1
c
c     = 2 if nlon < 4
c
c     = 3 if nlat < 3
c
c     = 4 if lsave < 2*(nlon+2*nlat)+32
c
c     = 5 if lwork < 2*nlon*(nlat+1) for nlon even or
c            lwork < nlon*(5*nlat+1) for nlon odd
c
c *** end of vshifte documentation
c
c     subroutine vshifti(ioff,nlon,nlat,lsav,wsav,ier)
c
c     subroutine vshifti initializes the saved work space wsav
c     for ioff and nlon and nlat (see documentation for vshifte).
c     vshifti must be called before vshifte whenever ioff or nlon
c     or nlat change.
c
c ... ier
c
c     = 0 if no errors with input arguments
c
c     = 1 if ioff is not 0 or 1
c
c     = 2 if nlon < 4
c
c     = 3 if nlat < 3
c
c     = 4 if lsav < 2*(2*nlat+nlon+16)
c
c *** end of vshifti documentation
c
      SUBROUTINE DVSHIFTE(IOFF,NLON,NLAT,UOFF,VOFF,UREG,VREG,WSAV,LSAV,
     +                   WRK,LWRK,IER)
      IMPLICIT NONE
      INTEGER IOFF,NLON,NLAT,N2,NR,NLAT2,NLATP1,LSAV,LWRK,IER
      INTEGER I1,I2,I3
      DOUBLE PRECISION UOFF(NLON,NLAT),VOFF(NLON,NLAT)
      DOUBLE PRECISION UREG(NLON,*),VREG(NLON,*)
      DOUBLE PRECISION WSAV(LSAV),WRK(LWRK)
c
c     check input parameters
c
      IER = 1
      IF (IOFF* (IOFF-1).NE.0) RETURN
      IER = 2
      IF (NLON.LT.4) RETURN
      IER = 3
      IF (NLAT.LT.3) RETURN
      IER = 4
      IF (LSAV.LT.2* (2*NLAT+NLON+16)) RETURN
      NLAT2 = NLAT + NLAT
      NLATP1 = NLAT + 1
      N2 = (NLON+1)/2
      IER = 5
      IF (2*N2.EQ.NLON) THEN
          IF (LWRK.LT.2*NLON* (NLAT+1)) RETURN
          NR = N2
          I1 = 1
          I2 = 1
          I3 = I2 + NLON*NLATP1
      ELSE
          IF (LWRK.LT.NLON* (5*NLAT+1)) RETURN
          NR = NLON
          I1 = 1
          I2 = I1 + NLAT2*NLON
          I3 = I2 + NLATP1*NLON
      END IF
      IER = 0
      IF (IOFF.EQ.0) THEN
c
c     shift (uoff,voff) to (ureg,vreg)
c
          CALL DVHFTOFF(NLON,NLAT,UOFF,UREG,WSAV,NR,NLAT2,NLATP1,
     +                  WRK(I1),WRK(I2),WRK(I2),WRK(I3))
          CALL DVHFTOFF(NLON,NLAT,VOFF,VREG,WSAV,NR,NLAT2,NLATP1,
     +                  WRK(I1),WRK(I2),WRK(I2),WRK(I3))
      ELSE
c
c     shift (ureg,vreg) to (uoff,voff)
c
          CALL DVHFTREG(NLON,NLAT,UOFF,UREG,WSAV,NR,NLAT2,NLATP1,
     +                  WRK(I1),WRK(I2),WRK(I2),WRK(I3))
          CALL DVHFTREG(NLON,NLAT,VOFF,VREG,WSAV,NR,NLAT2,NLATP1,
     +                  WRK(I1),WRK(I2),WRK(I2),WRK(I3))
      END IF
      END

      SUBROUTINE DVHFTOFF(NLON,NLAT,UOFF,UREG,WSAV,NR,NLAT2,NLATP1,
     +                   RLATU,RLONU,RLOU,WRK)
c
c     generate ureg from uoff (a vector component!)
c
      IMPLICIT NONE
      INTEGER NLON,NLAT,NLAT2,NLATP1,N2,NR,J,I,JS,ISAV
      DOUBLE PRECISION UOFF(NLON,NLAT),UREG(NLON,NLATP1)
      DOUBLE PRECISION RLATU(NR,NLAT2),RLONU(NLATP1,NLON),
     +                 RLOU(NLAT,NLON)
      DOUBLE PRECISION WSAV(*),WRK(*)

      ISAV = 4*NLAT + 17
      N2 = (NLON+1)/2
c
c     execute full circle latitude shifts for nlon odd or even
c
      IF (2*N2.GT.NLON) THEN
c
c     odd number of longitudes
c
          DO I = 1,NLAT
              DO J = 1,NLON
                  RLOU(I,J) = UOFF(J,I)
              END DO
          END DO
c
c       half shift in longitude
c
          CALL DVHIFTH(NLAT,NLON,RLOU,WSAV(ISAV),WRK)
c
c       set full 2*nlat circles in rlatu using shifted values in rlonu
c
          DO J = 1,N2 - 1
              JS = J + N2
              DO I = 1,NLAT
                  RLATU(J,I) = UOFF(J,I)
                  RLATU(J,NLAT+I) = -RLOU(NLAT+1-I,JS)
              END DO
          END DO
          DO J = N2,NLON
              JS = J - N2 + 1
              DO I = 1,NLAT
                  RLATU(J,I) = UOFF(J,I)
                  RLATU(J,NLAT+I) = -RLOU(NLAT+1-I,JS)
              END DO
          END DO
c
c       shift the nlon rlat vectors one half latitude grid
c
          CALL DVHIFTH(NLON,NLAT2,RLATU,WSAV,WRK)
c
c       set in ureg
c
          DO J = 1,NLON
              DO I = 1,NLAT + 1
                  UREG(J,I) = RLATU(J,I)
              END DO
          END DO
      ELSE
c
c     even number of longitudes (no initial longitude shift necessary)
C*PL*ERROR* Comment line too long
c     set full 2*nlat circles (over poles) for each longitude pair (j,js)
c     negating js vector side for periodicity
c
          DO J = 1,N2
              JS = N2 + J
              DO I = 1,NLAT
                  RLATU(J,I) = UOFF(J,I)
                  RLATU(J,NLAT+I) = -UOFF(JS,NLATP1-I)
              END DO
          END DO
c
c       shift the n2=(nlon+1)/2 rlat vectors one half latitude grid
c
          CALL DVHIFTH(N2,NLAT2,RLATU,WSAV,WRK)
c
c       set ureg,vreg shifted in latitude
c
          DO J = 1,N2
              JS = N2 + J
              UREG(J,1) = RLATU(J,1)
              UREG(JS,1) = -RLATU(J,1)
              DO I = 2,NLATP1
                  UREG(J,I) = RLATU(J,I)
                  UREG(JS,I) = -RLATU(J,NLAT2-I+2)
              END DO
          END DO
      END IF
c
c     execute full circle longitude shift
c
      DO J = 1,NLON
          DO I = 1,NLATP1
              RLONU(I,J) = UREG(J,I)
          END DO
      END DO
      CALL DVHIFTH(NLATP1,NLON,RLONU,WSAV(ISAV),WRK)
      DO J = 1,NLON
          DO I = 1,NLATP1
              UREG(J,I) = RLONU(I,J)
          END DO
      END DO
      END

      SUBROUTINE DVHFTREG(NLON,NLAT,UOFF,UREG,WSAV,NR,NLAT2,NLATP1,
     +                   RLATU,RLONU,RLOU,WRK)
c
c     generate uoff vector component from ureg
c
      IMPLICIT NONE
      INTEGER NLON,NLAT,NLAT2,NLATP1,N2,NR,J,I,JS,ISAV
      DOUBLE PRECISION UOFF(NLON,NLAT),UREG(NLON,NLATP1)
      DOUBLE PRECISION RLATU(NR,NLAT2),RLONU(NLATP1,NLON),
     +                 RLOU(NLAT,NLON)
      DOUBLE PRECISION WSAV(*),WRK(*)

      ISAV = 4*NLAT + 17
      N2 = (NLON+1)/2
c
c     execute full circle latitude shifts for nlon odd or even
c
      IF (2*N2.GT.NLON) THEN
c
c     odd number of longitudes
c
          DO I = 1,NLATP1
              DO J = 1,NLON
                  RLONU(I,J) = UREG(J,I)
              END DO
          END DO
c
c       half shift in longitude in rlon
c
          CALL DVHIFTH(NLATP1,NLON,RLONU,WSAV(ISAV),WRK)
c
c       set full 2*nlat circles in rlat using shifted values in rlon
c
          DO J = 1,N2
              JS = J + N2 - 1
              RLATU(J,1) = UREG(J,1)
              DO I = 2,NLAT
                  RLATU(J,I) = UREG(J,I)
                  RLATU(J,NLAT+I) = -RLONU(NLAT+2-I,JS)
              END DO
              RLATU(J,NLAT+1) = UREG(J,NLAT+1)
          END DO
          DO J = N2 + 1,NLON
              JS = J - N2
              RLATU(J,1) = UREG(J,1)
              DO I = 2,NLAT
                  RLATU(J,I) = UREG(J,I)
                  RLATU(J,NLAT+I) = -RLONU(NLAT+2-I,JS)
              END DO
              RLATU(J,NLAT+1) = UREG(J,NLAT+1)
          END DO
c
c       shift the nlon rlat vectors one halflatitude grid
c
          CALL DVHIFTH(NLON,NLAT2,RLATU,WSAV,WRK)
c
c       set values in uoff
c
          DO J = 1,NLON
              DO I = 1,NLAT
                  UOFF(J,I) = RLATU(J,I)
              END DO
          END DO
      ELSE
c
c     even number of longitudes (no initial longitude shift necessary)
C*PL*ERROR* Comment line too long
c     set full 2*nlat circles (over poles) for each longitude pair (j,js)
c
          DO J = 1,N2
              JS = N2 + J
              RLATU(J,1) = UREG(J,1)
              DO I = 2,NLAT
                  RLATU(J,I) = UREG(J,I)
                  RLATU(J,NLAT+I) = -UREG(JS,NLAT+2-I)
              END DO
              RLATU(J,NLAT+1) = UREG(J,NLAT+1)
          END DO
c
c       shift the n2=(nlon+1)/2 rlat vectors one half latitude grid
c
          CALL DVHIFTH(N2,NLAT2,RLATU,WSAV,WRK)
c
c       set values in uoff
c
          DO J = 1,N2
              JS = N2 + J
              DO I = 1,NLAT
                  UOFF(J,I) = RLATU(J,I)
                  UOFF(JS,I) = -RLATU(J,NLAT2+1-I)
              END DO
          END DO
      END IF
c
c     execute full circle longitude shift for all latitude circles
c
      DO J = 1,NLON
          DO I = 1,NLAT
              RLOU(I,J) = UOFF(J,I)
          END DO
      END DO
      CALL DVHIFTH(NLAT,NLON,RLOU,WSAV(ISAV),WRK)
      DO J = 1,NLON
          DO I = 1,NLAT
              UOFF(J,I) = RLOU(I,J)
          END DO
      END DO
      END

      SUBROUTINE DVSHIFTI(IOFF,NLON,NLAT,LSAV,WSAV,IER)
c
c     initialize wsav for vshifte
c
      INTEGER IOFF,NLAT,NLON,NLAT2,ISAV,IER
      DOUBLE PRECISION WSAV(LSAV)
      DOUBLE PRECISION PI,DLAT,DLON,DP

      IER = 1
      IF (IOFF* (IOFF-1).NE.0) RETURN
      IER = 2
      IF (NLON.LT.4) RETURN
      IER = 3
      IF (NLAT.LT.3) RETURN
      IER = 4
      IF (LSAV.LT.2* (2*NLAT+NLON+16)) RETURN
      IER = 0
      PI = 4.0D0*ATAN(1.0D0)
c
c     set lat,long increments
c
      DLAT = PI/NLAT
      DLON = (PI+PI)/NLON
c
c     set left or right latitude shifts
c
      IF (IOFF.EQ.0) THEN
          DP = -0.5D0*DLAT
      ELSE
          DP = 0.5D0*DLAT
      END IF
      NLAT2 = NLAT + NLAT
      CALL DVHIFTHI(NLAT2,DP,WSAV)
c
c     set left or right longitude shifts
c
      IF (IOFF.EQ.0) THEN
          DP = -0.5D0*DLON
      ELSE
          DP = 0.5D0*DLON
      END IF
      ISAV = 4*NLAT + 17
      CALL DVHIFTHI(NLON,DP,WSAV(ISAV))
      RETURN
      END

      SUBROUTINE DVHIFTH(M,N,R,WSAV,WORK)
      IMPLICIT NONE
      INTEGER M,N,N2,K,L
      DOUBLE PRECISION R(M,N),WSAV(*),WORK(*),R2KM2,R2KM1

      N2 = (N+1)/2
c
c     compute fourier coefficients for r on shifted grid
c
      CALL DHRFFTF(M,N,R,M,WSAV(N+2),WORK)
      DO L = 1,M
          DO K = 2,N2
              R2KM2 = R(L,K+K-2)
              R2KM1 = R(L,K+K-1)
              R(L,K+K-2) = R2KM2*WSAV(N2+K) - R2KM1*WSAV(K)
              R(L,K+K-1) = R2KM2*WSAV(K) + R2KM1*WSAV(N2+K)
          END DO
      END DO
c
c     shift r with fourier synthesis and normalization
c
      CALL DHRFFTB(M,N,R,M,WSAV(N+2),WORK)
      DO L = 1,M
          DO K = 1,N
              R(L,K) = R(L,K)/N
          END DO
      END DO
      RETURN
      END

      SUBROUTINE DVHIFTHI(N,DP,WSAV)
c
c     initialize wsav for subroutine vhifth
c
      IMPLICIT NONE
      INTEGER N,N2,K
      DOUBLE PRECISION WSAV(*),DP

      N2 = (N+1)/2
      DO K = 2,N2
          WSAV(K) = SIN((K-1)*DP)
          WSAV(K+N2) = COS((K-1)*DP)
      END DO
      CALL DHRFFTI(N,WSAV(N+2))
      RETURN
      END


c
c     $Id$
c
      subroutine muld(a, b, p, ar, ac, bc)
      implicit none
c
c     Modula-3/C array indexing M(COLS,ROWS)
c
      integer ar, ac, bc
      double precision a(ac,ar), b(bc,ac), p(bc,ar)

      integer row, col, term
      double precision elem

      do 200 row = 1, ar
         do 150 col = 1, bc
            p(col,row) = 0.0
            do 100 term = 1, ac
               p(col,row) = p(col,row) + a(term,row) * b(col,term)
 100        continue
 150     continue
 200  continue
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc