!-------------------------------------------------------------------------
!    NOAA/NCEP, National Centers for Environmental Prediction GSI        !
!-------------------------------------------------------------------------
module wind_fft
!$$$   module documentation block
!                .      .    .                                       .
! module:    wind_fft
! prgmmr: pondeca          org: np23                date: 2006-08-01
!
! abstract: contains subroutines for 2-dimensional FFTs on the plane.
!           adapted from jeff whitaker's August 1, 1991 two-layer
!           qg-model (qg2l)
!
! program history log:
!   2006-08-01  pondeca
!
! subroutines included:
!   sub divvort_to_psichi
!   sub fft2d
!   sub rfft
!   sub cfft
!   sub FFT2
!   sub PASS2
!   sub PREFFT
!   sub FACTOR
!
! variable definitions
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
  use kinds, only: i_kind,r_single,r_kind
  use constants, only: zero,half,one,two,four
  implicit none

! set default to private
  private
! set subroutines to public
  public :: divvort_to_psichi
  public :: fft2d
  public :: rfft
  public :: cfft
  public :: FFT2
  public :: PASS2
  public :: PREFFT
  public :: FACTOR

  integer(i_kind) nx,ny,mmax,nwavesx,nmax,nwavesy
  integer(i_kind) nfax0,nfay0

  real(r_kind),allocatable::rk(:),rl(:)
  real(r_kind),allocatable::indxy(:),trigx(:,:),trigy(:,:)

  real(r_kind),allocatable::delimn(:,:)

  complex(r_kind),allocatable::scrmn(:,:,:,:),scr(:,:),qmn(:,:,:)

  integer(i_kind) ifax0(20),ifay0(20)

!-------------------------------------------------------------------------
contains
!-------------------------------------------------------------------------
!    NOAA/NCEP, National Centers for Environmental Prediction GSI        !
!-------------------------------------------------------------------------
subroutine divvort_to_psichi(nx0,ny0,mmax0,nmax0,rld0,qg)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    divvort_to_psichi
! prgmmr: pondeca          org: np22                date: 2006-08-01
!
!
! abstract: use two-dimensional FFTs to convert gridded
!           fields of divergence and vorticity into
!           stream-function and velocity-potential
!
! program history log:
!   2005-02-08  pondeca
!
!   input argument list:
!     nx0,ny0           - number of grid points in x/y
!     mmax0,nmax0
!     rld0
!
!   output argument list:
!     qg
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
      implicit none

      integer(i_kind), intent(in   ) :: nx0,ny0
      integer(i_kind), intent(in   ) :: mmax0,nmax0
      real(r_single) , intent(in   ) :: rld0(nx0,ny0)
      real(r_single) , intent(  out) :: qg(nx0,ny0,2)

      real(r_kind) xmax,ymax,pi,wavey,delmn
      integer(i_kind) i,j,k,ny2,m,mm,indx

      nx=nx0
      ny=ny0
      mmax=mmax0
      nmax=nmax0
      nwavesx = mmax+1
      nwavesy = 2*nmax+1

!     write(6,*) ' in divvort_to_psichi: nx,ny,nwavesx,nwavesy=',nx,ny,nwavesx,nwavesy

      allocate(scrmn(nwavesx,nwavesy,2,4))
      allocate(scr(nwavesx,ny))
      allocate(qmn(nwavesx,nwavesy,2))
      allocate(delimn(nwavesx,nwavesy))

      allocate(rk(nwavesx))
      allocate(rl(nwavesy))
      allocate(indxy(nwavesy))
      allocate(trigx(2,nx))
      allocate(trigy(2,ny))

      pi = four*atan(one)

      xmax = float(nx-1)
      ymax = float(ny-1)
!     write(6,*) ' in divvort_to_psichi: xmax,ymax,=',xmax,ymax
!
!==> compute trig tables for fft routines.
!
      call prefft(nx,nfax0,ifax0,trigx)
      call prefft(ny,nfay0,ifay0,trigy)
!
!==> set up wavenumbers used in fourier differentiation.
      do 100 i=1,nwavesx
         rk(i) = two*pi*float(i-1)/xmax
100   continue

      ny2 = (ny/2)+1
      do 200 j=1,ny
         mm = j/ny2
         m = mm*ny+1
         wavey = two*pi*float(j-m)/ymax
         if (j<=nmax+1 .or. j>=ny-nmax+1) then
         indx = j-m+nmax+1
         indxy(indx) = j
         rl(indx) = wavey
         end if
200   continue
!
      do 300 j=1,nwavesy
      do 300 i=1,nwavesx
         delmn = -(rk(i)*rk(i) + rl(j)*rl(j))
         delimn(i,j) = zero
         if (delmn/=zero) delimn(i,j)=one/delmn
300   continue
!     write(6,*) 'divvort_to_psichi: delimn,min,max=',minval(delimn),maxval(delimn)

      do 600 k=1,2
          scr=(zero,zero)
          call fft2d(qg(1,1,k),qmn(1,1,k),scr,+1)
          do 500 j=1,nwavesy
          do 500 i=1,nwavesx
             qmn(i,j,k)=delimn(i,j)*qmn(i,j,k)
500       continue
          scr=(zero,zero)
          call fft2d(qg(1,1,k),qmn(1,1,k),scr,-1)
          qg(:,:,k)=qg(:,:,k)*rld0(:,:)**2
600   continue

!     write(6,*) ' in divvort_to_psichi: all done'

      deallocate(scrmn)
      deallocate(scr)
      deallocate(qmn)
      deallocate(delimn)
      deallocate(rk)
      deallocate(rl)
      deallocate(indxy)
      deallocate(trigx)
      deallocate(trigy)

      return
end  subroutine divvort_to_psichi
!
      subroutine fft2d(data,coeff,scr,idir)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    fft2d
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-10-02  lueken - added subprogram doc block
!
!   input argument list:
!    idir
!    data
!    scr,coeff
!
!   output argument list:
!    data
!    scr,coeff
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
      implicit none

      integer(i_kind), intent(in   ) :: idir
      real(r_single) , intent(inout) :: data(nx,ny)
      complex(r_kind), intent(inout) :: scr(nwavesx,ny),coeff(nwavesx,nwavesy)
!     write(6,*) 'IN fft2d,nx,ny,nwavesx,nwavesy=',nx,ny,nwavesx,nwavesy
!-------------------------------------------------
!==> forward transform.
!-------------------------------------------------
      if (idir==1) then
         call rfft(data,scr,1)
         call cfft(scr,coeff,1)
!-------------------------------------------------
!==> inverse transform.
!-------------------------------------------------
      else if (idir==-1) then
         call cfft(scr,coeff,-1)
         call rfft(data,scr,-1)
!
      else
         write(6,*) ' idir must be +1 or -1 in fft2d!'
         write(6,*) ' execution terminated.'
         stop
!
      end if
!
      return
end subroutine fft2d
!
      subroutine rfft(data,coeff,idir)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    rfft
!   prgmmr:
!
! abstract:  performs fast multiple real fft's pairwise using a
!            multiple complex fft routine.  the number of fft's
!            to be performed must be even.
!
! program history log:
!   2009-10-02  lueken - added subprogram doc block
!
!   input argument list:
!    idir
!
!   output argument list:
!    data
!    coeff
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
      implicit none

      integer(i_kind),intent(in   ) :: idir
      real(r_single) ,intent(  out) :: data(nx,ny)
      complex(r_kind),intent(  out) :: coeff(nwavesx,ny)

      integer(i_kind) i,j,n,npts,ndata,ndatah
      real(r_kind) a(ny/2,nx,2),c(ny/2,nx,2)

      npts = nx
      ndata = ny
      ndatah = ndata/2
!
!----------------------
!==> forward transform.
!----------------------
      if (idir==+1) then
!
!==> copy the data into the work array.
!    transforms are computed pairwise using a complex fft.
!
         do 10 j=1,npts
         do 10 i=1,ndatah
            a(i,j,1) = data(j,i)
            a(i,j,2) = data(j,i+ndatah)
10       continue
!
         call fft2(a,c,npts,npts-1,nfax0,ifax0,-1,trigx,ndatah)
!
         do 20 i=1,ndatah
         coeff(1,i) = c(i,1,1)
         coeff(1,i+ndatah) = c(i,1,2)
         do 20 n=2,nwavesx
            coeff(n,i) = half*cmplx(c(i,n,1),c(i,n,2)) + &
            half*cmplx(c(i,npts-n+2,1),-c(i,npts-n+2,2))
            coeff(n,i+ndatah) = half*cmplx(c(i,n,2),-c(i,n,1)) + &
            half*cmplx(c(i,npts-n+2,2),c(i,npts-n+2,1))
20       continue
!----------------------
!==> inverse transform.
!----------------------
      else if (idir==-1) then
!
         do 25 j=1,npts
         do 25 i=1,ndatah
            c(i,j,1) = zero
            c(i,j,2) = zero
25       continue
         do 30 i=1,ndatah
         c(i,1,1) = real(coeff(1,i))
         c(i,1,2) = real(coeff(1,i+ndatah))
         do 30 n=2,nwavesx
            c(i,npts-n+2,1) = real(coeff(n,i))+aimag(coeff(n,i+ndatah))
            c(i,n,1) = real(coeff(n,i))-aimag(coeff(n,i+ndatah))
            c(i,n,2) = aimag(coeff(n,i))+real(coeff(n,i+ndatah))
            c(i,npts-n+2,2) = real(coeff(n,i+ndatah))-aimag(coeff(n,i))
30       continue
!
         call fft2(c,a,npts,npts-1,nfax0,ifax0,+1,trigx,ndatah)
!
         do 40 j=1,npts
         do 40 i=1,ndatah
            data(j,i) = a(i,j,1)
            data(j,i+ndatah) = a(i,j,2)
40       continue
!
      else
         write(6,*) ' idir must be +1 or -1 in rfft!'
         write(6,*) ' execution terminated.'
         stop
      end if
!
      return
end subroutine rfft
!
      subroutine cfft(data,coeff,idir)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    cfft
!   prgmmr:
!
! abstract: performs fast multiple complex fft's.
!           array data(ndata,npts) contains ndata distinct complex
!           data sets of length npts to be transformed.
!
! program history log:
!   2009-10-02  lueken - added subprogram doc block
!
!   input argument list:
!    idir
!
!   output argument list:
!    data
!    coeff
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
      implicit none

      integer(i_kind),intent(in   ) :: idir
      complex(r_kind),intent(  out) :: data(nwavesx,ny),coeff(nwavesx,nwavesy)

      integer(i_kind) i,j,jj,npts,ndata
      real(r_kind) a(nwavesx,ny,2),c(nwavesx,ny,2)

      npts = ny
      ndata = nwavesx

!----------------------
!==> forward transform.
!----------------------
      if (idir==+1) then
!
!==> copy the data into the work array.
!
         do 10 j=1,npts
         do 10 i=1,ndata
            a(i,j,1) = real(data(i,j))
            a(i,j,2) = aimag(data(i,j))
10       continue
!
         call fft2(a,c,npts,npts-1,nfax0,ifax0,-1,trigy,ndata)
!
         do 20 j=1,nwavesy
         do 20 i=1,ndata
            jj = indxy(j)
            coeff(i,j) = cmplx(c(i,jj,1),c(i,jj,2))
20       continue
!----------------------
!==> inverse transform.
!----------------------
      else if (idir==-1) then
!
         do 25 j=1,npts
         do 25 i=1,ndata
            c(i,j,1) = zero
            c(i,j,2) = zero
25       continue
         do 30 j=1,nwavesy
         do 30 i=1,ndata
            jj = indxy(j)
            c(i,jj,1) = real(coeff(i,j))
            c(i,jj,2) = aimag(coeff(i,j))
30       continue
!
         call fft2(c,a,npts,npts-1,nfax0,ifax0,+1,trigy,ndata)
!
         do 40 j=1,npts
         do 40 i=1,ndata
            data(i,j) = cmplx(a(i,j,1),a(i,j,2))
40       continue
!
      else
         write(6,*) ' idir must be +1 or -1 in cfft!'
         write(6,*) ' execution terminated.'
         stop
      end if
!
      return
end subroutine cfft
!
      SUBROUTINE FFT2(A,C,N,NDIM,NFAX,IFAX,ISIGN,TRIG,LEN)
!$$$  subprogram documentation block
!                .      .    .                                      .
! subprogram:    FFT2
!   prgmmr:
!
! abstract: PERFORMS A COMPLEX FFT ON MULTIPLE DATA IN A
!           AND RETURNS THE RESULT IN C
!
! program history log:
!   2009-10-02  lueken - added subprogram doc block
!
!   input argument list:
!    A                      - INPUT ARRAY (DESTROYED DURING CALCULATION).
!                             DIMENSIONED AS A(LEN,0;NDIM,2), WHERE THE 1ST INDEX
!                             LABELS DISTINCT DATA TO BE TRANSFORMED, & 2ND INDEX LABELS
!                             THE N POINTS TO BE TRANSFORMED, & 3RD INDEX  LABELS
!                             REAL (1) OR IMAGINARY (2) PARTS
!    N                      - NO. OF POINTS IN TRANSFORM DIRECTION, MUST HAVE ONLY
!                             PRIME FACTORS OF 2 & 3
!    NDIM                   - 2ND DIMENSION OF A & C
!    NFAX                   - NO. OF PRIME FACTORS OF N
!    IFAX
!    ISIGN                  - SET ISIGN = -1 TO COMPUTE FOURIER COEFFICIENTS,
!                                       = +1 TO COMPUTE GRID VALUES.
!    TRIG                   -  ARRAY CONTAINING TRIGONOMETRIC FACTORS:
!                              DIMENSIONED TRIG(2,0:N-1)
!                                       TRIG(1,J) = COS (2.*PI*J/N)
!                                       TRIG(2,J) = SIN (2.*PI*J/N)
!    LEN                    - NO. OF DISTINCT TRANSFORMS TO BE PERFORMED.
!
!   output argument list:
!    C                      - OUTPUT ARRAY (MUST BE DISTINCT FROM INPUT ARRAY),
!                             DIMENSIONED THE SAME AS ARRAY A
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
      implicit none

      INTEGER(i_kind),intent(in   ) :: IFAX(*),LEN,NDIM,NFAX,ISIGN,N
      REAL(r_kind)   ,intent(inout) :: A(LEN,0:NDIM,2),TRIG(2,0:N-1)
      REAL(r_kind)   ,intent(inout) :: C(LEN,0:NDIM,2)

      INTEGER(i_kind) I,IJ,LA,IFAC
      REAL(r_kind) XNI
      LOGICAL ODD

      REAL(r_kind),PARAMETER::PI=3.1415926535898_r_kind
!
      LA=1
      ODD=.TRUE.
      DO 10 I=1,NFAX
         IFAC=IFAX(I)
         IF (ODD) THEN
            CALL PASS2(A,C,N,NDIM,ISIGN,IFAC,LA,TRIG,LEN)
         ELSE
            CALL PASS2(C,A,N,NDIM,ISIGN,IFAC,LA,TRIG,LEN)
         END IF
         ODD=.NOT.ODD
         LA=LA*IFAC
   10 CONTINUE
!
      IF (ODD) THEN
         DO 30 I=0,N-1
            DO 20 IJ=1,LEN
               C(IJ,I,1) = A(IJ,I,1)
               C(IJ,I,2) = A(IJ,I,2)
   20       CONTINUE
   30    CONTINUE
      END IF
      IF (ISIGN==-1) THEN
         XNI=one/N
         DO 50 I=0,N-1
            DO 40 IJ=1,LEN
               C(IJ,I,1) = XNI * C(IJ,I,1)
               C(IJ,I,2) = XNI * C(IJ,I,2)
   40       CONTINUE
   50    CONTINUE
      END IF
      RETURN
END SUBROUTINE FFT2
!  ------------------------------------------------------------
      SUBROUTINE PASS2(A,C,N,NDIM,ISIGN,IFAC,LA,TRIG,LEN)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    PASS2
!   prgmmr:
!
! abstract: PERFORMS ONE PASS OF  FFT2
!
! program history log:
!   2009-10-02  lueken - added subprogram doc block
!
!   input argument list:
!    A
!    N
!    NDIM
!    ISIGN
!    IFAC
!    LA
!    TRIG
!    LEN
!
!   output argument list:
!    C
!
! note:
!
!  THIS ROUTINE IS NEVER CALLED DIRECTLY BY THE USER.
!  THE ARGUMENTS ARE SIMILAR TO THOSE OF FFT2.
!
!  THE INNER LOOPS IN THIS SUBROUTINE (THOSE OVER THE INDEX IJ)
!  EXTEND OVER PART OF THE 2ND DIMENSIONS OF THE ARRAYS A & C.
!  THIS PRODUCES LONGER VECTOR LENGTHS.
!
!   THE FOLLOWING CONSTANTS PRESUME A 64-BIT MACHINE. THEY ARE
!   SINES OF 45 AND 60 DEGREES.
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
      implicit none

      INTEGER(i_kind),intent(in   ) :: N,NDIM,ISIGN,IFAC,LA,LEN
      REAL(r_kind)   ,intent(in   ) :: TRIG(2,0:N-1)
      REAL(r_kind)   ,intent(inout) :: A(LEN,0:NDIM,2),C(LEN,0:NDIM,2)

      INTEGER(i_kind) I,I0,I01,I1,I11,J,J0,J01,J1,J11,K,M,LLA,IND(0:20),JND(0:20),JUMP,IJ,IJ1
      INTEGER(i_kind) I2,I21,J2,J21
      REAL(r_kind) SN60,CC,SS,AM1,AM2,AP1,AP2,TA1,TA2,C1,C2,S1,S2,T1,T2

      REAL(r_kind),PARAMETER::ASN60 = half*1.732050807569_r_kind

      SN60=ISIGN * ASN60
      M = N/IFAC
!
!
!     SET UP INDEXING
!
      DO 10 K=0,IFAC-1
         IND(K) = K*M
         JND(K) = K*LA
   10 CONTINUE
      LLA =LA * LEN
!
!     PERFORM THE ARITHMETIC
!
      I = 0
      J = 0
      JUMP = (IFAC-1) * LA
      DO 130 K = 0,M-LA,LA
         IF (IFAC==2) THEN
            I0 = IND(0) + I
            I1 = IND(1) + I
            J0 = JND(0) + J
            J1 = JND(1) + J
            CC = TRIG(1,K)
            SS = ISIGN * TRIG(2,K)
            IF (K==0) THEN
               DO 20 IJ = 1,LLA
                  if(ij>len) then
                     ij1=mod(ij-1,len)+1
                     i01=(ij-1)/len+i0; i11=(ij-1)/len+i1
                     j01=(ij-1)/len+j0; j11=(ij-1)/len+j1
                     if(i01<=ndim.and.i11<=ndim.and.&
                        j01<=ndim.and.j11<=ndim) then
                        C(IJ1,J01,1) = A(IJ1,I01,1) + A(IJ1,I11,1)
                        C(IJ1,J01,2) = A(IJ1,I01,2) + A(IJ1,I11,2)
                        C(IJ1,J11,1) = A(IJ1,I01,1) - A(IJ1,I11,1)
                        C(IJ1,J11,2) = A(IJ1,I01,2) - A(IJ1,I11,2)
                     end if
                  else
                     C(IJ,J0,1) = A(IJ,I0,1) + A(IJ,I1,1)
                     C(IJ,J0,2) = A(IJ,I0,2) + A(IJ,I1,2)
                     C(IJ,J1,1) = A(IJ,I0,1) - A(IJ,I1,1)
                     C(IJ,J1,2) = A(IJ,I0,2) - A(IJ,I1,2)
                  end if
         20    CONTINUE
            ELSE
               DO 50 IJ = 1,LLA
                  if(ij>len) then
                     ij1=mod(ij-1,len)+1
                     i01=(ij-1)/len+i0; i11=(ij-1)/len+i1
                     j01=(ij-1)/len+j0; j11=(ij-1)/len+j1
                     if(i01<=ndim.and.i11<=ndim.and.&
                        j01<=ndim.and.j11<=ndim) then
                        C(IJ1,J01,1) = A(IJ1,I01,1) + A(IJ1,I11,1)
                        C(IJ1,J01,2) = A(IJ1,I01,2) + A(IJ1,I11,2)
                        AM1 = A(IJ1,I01,1) - A(IJ1,I11,1)
                        AM2 = A(IJ1,I01,2) - A(IJ1,I11,2)
                        C(IJ1,J11,1) = CC * AM1 - SS * AM2
                        C(IJ1,J11,2) = SS * AM1 + CC * AM2
                     end if
                  else
                     C(IJ,J0,1) = A(IJ,I0,1) + A(IJ,I1,1)
                     C(IJ,J0,2) = A(IJ,I0,2) + A(IJ,I1,2)
                     AM1 = A(IJ,I0,1) - A(IJ,I1,1)
                     AM2 = A(IJ,I0,2) - A(IJ,I1,2)
                     C(IJ,J1,1) = CC * AM1 - SS * AM2
                     C(IJ,J1,2) = SS * AM1 + CC * AM2
                  end if
            50 CONTINUE
            END IF
         ELSEIF (IFAC==3) THEN
            I0 = IND(0) + I
            I1 = IND(1) + I
            I2 = IND(2) + I
            J0 = JND(0) + J
            J1 = JND(1) + J
            J2 = JND(2) + J
            IF (K==0) THEN
               DO 60 IJ = 1,LLA
                  if(ij>len) then
                     ij1=mod(ij-1,len)+1
                     i01=(ij-1)/len+i0; i11=(ij-1)/len+i1; i21=(ij-1)/len+i2
                     j01=(ij-1)/len+j0; j11=(ij-1)/len+j1; j21=(ij-1)/len+j2
                     if(i01<=ndim.and.i11<=ndim.and.i21<=ndim.and. &
                        j01<=ndim.and.j11<=ndim.and.i21<=ndim) then
                        AP1 = A(IJ1,I11,1) + A(IJ1,I21,1)
                        AP2 = A(IJ1,I11,2) + A(IJ1,I21,2)
                        C(IJ1,J01,1) = A(IJ1,I01,1) + AP1
                        C(IJ1,J01,2) = A(IJ1,I01,2) + AP2
                        TA1 = A(IJ1,I01,1) - half * AP1
                        TA2 = A(IJ1,I01,2) - half * AP2
                        AM1 = SN60 * (A(IJ1,I11,1) - A(IJ1,I21,1))
                        AM2 = SN60 * (A(IJ1,I11,2) - A(IJ1,I21,2))
                        C(IJ1,J11,1) = TA1 - AM2
                        C(IJ1,J11,2) = TA2 + AM1
                        C(IJ1,J21,1) = TA1 + AM2
                        C(IJ1,J21,2) = TA2 - AM1
                     endif
                  else
                     AP1 = A(IJ,I1,1) + A(IJ,I2,1)
                     AP2 = A(IJ,I1,2) + A(IJ,I2,2)
                     C(IJ,J0,1) = A(IJ,I0,1) + AP1
                     C(IJ,J0,2) = A(IJ,I0,2) + AP2
                     TA1 = A(IJ,I0,1) - half * AP1
                     TA2 = A(IJ,I0,2) - half * AP2
                     AM1 = SN60 * (A(IJ,I1,1) - A(IJ,I2,1))
                     AM2 = SN60 * (A(IJ,I1,2) - A(IJ,I2,2))
                     C(IJ,J1,1) = TA1 - AM2
                     C(IJ,J1,2) = TA2 + AM1
                     C(IJ,J2,1) = TA1 + AM2
                     C(IJ,J2,2) = TA2 - AM1
                  end if
            60 CONTINUE
            ELSE
               C1 = TRIG(1,K)
               C2 = TRIG(1,2*K)
               S1 = ISIGN * TRIG(2,K)
               S2 = ISIGN * TRIG(2,2*K)
               DO 70 IJ = 1,LLA
                  if(ij>len) then
                     ij1=mod(ij-1,len)+1
                     i01=(ij-1)/len+i0; i11=(ij-1)/len+i1; i21=(ij-1)/len+i2
                     j01=(ij-1)/len+j0; j11=(ij-1)/len+j1; j21=(ij-1)/len+j2
                     if(i01<=ndim.and.i11<=ndim.and.i21<=ndim.and. &
                        j01<=ndim.and.j11<=ndim.and.i21<=ndim) then
                        AP1 = A(IJ1,I11,1) +A(IJ1,I21,1)
                        AP2 = A(IJ1,I11,2) +A(IJ1,I21,2)
                        C(IJ1,J01,1) = A(IJ1,I01,1) +AP1
                        C(IJ1,J01,2) = A(IJ1,I01,2) +AP2
                        TA1 = A(IJ1,I01,1) - half*AP1
                        TA2 = A(IJ1,I01,2) - half*AP2
                        AM1 = SN60 * (A(IJ1,I11,1) - A(IJ1,I21,1))
                        AM2 = SN60 * (A(IJ1,I11,2) - A(IJ1,I21,2))
                        T1 = TA1 - AM2
                        T2 = TA2 + AM1
                        C(IJ1,J11,1) = C1 * T1 - S1 * T2
                        C(IJ1,J11,2) = S1 * T1 + C1 *T2
                        T1 = TA1 + AM2
                        T2 = TA2 - AM1
                        C(IJ1,J21,1) = C2 * T1 - S2 * T2
                        C(IJ1,J21,2) = S2 * T1 + C2 * T2
                     endif
                  else
                     AP1 = A(IJ,I1,1) +A(IJ,I2,1)
                     AP2 = A(IJ,I1,2) +A(IJ,I2,2)
                     C(IJ,J0,1) = A(IJ,I0,1) +AP1
                     C(IJ,J0,2) = A(IJ,I0,2) +AP2
                     TA1 = A(IJ,I0,1) - half*AP1
                     TA2 = A(IJ,I0,2) - half*AP2
                     AM1 = SN60 * (A(IJ,I1,1) - A(IJ,I2,1))
                     AM2 = SN60 * (A(IJ,I1,2) - A(IJ,I2,2))
                     T1 = TA1 - AM2
                     T2 = TA2 + AM1
                     C(IJ,J1,1) = C1 * T1 - S1 * T2
                     C(IJ,J1,2) = S1 * T1 + C1 *T2
                     T1 = TA1 + AM2
                     T2 = TA2 - AM1
                     C(IJ,J2,1) = C2 * T1 - S2 * T2
                     C(IJ,J2,2) = S2 * T1 + C2 * T2
                  end if
         70    CONTINUE
            END IF
         END IF
         I = I+LA
         J = J+LA
         J = J+JUMP
  130 CONTINUE
      RETURN
END SUBROUTINE PASS2
!-------------------------------------------------------------
      SUBROUTINE PREFFT (N,NFAX,IFAX,TRIG)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    PREFFT
!   prgmmr:
!
! abstract: C0MPUTES PRELIMINARY QUANTITIES FOR FFT ROUTINES
!
! program history log:
!   2009-10-02  lueken - added subprogram doc block
!
!   input argument list:
!    N                     - NO. OF POINTS IN DATA, MUST HAVE PRIME FACTORS 2 & 3
!    TRIG                  - ARRAY CONTAINING TRIGONOMETRIC FACTORS, DIMNSN (2,0;N-1)
!                            TRIG(1,J) = COS (2*PI*J/N)
!                            TRIG(2,J) = SIN (2.*PI*J/N)
!
!   output argument list:
!    NFAX                  - NO. OF PRIME FACTORS OF N (OUTPUT)
!    IFAX                  - ARRAY CONTAINING PRIME FACTORS OF N (OUTPUT)
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
      implicit none

      INTEGER(i_kind),intent(in   ) :: N
      REAL(r_kind)   ,intent(inout) :: TRIG(2,0:N-1)

      INTEGER(i_kind),intent(  out) :: IFAX(*),NFAX

      INTEGER(i_kind) K
      REAL(r_kind) ARG
      REAL(r_kind),PARAMETER::PI=3.1415926535898_r_kind

      CALL FACTOR (N,NFAX,IFAX)
      DO 10 K=0,N-1
         ARG = two*PI*K/N
         TRIG(1,K) = COS(ARG)
         TRIG(2,K) = SIN(ARG)
   10 CONTINUE
      RETURN
END SUBROUTINE PREFFT
!  --------------------------------------------------------------
      SUBROUTINE FACTOR (N,NFAX,IFAX)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    FACTOR
!   prgmmr:
!
! abstract: COMPUTES THE FACTORS OF N
!
! program history log:
!   2009-10-02  lueken - added subprogram doc block
!
!   input argument list:
!    N
!
!   output argument list:
!    NFAX
!    IFAX
!
! note:
!
!    THIS ROUTINE IS NOT CALLED DIRECTLY BY THE USER
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
      implicit none

      INTEGER(i_kind),intent(in   ) :: N
      INTEGER(i_kind),intent(  out) :: IFAX(*),NFAX

      INTEGER(i_kind) NN,II

      NFAX = 0
      NN= N

!     EXTRACT FACTORS OF 3
      DO 10 II = 1,20
         IF (NN==3*(NN/3)) THEN
            NFAX = NFAX+1
            IFAX(NFAX) = 3
            NN = NN/3
         ELSE
            EXIT
         END IF
   10 CONTINUE
!     EXTRACT FACTORS OF 2
      DO 30 II = NFAX+1,20
         IF (NN==2*(NN/2)) THEN
            NFAX = NFAX +1
            IFAX(NFAX) =2
            NN = NN/2
         ELSE
            EXIT
         END IF
   30 CONTINUE
      IF (NN/=1) THEN
         write(6,*) 'PORRA 4'
         STOP
      END IF
      RETURN
END SUBROUTINE FACTOR
!=======================================================================
!=======================================================================
end module wind_fft


      double precision function theta(s,t0,p0,pr)
c
c ***********************************
c to compute local potential temperature at pr
c using bryden 1973 polynomial for adiabatic lapse rate
c and runge-kutta 4-th order integration algorithm.
c ref: bryden,h.,1973,deep-sea res.,20,401-408
c fofonoff,n.,1977,deep-sea res.,24,489-491
c units:
c       pressure        p0       decibars
c       temperature     t0       deg celsius (ipts-68)
c       salinity        s        (ipss-78)
c       reference prs   pr       decibars
c       potential tmp.  theta    deg celsius
c checkvalue: theta= 36.89073 c,s=40 (ipss-78),t0=40 deg c,
c p0=10000 decibars,pr=0 decibars
c
c      set-up intermediate temperature and pressure variables
c
      implicit double precision (a-h,o-z)
      double precision h
c      real p,p0,t,t0,h,pr,xk,s,q,theta,atg
      p=p0
      t=t0
c**************
      h = pr - p
      xk = h*atg(s,t,p)
      t = t + 0.5*xk
      q = xk
      p = p + 0.5*h
      xk = h*atg(s,t,p)
      t = t + 0.29289322*(xk-q)
      q = 0.58578644*xk + 0.121320344*q
      xk = h*atg(s,t,p)
      t = t + 1.707106781*(xk-q)
      q = 3.414213562*xk - 4.121320344*q
      p = p + 0.5*h
      xk = h*atg(s,t,p)
      theta = t + (xk-2.0*q)/6.0
      return
      end


c*************************************************************************
c                            RMVS_CHK_IND.F
c*************************************************************************
c  Subroutine to check if a test particle and planet
c  are having or **will** have an encounter
c  in the next timestep.
c
c             Input:
c                 xr,yr,zr     ==>  relative position of tp wrt planet
c                                   (real scalar)
c                 vxr,vyr,vzr  ==>  relative velocity of tp wrt planet
c                                   (real scalor)
c                 dt           ==>  time step (real scalor)
c                 r2crit       ==> boundary of outer enc region
c                                   (real scalor)
c                 r2critp      ==> boundary of inner (planocentric) enc region
c                                   (real scalor)
c             Output:
c                 iflag        ==> encounter?  =  0 no
c                                              =  1 yes, in outer region
c                                              = -1 yes, in inner region
c
c
c Remarks: Based on Hal's wiscl_fk.f' but origonaly written by Martin Duncan
c Authors:  Hal Levison
c Date:    2/19/93
c Last revision:

      subroutine rmvs_chk_ind(xr,yr,zr,vxr,vyr,vzr,dt,
     &                         r2crit,r2critp,iflag)

      include '../swift.inc'
      include 'rmvs.inc'

c...  Inputs:
      real*8 xr,yr,zr,vxr,vyr,vzr,dt,r2crit,r2critp

c...  Outputs
	integer iflag

c...  Internals
	real*8 r2,v2,vdotr,tmin,r2min

c-----
c...  Executable code

c...    First check if we're already in the encounter region. If so return
c.             with flag set to one.
	r2 = xr**2 + yr**2 + zr**2
	if (r2 .le. r2critp) then
	   iflag = -1
	   return
	endif

c...    If we're heading outward, use r2 to calc iflag
	vdotr = xr*vxr + yr*vyr + zr*vzr
	if (vdotr . gt. 0.d0) then
           if (r2 .ge. r2crit) then
	      iflag = 0
           else
	      iflag = 1
           endif
	   return
	endif

c...    We're not yet inside and are converging so we need to calc. the
c.           minimum separation attained in time dt.
	v2 = vxr**2 + vyr**2 + vzr**2
	tmin = -vdotr/v2

	if(tmin.lt.dt) then
	   r2min = r2 -(vdotr**2)/v2
	else
	   r2min = r2 + 2.d0*vdotr*dt + v2*dt*dt
	endif

        r2min = dmin1(r2min,r2)     ! really make sure

        if (r2min.le.r2critp)then
	   iflag = -1
	else if(r2min.le.r2crit)then
	   iflag = 1
	else
	   iflag = 0
	endif

	return
	end  ! rmvs_chk_ind
c--------------------------------------------------------------


      real             function SSQUAD(K, N, T, BCOEF, X1, X2)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SSQUAD Krogh  Added external statement.
c>> 1994-10-20 SSQUAD Krogh  Changes to use M77CON
c>> 1992-11-12 SSQUAD C. L. Lawson, JPL Saving IL1 & IL2.
c>> 1992-10-27 C. L. Lawson, JPL
c>> 1988-04-01 C. L. Lawson, JPL
C
C   This subprogram computes the integral over [X1,X2] of a K-th order
C      B-spline using the B-representation (T,BCOEF,N,K).  Orders
C      K as high as 20 are permitted.  Permits X1 .le. X2 or X1 gt. X2.
C      The "proper interpolation interval" is from T(K) to T(N+1).
c      For most reliable results, X1 and X2 should lie in this
c      interval, however this subr will give a result even if this
c      is not the case by use of extrapolation.
C      This subr applies a 2, 6, or 10 point Gauss formula on
c      subintervals of [X1,X2] which are formed by the included
c      (distinct) knots.

C     DESCRIPTION OF ARGUMENTS
C         INPUT
C           K       - ORDER OF B-SPLINE, 2 .le. K .le. 20
c                     Note that the polynomial degree of the segments of
c                     the spline are one less than the order.
C           N       - LENGTH OF COEFFICIENT ARRAY
C           T()     - KNOT ARRAY OF LENGTH N+K
C           BCOEF() - B-SPLINE COEFFICIENT ARRAY OF LENGTH N
C           X1,X2   - END POINTS OF QUADRATURE INTERVAL.
C                     Permit X1 .le. X2 or X1 .gt. X2.
C         OUTPUT
C           SSQUAD  - INTEGRAL OF THE B-SPLINE OVER [X1,X2].
C
C     ERROR CONDITIONS: None
c     ------------------------------------------------------------------
C     Original code was called BQUAD or BSQUAD.  Written by D. E. Amos,
c     Sandia, June, 1979.  Documented in SAND79-1825.
c     Uses the (T, BCOEF, N, K) representation of a B-spline as
c     presented in A PRACTICAL GUIDE TO SPLINES by Carl De Boor,
c     Springer-Verlag, 1978.
c     Current version by C. L. Lawson, JPL, March 1988.
c     ------------------------------------------------------------------
c--S replaces "?": ?SQUAD, ?SFIND, ?SVAL
c     ------------------------------------------------------------------
c     GPTS(), GWTS()  Index 1 selects 2-point Gaussian formula.
c                     Indices 2-4 select 6-point Gaussian formula.
c                     Indices 5-9 select 10-point Gaussian formula.
c     ------------------------------------------------------------------
      external SSVAL
      integer I, IL1, IL2, JF, K, LEFT, M, MF, MODE, N
      real             SSVAL
      real             A, AA, B, BB, BCOEF(N), BMA, BPA, C1
      real             GPTS(9), GWTS(9), HALF
      real             Q, SUM(5), T(N+K), TA, TB, X1, X2, ZERO
      parameter(HALF = 0.50E0, ZERO = 0.0E0)
      save IL1, IL2
      data IL1, IL2 / 1,1/
C
*     DATA GPTS            / 5.77350269189626E-01, 2.38619186083197E-01,
*    1 6.61209386466265E-01, 9.32469514203152E-01, 1.48874338981631E-01,
*    2 4.33395394129247E-01, 6.79409568299024E-01, 8.65063366688985E-01,
*    3 9.73906528517172E-01/
C
*     DATA GWTS            / 1.00000000000000E+00, 4.67913934572691E-01,
*    1 3.60761573048139E-01, 1.71324492379170E-01, 2.95524224714753E-01,
*    2 2.69266719309996E-01, 2.19086362515982E-01, 1.49451349150581E-01,
*    3 6.66713443086880E-02/
c
c     Gaussian quadrature abcissae and weights to 40 decimal digits.
      data GPTS / 0.5773502691896257645091487805019574556476e0,
     2            0.2386191860831969086305017216807119354186e0,
     3            0.6612093864662645136613995950199053470064e0,
     4            0.9324695142031520278123015544939946091348e0,
     5            0.1488743389816312108848260011297199846176e0,
     6            0.4333953941292471907992659431657841622001e0,
     7            0.6794095682990244062343273651148735757693e0,
     8            0.8650633666889845107320966884234930485275e0,
     9            0.9739065285171717200779640120844520534283e0/
c
      data GWTS / 1.0e0,
     2            0.4679139345726910473898703439895509948120e0,
     3            0.3607615730481386075698335138377161116612e0,
     4            0.1713244923791703450402961421727328935273e0,
     5            0.2955242247147528701738929946513383294210e0,
     6            0.2692667193099963550912269215694693528586e0,
     7            0.2190863625159820439955349342281631924634e0,
     8            0.1494513491505805931457763396576973323908e0,
     9            0.06667134430868813759356880989333179285686e0/
c     ------------------------------------------------------------------
C
      AA= min(X1,X2)
      BB= max(X1,X2)
      if(AA .eq. BB) then
         Q = ZERO
         go to 90
      endif
C                  Selection of Gaussian quadrature formula:
c                  KORDER .le. 4          =>   2 point formula
c                  5 .le. KORDER .le. 12  =>  6 point formula
c                  KORDER .ge. 13         =>  10 point formula
c
      if(K .le. 4) then
         JF=0
         MF=1
      elseif(K .le. 12) then
         JF=1
         MF=3
      else
         JF=4
         MF=5
      endif
C
      do 15 I=1,MF
         SUM(I)= ZERO
   15 continue
      call SSFIND(T,K, N+1,AA,IL1,MODE)
      call SSFIND(T,K, N+1,BB,IL2,MODE)
      do 20 LEFT=IL1,IL2
         TA=T(LEFT)
         TB=T(LEFT+1)
         if(TA .ne. TB) then
            if(LEFT .eq. K) then
               A = AA
            else
               A= max(AA,TA)
            endif
            if(LEFT .eq. N) then
               B = BB
            else
               B= min(BB,TB)
            endif
            BMA= HALF *(B-A)
            BPA= HALF *(B+A)
            DO 25 M=1,MF
               C1=BMA*GPTS(JF+M)
               SUM(M)=SUM(M) + BMA * (SSVAL(K, N, T, BCOEF, BPA+C1, 0)+
     *                                SSVAL(K, N, T, BCOEF, BPA-C1, 0))
   25       continue
         endif
   20 continue
      Q= ZERO
      DO 30 M=1,MF
         Q=Q+GWTS(JF+M)*SUM(M)
   30 continue
      if(X1 .gt. X2) Q=-Q
   90 continue
      SSQUAD = Q
      return
      end


! =====================================================================
!
! function KRXV
!
! This function computes the expectation value of the radial momentum
! operator.
!
! ---------------------------------------------------------------------
      double precision function KRXV(nRP,nR,nP,dR,R,RdRP,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: dR
      double precision :: R(nR)
      double precision :: RdRP(nR)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k
      double complex :: a
      double complex :: b

      KRXV = 0.0d0
      a = dcmplx(0.0d0,-0.5d0/dR)

      k = 0
      do j = 1, nP
         k = k + 1
         b = dcmplx(0.0d0,-0.5d0/R(1)**2)
         KRXV = KRXV + dble(dconjg(U(k))*(a*U(k+1)+b*U(k)))*RdRP(1)
         do i = 2, nR-1
            k = k + 1
            b = dcmplx(0.0d0,-0.5d0/R(i)**2)
            KRXV = KRXV + dble(dconjg(U(k))*(a*(U(k+1)-U(k-1))+ b*U(k)))*RdRP(i)
         enddo
         k = k + 1
         b = dcmplx(0.0d0,-0.5d0/R(nR)**2)
         KRXV = KRXV + dble(dconjg(U(k))*(a*-U(k-1)+b*U(k)))*RdRP(nR)
      enddo

      return
      end
! =====================================================================


c  this is a rebinning/pixelizing routine.
c  given n points and x(i), y(i), rebin into
c  nout pixels that have x(0)=x0, and linear spacing dx.
c  The input arrays x and y are assumed to be sorted in
c  increasing x.

      subroutine linrebin(n,x,y,nout,x0,dx,yout)

      integer n,nout
      real x(n),y(n),yout(nout)
      real x0,dx
      real weight(nout)

c      include 'pcredshift.h'
      bad = -1.e4
      badset = -1.e6

c for the moment we just calculate x0 and dx from the
c extreme points.  This might or might not be a bad idea.
c If the x are nearly linear it should be ok.

      xmin=x(1)
      xmax=x(n)
      dx = (xmax-xmin)/(nout-1.)
      x0 = xmin-dx

      do j=1,nout
         yout(j) = 0.0
         weight(j) = 0.0
      end do

c loop through OLD pixels and figure out how much
c flux to put in each new pixel and how much of the
c new pixel is covered.  Hopefully this has a lot in
c common with logrebin, but here I'm looping over the
c OLD bins while in logrebin I looped over the NEW bins.

c I'm trying to conserve total counts (photons or whatever)

      do i=1,n
c if the cell value is bad skip the whole thing
         if(y(i) .lt. bad) go to 200
c boundaries of this cell
         if (i .eq. 1) then
            x1 = x(i)
         else
            x1 = (x(i-1) + x(i)) /2.
         end if
         if (i .eq. n) then
            x2 = x(i)
         else
            x2 = (x(i) + x(i+1)) /2.
         end if
c boundaries in pixel coords
         r1 = (x1-x0)/dx
         r2 = (x2-x0)/dx
c compute what lin bin the cell boundaries fall in
         j1 = int(r1+0.5)
         j2 = int(r2+0.5)
c just trimming to the min/max is not ideal but leave it for now
         j1 = min(max(j1,1),nout)
         j2 = min(max(j2,1),nout)
         frac1 = r1 - (j1-0.5)
         frac2 = r2 - (j2-0.5)
c We have to keep track of both how much of the old pixel to
c put in each new bin, e.g. (1-frac1)/(r2-r1) for the first new pixel;
c and how much of each new pixel is being covered, this is weight(j)
c
c first handle the special case if the boundaries are
c in the same bin
         if (j1 .eq. j2) then
            yout(j1) = yout(j1) + y(i)
            weight(j1) = weight(j1) + (frac2-frac1)
            go to 200
         end if
c Do the first, fractional pixel
         yout(j1) = yout(j1) + y(i) * (1.-frac1) / (r2-r1)
         weight(j1) = weight(j1) + (1.-frac1)
c Loop through the whole pixels
         do j=j1+1,j2-1
            yout(j)  = yout(j) + y(i) / (r2-r1)
            weight(j) = weight(j) + 1.
         end do
c Do the last, fractional pixel
         yout(j2) = yout(j2) + y(i) * frac2 / (r2-r1)
         weight(j2) = weight(j2) + frac2

 200     continue
      end do

c  conserve counts (photons) so don't use the weight to normalize

c  Hopefully most of the time we will have covered all of the new
c  pixel so weight(j) will be 1.0 (within roundoff).  However if
c  a bad old pixel was mapped onto part of the new pixel, weight(j)
c  will be less than 1 and yout(j) will be lower than it ought to be.

      do j=2,nout-1
         if(weight(j) .gt. 1.001) then
c            write(*,*) "Weight problem ",j,x0+j*dx,weight(j),yout(j)
         else if (weight(j) .gt. 0.1) then
            yout(j) = yout(j) * 1.0 / weight(j)
         else
c            write(*,*) "Weight problem ",j,x0+j*dx,weight(j),yout(j)
            yout(j) = badset
         end if
      end do

      return
      end


       subroutine derx_BC(q3, q4)

!----------------------------------------------------------- !
!               F. Califano, 2006                            !
!  First x-derivative by FFT (periodic boundary conditions)  !
!----------------------------------------------------------- !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!  3D PARALLEL VERSION: FAGANELLO 2010
!**************************************************

use parameter_mod
use box_mod
use deriv_mod
use dom_distr_mod
use parallel_mod

IMPLICIT NONE

! *************N.B. ny = nyl*****************************

REAL(dp) :: frac
REAL(dp),DIMENSION (nxl,nyl,nzl) :: q3 !!!!!!!!!!!!!! con o senza l vari ???????????????????????????????????
REAL(dp),DIMENSION (2,nyl,nzl) :: q4 !!!!!!!!!!!!!!!!!!! con o senza l vari ????????????????????????????????

!integer :: ix
!do ix = 1, 5
!q3(ix,:) = exp(x(ix))
!enddo
!do ix = nx4, nx
! q3(ix,:) = exp(x(ix))
!enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     Derivata al bordo sx calcolata con i soli punti interni            !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

frac = 1.0d0 / ( 12.0d0 * dx )

     q4(1,:,:) = (- 25.0d0 * q3(1,:,:) + 48.0d0 * q3(2,:,:) - 36.0d0  * q3(3,:,:) &
                + 16.0d0 * q3(4,:,:) - 3.0d0 * q3(5,:,:) ) * frac

     q4(2,:,:) = ( 25.0d0 * q3(nxl,:,:) - 48.0d0 * q3(nxlm1,:,:) + 36.0d0 &
               * q3(nxlm2,:,:) - 16.0d0 * q3(nxlm3,:,:) + &
                       3.0d0 * q3(nxlm4,:,:) ) * frac

!write(*,*), 'derivata numerica'
!write(*,*), q4(1,1)
!write(*,*), 'valore analitico'
!write(*,*), exp(x(1))

!write(*,*), 'derivata numerica'
!write(*,*), q4(2,1)
!write(*,*), 'valore analitico'
!write(*,*), exp(x(nx))
!stop

end subroutine


      function diskdf3ez(ep,am,ez)
      parameter (pi=3.1415926535)
      real psi00

      psi00 = pot(0.0,0.0)
      rc=rcirc(am)
      call omekap(rc,fomega,fkappa)
      vc=rc*fomega
c
      ec = - pot(rc,0.0)+0.5*vc**2
c
      if (am.lt.0.) ec = - 2.0*psi00 - ec
      sr2=sigr2(rc)
      sz2=sigz2(rc)

      if (sz2.gt.0.) then
         fvert=fnamidden(rc)*exp(-ez/sz2)/sqrt(2*pi*sz2)
         diskdf3ez=fomega/(pi*fkappa)/sr2*exp(-(ep - ec)/sr2)*fvert
      else
         diskdf3ez=0
      endif

      return
      end


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompGibbsMagneticSoln.f90
    !> \brief   Compute magnetic contributions to the Gibbs energy terms for a solution phase.
    !> \author  M.H.A. Piro
    !> \date    March 7, 2013
    !> \sa      CompExcessGibbsEnergy.f90
    !
    !
    !
    ! Revisions:
    ! ==========
    !
    !    Date          Programmer        Description of change
    !    ----          ----------        ---------------------
    !    03/07/2013    M.H.A. Piro       Original code
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the magnetic contribution to the standard molar
    !! Gibbs energy of a solution species.  This contribution is given by
    !! \f$ \Delta g_{mag} = RT ln(B_o + 1) g(\tau ) \f$, where \f$ B_o \f$ is the average magnetic moment per
    !! atom, \f$ \tau \f$  is the absolute temperature divided by the critical temperature (i.e., the Curie
    !! temperature for ferromagnetic materials or the Neel temperature for antiferromagnetic materials) and
    !! \f$ g \f$ is a function of \f$ \tau \f$, given by:
    !! \f$ g(\tau ) = 1 - \left( \frac{79\tau^-1}{140p} + \frac{474}{497}(\frac{1}{p} - 1)(\frac{\tau ^3}{6}
    !!   + \frac{\tau ^9}{135} \frac{\tau ^15}{600}   )  \right) /D, \tau \leq 1 \f$
    !! and \f$ g(\tau ) = - \left( \frac{\tau ^{-5}}{10} + \frac{\tau ^{-15}}{315} + \frac{\tau ^{-25}}{1500}
    !!   \right) /D, \tau > 1 \f$, where \f$ D = \frac{518}{1125} + \frac{11692}{15975} \left( \frac{1}{p} -1
    !!   \right) \f$.
    !!
    !
    ! References:
    ! ===========
    !
    !> \details The following references explain the magnetic contribution to the Gibbs energy term that is
    !! used in this subroutine:
    !!
    !!   M. Hillert and M. Jarl, "A Model for Alloying Effects in Ferromagnetic Alloys," CALPHAD, 2, 3
    !!   (1978) 227-238.
    !!
    !!   A.T. Dinsdale, "SGTE Data for Pure Elements," CALPHAD, 15, 4 (1991) 317-425.
    !!
    !!   H.L. Lukas, S.G. Fries and B. Sundman, "Computational Thermodynamics: The Calphad Method," Cambridge
    !!   University Press, New York (2007).
    !!
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in]   iSolnPhaseIndex   An integer scalar representing the absolute solution phase index.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompGibbsMagneticSoln(iSolnPhaseIndex)

    USE ModuleThermo
    USE ModuleThermoIO

    implicit none

    integer :: i, j, iFirst, iLast, iSolnPhaseIndex, iExponent, iParam
    integer :: k, m, n, s, c, sd, KD, l
    integer :: nSublattice, iChargedPhaseID
    integer :: iFirstParam, iSecondParam, iSubParam
    real(8) :: B, D, p, invpmone, tau, Tcritical, g, StructureFactor
    real(8) :: dTemp, dTempA, dTempB, dTempC, dTempD, dTempCoeff1, dTempCoeff2
    real(8) :: x1, x2, dx, xprod, dxvmo, dPreFactor
    logical :: lTn, lBn

    ! Initialize variables:
    Tcritical = 0D0
    B         = 0D0

    ! Store the first and last species indices:
    iFirst = nSpeciesPhase(iSolnPhaseIndex-1) + 1
    iLast  = nSpeciesPhase(iSolnPhaseIndex)

    ! Note: the structure factor and p factor are the same for all constituents in the phase.
    StructureFactor = dCoeffGibbsMagnetic(iFirst,3)
    p               = dCoeffGibbsMagnetic(iFirst,4)
    invpmone        = 1D0/p - 1D0

    call CompMagneticTemperatureMoment(iSolnPhaseIndex,Tcritical,B)

    ! ChemSage files store the critical temperature for antiferromagnetic materials
    ! (i.e., the Neel temperature) as a negative real value divided by the structure factor.
    lBn = .FALSE.
    lTn = .FALSE.
    if (B < 0D0) then
        lBn = .TRUE.
        B         = -B * StructureFactor
    end if
    if (Tcritical < 0D0) then
        lTn = .TRUE.
        Tcritical = -Tcritical * StructureFactor
    end if

    ! Only proceed if the critical temperature is not zero:
    IF_Proceed: if (Tcritical /= 0D0) then

        ! Compute model parameters:
        tau = dTemperature / Tcritical
        D   = (518D0/1125D0) + (11692D0/15975D0) * invpmone

        ! The magnetic model of Hillert and Jarl is empirical and depends on tau:
        IF_Tau: if (tau > 1D0) then
            dTempA = tau**(-5)                  ! tau^(-5)
            dTempB = dTempA**(3)                ! tau^(-15)
            dTempC = dTempA * dTempA * dTempB   ! tau^(-25)
            dTempD = (1D0 / (D * Tcritical)) * (dTempA / 2D0 + dTempB / 21D0 + dTempC / 60D0)
            g      = -(dTempA/10D0 + dTempB/315D0 + dTempC/1500D0) / D
        else
            dTempA = tau**(3)                   ! tau^(3)
            dTempB = dTempA**(3)                ! tau^(9)
            dTempC = dTempA * dTempA * dTempB   ! tau^(15)
            dTempD = (-79D0 / (140D0 * p * dTemperature))
            dTempD = dTempD + (474D0/(497D0*Tcritical)) * invpmone * (dTempA / 2D0 + dTempB / 15D0 + dTempC / 40D0)
            dTempD = dTempD / D
            g      = 1D0 - (79D0/(140D0*p*tau) + (474D0/497D0)*invpmone*(dTempA/6D0 + dTempB/135D0 + dTempC/600D0)) / D
        end if IF_Tau

        ! Loop through species in this phase and update the chemical potential:
        do i = iFirst, iLast
            dTempCoeff1 = dCoeffGibbsMagnetic(i,1)
            dTempCoeff2 = dCoeffGibbsMagnetic(i,2)
            if (lTn) then
                dTempCoeff1 = -dTempCoeff1 * StructureFactor
            end if
            if (lBn) then
                dTempCoeff2 = -dTempCoeff2 * StructureFactor
            end if
            dTemp = -(Tcritical - dTempCoeff1) * dTempD
            dTemp = g * ((dTempCoeff2 - B) / (1D0 + B)) + DLOG(1D0 + B) * (dTemp + g)
            if (cSolnPhaseType(iSolnPhaseIndex) == 'RKMPM') then
                dMagGibbsEnergy(i) = dTemp
            else if (cSolnPhaseType(iSolnPhaseIndex) == 'SUBLM') then
                m = i - iFirst + 1
                iChargedPhaseID = iPhaseSublattice(iSolnPhaseIndex)
                nSublattice     = nSublatticePhase(iChargedPhaseID)
                do j = iFirst, iLast
                    ! Relative species index:
                    n = j - iFirst + 1

                    ! Compute pre-factor term:
                    dPreFactor = 1D0 - DFLOAT(nSublattice)

                    ! Loop through sublattices:
                    do s = 1, nSublattice
                        ! Store constituent indices:
                        k = iConstituentSublattice(iChargedPhaseID,s,m)
                        l = iConstituentSublattice(iChargedPhaseID,s,n)

                        ! Effectively apply Kronecker-Delta term to pre-factor:
                        if (k == l)  dPreFactor = dPreFactor + 1D0 / dSiteFraction(iChargedPhaseID,s,k)
                    end do

                    ! Update the reference molar Gibbs energy:
                    ! print *, cSpeciesName(i), cSpeciesName(j), dPreFactor, dTemp
                    dMagGibbsEnergy(j) = dMagGibbsEnergy(j) + dPreFactor * dMolFraction(i) * dTemp
                end do

            end if
        end do

        LOOP_Param: do iParam = nMagParamPhase(iSolnPhaseIndex-1)+1, nMagParamPhase(iSolnPhaseIndex)
            dTempCoeff1 = dMagneticParam(iParam,1)
            dTempCoeff2 = dMagneticParam(iParam,2)
            if (lTn) then
                dTempCoeff1 = -dTempCoeff1 * StructureFactor
            end if
            if (lBn) then
                dTempCoeff2 = -dTempCoeff2 * StructureFactor
            end if
            dTemp = -(-dTempCoeff1) * dTempD
            dTemp = g * ((dTempCoeff2) / (1D0 + B)) + DLOG(1D0 + B) * (dTemp)
            if (cSolnPhaseType(iSolnPhaseIndex) == 'RKMPM') then
                ! Compute temporary variables for sake of convenience:
                if (iMagneticParam(iParam,1) == 2) then
                    ! Binary parameter:
                    x1    = dMolFraction(iFirst + iMagneticParam(iParam,2) - 1)
                    x2    = dMolFraction(iFirst + iMagneticParam(iParam,3) - 1)
                    iExponent = iMagneticParam(iParam,4)
                    xprod = x1 * x2
                    dx    = x1 - x2
                    dxvmo     = dx**(iExponent-1)
                    dxvmo     = DMIN1(dxvmo,1D30)
                    ! Cycle if dx = 0 to prevent calculating either an INF or a NAN:
                    if (dx == 0D0) cycle LOOP_Param
                    do i = iFirst, iLast
                        j = i - iFirst + 1
                        if (j == iMagneticParam(iParam,2)) then
                            ! First species of parameter.
                            dMagGibbsEnergy(i) = dMagGibbsEnergy(i) + dTemp * &
                                dxvmo * ((x2 - xprod)*dx + DFLOAT(iExponent)*xprod*(1D0 - dx))

                        elseif (j == iMagneticParam(iParam,3)) then
                            ! Second species of parameter.
                            dMagGibbsEnergy(i) = dMagGibbsEnergy(i) + dTemp * &
                                dxvmo * ((x1 - xprod)*dx - DFLOAT(iExponent)*xprod*(1D0 + dx))
                        else
                            ! This species does not belong to the parameter.
                            dMagGibbsEnergy(i) = dMagGibbsEnergy(i) - dTemp * &
                                (dx**(iExponent)) * xprod * (1D0 + DFLOAT(iExponent))
                        end if

                    end do
                else
                    ! The parameter index is not supported/recognized.  Report an error and exit.
                    INFOThermo = 43
                    exit LOOP_Param
                end if
            else if (cSolnPhaseType(iSolnPhaseIndex) == 'SUBLM') then
                iChargedPhaseID = iPhaseSublattice(iSolnPhaseIndex)
                nSublattice     = nSublatticePhase(iChargedPhaseID)
                ! Reinitialize temporary variable:
                dPreFactor = 1D0

                ! Store the number of constituents involved in this parameter:
                n = iMagneticParam(iParam,1)
                iExponent = iMagneticParam(iParam,n+2)

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1

                    ! Determine constituent and sublattice indices:
                    c = MOD(iMagneticParam(iParam,k), 10000)
                    s = iMagneticParam(iParam,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iChargedPhaseID,s,c)

                    ! Store the first and second site fractions:
                    ! This assumes that the constituents that are mixing are the first two listed:
                    if (k == 2) then
                        x1 = dSiteFraction(iChargedPhaseID,s,c)
                        iFirstParam = c
                        iSubParam   = s
                    elseif (k == 3) then
                        x2 = dSiteFraction(iChargedPhaseID,s,c)
                        iSecondParam = c
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                dPreFactor = dPreFactor * dTemp * (x1 - x2)**iExponent

                LOOP_Param_Species: do i = iFirst, iLast
                    ! Reinitialize variables:
                    KD    = 0
                    m     = i - iFirst + 1
                    dTemp = -DFLOAT(nSublattice + iMagneticParam(iParam,n+2))

                    ! Loop through sublattices associated with this phase:
                    LOOP_Param_Sub: do s = 1, nSublattice
                        ! Store constituent index corresponding to component i on sublattice s:
                        c = iConstituentSublattice(iChargedPhaseID,s,m)

                        ! Assign Kronecker-Delta term if this component contains the constituent corresponding
                        ! to the mixing parameter:
                        if (s == iSubParam) then
                            if (c == iFirstParam) then
                                ! This is the first mixing constituent:
                                KD = 1
                            elseif (c == iSecondParam) then
                                ! This is the second mixing constituent:
                                KD = -1
                            else
                                ! The constituents don't match:
                                KD = 0
                            end if
                        end if

                        ! Loop through constituents involved in this mixing parameter:
                        LOOP_Param_Const: do j = 2, n + 1
                            k = MOD(iMagneticParam(iParam,j), 10000)  ! Constituent index corresponding to parameter.
                            sd = iMagneticParam(iParam,j) - k
                            sd = sd / 10000                       ! Sublattice index corresponding to parameter.

                            ! Cycle if they are on different sublattices:
                            if (sd /= s) cycle LOOP_Param_Const

                            ! Cycle if they are different constituents:
                            if (k /= c) cycle LOOP_Param_Const

                            ! Include contribution from this site fraction:
                            dTemp = dTemp + 1D0 / dSiteFraction(iChargedPhaseID,s,c)

                        end do LOOP_Param_Const ! j
                    end do LOOP_Param_Sub       ! s

                    ! Apply higher order terms (only if x1 and x2 are not the same):
                    if (x1 /= x2) then
                        dTemp = dTemp + DFLOAT(KD * iMagneticParam(iParam,n+2)) / (x1 - x2)
                    end if

                    ! Apply partial molar excess Gibbs energy of mixing:
                    dMagGibbsEnergy(i) = dMagGibbsEnergy(i) + dPreFactor * dTemp

                end do LOOP_Param_Species       ! i
            end if
        end do LOOP_Param

    end if IF_Proceed

    return

end subroutine CompGibbsMagneticSoln


!! use parallel minres method to solve large scale sparse linear system,
!! Ax = b or (A-sI)x = b, where s can be any number
subroutine pminres_csr(nblock, end_indx, needed, nloc, ham, b_vec, x_vec, info)
    use m_constants, only: dp, zero, czero, cone, mystd
    use m_control,   only: linsys_tol, linsys_max, nprocs, myid, master
    use m_types
    use mpi

    implicit none

    ! external variables
    integer, intent(in)       :: nblock
    integer, intent(in)       :: end_indx(2,2,nprocs)
    integer, intent(in)       :: needed(nprocs,nprocs)
    integer, intent(in)       :: nloc
    type (T_csr)              :: ham(nblock)
    complex(dp), intent(in)   :: b_vec(nloc)
    complex(dp), intent(out)  :: x_vec(nloc)
    integer, intent(out)      :: info

    ! local variables
    integer  :: curr, prev, tmp_indx, ierror
    integer  :: iter
    real(dp) :: beta0, beta1
    real(dp) :: beta0_mpi, beta1_mpi
    complex(dp) :: sigma0, sigma1
    complex(dp) :: gamma0, gamma1
    complex(dp) :: eta
    complex(dp) :: delta
    complex(dp) :: res
    complex(dp) :: alpha, alpha_mpi
    complex(dp) :: rho1
    complex(dp) :: rho2
    complex(dp) :: rho3

    complex(dp), allocatable :: v_vec(:,:)
    complex(dp), allocatable :: w_vec(:,:)
    complex(dp), allocatable :: tmp_vec(:)

    info = 0

    allocate(v_vec(nloc,2))
    allocate(w_vec(nloc,2))
    allocate(tmp_vec(nloc))

    x_vec = czero
    v_vec = czero
    w_vec = czero
    tmp_vec = czero
    sigma0 = czero
    sigma1 = czero
    gamma0 = cone
    gamma1 = cone
    beta0 = zero
    beta1 = zero
    beta0_mpi = zero
    beta1_mpi = zero
    alpha = czero
    alpha_mpi = czero
    rho1 = czero
    rho2 = czero
    rho3 = czero
    delta = czero

    curr = 1
    prev = 2

    v_vec(:,curr) = b_vec
    beta0 = real(dot_product(v_vec(:,curr), v_vec(:,curr)))
    call MPI_ALLREDUCE(beta0, beta0_mpi, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierror)
    beta0 = sqrt(beta0_mpi)
    eta = beta0
    res = beta0

    iter = 0
    do while (abs(res) > linsys_tol .and. iter < linsys_max )
        iter = iter + 1
        if (myid==master .and. mod(iter,10) == 0 ) then
            write(mystd,"(a25, i5, E10.2, a5, E10.2)")  "PMINRES iteration:  ", iter, abs(res), "-->", linsys_tol
        endif
        v_vec(:,curr) = v_vec(:,curr) / beta0
        tmp_vec = czero
        call pspmv_csr(MPI_COMM_WORLD, nblock, end_indx, needed, nloc, nloc, ham, v_vec(:,curr), tmp_vec)
        alpha = dot_product(v_vec(:,curr), tmp_vec)
        call MPI_ALLREDUCE(alpha, alpha_mpi, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
        alpha = alpha_mpi
        v_vec(:,prev) = tmp_vec - alpha * v_vec(:,curr) - beta0 * v_vec(:,prev)
        beta1 = real(dot_product(v_vec(:,prev), v_vec(:,prev)))
        call MPI_ALLREDUCE(beta1, beta1_mpi, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierror)
        beta1 = sqrt(beta1_mpi)

        delta = gamma0 * alpha - gamma1 * sigma0 * beta0
        rho1 = sqrt(delta*delta + beta1*beta1)
        rho2 = sigma0 * alpha + gamma1 * gamma0 * beta0
        rho3 = sigma1 * beta0

        gamma1 = gamma0
        sigma1 = sigma0
        gamma0 = delta / rho1
        sigma0 = beta1 / rho1

        w_vec(:,prev) = (v_vec(:,curr) - rho3 * w_vec(:,prev) - rho2 * w_vec(:,curr))/rho1
        x_vec = x_vec + gamma0 * eta * w_vec(:,prev)

        res = abs(sigma0) * res
        eta = -sigma0 * eta

        beta0 = beta1
        tmp_indx = curr
        curr = prev
        prev = tmp_indx
    enddo
    if (myid==master) then
        write(mystd,"(a25, i5, E10.2, a5, E10.2)")  "PMINRES iteration:  ", iter, abs(res), "-->", linsys_tol
    endif
    ! test the precision
    tmp_vec = czero
    call pspmv_csr(MPI_COMM_WORLD, nblock, end_indx, needed, nloc, nloc, ham, x_vec, tmp_vec)
    tmp_vec = tmp_vec - b_vec
    alpha = dot_product(tmp_vec, tmp_vec)
    call MPI_ALLREDUCE(alpha, alpha_mpi, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
    alpha = alpha_mpi
    if (myid==master) then
        write(mystd,"(a34, E10.2)")  "Final precision of |H*x-b|:  ", sqrt(abs(alpha))
    endif

    return
end subroutine pminres_csr


	real x (100), y (100), z (100)

	x (1) = -1.9
	y (1) = sin (x (1))
	z (1) = cos (x (1)) * 1.5
	do 5 i=2,90
		x (i) = x (i-1) + 0.1
		y (i) = sin (x (i))
		z (i) = cos (x (i)) * 1.5
   5            continue
c       call setmtf ('sample.mtf', 10)
	call setpen (2)
	call page (15., 20., 'PAGE', 4, 1)
	call setpen (3)
	call limits (-2., 7., -1.5, 1.5)
	call region (3., 3., 10., 15., 'REGION', 6, 1)
	call setpen (6)
	call axes ('X axis', 6, 1., 5, 'Y axis', 6, 0.3, 4, 0)
	call setpen (5)
	call linemo (x, y, 85, 2, 10)
	call broken (0.5, 0.2, 0.3, 0.2)
	call brline (x, z, 85)
	call endpg (0)
	end


!@brief Module considers arrays to caclculate vels
!!   $$\textbf{u} = 2 \sum_{m=1}^M Ac_m cos(\textbf(B_m}\cdot \textbf{x} + C_m) $$
!!
!! here we define angle `dphi_m` = $\phi_m = \textbf(B_m}\cdot \textbf{x} + C_m$
!!
module tmp_mod
  USE prec_mod
  implicit none
  integer :: nmodes                                   !< number of Modes
  integer :: ntimes                                   !< number of timesteps
  integer :: nkmod                                   !< number of overall modes
  real(prec), dimension(:,:), allocatable :: ac_m     !< coefficient amplitude with COS
  real(prec), dimension(:,:), allocatable :: as_m     !< coefficient amplitude with SIN
  real(prec), dimension(:,:), allocatable :: b_m      !< coefficient vector K inside SIN and COS
  real(prec), dimension(:), allocatable :: c_m        !< random numbers inside SIN and COS
  real(prec), dimension(:,:), allocatable :: dphi_m   !< calculated angle for SIN and COS
  real(prec), dimension(:), allocatable :: cs_m       !< Internal temporary coefficient
  real(prec), dimension(:), allocatable :: cos_m       !< Internal temporary coefficient
  real(prec), dimension(:), allocatable :: sin_m       !< Internal temporary coefficient

  !-----

  integer :: nx !< number of elements by X-coordinate
  integer :: ny !< number of elements by Y-coordinate
  integer :: nz !< number of elements by Z-coordinate
  !  Use temporary variables for coordinates and velocities in cells
  integer :: tcell                                    !< number of cells
  ! real(prec), dimension(:,:), allocatable :: xp       !< Cell Cartesian coordinates
  ! real(prec), dimension(:,:), allocatable :: u        !< velocities in Cells
  integer :: in_time                                  !< Current timestep. Used in ge_flow
  real(prec), dimension(:), allocatable :: dtim       !< times in array of timesteps

  !-----
  ! Set variables for correlation dependencies
  real(prec), dimension(:), allocatable :: dRtime       !< Vector of correlation by time
  real(prec), dimension(:), allocatable :: dRlong       !< Longitudal Vector of correlation
  real(prec), dimension(:), allocatable :: dRtang       !< Tangential Vector of correlation
end module tmp_mod