#include "Definitions.INC"

module newpulsesubmod
contains

  ! function [aField,eField,dField] = GetField(calcTimes,fieldStrength,omega,duration,phaseShift,doplot,ENV_PWR)

  subroutine NewField(aField,eField,calcTime,omega,duration,phaseShift,envdernum,envpwr)
    use fileptrmod
    implicit none
    real*8, intent(in) :: calcTime, omega, duration, phaseShift
    integer, intent(in) :: envdernum, envpwr
    real*8, intent(out) :: aField,eField
    real*8 :: nothing1, nothing2, nothing3

    if (envdernum == 0) then
       call FieldFunction(calcTime,omega,duration,phaseShift,envpwr,nothing1,aField,eField,nothing2,nothing3)
       aField = aField / omega
       eField = eField / omega
    elseif (envdernum == 1) then
       call FieldFunction(calcTime,omega,duration,phaseShift,envpwr,nothing1,nothing2,aField,eField,nothing3)
       aField = aField / omega**2
       eField = eField / omega**2
    elseif (envdernum == 2) then
       call FieldFunction(calcTime,omega,duration,phaseShift,envpwr,nothing1,nothing2,nothing3,aField,eField)
       aField = aField / omega**3
       eField = eField / omega**3
    else
       OFLWR "envdernum Not supported ", envdernum; CFLST
    endif

    ! fac = sqrt(2*pi*fieldStrength) / omega / sqrt(duration);

    ! aField = aField * fac ;
    ! eField = eField * fac ;

  end subroutine NewField

  subroutine FieldFunction(intime,omega,duration,phaseShift,N,y,yp,ypp,yp3,yp4)
    use constant_parameters
    implicit none
    real*8, intent(in) :: intime,omega,duration,phaseShift
    integer, intent(in) :: N
    real*8, intent(out) :: y,yp,ypp,yp3,yp4
    real*8 :: O, funt, dfunt, ddfunt, d3funt, d4funt, env, denv, ddenv, d3env, d4env
    real*8 :: env0, denv0, ddenv0, d3env0, d4env0
    real*8 :: t

    t = intime;

    O = pi/duration;

    y = 0;
    yp = 0;
    ypp = 0;
    yp3 = 0;
    yp4 = 0;

    if (t<=0 .or. t>=duration) then
       return;
    endif

    ! NOW CENTERED
    t = t - duration / 2;

    !    fun   = @sin;
    !    dfun  = @(x) cos(x);
    !    ddfun = @(x) -sin(x);
    !    d3fun = @(x) -cos(x);
    !    d4fun = @(x) sin(x);
    !
    !    funt = fun(omega*t+phaseShift);
    !    dfunt = omega * dfun(omega*t+phaseShift);
    !    ddfunt = omega**2 * ddfun(omega*t+phaseShift);
    !    d3funt = omega**3 * d3fun(omega*t+phaseShift);
    !    d4funt = omega**4 * d4fun(omega*t+phaseShift);

    funt = sin(omega*t+phaseShift);
    dfunt = omega * cos(omega*t+phaseShift);
    ddfunt = -omega**2 * sin(omega*t+phaseShift);
    d3funt = -omega**3 * cos(omega*t+phaseShift);
    d4funt = omega**4 * sin(omega*t+phaseShift);

    if (1 == 0) then

       ! %$$ N = 3;   % N=3 is minimal value ensuring E is zero at t=0.
       ! %$$          % with N=3, d/dt E is not zero at t=0.

       ! N = 5;

       env = cos(O*t)**N;
       denv = -O * N * cos(O*t)**(N-1) * sin(O*t);
       ddenv =   &
            O**2 * N * (N-1) * cos(O*t)**(N-2) * sin(O*t)**2 &
            - O**2 * N * cos(O*t)**N ;

       ! - O**2 * N * cos(O*t)**(N-1) * cos(O*t) ;

       d3env =   &
            - O**3 * N * (N-1) * (N-2) * cos(O*t)**(N-3) * sin(O*t)**3 &
            + O**3 * N * (3*N-2)       * cos(O*t)**(N-1) * sin(O*t) ;

       ! + O**3 * N * (N-1) * 2     * cos(O*t)**(N-1) * sin(O*t) &
       ! + O**3 * N**2               * cos(O*t)**(N-1) * sin(O*t) ;

       d4env =   &
            + O**4 * N * (N-1) * (N-2) * (N-3) * cos(O*t)**(N-4) * sin(O*t)**4 &
            - O**4 * N * (N-1) * (6*N-8)   * cos(O*t)**(N-2) * sin(O*t)**2 &
            + O**4 * N * (3*N-2)           * cos(O*t)**N  ;

       ! - O**4 * N * (N-1) * (N-2) * 3 * cos(O*t)**(N-2) * sin(O*t)**2 &
       ! - O**4 * N * (N-1) * (3*N-2)   * cos(O*t)**(N-2) * sin(O*t)**2 ;

    else

       ! N = 3;

       env0     = 1-(O*2/pi)**2*t**2;
       denv0    = -2*(O*2/pi)**2*t;
       ddenv0   = -2*(O*2/pi)**2*(t*0+1);
       d3env0   = t*0;
       d4env0   = t*0;

       env     = env0**N;
       denv    = N * env0**(N-1) * denv0;
       ddenv   = N * (N-1) * env0**(N-2) * denv0**2 + N * env0**(N-1) * ddenv0;

       !d3env   = N * (N-1) * (N-2) * env0**(N-3) * denv0**3 &
       !     + 2 * N * (N-1) * env0**(N-2) * denv0 * ddenv0 &
       !     +     N * (N-1) * env0**(N-2) * denv0 * ddenv0 &
       !     + N * env0**(N-1) * d3env0;

       d3env   = N * (N-1) * (N-2) * env0**(N-3) * denv0**3 &
            + 3 * N * (N-1) * env0**(N-2) * denv0 * ddenv0 &
            + N * env0**(N-1) * d3env0;

       !d4env   = N * (N-1) * (N-2) * (N-3) * env0**(N-4) * denv0**4 &
       !     + 3 * N * (N-1) * (N-2) * env0**(N-3) * ddenv0 * denv0**2 &
       !     + 3 * N * (N-1) * (N-2) * env0**(N-3) * denv0**2 * ddenv0 &
       !     + 3 * N * (N-1) * env0**(N-2) * ddenv0**2 &
       !     + 3 * N * (N-1) * env0**(N-2) * denv0 * d3env0 &
       !     + N * (N-1) * env0**(N-2) * denv0 * d3env0 &
       !     + N * env0**(N-1) * d4env0;

       d4env   = N * (N-1) * (N-2) * (N-3) * env0**(N-4) * denv0**4 &
            + 6 * N * (N-1) * (N-2) * env0**(N-3) * denv0**2 * ddenv0 &
            + N * (N-1) * env0**(N-2) * ( 3 * ddenv0**2 + 3 * denv0 * d3env0  + denv0 * d3env0 ) &
            + N * env0**(N-1) * d4env0;

    end if

    y = &
         env * funt ;

    yp = &
         denv * funt + &
         env * dfunt ;

    ypp = &
         ddenv    * funt + &
         2 * denv * dfunt + &
         env      * ddfunt ;

    yp3 = &
         d3env     * funt + &
         3 * ddenv * dfunt + &
         3 * denv  * ddfunt + &
         env       * d3funt ;

    yp4 = &
         d4env     * funt + &
         4 * d3env * dfunt + &
         6 * ddenv * ddfunt + &
         4 * denv  * d3funt + &
         env       * d4funt ;

  end subroutine FieldFunction

end module newpulsesubmod

module pulsesubmod
contains

subroutine vectdpot(myintime,invelflag,tdpotsout,imc)
  use pulse_parameters
  implicit none
  real*8,intent(in) :: myintime
  integer, intent(in) :: invelflag,imc
  DATATYPE,intent(out) :: tdpotsout(3)

  call vectdpot0(myintime,invelflag,tdpotsout,imc,1,numpulses)

end subroutine vectdpot

subroutine vectdpot0(myintime,invelflag,tdpotsout,imc,ilow,ihigh)
  use pulse_parameters
  use fileptrmod
  implicit none
  integer, intent(in) :: invelflag,imc,ilow,ihigh
  real*8,intent(in) :: myintime
  DATATYPE,intent(out) :: tdpotsout(3)

  if (invelflag.eq.0) then
     tdpotsout(1)=tdpotlen0(myintime,1,ilow,ihigh)
     tdpotsout(2)=tdpotlen0(myintime,2,ilow,ihigh)
     tdpotsout(3)=tdpotlen0(myintime,3,ilow,ihigh)
  else
     tdpotsout(1)=tdpotvel0(myintime,1,ilow,ihigh)
     tdpotsout(2)=tdpotvel0(myintime,2,ilow,ihigh)
     tdpotsout(3)=tdpotvel0(myintime,3,ilow,ihigh)
  endif

!  if (conjgpropflag.ne.0) then
!     select case (imc)
!     case(-1)
!        tdpotsout(:)=real(tdpotsout(:),8)
!     case(1)
!     case(2)
!        tdpotsout(:)=ALLCON(tdpotsout(:))
!     case default
!        OFLWR "WHOOPS?? conjgprop",imc; CFLST
!     end select
!  endif

end subroutine vectdpot0

function tdpotlen0(myintime, which,ilow,ihigh)
  use pulse_parameters
  use fileptrmod
  implicit none
  integer,intent(in) :: which,ilow,ihigh
  real*8,intent(in) :: myintime
  integer :: ipulse
  real*8 :: fac
  DATATYPE :: tdpotlen0

  tdpotlen0=0.d0

!!  do ipulse=1,numpulses

  do ipulse=ilow,ihigh

     if (which==3) then !! z component
        fac=cos(pulsetheta(ipulse))
     else if (which==1) then
        fac=sin(pulsetheta(ipulse))*cos(pulsephi(ipulse))
     else if (which==2) then
        fac=sin(pulsetheta(ipulse))*sin(pulsephi(ipulse))
     else
        OFLWR "ACK which = ",which," not allowed tdpotlen0"; CFLST
        fac=798d0   !! avoid warn unused
     endif

     if (fac.ne.0d0) then
        select case (pulsetype(ipulse))
        case (1)
           tdpotlen0=tdpotlen0+simplepulselen(myintime,ipulse) * fac
        case (2)
           tdpotlen0=tdpotlen0+pulselen(myintime,ipulse) * fac
        !$$  case (3)
        !$$     tdpotlen0=tdpotlen0+longpulselen(myintime,ipulse) * fac
        !$$  case (4)
        !$$     tdpotlen0=tdpotlen0+cwpulselen(myintime,ipulse) * fac
        !$$  case (5)
        !$$    tdpotlen0=tdpotlen0+monopulselen(myintime,ipulse) * fac
        case (6)
           tdpotlen0=tdpotlen0+newpulselen(myintime,ipulse) * fac
        case (7)
           tdpotlen0=tdpotlen0+threepulselen(myintime,ipulse) * fac
        case default
           OFLWR "Pulse type not supported: ", pulsetype(ipulse); CFLST
        end select
     endif
  enddo

end function tdpotlen0

function tdpotvel0(myintime,which,ilow,ihigh)
  use pulse_parameters
  use fileptrmod
  implicit none
  integer,intent(in) :: which,ilow,ihigh
  real*8,intent(in) :: myintime
  integer :: ipulse
  real*8 :: fac
  DATATYPE :: tdpotvel0

  tdpotvel0=0.d0

!!  do ipulse=1,numpulses

  do ipulse=ilow,ihigh

     if (which==3) then !! z component
        fac=cos(pulsetheta(ipulse))
     else if (which==1) then
        fac=sin(pulsetheta(ipulse))*cos(pulsephi(ipulse))
     else if (which==2) then
        fac=sin(pulsetheta(ipulse))*sin(pulsephi(ipulse))
     else
        OFLWR "ACK which = ",which," not allowed tdpotvel0"; CFLST
        fac=798d0   !! avoid warn unused
     endif

     if (fac.ne.0d0) then
        select case (pulsetype(ipulse))
        case (1)
           tdpotvel0=tdpotvel0+simplepulsevel(myintime, ipulse) * fac
        case (2)
           tdpotvel0=tdpotvel0+pulsevel(myintime, ipulse) * fac
        !$$  case (3)
        !$$     tdpotvel0=tdpotvel0+longpulsevel(myintime, ipulse) * fac
        !$$  case (4)
        !$$     tdpotvel0=tdpotvel0+cwpulsevel(myintime, ipulse) * fac
        !$$  case (5)
        !$$     tdpotvel0=tdpotvel0+monopulsevel(myintime, ipulse) * fac
        case (6)
           tdpotvel0=tdpotvel0+newpulsevel(myintime, ipulse) * fac
        case (7)
           tdpotvel0=tdpotvel0+threepulsevel(myintime, ipulse) * fac
        case default
           OFLWR "Pulse type not supported: ", pulsetype(ipulse); CFLST
        end select
     endif
  enddo

end function tdpotvel0

function newpulselen(myintime, ipulse)
  use pulse_parameters
  use constant_parameters
  use newpulsesubmod
  implicit none
  integer,intent(in) :: ipulse
  real*8,intent(in) :: myintime
  real*8 :: time, duration, aField, eField
  DATATYPE :: newpulselen

  newpulselen=0.d0

  if (myintime.ge.pulsestart(ipulse)) then
     time=myintime-pulsestart(ipulse)
     duration = pulsedur(ipulse)
     if (time.le.duration) then
        call NewField(aField,eField,time,omega2(ipulse),duration,phaseshift(ipulse),envdernum,envpwr)
        newpulselen = pulsestrength(ipulse) * eField;
     endif
  endif

end function newpulselen

function newpulsevel(myintime, ipulse)
  use pulse_parameters
  use constant_parameters
  use newpulsesubmod
  implicit none
  integer,intent(in) :: ipulse
  real*8,intent(in) :: myintime
  real*8 :: time, duration, aField, eField
  DATATYPE :: newpulsevel

  newpulsevel=0.d0

  if (myintime.ge.pulsestart(ipulse)) then
     time=myintime-pulsestart(ipulse)
     duration = pulsedur(ipulse)
     if (time.le.duration) then
        call NewField(aField,eField,time,omega2(ipulse),duration,phaseshift(ipulse),envdernum,envpwr)
        newpulsevel = pulsestrength(ipulse) * aField;
     endif
  endif

end function newpulsevel

function simplepulselen(myintime, ipulse)
  use pulse_parameters
  use constant_parameters
  implicit none
  integer,intent(in) :: ipulse
  real*8,intent(in) :: myintime
  real*8 :: time
  DATATYPE :: simplepulselen

  simplepulselen=0.d0

  if (myintime.ge.pulsestart(ipulse)) then
     time=myintime-pulsestart(ipulse)
     if (time.le.pi/omega(ipulse)) then
        simplepulselen = pulsestrength(ipulse) * omega(ipulse) * &
             ( sin(time*omega(ipulse))*cos(time*omega(ipulse) + phaseshift(ipulse)) &
             + sin(time*omega(ipulse) + phaseshift(ipulse))*cos(time*omega(ipulse)) )

     endif
  endif
end function simplepulselen

function simplepulsevel(myintime, ipulse)
  use pulse_parameters
  use constant_parameters
  implicit none
  integer,intent(in) :: ipulse
  real*8,intent(in) :: myintime
  real*8 :: time
  DATATYPE :: simplepulsevel

  simplepulsevel=0.d0

  if (myintime.ge.pulsestart(ipulse)) then
     time=myintime-pulsestart(ipulse)
     if (time.le.pi/omega(ipulse)) then

        simplepulsevel = pulsestrength(ipulse) * &
             sin(time*omega(ipulse)) * sin(time*omega(ipulse) + phaseshift(ipulse) )

     endif
  endif

end function simplepulsevel

function threepulsevel(intime, ipulse)
  use pulse_parameters
  use constant_parameters
  implicit none
  integer,intent(in) :: ipulse
  real*8,intent(in) :: intime
  real*8 :: time,dur,pstart,f,df,ddf
  DATATYPE :: pstren, threepulsevel
  integer :: opt1, negflag

  opt1    = pulse7opt1(ipulse) ;
  negflag = 0;
  select case(opt1)
  case(0,1)
  case(2,3)
     opt1 = opt1 - 2;
     negflag = 1;
  case default
  end select

  threepulsevel       = 0.d0
  dur                 = pulsedur(ipulse)
  pstart              = pulsestart(ipulse)
  pstren              = pulsestrength(ipulse)
  if (negflag .ne. 0) then
     pstren           = pstren * (-1)  ! if flip time, mult deriv by (-1)
     pstren           = pstren * (-1)  ! flipping sign both length and velocity
  endif
  if (intime.ge.pstart) then
     time             = intime - pstart
     if (time.le.dur) then
        time          = time/dur
        if (negflag .ne. 0) then
           time = 1-time;
        endif
        call threepulsefunction(time,f,df,ddf,opt1)
        threepulsevel = pstren * df ;
     endif
  endif
end function threepulsevel

function threepulselen(intime, ipulse)
  use pulse_parameters
  use constant_parameters
  implicit none
  integer,intent(in) :: ipulse
  real*8,intent(in) :: intime
  real*8 :: time,dur,pstart,f,df,ddf
  DATATYPE :: pstren, threepulselen
  integer :: opt1, negflag

  opt1    = pulse7opt1(ipulse) ;
  negflag = 0;
  select case(opt1)
  case(0,1)
  case(2,3)
     opt1 = opt1 - 2;
     negflag = 1;
  case default
  end select

  threepulselen       = 0.d0
  dur                 = pulsedur(ipulse)
  pstart              = pulsestart(ipulse)
  pstren              = pulsestrength(ipulse)
  if (negflag .ne. 0) then
     pstren           = pstren * (-1)  ! flipping sign both length and velocity
  endif
  if (intime.ge.pstart) then
     time             = intime - pstart
     if (time.le.dur) then
        time          = time/dur
        if (negflag .ne. 0) then
           time = 1-time;
        endif
        call threepulsefunction(time,f,df,ddf,opt1)
        threepulselen = pstren * ddf / dur;
     endif
  endif
end function threepulselen

subroutine threepulsefunction(time,f,df,ddf,OPT)
  use fileptrmod
  implicit none
  integer,intent(in) :: OPT
  real*8, intent(in) :: time
  real*8, intent(out) :: f,df,ddf
  real*8 :: aval=0, bval=0, nfac=0, &
       fac1=0,   fac2=0,   faca=0,   facb=0,  &
       dfac1=0,  dfac2=0,  dfaca=0,  dfacb=0,  &
       ddfac1=0, ddfac2=0, ddfaca=0, ddfacb=0

  if (time<0 .or. time>1) then
     OFLWR "TIME ERROR ", time; CFLST
  endif

  if (OPT == 0) then
     aval = 1/220d0 * ( 85 - sqrt(185d0) )
     bval = 1/115d0 * ( 45 + sqrt(185d0) )
     fac1 = time**8;
     dfac1 = 8*time**7;
     ddfac1 = 56*time**6;
     fac2 = (1-time)**13;
     dfac2 = -13*(1-time)**12;
     ddfac2 = 156*(1-time)**11;
  elseif (OPT == 1) then
     aval = 1/220d0 * ( 135 - sqrt(185d0) )
     bval = 1/115d0 * ( 70 + sqrt(185d0) )
     fac1 = time**13;
     dfac1 = 13*time**12;
     ddfac1 = 156*time**11;
     fac2 = (1-time)**8;
     dfac2 = -8*(1-time)**7;
     ddfac2 = 56*(1-time)**6;
  else
     OFLWR "programmer error threepulsefunction"; CFLST
  endif

  faca = (time-aval)**2;
  dfaca = 2*(time-aval);
  ddfaca = 2;
  facb = (time-bval);
  dfacb = 1;
  ddfacb = 0;

  f =  fac1 * fac2 * faca * facb;
  df = dfac1 * fac2 * faca * facb + &
       fac1 * dfac2 * faca * facb + &
       fac1 * fac2 * dfaca * facb + &
       fac1 * fac2 * faca * dfacb ;
  ddf= ddfac1 * fac2 * faca * facb + &
       dfac1 * dfac2 * faca * facb * 2 + &
       dfac1 * fac2 * dfaca * facb * 2 + &
       dfac1 * fac2 * faca * dfacb * 2 + &
       fac1 * ddfac2 * faca * facb + &
       fac1 * dfac2 * dfaca * facb * 2 + &
       fac1 * dfac2 * faca * dfacb * 2 + &
       fac1 * fac2 * ddfaca * facb + &
       fac1 * fac2 * dfaca * dfacb * 2 + &
       fac1 * fac2 * faca * ddfacb ;

  nfac = 3.069e-7;

  f   = f / nfac;
  df  = df / nfac;
  ddf = ddf / nfac;

end subroutine threepulsefunction

!!$function cwpulselen(myintime, ipulse)
!!$  use pulse_parameters
!!$  use constant_parameters
!!$  implicit none
!!$  integer,intent(in) :: ipulse
!!$  real*8,intent(in) :: myintime
!!$  DATATYPE :: cwpulselen
!!$
!!$  cwpulselen=0d0
!!$  if (myintime.lt.pi/omega(ipulse)) then
!!$     cwpulselen = pulsestrength(ipulse) * omega2(ipulse) * &
!!$          cos(myintime*omega2(ipulse)+phaseshift(ipulse))
!!$  endif
!!$
!!$end function cwpulselen
!!$
!!$
!!$function cwpulsevel(myintime, ipulse)
!!$  use pulse_parameters
!!$  use constant_parameters
!!$  implicit none
!!$  integer,intent(in) :: ipulse
!!$  real*8,intent(in) :: myintime
!!$  DATATYPE :: cwpulsevel
!!$
!!$  cwpulsevel=0.d0
!!$  if (myintime.lt.pi/omega(ipulse)) then
!!$     cwpulsevel = pulsestrength(ipulse) * sin(myintime*omega2(ipulse) + phaseshift(ipulse))
!!$  endif
!!$
!!$end function cwpulsevel

!!$function monopulselen(myintime, ipulse)
!!$  use pulse_parameters
!!$  use constant_parameters
!!$  implicit none
!!$  integer,intent(in) :: ipulse
!!$  real*8,intent(in) :: myintime
!!$  real*8 :: pptime
!!$  DATATYPE :: monopulselen
!!$
!!$  pptime=myintime*omega(ipulse) - pi/2
!!$
!!$  if (pptime.lt.pi/2) then
!!$     monopulselen = pulsestrength(ipulse) * (0.75d0*cos(pptime) + cos(3*pptime)/4d0)
!!$  else
!!$     monopulselen = 0
!!$  end if
!!$
!!$end function monopulselen
!!$
!!$
!!$function monopulsevel(myintime, ipulse)
!!$  use pulse_parameters
!!$  use constant_parameters
!!$  implicit none
!!$  integer,intent(in) :: ipulse
!!$  real*8,intent(in) :: myintime
!!$  real*8 :: pptime
!!$  DATATYPE :: monopulsevel
!!$
!!$  pptime=myintime*omega(ipulse) - pi/2
!!$
!!$  if (pptime.lt.pi/2) then
!!$     monopulsevel = pulsestrength(ipulse) * (0.75d0*sin(pptime) + sin(3*pptime)/12d0 + 2d0/3d0)
!!$  else
!!$     monopulsevel = pulsestrength(ipulse) * (4d0/3d0)
!!$  endif
!!$
!!$end function monopulsevel

function pulselen(myintime, ipulse)
  use pulse_parameters
  use constant_parameters
  use fileptrmod
  implicit none
  integer,intent(in) :: ipulse
  real*8,intent(in) :: myintime
  real*8 :: time
  DATATYPE :: pulselen

  pulselen=0.d0

  if (chirp(ipulse).ne.0d0.or.ramp(ipulse).ne.0d0) then
     OFLWR "Chirp / ramp not supported for length", chirp(ipulse), ipulse; CFLST
  endif
  if (myintime.ge.pulsestart(ipulse)) then
     time=myintime-pulsestart(ipulse)
     if (time.le.pi/omega(ipulse)) then
        pulselen = pulsestrength(ipulse) * ( &
             2*omega(ipulse)*sin(time*omega(ipulse))*cos(time*omega(ipulse)) * &
             sin((time-pi/omega(ipulse)/2)*omega2(ipulse) + phaseshift(ipulse)) &
             + sin(time*omega(ipulse))**2 * omega2(ipulse) * &
             cos((time-pi/omega(ipulse)/2)*omega2(ipulse) + phaseshift(ipulse)) )
     endif
  endif

end function pulselen

function pulsevel(myintime, ipulse)
  use pulse_parameters
  use constant_parameters
  implicit none
  integer,intent(in) :: ipulse
  real*8,intent(in) :: myintime
  real*8 :: time,thisomega2
  DATATYPE :: pulsevel, thisstrength

  pulsevel=0.d0

  if (myintime.ge.pulsestart(ipulse)) then
     time=myintime-pulsestart(ipulse)

!!# notice denominator here , half the total pulse time: energy at start of pulse
!!# is omega2-chirp; at 1/4 pulse omega2-chirp/2; at 3/4 omega2+chirp/2; end of pulse
!!# omega2+chirp.  Therefore with given value of chirp, will span this range of
!!# energies over FWHM.

     thisomega2=omega2(ipulse)+chirp(ipulse)*(time-pi/omega(ipulse)/2)/(pi/omega(ipulse)/2)   /2

     thisstrength=pulsestrength(ipulse)*(1d0+ramp(ipulse) * &
          (time-pi/omega(ipulse)/2)/(pi/omega(ipulse)/2))

     if (time.le.pi/omega(ipulse)) then
        pulsevel = thisstrength * sin(time*omega(ipulse))**2 * &
             sin((time-pi/omega(ipulse)/2)*thisomega2 + phaseshift(ipulse))
     endif
  endif

end function pulsevel

!!$!! wtf with longstep...  why did I do it 2* longstep+1?  So for longstep 0, no constant part of
!!$!!  envelope; for longstep 1, constant part is middle 2/3 of pulse.
!!$
!!$function longpulselen(myintime, ipulse)
!!$  use pulse_parameters
!!$  use constant_parameters
!!$  use fileptrmod
!!$  implicit none
!!$  integer,intent(in) :: ipulse
!!$  real*8,intent(in) :: myintime
!!$  real*8 :: time, fac, fac2
!!$  DATATYPE :: longpulselen
!!$
!!$  longpulselen=0.d0
!!$
!!$  if (chirp(ipulse).ne.0d0.or.ramp(ipulse).ne.0d0) then
!!$     OFLWR "Chirp not supported for length", chirp(ipulse), ipulse; CFLST
!!$  endif
!!$  if (myintime.ge.pulsestart(ipulse)) then
!!$     time=myintime-pulsestart(ipulse)
!!$
!!$     if (time.le.pi/omega(ipulse)) then
!!$
!!$        if ( (time.le.pi/2.d0/omega(ipulse)/(2*longstep(ipulse)+1)) .or.&
!!$             (time.ge.pi/omega(ipulse) - pi/2.d0/omega(ipulse)/(2*longstep(ipulse)+1)) ) then
!!$           fac=2*omega(ipulse)*(2*longstep(ipulse)+1)*sin(time*omega(ipulse)*(2*longstep(ipulse)+1)) * &
!!$                cos(time*omega(ipulse)*(2*longstep(ipulse)+1))
!!$           fac2=sin(time*omega(ipulse)*(2*longstep(ipulse)+1))**2
!!$        else
!!$           fac=0.d0
!!$           fac2=1.d0
!!$        endif
!!$
!!$        longpulselen = pulsestrength(ipulse) * ( &
!!$             fac * sin(time*omega2(ipulse) + phaseshift(ipulse)) &
!!$          + fac2 * omega2(ipulse) * cos(time*omega2(ipulse) + phaseshift(ipulse)) )
!!$     endif
!!$  endif
!!$
!!$end function longpulselen
!!$
!!$
!!$function longpulsevel(myintime, ipulse)
!!$  use pulse_parameters
!!$  use constant_parameters
!!$  implicit none
!!$  integer,intent(in) :: ipulse
!!$  real*8,intent(in) :: myintime
!!$  real*8 :: time, thisomega2
!!$  DATATYPE :: longpulsevel,thisstrength
!!$
!!$  longpulsevel=0.d0
!!$
!!$  if (myintime.ge.pulsestart(ipulse)) then
!!$     time=myintime-pulsestart(ipulse)
!!$
!!$     if (time.le.pi/omega(ipulse)) then
!!$
!!$!! this is right I think  goes to chirp/2  when 2*logstep+1 / 4*longstep+2 -way before half time
!!$
!!$        thisomega2=omega2(ipulse)+chirp(ipulse)/2 *(time-pi/omega(ipulse)/2)/&
!!$             (pi/omega(ipulse)/2*(2*longstep(ipulse)+1)/(4*longstep(ipulse)+2))
!!$        thisstrength=pulsestrength(ipulse)*(1d0 +ramp(ipulse) * &
!!$             (time-pi/omega(ipulse)/2)/(pi/omega(ipulse)/2))
!!$
!!$!!(2*longstep(ipulse)+1)/(4*longstep(ipulse)+2)))
!!$
!!$        if ( (time.le.pi/2.d0/omega(ipulse)/(2*longstep(ipulse)+1)) .or. &
!!$             (time.ge.pi/omega(ipulse) - pi/2.d0/omega(ipulse)/(2*longstep(ipulse)+1)) ) then
!!$          longpulsevel = thisstrength  * &
!!$               sin((time-pi/omega(ipulse)/2)*thisomega2 + phaseshift(ipulse)) * &
!!$               sin(time*omega(ipulse)*(2*longstep(ipulse)+1))**2
!!$        else
!!$           longpulsevel = thisstrength * &
!!$                sin((time-pi/omega(ipulse)/2)*thisomega2 + phaseshift(ipulse))
!!$        endif
!!$     endif
!!$  endif
!!$
!!$end function longpulsevel

!! not useful because tentmode=1 isn't better than tentmode=0; tentmode=0 default;
!! keeping these subroutines anyway

function get_rtentsum(num,vec)
  use parameters   !! tentmode
  implicit none
  real*8 :: get_rtentsum
  integer,intent(in) :: num
  real*8, intent(in) :: vec(-num:num)
  integer :: itent,jtent

  if (num.lt.0) then
     OFLWR "rtentsumerror", num; CFLST
  elseif (num.eq.0) then
     get_rtentsum=vec(0)
     return
  endif

  if (tentmode.eq.0) then
     itent=0
     jtent=1
  else
     itent=(num+1)/2 * (-1)
     jtent=(num+1)/2
  endif

  get_rtentsum = SUM(vec(-num:itent)) + SUM(vec(jtent:num))

end function get_rtentsum

function get_ctentsum(num,vec)
  use parameters   !! tentmode
  implicit none
  complex*16 :: get_ctentsum
  integer,intent(in) :: num
  complex*16, intent(in) :: vec(-num:num)
  integer :: itent,jtent

  if (num.lt.0) then
     OFLWR "ctentsumerror", num; CFLST
  elseif (num.eq.0) then
     get_ctentsum=vec(0)
     return
  endif

  if (tentmode.eq.0) then
     itent=0
     jtent=1
  else
     itent=(num+1)/2 * (-1)
     jtent=(num+1)/2
  endif

  get_ctentsum = SUM(vec(-num:itent)) + SUM(vec(jtent:num))

end function get_ctentsum

end module pulsesubmod


      function fv(VS)
        include "common6.h"
        COMMON/GALAXY/ GMG,RG(3),VG(3),FG(3),FGD(3),TG,
     &               OMEGA,DISK,A,B,V02,RL2,GMB,AR,GAM,ZDUM(7)
        real*8 :: VS, E_DIM, fv
*
        !write(206,*) "VS", VS
        !Calculate dimensionless energy for star at v and r.
        E_DIM = 0.5*VS**2 -(GMB/AR)*(1.d0/(2.d0-GAM))*
     & ( 1.d0 - (RGDENSMAG/(RGDENSMAG+AR))**(2.d0-GAM))
        !write(206,*) "E_DIM", E_DIM
        E_DIM = -E_DIM*(AR/GMB)
        !write(206,*) "E_DIM", E_DIM, AR, GMB, GAM, RGDENSMAG, ONEPI
*
        !Calculate f(E) (gamma = 0) (Dehnen 1993)
        fv = ((3.d0*GMB/(2.d0*(ONEPI**3)*(GMB*AR)**1.5))*
     &  ((sqrt(2.0*E_DIM) * (3.0-4.0*E_DIM)/(1.0-2.0*E_DIM))
     &   - 3.0*asinh(sqrt(2.0*E_DIM/(1.0-2.0*E_DIM)))))

        !write(206,*) (sqrt(2.0*E_DIM) * (3.0-4.0*E_DIM)/(1.0-2.0*E_DIM))
    ! &   - 3.0*asinh(sqrt(2.0*E_DIM/(1.0-2.0*E_DIM)))
        !write(206,*) "fv",fv
*
        fv = fv*4.0*ONEPI*VS**2
        !write(206,*) "fv",fv
*
       end function


c     Demo using FINUFFT for single-precision 1d transforms in legacy fortran.
c     Does types 1,2,3, including math test against direct summation.
c     Default opts only (see simple1d1f for how to change opts).
c
c     A slight modification of drivers from the CMCL NUFFT, (C) 2004-2009,
c     Leslie Greengard and June-Yub Lee. See: cmcl_license.txt.
c
c     Tweaked by Alex Barnett to call FINUFFT 2/17/17, & single prec.
c     dyn malloc; type 2 uses same input data fk0, 3/8/17
c     Also see: ../README.
c
c     Compile with, eg (GCC, multithreaded, static lib; paste to a single line):
c
c     gfortran nufft1d_demof.f ../directft/dirft1df.f -o nufft1d_demof
c     ../../lib-static/libfinufftf.a -lstdc++ -lfftw3f -lfftw3f_omp -lm -fopenmp
c
      program nufft1d_demof
      implicit none
c
c --- local variables
c
      integer i,ier,iflag,j,k1,mx
      integer*8 ms,nj
      real*4, allocatable :: xj(:),sk(:)
      real*4 err,eps,pi
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*8, allocatable :: cj(:),cj0(:),cj1(:),fk0(:),fk1(:)
c     this (since unallocated) used to pass a NULL ptr to FINUFFT...
      integer*8, allocatable :: null
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
      ms = 90
      nj = 128
c     first alloc everything
      allocate(fk0(ms))
      allocate(fk1(ms))
      allocate(sk(ms))
      allocate(xj(nj))
      allocate(cj(nj))
      allocate(cj0(nj))
      allocate(cj1(nj))
      do k1 = -nj/2, (nj-1)/2
         j = k1+nj/2+1
         xj(j) = pi * cos(-pi*j/nj)
         cj(j) = cmplx( sin(pi*j/nj), cos(pi*j/nj))
      enddo
c
c     --------------------------------------------------
c     start tests
c     --------------------------------------------------
c
      iflag = 1
      print*,' Start 1D testing: ', ' nj =',nj, ' ms =',ms
      do i = 1,4
         if (i.eq.1) eps=1e-2
         if (i.eq.2) eps=1e-4
         if (i.eq.3) eps=1e-6
         if (i.eq.4) eps=1e-8
	 print*,' '
  	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 1D Type1 method
c     -----------------------
c
         call dirft1d1f(nj,xj,cj,iflag, ms,fk0)
         call finufftf1d1(nj,xj,cj,iflag,eps,ms,fk1,null,ier)
         call errcomp(fk0,fk1,ms,err)
         print *,' ier = ',ier
         print *,' type 1 error = ',err
c
c     -----------------------
c     call 1D Type2 method
c     -----------------------
c
         call dirft1d2f(nj,xj,cj0,iflag, ms,fk0,ier)
         call finufftf1d2(nj,xj,cj1,iflag, eps, ms,fk0,null,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 2 error = ',err
c
c     -----------------------
c     call 1D Type3 method
c     -----------------------
         do k1 = 1, ms
            sk(k1) = 48*cos(k1*pi/ms)
         enddo
         call dirft1d3f(nj,xj,cj,iflag, ms,sk,fk0)
         call finufftf1d3(nj,xj,cj,iflag,eps, ms,sk,fk1,null,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 3 error = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer*8 k,n
      complex*8 fk0(n), fk1(n)
      real *4 salg,ealg,err
c
      ealg = 0e0
      salg = 0e0
      do k = 1, n
         ealg = ealg + cabs(fk1(k)-fk0(k))**2
         salg = salg + cabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


      module precision_mod
      implicit none
      integer, parameter :: dp = selected_real_kind(15,100)
      integer, parameter :: sp = selected_real_kind(6,30)
!     --------------------------------
!     use wp = sp for single precision
!     use wp = dp for double precision
!     --------------------------------
      integer, parameter :: wp = dp

      integer, parameter :: i8 = selected_int_kind( 12 )
      end module precision_mod

      module gemm_mod
      use precision_mod
      contains

      subroutine test_gemm_nn_strided_batched(m,n,k,batchCount,use_gpu0)
      use precision_mod
      implicit none
      integer, intent(in) :: m,n,k,batchCount
      logical, intent(in) :: use_gpu0

      real(kind=wp), allocatable :: A(:,:,:)
      real(kind=wp), allocatable :: B(:,:,:)
      real(kind=wp), allocatable :: C(:,:,:)
      real(kind=wp), allocatable :: Chost(:,:,:)
      real(kind=wp) :: alpha,beta
      integer :: lda,ldb,ldc

      integer, parameter :: idebug = 1
      real(kind=wp), parameter :: tol  = 1e-5

      real(kind=wp) :: max_err, cnorm_1,cnorm_2,cnorm_max
      real(kind=wp) :: c_ij, ch_ij
      integer :: i,i1,i2,i3
      integer(kind=i8) :: strideA,strideB,strideC
      integer :: ic,jc,ib,ibatch

      logical :: use_gpu

      use_gpu = use_gpu0

      allocate( A(m,k,batchCount) )
      allocate( B(k,n,batchCount) )
      allocate( C(m,n,batchCount) )
      allocate( Chost(m,n,batchCount) )

      lda = size(A,1)
      ldb = size(B,1)
      ldc = size(C,1)

      A = 1
      B = 2
      C = 3

      Chost = C
      alpha = -1
      beta = 1

!     -------------------
!     perform on cpu host
!     -------------------
!$omp parallel do
      do i=1,batchCount
        Chost(1:m,1:n,i) = beta * Chost(1:m,1:n,i) +                     &
     &                 alpha*matmul(A(1:m,1:k,i),B(1:k,1:n,i))
      enddo

      strideA = size(A,1)*size(A,2)
      strideB = size(B,1)*size(B,2)
      strideC = size(C,1)*size(C,2)

!$omp  target data                                                        &
!$omp& if (use_gpu)                                                       &
!$omp& map(to:m,n,k,batchCount,lda,ldb,ldc)                               &
!$omp& map(to:alpha,beta,strideA,strideB,strideC)                         &
!$omp& map(to:A,B) map(C)

!$omp  target teams distribute parallel do simd                              &
!$omp& if (use_gpu)                                                          &
!$omp& private(ic,jc,ib,c_ij)

      do ibatch=1,batchCount

        do jc=1,n
        do ic=1,m
          c_ij = 0
          do ib=1,k
           c_ij = c_ij + A(ic,ib,ibatch)*B(ib,jc,ibatch)
          enddo
          if (beta.eq.0) then
             C(ic,jc,ibatch) = alpha * c_ij
          else
             C(ic,jc,ibatch) = beta*C(ic,jc,ibatch) + alpha*c_ij
          endif
        enddo
        enddo
      enddo

!$omp end target data

       max_err = 0
       cnorm_max = 0
       cnorm_1 = 0
       cnorm_2 = 0
!$omp  parallel do                                                       &
!$omp& private(c_ij,ch_ij)                                               &
!$omp& reduction(max:max_err,cnorm_max)                                  &
!$omp& reduction(+:cnorm_1,cnorm_2)
       do i3=1,size(C,3)
       do i2=1,size(C,2)
       do i1=1,size(C,1)
         c_ij = C(i1,i2,i3)
         ch_ij = Chost(i1,i2,i3)

         max_err = max(max_err,abs(c_ij - ch_ij))
         cnorm_max = max( cnorm_max, abs(ch_ij))
         cnorm_1 = cnorm_1 + abs(ch_ij)
         cnorm_2 = cnorm_2 + abs(ch_ij) * abs(ch_ij)
       enddo
       enddo
       enddo
       cnorm_2 = sqrt( cnorm_2 )

       print 9010, max_err, cnorm_max,cnorm_1,cnorm_2
 9010  format(' max_err= ',1pe14.4,' cnorm_max = ',1pe14.4,              &
     &        ' cnorm_1 = ',1pe14.4, ' cnorm_2 = ', 1pe14.4)

       if ((idebug >= 1) .and. (max_err > tol)) then
          do i3=1,size(C,3)
          do i2=1,size(C,2)
          do i1=1,size(C,1)
           c_ij = C(i1,i2,i3)
           ch_ij = Chost(i1,i2,i3)
           if (abs(c_ij - ch_ij) > tol) then
            print 9100, i1,i2,i3,c_ij, i1,i2,i3,ch_ij
 9100       format(' C(',i4,',',i4,',',i4,') = ',1pe14.4,                &
     &             ' Ch(',i4,',',i4,',',i4,') = ',1pe14.4 )
            stop 2
           endif
          enddo
          enddo
          enddo
       endif

       deallocate(A,B,C,Chost)
       return
       end subroutine test_gemm_nn_strided_batched

       end module gemm_mod

      program main_gemm_nn_strided_batched
!$    use omp_lib
      use precision_mod
      use gemm_mod
      implicit none

      integer :: m,n,k,batchCount
      integer :: nthreads
      logical :: use_gpu

      nthreads = 1
!$omp parallel
!$omp master
!$    nthreads = omp_get_num_threads()
!$omp end master
!$omp end parallel
      print 9010,nthreads
 9010 format(' nthreads = ', i6)

      m = 3
      n = 3
      k = 3
      batchCount = 64

      use_gpu = .false.
      print*,'use_gpu ',use_gpu
      print 9020, m,n,k,batchCount
 9020 format(' m,n,k,batchCount ', 4(1x,i6) )
      call test_gemm_nn_strided_batched(m,n,k,batchCount,use_gpu)

      use_gpu = .true.
      print*,'use_gpu ',use_gpu
      print 9030, m,n,k,batchCount
 9030 format(' m,n,k,batchCount ', 4(1x,i6) )
      call test_gemm_nn_strided_batched(m,n,k,batchCount,use_gpu)

      m = 10
      n = 10
      k = 10
      batchCount = 2

      use_gpu = .false.
      print*,'use_gpu ',use_gpu
      print 9040, m,n,k,batchCount
 9040 format(' m,n,k,batchCount ', 4(1x,i6) )
      call test_gemm_nn_strided_batched(m,n,k,batchCount,use_gpu)

      use_gpu = .true.
      print*,'use_gpu ',use_gpu
      print 9050, m,n,k,batchCount
 9050 format(' m,n,k,batchCount ', 4(1x,i6) )
      call test_gemm_nn_strided_batched(m,n,k,batchCount,use_gpu)

      end program main_gemm_nn_strided_batched


!
!////////////////////////////////////////////////////////////////////////
!
!      Calculator.f90
!      Created: July 31, 2014 at 9:23 AM
!      By: David Kopriva
!
!      A simple toy reverse polish calculator.
!
!        ---------------------------------
!        Example: compute 3*(4+2*3)-5 = 25
!        ---------------------------------
!
!         CALL calc % init()
!         CALL calc % enter(2.0d0)
!         CALL calc % enter(3.0d0)
!         CALL calc % enter("*")
!         CALL calc % enter(4.0d0)
!         CALL calc % enter("+")
!         CALL calc % enter(3.0d0)
!         CALL calc % enter("*")
!         CALL calc % enter(5.0d0)
!         CALL calc % enter("-")
!         PRINT *, "3*(4+2*3)-5 = ",calc % readDisplay()
!         CALL calc % destruct()
!
!
!////////////////////////////////////////////////////////////////////////
!
      Module CalculatorClass
         USE FTObjectClass
         USE FTStackClass
         USE FTValueClass

         IMPLICIT NONE
         PRIVATE

         TYPE, EXTENDS(FTObject) :: Calculator
            CLASS(FTStack), POINTER, PRIVATE  :: stack
!
!           ========
            CONTAINS
!           ========
!
            PROCEDURE, PUBLIC  :: init     => initCalculator
            PROCEDURE, PUBLIC  :: destruct => destructCalculator
            PROCEDURE, PUBLIC  :: clear    => clearCalculator
            PROCEDURE, PUBLIC  :: enterOperation
            PROCEDURE, PUBLIC  :: enterValue
            GENERIC            :: enter     => enterOperation, enterValue
            PROCEDURE, PUBLIC  :: readDisplay
         END TYPE Calculator

         PUBLIC :: Calculator
!
!        ========
         CONTAINS
!        ========
!
!
!////////////////////////////////////////////////////////////////////////
!
         SUBROUTINE initCalculator(self)
            IMPLICIT NONE
            CLASS(Calculator) :: self

            CALL self % FTObject % init()
            ALLOCATE(self % stack)
            CALL self % stack % init()

         END SUBROUTINE initCalculator
!
!////////////////////////////////////////////////////////////////////////
!
         SUBROUTINE destructCalculator(self)
            IMPLICIT NONE
            CLASS(Calculator) :: self

            CALL releaseFTStack(self % stack)

         END SUBROUTINE destructCalculator
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE releaseCalculator(self)
         IMPLICIT NONE
         CLASS(Calculator) , POINTER :: self
         CLASS(FTObject)   , POINTER :: obj
         IF(.NOT. ASSOCIATED(self)) RETURN
         obj => self
         CALL releaseFTObject(self = obj)
         IF ( .NOT. ASSOCIATED(obj) )     THEN
            self => NULL()
         END IF
      END SUBROUTINE releaseCalculator
!
!////////////////////////////////////////////////////////////////////////
!
         SUBROUTINE clearCalculator(self)
            IMPLICIT NONE
            CLASS(Calculator) :: self
            CALL self % stack % removeAllObjects()
         END SUBROUTINE clearCalculator
!
!////////////////////////////////////////////////////////////////////////
!
         SUBROUTINE enterOperation(self,op)
            IMPLICIT NONE
            CLASS(Calculator)                   :: self
            CHARACTER(LEN=*)                    :: op
            CLASS(FTObject) , POINTER           :: obj
            CLASS(FTValue)  , POINTER           :: v
            REAL(KIND=FT_DOUBLE_PRECISION_KIND) :: x, y, r

            SELECT CASE ( op )
               CASE( "+" )
                  x = popValue(self % stack)
                  y = popValue(self % stack)
                  r = x + y
                  CALL self % enterValue(r)
               CASE( "-" )
                  x = popValue(self % stack)
                  y = popValue(self % stack)
                  r = y - x
                  CALL self % enterValue(r)
               CASE( "*" )
                  x = popValue(self % stack)
                  y = popValue(self % stack)
                  r = x*y
                  CALL self % enterValue(r)
               CASE( "/" )
                  x = popValue(self % stack)
                  y = popValue(self % stack)
                  r = x/y
                  CALL self % enterValue(r)
               CASE DEFAULT
            END SELECT

         END SUBROUTINE enterOperation
!
!////////////////////////////////////////////////////////////////////////
!
         FUNCTION popValue(stack) RESULT(r)
            IMPLICIT NONE
            TYPE(FTStack)                       :: stack
            CLASS(FTObject) , POINTER           :: obj
            CLASS(FTValue)  , POINTER           :: v
            REAL(KIND=FT_DOUBLE_PRECISION_KIND) :: r

            CALL stack % pop(obj)

            v   => valueFromObject(obj)
            r   = v % doublePrecisionValue()

            CALL releaseFTValue(v)

         END FUNCTION popValue
!
!////////////////////////////////////////////////////////////////////////
!
         SUBROUTINE enterValue(self,v)
            IMPLICIT NONE
            CLASS(Calculator)                   :: self
            REAL(KIND=FT_DOUBLE_PRECISION_KIND) :: v
            CLASS(FTValue) , POINTER            :: vValue
            CLASS(FTObject), POINTER            :: obj

            ALLOCATE(vValue)
            CALL vValue % initWithValue(v)

            obj => vValue
            CALL self % stack % push(obj)
            CALL releaseFTValue(vValue)

         END SUBROUTINE enterValue
!
!////////////////////////////////////////////////////////////////////////
!
         FUNCTION readDisplay(self)  RESULT(r)
            IMPLICIT NONE
            CLASS(Calculator)                   :: self
            REAL(KIND=FT_DOUBLE_PRECISION_KIND) :: r
            CLASS(FTObject), POINTER            :: obj

            obj => self % stack % peek()
            SELECT TYPE(obj)
               TYPE is (FTValue)
                  r = obj % doublePrecisionValue()
               CLASS DEFAULT
                  PRINT *, "Can't read display"
                  r = 0.0
            END SELECT

         END FUNCTION readDisplay
      END MODULE CalculatorClass


Module SortUnique
contains
  Recursive Subroutine MergeSort(temp, Begin, Finish, list)
    ! 1st 3 arguments are input, 4th is output sorted list
    implicit none
    integer(kind=4),intent(inout) :: Begin,list(:),temp(:)
    integer(kind=4),intent(in) :: Finish
    integer(kind=4) :: Middle
    if (Finish-Begin<2) then    !if run size =1
       return                   !it is sorted
    else
       ! split longer runs into halves
       Middle = (Finish+Begin)/2
       ! recursively sort both halves from list into temp
       call MergeSort(list, Begin, Middle, temp)
       call MergeSort(list, Middle, Finish, temp)
       ! merge sorted runs from temp into list
       call Merge(temp, Begin, Middle, Finish, list)
     endif
  End Subroutine MergeSort

  Subroutine Merge(list, Begin, Middle, Finish, temp)
    implicit none
    integer(kind=4),intent(inout) :: list(:),temp(:)
    integer(kind=4),intent(in) ::Begin,Middle,Finish
    integer(kind=4)    :: kx,ky,kz
    ky=Begin
    kz=Middle
    !! While there are elements in the left or right runs...
    do kx=Begin,Finish-1
       !! If left run head exists and is <= existing right run head.
       if (ky.lt.Middle.and.(kz.ge.Finish.or.list(ky).le.list(kz))) then
          temp(kx)=list(ky)
          ky=ky+1
       else
          temp(kx)=list(kz)
          kz = kz + 1
       end if
    end do

  End Subroutine Merge

  Function Unique(list)
    !! usage sortedlist=Unique(list)
    implicit none
    integer(kind=4) :: strt,fin,N
    integer(kind=4), intent(inout) :: list(:)
    integer(kind=4), allocatable  :: unique(:),work(:)
    logical,allocatable :: mask(:)
    ! sort
    work=list;strt=1;N=size(list);fin=N+1
    call MergeSort(work,strt,fin,list)
    ! cull duplicate indices
    allocate(mask(N));
    mask=.false.
    mask(1:N-1)=list(1:N-1)==list(2:N)
    unique=pack(list,.not.mask)

  End Function Unique

End Module SortUnique


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   DIM constant folding in the expander.

	parameter(n = 35)
	integer rslts(n), expect(n)
	real  rrslts(n), rexpect(n)
	equivalence (rslts, rrslts), (expect, rexpect)

        integer  i, j, k, l
        real     r, s, t, u
        double precision  d, e, f, g

	data (expect(i), i = 1, 11) /0,21,0,11,57,0,0,23,0,0,0/
        i = DIM( 2, 23)
        rslts(1) = i
        i = DIM( 23, 2)
        rslts(2) = i
        j = DIM( -34, -23)
        rslts(3) = j
        j = DIM( -23, -34)
        rslts(4) = j
        j = DIM( 23, -34)
        rslts(5) = j
        j = DIM( -23, 34)
        rslts(6) = j
        k = DIM(0, 23)
        rslts(7) = k
        k = DIM(23, 0)
        rslts(8) = k
        k = DIM(0,0)
        rslts(9) = k
        l = DIM(j,k)
        rslts(10) = l
        l = DIM(k,l)
        rslts(11) = l

	data (rexpect(i), i = 12, 23) /0.0,21.2,0.0,11.6,0.0,58.0,
     -  34.5,0.0,0.0,58.0,0.0,0.0/
        r = DIM(2.45,23.2)
        rrslts(12) = r
        r = DIM(23.45,2.25)
        rrslts(13) = r
        s = DIM(-34.6,-23.4)
        rrslts(14) = s
        s = DIM(-23.4,-35.0)
        rrslts(15) = s
        s = DIM(-23.4,34.6)
        rrslts(16) = s
        s = DIM(23.4,-34.6)
        rrslts(17) = s
        t = DIM(0.0, -34.5)
        rrslts(18) = t
        t = DIM(0.0, 34.5)
        rrslts(19) = t
        t = DIM(0.0, 0.0)
        rrslts(20) = t
        u = DIM(s,t)
        rrslts(21) = u
        u = DIM(t,s)
        rrslts(22) = u
        u = DIM(s,s)
        rrslts(23) = u

	data (rexpect(i), i = 24, 35) /0.0,32.0,0.0,23.3,92.5,0.0,
     -  0.0,34.8,0.0,0.0,0.0,0.0/
        d = DIM(2.45D0,34.3D0)
        rrslts(24) = d
        d = DIM(34.45D0, 2.45D0)
        rrslts(25) = d
        e = DIM(-34.6D0,-23.6D0)
        rrslts(26) = e
        e = DIM(-34.6D0, -57.9D0)
        rrslts(27) = e
        e = DIM(34.6D0, -57.9D0)
        rrslts(28) = e
        e = DIM(-34.6D0, 57.9D0)
        rrslts(29) = e
        f = DIM(0.0D0,34.8D0)
        rrslts(30) = f
        f = DIM(34.8D0,0.0D0)
        rrslts(31) = f
        f = DIM(0.0D0,0.0D0)
        rrslts(32) = f
        g = DIM(e,f)
        rrslts(33) = g
        g = DIM(g,e)
        rrslts(34) = g
        g = DIM(g,g)
        rrslts(35) = g

        call check(rslts,expect,n)
        end


PROGRAM main
USE shared_parameter

IMPLICIT NONE

REAL(DBL) :: b = 1
INTEGER :: nbead
INTEGER :: nlinks
REAL(DBL),ALLOCATABLE,DIMENSION(:,:):: r
INTEGER,ALLOCATABLE,DIMENSION(:) :: laplace
CHARACTER(len=32) :: config_file, beads_arg
INTEGER :: j, status, config_int
REAL(DBL) :: radius

CALL get_command_argument(1,VALUE=beads_arg,STATUS=status)
IF (status /= 0) STOP 'No number of beads specified'
CALL get_command_argument(2,VALUE=config_file,STATUS=status)
IF (status /= 0) STOP 'No correct config file designated'

READ(beads_arg,'(i10)') nbead
READ(config_file,'(i10)') config_int

OPEN(10,FILE='./io/pos'//trim(config_file)//'.dat', &
     ACTION='WRITE',STATUS='UNKNOWN')
OPEN(14,FILE='./io/lpl'//trim(config_file)//'.dat', &
     ACTION='WRITE',STATUS='UNKNOWN')

 ! initialize in straight line with initial spring extension b
   ! nbead = 21
   ALLOCATE(r(3,nbead),STAT=status)

   radius = (nbead - 1) * 2.d0 * b / 2 / pi
   r(2,:)= (/(radius * COS(DBLE(j) * 2.d0 * pi / (nbead)),j=0,nbead-1)/)
   r(1,:)= (/(radius * SIN(DBLE(j) * 2.d0 * pi / (nbead)),j=0,nbead-1)/)
   r(3,:)= 0.d0

 ! circular polymer

   nlinks = nbead * 2
   ALLOCATE(laplace(nbead + nlinks), STAT=status)
   laplace(1) = 2
   laplace(2) = nbead
   laplace(3) = 2
   DO j=2,nbead-1
      laplace((j - 2) * 3 + 4) = 2
      laplace((j - 2) * 3 + 5) = j - 1
      laplace((j - 2) * 3 + 6) = j + 1
   END DO
   laplace(4 + (nbead - 2) * 3) = 2
   laplace(4 + (nbead - 2) * 3 + 1) = nbead - 1
   laplace(4 + (nbead - 2) * 3 + 2) = 1

WRITE(10, *) nbead
WRITE(10, *) r
WRITE(14, *) nlinks
WRITE(14, *) laplace

CLOSE(10)
CLOSE(14)
END PROGRAM main


      SUBROUTINE SVD(A,U,S,S_matrix,V,M,N)
      DOUBLE PRECISION:: A(M,N),U(M,M),VT(N,N),S(N),V(N,N),S_matrix(M,M)
!
! Program computes the matrix singular value decomposition.
! Using Lapack library.
!
! Programmed by sukhbinder Singh
! 14th January 2011
!

      DOUBLE PRECISION,ALLOCATABLE :: WORK(:)
      INTEGER LDA,M,N,LWORK,LDVT,INFO
      CHARACTER  JOBU, JOBVT

      JOBU='A'
      JOBVT='A'
      LDA=M
      LDU=M
      LDVT=N

      LWORK=MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N))

      ALLOCATE(work(lwork))

      CALL DGESVD(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,WORK, &
                  LWORK, INFO )

       DO I=1,LDVT
         DO J=1,LDVT
           V(I,J)=VT(J,I)
         END DO
       END DO
       S_matrix=0
       DO I=1,LDU
         S_matrix(I,I)=S(I)
       ENDDO
      END SUBROUTINE SVD


c-----------------------------------------------------------------------
      subroutine polyeval(x,n,p,uq)
      real*8 x,y
      integer n,i
      real*8 p(1)
      real*8 uq

      y=p(n)

      do i=n-1,1,-1
        y=y*x+p(i)
      enddo

      uq=y

      end
c-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer x,xq,u,uq
      integer bxl,bul,bxg,bug
      integer i
      integer q
      parameter(q=6)

      real*8 p(6)
      real*8 xx(2)
      real*8 xxq(q)
      real*8 uuq(q)
      real*8 px
      integer*8 offset1,offset2

      character arg*32

      data p/1,2,3,4,5,6/
      data xx/-1,1/

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedvectorcreate(ceed,2,x,err)
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,err)
      call ceedvectorcreate(ceed,q,xq,err)
      call ceedvectorsetvalue(xq,0.d0,err)
      call ceedvectorcreate(ceed,q,u,err)
      call ceedvectorsetvalue(u,0.d0,err)
      call ceedvectorcreate(ceed,q,uq,err)
      call ceedvectorsetvalue(uq,0.d0,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,
     $  ceed_gauss_lobatto,bxl,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,
     $  ceed_gauss_lobatto,bul,err)

      call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,
     $  x,xq,err)

      call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err)
      do i=1,q
        call polyeval(xxq(i+offset1),6,p,uuq(i))
      enddo
      call ceedvectorrestorearrayread(xq,xxq,offset1,err)
      call ceedvectorsetarray(uq,ceed_mem_host,ceed_use_pointer,uuq,err)

      call ceedbasisapply(bul,1,ceed_transpose,ceed_eval_interp,uq,u,
     $  err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,
     $  bxg,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,ceed_gauss,
     $  bug,err)

      call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err)
      call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset2,err)
      do i=1,q
        call polyeval(xxq(i+offset1),6,p,px)
        if (abs(uuq(i+offset2)-px) > 1e-14) then
          write(*,*) uuq(i+offset2),' not eqaul to ',
     $      px,'=p(',xxq(i+offset1),')'
        endif
      enddo
      call ceedvectorrestorearrayread(xq,xxq,offset1,err)
      call ceedvectorrestorearrayread(uq,uuq,offest2,err)

      call ceedvectordestroy(x,err)
      call ceedvectordestroy(xq,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(uq,err)
      call ceedbasisdestroy(bxl,err)
      call ceedbasisdestroy(bul,err)
      call ceedbasisdestroy(bxg,err)
      call ceedbasisdestroy(bug,err)
      call ceeddestroy(ceed,err)
      end
c-----------------------------------------------------------------------


      SUBROUTINE rkdumb(vstart,nvar,x1,x2,nstep,derivs)
      INTEGER nstep,nvar,NMAX,NSTPMX
      PARAMETER (NMAX=50,NSTPMX=200)
      REAL x1,x2,vstart(nvar),xx(NSTPMX),y(NMAX,NSTPMX)
      EXTERNAL derivs
      COMMON /path/ xx,y
CU    USES rk4
      INTEGER i,k
      REAL h,x,dv(NMAX),v(NMAX)
      do 11 i=1,nvar
        v(i)=vstart(i)
        y(i,1)=v(i)
11    continue
      xx(1)=x1
      x=x1
      h=(x2-x1)/nstep
      do 13 k=1,nstep
        call derivs(x,v,dv)
        call rk4(v,dv,nvar,x,h,v,derivs)
        if(x+h.eq.x)pause 'stepsize not significant in rkdumb'
        x=x+h
        xx(k+1)=x
        do 12 i=1,nvar
          y(i,k+1)=v(i)
12      continue
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rkdumb.for


MODULE SOI_hg_phase_function

	USE Type_Kinds, only : fpk => fp_kind

IMPLICIT NONE

	REAL(fpk), PRIVATE, PARAMETER	:: ONE = 1.0_fpk
	REAL(fpk), PRIVATE, PARAMETER	:: TWO = 2.0_fpk
	REAL(fpk), PRIVATE, PARAMETER	:: ZERO = 0.0_fpk

PUBLIC  :: hg_phase_function, hg_phase_function_TL, &
		   hg_phase_function_AD, calc_plegr, pleg

CONTAINS

	SUBROUTINE hg_phase_function(	asy, &   ! assymetry parameter
									wgts, & ! weights
									plegr, & ! legendre polynomials
									pf, & ! forward-scattering phase function
									pb, & ! backward-scattering phase function
									norm ) ! normalization for each row of phase matrix

		REAL(fpk), intent(in)					::	asy
		REAL(fpk), intent(in), dimension(:)		::	wgts
		REAL(fpk), intent(in), dimension(:,:)	::	plegr
		REAL(fpk), intent(out), dimension(:,:)	::	pf, pb
		REAL(fpk), intent(out), dimension(:), optional 	::	norm

	!	REAL(fpk), dimension(size(wgts)) 	::	norm_
		REAL(fpk) 	::	norm_
		integer :: j, k, l, isign, npts, nleg
		REAL(fpk)	:: pp

 		pf = ZERO  ! initialize matrices
		pb = ZERO
		npts = size(wgts)
		nleg = size(plegr, 1)
		do j = 1, npts    ! up-going input angles
			norm_ = ZERO
			do k = 1, npts 	! out-going angles
			  isign = 1
			  do l = 1, nleg ! sum up necessary # of terms
    			pp = (TWO*l-ONE)*asy**(l-ONE) * plegr(l,j) * plegr(l,k)
    			pf( j, k) = pf( j, k) + pp
    			pb( j, k) = pb( j, k) + isign * pp
    			isign = -isign
			  end do
			  norm_ = norm_ + (pf(j,k) + pb(j,k)) * wgts(k)
			end do
			pf(j,:) = pf(j,:) /norm_
			pb(j,:) = pb(j,:) /norm_
			if ( present(norm) ) norm(j) = norm_
		enddo

	END SUBROUTINE hg_phase_function

	SUBROUTINE hg_phase_function_TL(asy, &   ! assymetry parameter
									wgts, & ! weights
									plegr, & ! legendre polynomials
									asy_TL, & ! variation in assymetry parameter
									pf, pb, & ! phase matrices
									pf_TL, pb_TL )  ! variation in phase matrices

		REAL(fpk), intent(in)					::	asy
		REAL(fpk), intent(in), dimension(:)		::	wgts
		REAL(fpk), intent(in), dimension(:,:)	::	plegr
		REAL(fpk), intent(in)					::	asy_TL
		REAL(fpk), intent(out), dimension(:,:)	::	pf, pb
		REAL(fpk), intent(out), dimension(:,:)	::	pf_TL, pb_TL

		integer :: j, k, l, isign, npts, nleg
		REAL(fpk)	:: norm, pp, norm_TL, pp_TL

	pf = ZERO  ! initialize matrices
	pb = ZERO
	pf_TL = ZERO
	pb_TL = ZERO
	npts = size(wgts)
	nleg = size(plegr, 1)
	do j = 1, npts    ! up-going input angles
		norm_TL = ZERO
		norm = ZERO
		do k = 1, npts 	! out-going angles
		  isign = 1
		  do l = 1, nleg ! sum up necessary # of terms
    		pp = (2*l-ONE) * plegr(l,j) * plegr(l,k)
			if (l == 1) then
				pp_TL = ZERO
			else
				pp_TL = (l-ONE) * asy**(l-TWO) *asy_TL * pp
			endif
			pp = pp * asy**(l-1)
			pf_TL(j,k) = pf_TL(j,k) + pp_TL
    		pf( j, k) = pf( j, k) + pp
			pb_TL(j,k) = pb_TL(j,k) + isign * pp_TL
    		pb( j, k) = pb( j, k) + isign * pp
    		isign = -isign
		  end do
		  norm = norm + (pf(j,k) + pb(j,k)) * wgts(k)
		  norm_TL = norm_TL + (pf_TL(j,k) + pb_TL(j,k)) * wgts(k)
		end do
		pf_TL(j,:) = pf_TL(j,:)/norm - pf(j,:)/(norm*norm) * norm_TL
		pf(j,:) = pf(j,:) /norm
		pb_TL(j,:) = pb_TL(j,:)/norm - pb(j,:)/(norm*norm) * norm_TL
		pb(j,:) = pb(j,:) /norm
	enddo

	END SUBROUTINE hg_phase_function_TL

	SUBROUTINE hg_phase_function_AD(asy, &   ! assymetry parameter
									wgts, & ! weights
									plegr, & ! legendre polynomials
									pf, pb, & ! pre-computed phase matrices
									norm, & ! pre-computed normalization vector
									pf_AD, & ! input, AD of pf
									pb_AD, & ! input, AD of pb
									asy_AD ) ! output, AD of asy

		REAL(fpk), intent(in)					::	asy
		REAL(fpk), intent(in), dimension(:)		::	wgts
		REAL(fpk), intent(in), dimension(:,:)	::	plegr
		REAL(fpk), intent(in), dimension(:,:)	::	pf, pb
		REAL(fpk), intent(in), dimension(:)		::	norm
		REAL(fpk), intent(inout), dimension(:,:)	::	pf_AD, pb_AD
		REAL(fpk), intent(inout)					::	asy_AD

		integer :: j, k, l, isign, npts, nleg
		REAL(fpk)	::  norm_AD

		npts = size(wgts)
		nleg = size(plegr, 1)

! ADJOINT CALCULATIONS
		do j = 1, npts
			norm_AD = -sum(pf(j,:) * pf_AD(j,:) + pb(j,:)*pb_AD(j,:))/norm(j)
			pb_AD(j,:) = pb_AD(j,:) / norm(j)
			pf_AD(j,:) = pf_AD(j,:) / norm(j)
			do k = 1, npts
				pf_ad(j,k) = norm_ad * wgts(k) + pf_ad(j,k)
				pb_ad(j,k) = norm_ad * wgts(k) + pb_ad(j,k)
				isign = -1
				do l = 2, nleg
					asy_AD = asy_AD + (TWO*l-ONE)*(l-ONE)*asy**(l-TWO)*plegr(l,j)*plegr(l,k) &
							* ( pf_ad(j,k) + isign*pb_ad(j,k) )
					isign = -isign
				enddo
			enddo
		enddo

	END SUBROUTINE hg_phase_function_AD

	SUBROUTINE calc_plegr(	pts, & ! vector of mu-values
							nleg, & ! # of nlegendre terms to use
							plegr ) ! output array

		! note: nleg = 2*(npts-1) for usual normalization

		REAL(fpk), intent(in), dimension(:)		::	pts
		INTEGER, intent(in)					::	nleg
		REAL(fpk), intent(out), dimension(:,:)	::  plegr
		REAL(fpk), DIMENSION(nleg)				::	leg

		integer 	::	i, j, npts

		npts = size(pts)

		do i = 1, npts
			call pleg( pts(i), nleg, leg )
			do j = 1, nleg
				plegr( j, i ) = leg( j )
			enddo
    	enddo

	END SUBROUTINE calc_plegr

	SUBROUTINE pleg( x,      &   ! Input
            	     nleg,   &   ! Input
             	     p       )   ! Output

		!------------
		!  Arguments
		!------------

		REAL(fpk)    x
		INTEGER nleg
		REAL(fpk)    p( nleg )

		INTEGER i

		P( 1 ) = ONE
		P( 2 ) = x
		DO i = 3, nleg
		  p( i ) = ( ( TWO * i - 3.0_fpk ) * x * p( i - 1 ) - &
					( i - TWO ) * p( i - 2 ) ) / ( i - ONE )
		ENDDO

	END SUBROUTINE pleg

END MODULE SOI_hg_phase_function


c ------------
c NCLFORTSTART
      SUBROUTINE DCDFCDFTT(N, P, T, DF, IER )
c NCL: p = cdft_t(p,df)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION P(N),DF(N)
c output
      INTEGER IER
      DOUBLE PRECISION T(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,BOUND

C iwhich = 2 : Calculate T from P and DF
c              Q not returned
      WHICH = 2
      BOUND = -999.D0
      DO I=1,N
         Q = 1.0D0 - P(I)
         CALL CDFT(WHICH,P(I),Q,T(I),DF(I),IER,BOUND)
         IF (IER.NE.0) CALL DCDFTERR('CDFT_T',IER)
      END DO

      RETURN
      END
c ------------
c NCLFORTSTART
      SUBROUTINE DCDFCDFTP(N, P, T, DF, IER )
c NCL: p = cdft_p(t,df)
      IMPLICIT NONE
c input
      INTEGER N
      DOUBLE PRECISION T(N),DF(N)
c output
      INTEGER IER
      DOUBLE PRECISION P(N)
c NCLEND
c local
      INTEGER WHICH, I
      DOUBLE PRECISION Q,BOUND

C iwhich = 1 : Calculate P from T and DF
c              Q not returned
      WHICH = 1
      BOUND = -999.D0
      DO I=1,N
         Q = 1.0D0 - P(I)
         CALL CDFT(WHICH,P(I),Q,T(I),DF(I),IER,BOUND)
         IF (IER.NE.0) CALL DCDFTERR('CDFT_T',IER)
      END DO

      RETURN
      END
c ------------
      SUBROUTINE DCDFTERR(NAME,IER)
c error messages for cdft_{t, p} functions
      IMPLICIT NONE
      CHARACTER*(*) NAME
      INTEGER IER

      IF (IER.NE.0) THEN
          IF (IER.LT.0) PRINT *,NAME,': bad input parameter, IER=', IER
          IF (IER.EQ.1) PRINT *,NAME,': lower bound error'
          IF (IER.EQ.2) PRINT *,NAME,': upper bound error'
          IF (IER.EQ.3) PRINT *,NAME,': P+Q .ne. 1'
      END IF
      RETURN
      END


program floor_03
  real :: x1, x2, x3
  real :: y1, y2, y3
  x1 = 3.3 ! 3
  x2 = 3.5 ! 3
  x3 = 3.7 ! 3
  y1 = -3.3 ! -4
  y2 = -3.5 ! -4
  y3 = -3.7 ! -4
  print*, floor(x1), floor(x2), floor(x3)
  print*, floor(y1), floor(y2), floor(y3)
end program


SUBROUTINE integr_rkn768(zo, step, lamda_h, z_q, e_r)

! ----------------------------------------------------------------------
! SUBROUTINE: integr_rkn768.f03
! ----------------------------------------------------------------------
! Purpose:
!  Runge-Kutta-Nystrom numerical integration methods
!  RKN7(6)-8 method by Dormand & Prince(1978) is implemented for satellite orbit integration
! ----------------------------------------------------------------------
! Input arguments:
! - zo:  		Initial epoch (to) and state vector in Celestial Reference System GCRS
!        		zo = [MJDo to ro vo]
!   			MJDo: initial epoch's Modified Julian Day (MJD) number (including the fraction of the day)
!   			ro:   Position vector at initial epoch in GCRS (m)
!   			vo:   Velocity vector at initial epoch in GCRS (m/sec)
! - step:		Integration stepsize (sec)
! - lamda_h:	RKN7(6)-8 specific parameter for stepsize control
!
! Output arguments
! - z_q:		State vector at the next epoch t=to+h in GCRS
! - e_r:   		Local truncation error of position vector
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	6 October 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN), DIMENSION(8) :: zo
      REAL (KIND = prec_d), INTENT(IN) :: step
      REAL (KIND = prec_d), INTENT(IN) :: lamda_h
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(6) :: z_q
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(3) :: e_r
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: h, to, mjd_t, mjd_to, t_sec
      REAL (KIND = prec_d), DIMENSION(9) :: t
      REAL (KIND = prec_d), DIMENSION(3) :: ro, vo
      REAL (KIND = prec_d), DIMENSION(3) :: ri1, vi1
      REAL (KIND = prec_d), DIMENSION(3) :: r_q, v_q, r_p, er, ev
      REAL (KIND = prec_d), DIMENSION(3,9) :: r, k
      REAL (KIND = prec_d), DIMENSION(3) :: sum_ak
      REAL (KIND = prec_d), DIMENSION(9) :: c, b, b1, b2
      REAL (KIND = prec_d), DIMENSION(9,8) :: a
      REAL (KIND = prec_d), DIMENSION(8,9) :: a_transp
      INTEGER (KIND = prec_int4) :: s, i, j
      REAL (KIND = prec_d) :: fx, fy, fz
	  REAL (KIND = prec_d), DIMENSION(3) :: sum_bk, sum_b1k, sum_b2k
! ----------------------------------------------------------------------

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Integration step
h = step
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% Initial Conditions
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% Initial epoch
! MJD
mjd_to = zo(1)
! Seconds at MJDo since 00h
to = zo(2) !to = (mjd_to - INT(mjd_to)) * (24.D0 * 3600.D0)

!% Initial position and velocity vectors
ro = zo(3:5)
vo = zo(6:8)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Coefficients ci, aij, bi
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! s-stage Function evaluations k(s), s=0..to...
s = 8

!% order p=7

! ci coefficients, i=0,....,s
!c=[ 0
!    1/10
!    1/5
!    3/8
!    1/2
!    (7-sqrt(21))/14
!    (7+sqrt(21))/14
!    1
!    1];
c(1:9) = (/ 0.D0, 1.D0/10.D0, 1.D0/5.D0, 3.D0/8.D0, 1.D0/2.D0, (7.D0-sqrt(21.D0))/14.D0, (7.D0+sqrt(21.D0))/14.D0, 1.D0, 1.D0 /)

! ----------------------------------------------------------------------
! aij coefficients, i=1,....,s, j=0,...,s-1
! ----------------------------------------------------------------------
!a=[  NaN                         NaN                            NaN                             NaN                                 NaN                          NaN                          NaN                  NaN
!    1/200                        NaN                            NaN                             NaN                                 NaN                          NaN                          NaN                  NaN
!    1/150                        1/75                           NaN                             NaN                                 NaN                          NaN                          NaN                  NaN
!    171/8192                     45/4096                        315/8192                        NaN                                 NaN                          NaN                          NaN                  NaN
!    5/288                        25/528                         25/672                          16/693                              NaN                          NaN                          NaN                  NaN
!    (1003-205*sqrt(21))/12348   -25*(751-173*sqrt(21))/90552    25*(624-137*sqrt(21))/43218    -128*(361-79*sqrt(21))/237699        (3411-745*sqrt(21))/24696    NaN                          NaN                  NaN
!    (793+187*sqrt(21))/12348    -25*(331+113*sqrt(21))/90552    25*(1044+247*sqrt(21))/43218   -128*(14885+3779*sqrt(21))/9745659   (3327+797*sqrt(21))/24696   -(581+127*sqrt(21))/1722      NaN                  NaN
!    -(157-3*sqrt(21))/378        25*(143-10*sqrt(21))/2772     -25*(876+55*sqrt(21))/3969       1280*(913+18*sqrt(21))/596673      -(1353+26*sqrt(21))/2268      7*(1777+377*sqrt(21))/4428   7*(5-sqrt(21))/36    NaN
!    1/20                         0                              0                               0                                   8/45                         7*(7+sqrt(21))/360           7*(7-sqrt(21))/360   0   ];

a(1,1:8) = (/ 0.0D0, 0.0D0, 0.0D0, 0.0D0,  0.0D0, 0.0D0, 0.0D0, 0.0D0 /)
a(2,1:8) = (/ 1.D0/200.D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0 /)
a(3,1:8) = (/ 1.D0/150.D0,   1.D0/75.D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0 /)
a(4,1:8) = (/ 171.D0/8192.D0,   45.D0/4096.D0,   315.D0/8192.D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0 /)
a(5,1:8) = (/ 5.D0/288.D0,   25.D0/528.D0,   25.D0/672.D0,   16.D0/693.D0,   0.0D0,   0.0D0,   0.0D0,   0.0D0 /)

!!a(6,1:5) = (/ (1003.D0-205.D0*sqrt(21.D0))/12348.D0,   -25.D0*(751.D0-173.D0*sqrt(21.D0))/90552.D0,   25.D0*(624.D0-137.D0*sqrt(21.D0))/43218.D0,   -128.D0*(361.D0-79.D0*sqrt(21.D0))/237699.D0,   (3411.D0-745.D0*sqrt(21.D0))/24696.D0, 	 0.0D0,   0.0D0,   0.0D0 /)
a(6,1) = (1003.D0-205.D0*sqrt(21.D0))/12348.D0
a(6,2) = -25.D0*(751.D0-173.D0*sqrt(21.D0))/90552.D0
a(6,3) = 25.D0*(624.D0-137.D0*sqrt(21.D0))/43218.D0
a(6,4) = -128.D0*(361.D0-79.D0*sqrt(21.D0))/237699.D0
a(6,5) = (3411.D0-745.D0*sqrt(21.D0))/24696.D0
a(6,6:8) = (/ 0.0D0,   0.0D0,   0.0D0 /)

!a(7,1:8) = (/ (793.D0+187.D0*sqrt(21.D0))/12348.D0,   -25.D0*(331.D0+113.D0*sqrt(21.D0))/90552.D0,   25.D0*(1044.D0+247.D0*sqrt(21.D0))/43218.D0,   -128.D0*(14885.D0+3779.D0*sqrt(21.D0))/9745659.D0,   (3327.D0+797.D0*sqrt(21.D0))/24696.D0,   -(581.D0+127.D0*sqrt(21.D0))/1722.D0,   0.0D0,   0.0D0 /)
a(7,1) = (793.D0+187.D0*sqrt(21.D0))/12348.D0
a(7,2) = -25.D0*(331.D0+113.D0*sqrt(21.D0))/90552.D0
a(7,3) = 25.D0*(1044.D0+247.D0*sqrt(21.D0))/43218.D0
a(7,4) = -128.D0*(14885.D0+3779.D0*sqrt(21.D0))/9745659.D0
a(7,5) = (3327.D0+797.D0*sqrt(21.D0))/24696.D0
a(7,6) = -(581.D0+127.D0*sqrt(21.D0))/1722.D0
a(7,7) = 0.0D0
a(7,8) = 0.0D0

!a(8,1:8) = (/ -(157.D0-3.D0*sqrt(21.D0))/378.D0,   25.D0*(143.D0-10.D0*sqrt(21.D0))/2772.D0,   -25.D0*(876.D0+55.D0*sqrt(21.D0))/3969.D0,  	1280.D0*(913.D0+18.D0*sqrt(21.D0))/596673.D0,   -(1353.D0+26.D0*sqrt(21.D0))/2268.D0,  	7.D0*(1777.D0+377.D0*sqrt(21.D0))/4428.D0,   7.D0*(5.D0-sqrt(21.D0))/36.D0,   0.0D0 /)
a(8,1) = -(157.D0-3.D0*sqrt(21.D0))/378.D0
a(8,2) = 25.D0*(143.D0-10.D0*sqrt(21.D0))/2772.D0
a(8,3) = -25.D0*(876.D0+55.D0*sqrt(21.D0))/3969.D0
a(8,4) = 1280.D0*(913.D0+18.D0*sqrt(21.D0))/596673.D0
a(8,5) = -(1353.D0+26.D0*sqrt(21.D0))/2268.D0
a(8,6) = 7.D0*(1777.D0+377.D0*sqrt(21.D0))/4428.D0
a(8,7) = 7.D0*(5.D0-sqrt(21.D0))/36.D0
a(8,8) = 0.0D0

!a(9,1:8) = (/ 1.D0/20.D0,   0.D0,   0.D0,   0.D0,   8.D0/45.D0,   7.D0*(7.D0+sqrt(21.D0))/360.D0,   7.D0*(7.D0-sqrt(21.D0))/360.D0,   0.D0 /)
a(9,1:5) = (/ 1.D0/20.D0,   0.D0,   0.D0,   0.D0,   8.D0/45.D0 /)
a(9,6) = 7.D0*(7.D0+sqrt(21.D0))/360.D0
a(9,7) = 7.D0*(7.D0-sqrt(21.D0))/360.D0
a(9,8) = 0.D0
! ----------------------------------------------------------------------

!% position coefficients bi, order p+1,  i=0,....,s
!b1 = [ 1/20 0 0 0 8/45 7*(7+sqrt(21))/360 7*(7-sqrt(21))/360 0 0 ]';
b1(1:9) = (/ 1.D0/20.D0, 0.D0, 0.D0, 0.D0, 8.D0/45.D0, 7.D0*(7.D0+sqrt(21.D0))/360.D0, 7.D0*(7.D0-sqrt(21.D0))/360.D0, 0.D0, 0.D0 /)

!% position coefficients bi, order p,  i=0,....,s
!b = [ 1/20 0 0 0 8/45 7*(7+sqrt(21))/360 7*(7-sqrt(21))/360 -lamda_h lamda_h ]';
b(1:9) = (/ 1.D0/20.D0, 0.D0, 0.D0, 0.D0, 8.D0/45.D0, 7.D0*(7.D0+sqrt(21.D0))/360.D0, 7.D0*(7.D0-sqrt(21.D0))/360.D0,  &
           -lamda_h, lamda_h /)

!% velocity coefficients bi, order p+1(p),  i=0,....,s
!b2 = [ 1/20 0 0 0 16/45 49/180 49/180 1/20 0 ]';
b2(1:9) = (/ 1.D0/20.D0, 0.D0, 0.D0, 0.D0, 16.D0/45.D0, 49.D0/180.D0, 49.D0/180.D0, 1.D0/20.D0, 0.D0 /)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% Equations for the description of the Runge-Kutta-Nystrom method
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% Function evaluations K(i), i = 0,...,s
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! K(i) is expressed here as matrix K(:,i) = [Kx(i); Ky(i); Kz(i)]
sum_ak(1:3) = (/ 0.0D0, 0.0D0, 0.0D0 /)

DO i = 0 , s
    If (i == 0) Then

!%%      Function evaluations (ki) for State vector (z = [r v]')
        t(i+1) = to
        r(1:3,i+1) = ro

        !% random value for velocity v = vo:
        !% Force model is indepedent from velocity vector
		vi1 = vo

		ri1(1:3) = ro

		! MJD (in days) at ti including the fraction of the day
		mjd_t = INT(mjd_to) + t(i+1) / (24.D0 * 3600.D0)

		! Force model acceleration components
                t_sec = t(i+1)
		Call force_sum(mjd_t, t_sec, ri1, vi1, fx, fy, fz, i)

        k(1:3,i+1) = (/ fx, fy, fz /)

    Else

!%%      Function evaluations (ki) for State vector
        Do j = 0 , i-1
           !sum_ak = sum_ak + a(i+1,j+1) * k(:,j+1);
           sum_ak = sum_ak + a(i+1,j+1) * k(1:3,j+1)
        end do

		t(i+1) = to + c(i+1) * h
        r(1:3,i+1) = ro + c(i+1) * h * vo + h**2 * sum_ak

        sum_ak(1:3) = (/ 0.0D0, 0.0D0, 0.0D0 /)

		!% random value for velocity v = vo:
        !% Force model is indepedent from velocity vector
		vi1 = vo

		ri1(1:3) = r(1:3,i+1)

		! MJD (in days) at ti including the fraction of the day
		mjd_t = INT(mjd_to) + t(i+1) / (24.D0 * 3600.D0)

		! Force model acceleration components
                t_sec = t(i+1)
		Call force_sum(mjd_t, t_sec, ri1, vi1, fx, fy, fz, i)

        k(1:3,i+1) = (/ fx, fy, fz /)

    End If
End Do
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!% Increment function for State vector
sum_bk(1:3) = (/ 0.0D0, 0.0D0, 0.0D0 /)
sum_b1k(1:3) = (/ 0.0D0, 0.0D0, 0.0D0 /)
sum_b2k(1:3) = (/ 0.0D0, 0.0D0, 0.0D0 /)

Do i = 0 , s
    sum_bk = sum_bk + b(i+1) * k(:,i+1)
    sum_b1k = sum_b1k + b1(i+1) * k(:,i+1)
    sum_b2k = sum_b2k + b2(i+1) * k(:,i+1)
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% Solution
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%  Embedded Runge-Kutta method
!%  Position and velocity approximations of order q(p+1)
r_q = ro + h * vo + h**2 * sum_b1k
v_q = vo + h * sum_b2k

z_q(1:3) = r_q
z_q(4:6) = v_q
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!% Local truncation error
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%  Position approximation of lower order p
r_p = ro + h * vo + h**2 * sum_bk

!%  Local truncation error - Stepsize control
er = abs(r_q - r_p)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

e_r = er

END SUBROUTINE


module stats_mod
    implicit none

    private

    type, public :: descriptive_stats_t
        private
        integer :: nr_values = 0
        real :: sum = 0.0, sum2 = 0.0
    contains
        procedure, public, pass :: add_value, get_nr_values, get_mean, get_stddev
        procedure, private :: write_stats
        generic :: write(formatted) => write_stats
        procedure, private :: add_stats, stats_plus_value
    end type descriptive_stats_t

    interface operator(+)
        module procedure add_stats, stats_plus_value, value_plus_stats
    end interface

    interface operator(*)
        module procedure value_times_stats
    end interface

    public :: operator(+), operator(*)

contains

    subroutine add_value(stats, new_value)
        implicit none
        class(descriptive_stats_t), intent(inout) :: stats
        real, value :: new_value

        stats%nr_values = stats%nr_values + 1
        stats%sum = stats%sum + new_value
        stats%sum2 = stats%sum2 + new_value**2
    end subroutine add_value

    function get_nr_values(stats) result(nr_values)
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        integer :: nr_values

        nr_values = stats%nr_values
    end function get_nr_values

    function get_mean(stats) result(mean_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        real :: mean_value

        if (stats%nr_values == 0) then
            write (unit=error_unit, fmt='(A)') &
                'error: too few data value to compute mean'
            stop 1
        end if
        associate (n => stats%nr_values, sum => stats%sum)
            mean_value = sum/n
        end associate
    end function get_mean

    function get_stddev(stats) result(stddev_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        real :: stddev_value

        if (stats%nr_values < 2) then
            write (unit=error_unit, fmt='(A)') &
                'error: too few data values to compute stddev'
            stop 2
        end if
        associate (n => stats%nr_values, sum => stats%sum, sum2 => stats%sum2)
            stddev_value = sqrt((sum2 - sum**2/n)/(n - 1.0))
        end associate
    end function get_stddev

    subroutine write_stats(stats, unit_nr, iotype, v_list, iostat, iomsg)
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        integer, intent(in) :: unit_nr
        character(len=*), intent(in) :: iotype
        integer, dimension(:), intent(in) :: v_list
        integer, intent(out) :: iostat
        character(len=*), intent(inout) :: iomsg
        character(len=1024) :: fmt_str

        if (size(v_list) == 4) then
            write (fmt_str, '(A, 2(A, I0, A, I0), A)') &
                '("n = ", I0', &
                ', ", mean = ", F', v_list(1), '.', v_list(2), &
                ', ", stddev = ", F', v_list(3), '.', v_list(4), &
                ')'
            write (unit=unit_nr, fmt=fmt_str, iostat=iostat, iomsg=iomsg) &
                stats%get_nr_values(), stats%get_mean(), stats%get_stddev()
        else
            write (unit=unit_nr, fmt=*, iostat=iostat, iomsg=iomsg) &
                stats%get_nr_values(), stats%get_mean(), stats%get_stddev()
        end if
    end subroutine write_stats

    function add_stats(stats_lo, stats_ro) result(stats)
        implicit none
        class(descriptive_stats_t), intent(in) :: stats_lo, stats_ro
        type(descriptive_stats_t) :: stats

        stats%nr_values = stats_lo%nr_values + stats_ro%nr_values
        stats%sum = stats_lo%sum + stats_ro%sum
        stats%sum2 = stats_lo%sum2 + stats_ro%sum2
    end function add_stats

    function stats_plus_value(stats, val) result(new_stats)
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        real, intent(in) :: val
        type(descriptive_stats_t) :: new_stats

        new_stats%nr_values = stats%nr_values
        new_stats%sum = stats%sum + stats%nr_values*val
        new_stats%sum2 = stats%sum2 + 2.0*val*stats%sum + stats%nr_values*val**2
    end function stats_plus_value

    function value_plus_stats(val, stats) result(new_stats)
        implicit none
        class(descriptive_stats_t), intent(in) :: stats
        real, intent(in) :: val
        type(descriptive_stats_t) :: new_stats

        new_stats = stats_plus_value(stats, val)
    end function value_plus_stats

    function value_times_stats(val, stats) result(new_stats)
        implicit none
        real, intent(in) :: val
        class(descriptive_stats_t), intent(in) :: stats
        type(descriptive_stats_t) :: new_stats

        new_stats%nr_values = stats%nr_values
        new_stats%sum = val*stats%sum
        new_stats%sum2 = stats%sum2*val**2
    end function value_times_stats

end module stats_mod


*DECK DPCHCI
      SUBROUTINE DPCHCI (N, H, SLOPE, D, INCFD)
C***BEGIN PROLOGUE  DPCHCI
C***SUBSIDIARY
C***PURPOSE  Set interior derivatives for DPCHIC
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (PCHCI-S, DPCHCI-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C          DPCHCI:  DPCHIC Initial Derivative Setter.
C
C    Called by DPCHIC to set derivatives needed to determine a monotone
C    piecewise cubic Hermite interpolant to the data.
C
C    Default boundary conditions are provided which are compatible
C    with monotonicity.  If the data are only piecewise monotonic, the
C    interpolant will have an extremum at each point where monotonicity
C    switches direction.
C
C    To facilitate two-dimensional applications, includes an increment
C    between successive values of the D-array.
C
C    The resulting piecewise cubic Hermite function should be identical
C    (within roundoff error) to that produced by DPCHIM.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N
C        DOUBLE PRECISION  H(N), SLOPE(N), D(INCFD,N)
C
C        CALL  DPCHCI (N, H, SLOPE, D, INCFD)
C
C   Parameters:
C
C     N -- (input) number of data points.
C           If N=2, simply does linear interpolation.
C
C     H -- (input) real*8 array of interval lengths.
C     SLOPE -- (input) real*8 array of data slopes.
C           If the data are (X(I),Y(I)), I=1(1)N, then these inputs are:
C                  H(I) =  X(I+1)-X(I),
C              SLOPE(I) = (Y(I+1)-Y(I))/H(I),  I=1(1)N-1.
C
C     D -- (output) real*8 array of derivative values at data points.
C           If the data are monotonic, these values will determine a
C           a monotone cubic Hermite function.
C           The value corresponding to X(I) is stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C           No other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in D.
C           This argument is provided primarily for 2-D applications.
C
C    -------
C    WARNING:  This routine does no validity-checking of arguments.
C    -------
C
C  Fortran intrinsics used:  ABS, MAX, MIN.
C
C***SEE ALSO  DPCHIC
C***ROUTINES CALLED  DPCHST
C***REVISION HISTORY  (YYMMDD)
C   820218  DATE WRITTEN
C   820601  Modified end conditions to be continuous functions of
C           data when monotonicity switches in next interval.
C   820602  1. Modified formulas so end conditions are less prone
C             to over/underflow problems.
C           2. Minor modification to HSUM calculation.
C   820805  Converted to SLATEC library version.
C   870813  Minor cosmetic changes.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR section in prologue.  (WRB)
C   930503  Improved purpose.  (FNF)
C***END PROLOGUE  DPCHCI
C
C  Programming notes:
C     1. The function  DPCHST(ARG1,ARG2)  is assumed to return zero if
C        either argument is zero, +1 if they are of the same sign, and
C        -1 if they are of opposite sign.
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD
      DOUBLE PRECISION  H(*), SLOPE(*), D(INCFD,*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, NLESS1
      DOUBLE PRECISION  DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, HSUM,
     *      HSUMT3, THREE, W1, W2, ZERO
      SAVE ZERO, THREE
      DOUBLE PRECISION  DPCHST
C
C  INITIALIZE.
C
      DATA  ZERO /0.D0/, THREE/3.D0/
C***FIRST EXECUTABLE STATEMENT  DPCHCI
      NLESS1 = N - 1
      DEL1 = SLOPE(1)
C
C  SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION.
C
      IF (NLESS1 .GT. 1)  GO TO 10
      D(1,1) = DEL1
      D(1,N) = DEL1
      GO TO 5000
C
C  NORMAL CASE  (N .GE. 3).
C
   10 CONTINUE
      DEL2 = SLOPE(2)
C
C  SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
C     SHAPE-PRESERVING.
C
      HSUM = H(1) + H(2)
      W1 = (H(1) + HSUM)/HSUM
      W2 = -H(1)/HSUM
      D(1,1) = W1*DEL1 + W2*DEL2
      IF ( DPCHST(D(1,1),DEL1) .LE. ZERO)  THEN
         D(1,1) = ZERO
      ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO)  THEN
C        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
         DMAX = THREE*DEL1
         IF (ABS(D(1,1)) .GT. ABS(DMAX))  D(1,1) = DMAX
      ENDIF
C
C  LOOP THROUGH INTERIOR POINTS.
C
      DO 50  I = 2, NLESS1
         IF (I .EQ. 2)  GO TO 40
C
         HSUM = H(I-1) + H(I)
         DEL1 = DEL2
         DEL2 = SLOPE(I)
   40    CONTINUE
C
C        SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC.
C
         D(1,I) = ZERO
         IF ( DPCHST(DEL1,DEL2) .LE. ZERO)  GO TO 50
C
C        USE BRODLIE MODIFICATION OF BUTLAND FORMULA.
C
         HSUMT3 = HSUM+HSUM+HSUM
         W1 = (HSUM + H(I-1))/HSUMT3
         W2 = (HSUM + H(I)  )/HSUMT3
         DMAX = MAX( ABS(DEL1), ABS(DEL2) )
         DMIN = MIN( ABS(DEL1), ABS(DEL2) )
         DRAT1 = DEL1/DMAX
         DRAT2 = DEL2/DMAX
         D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2)
C
   50 CONTINUE
C
C  SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
C     SHAPE-PRESERVING.
C
      W1 = -H(N-1)/HSUM
      W2 = (H(N-1) + HSUM)/HSUM
      D(1,N) = W1*DEL1 + W2*DEL2
      IF ( DPCHST(D(1,N),DEL2) .LE. ZERO)  THEN
         D(1,N) = ZERO
      ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO)  THEN
C        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
         DMAX = THREE*DEL2
         IF (ABS(D(1,N)) .GT. ABS(DMAX))  D(1,N) = DMAX
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C------------- LAST LINE OF DPCHCI FOLLOWS -----------------------------
      END


        subroutine midpoint(a1,a2,a3,b1,b2,b3,m1,m2,m3)
        implicit real*8 (A-Z)

        call normalize(a1,a2,a3,maga)
        call normalize(b1,b2,b3,magb)
        m1 = 0.5d0 * (a1+b1)
        m2 = 0.5d0 * (a2+b2)
        m3 = 0.5d0 * (a3+b3)
        call normalize(m1,m2,m3,magm)

        return
        end

        subroutine anglevectors(a1,a2,a3,b1,b2,b3,angle)
        implicit real*8 (A-Z)

        maga = mag(a1,a2,a3)
        magb = mag(b1,b2,b3)

        call crossproduct(a1,a2,a3,b1,b2,b3,c1,c2,c3)

        magc = mag(c1,c2,c3)

        sinangle = magc/(maga*magb)
        cosangle = dotproduct(a1,a2,a3,b1,b2,b3)/(maga*magb)

        angle = atan2(sinangle,cosangle)

        return
        end

        function dotproduct(a1,a2,a3,b1,b2,b3)
        implicit real*8 (A-Z)

        dotproduct  = a1 * b1 + a2 * b2 + a3 * b3

        return
        end

        function angle_vectors(a1,a2,a3,b1,b2,b3)
        implicit real*8 (A-Z)

        maga = mag(a1,a2,a3)
        magb = mag(b1,b2,b3)

        call crossproduct(a1,a2,a3,b1,b2,b3,c1,c2,c3)

        magc = mag(c1,c2,c3)

        sinangle = magc/(maga*magb)
        cosangle = dotproduct(a1,a2,a3,b1,b2,b3)/(maga*magb)

        angle_vectors = atan2(sinangle,cosangle)

        return
        end

        subroutine normalize(a1,a2,a3,maga)
        implicit real*8 (A-Z)

        maga    = sqrt(a1*a1+a2*a2+a3*a3)

        if(maga .ne. 0.)then

            magainv = 1.d0/maga

            a1 = a1 * magainv
            a2 = a2 * magainv
            a3 = a3 * magainv

        endif

        return
        end

        function mag(a1,a2,a3)
        implicit real*8 (A-Z)

        mag    = sqrt(a1*a1+a2*a2+a3*a3)

        return
        end

        subroutine xyztolatlon(x,y,z,lat,lon)
        implicit real*8 (A-Z)

        lat = atan(z/sqrt(x**2 + y**2))
        lon = atan3(y,x)

        return
        end

        subroutine latlontoxyz(lat,lon,x,y,z)
        implicit real*8 (A-Z)

        x = cos(lon)*cos(lat)
        y = sin(lon)*cos(lat)
        z = sin(lat)

        return
        end

        subroutine crossproduct(a1,a2,a3,b1,b2,b3,c1,c2,c3)
        implicit real*8 (A-Z)

        c1   = a2 * b3 - a3 * b2
        c2   = a3 * b1 - a1 * b3
        c3   = a1 * b2 - a2 * b1

        return
        end


      subroutine dfftr (x,nft,dirctn,delta)
c                                              a.shakal, 1/78, 15 jul 80
c           this subroutine does a fast fourier transform on a real
c        time series.  it requires 1/2 the storage and e1/2 the time
c        required by a complex fft.
c
c     forward transform, "call dfftr(x,nft,'forward',dt)":
c           input = x(1),x(2),..,x(nft) = real time series of nft points
c          output = x(1),x(2),..,x(nft+2) = nft/2+1 complex spectral poi
c        these spectral points are identical to the first nft/2+1 return
c        by subroutine fft (i.e., pos freq terms).  thus, the coefficien
c        at fj, the j-th frequency point (where fj = (j-1)*delf, j=1,nft
c        and delf = 1/(nft*dt)), is in x(i-1),x(i), where i=2j.  x(1) is
c        dc term, x(2) = 0 (because real time series), x(nft+1) is real
c        of nyquist coef, and x(nft+2) is imaginary part (0 because real
c        series).
c
c     inverse transform, "call dfftr(x,nft,'inverse',delf)":
c        input and output are interchanged.
c
c           if this subroutine is called with 'forward', and then with '
c        and delf of 1/(nft*dt), the original time series is recovered.
c        identical results (but for scaling) can be obtained by calling
c        fft(x,nft,isign), but in fft a real time series must be stored
c        complex array with zero imaginary parts, which requires 2*nft p
c        of array x.  also, the coefs returned by the fft will differ by
c        n-scaling, since fft's leave out the dt,delf of the approximate
c        integrations.  this subroutine calls fft.
c           this subroutine is a modification of the subroutine 'fftr',
c        written by c.frasier.  the principal modifications are:
c             1) the delt,delf of the integrations are included to make
c                a discrete approximation to the fourier transform.
c             2) the storage of the spectrum (on output if forward, or i
c                if inverse) has x(2) = zero, with the nyquist component
c                x(nft+1), with x(nft+2) = 0.
c
      logical forwrd, invrse
      character dirctn*7
      complex  csign, c1, c2, c3, speci, specj
      real x(nft)
      pi = 3.1415927
c
      call lowcas(dirctn,invrse,forwrd)
c
      nftby2 = nft/2
      if (.not.(forwrd)) go to 20001
c            forward transform..
      call fft (x,nftby2,-1)
      x1 = x(1)
      x(1) = x1 + x(2)
      x(2) = x1 - x(2)
      sign = -1.
      go to 20002
20001 if (.not.(invrse)) go to 10001
c            adjust nyquist element storage for inverse transform
      x(2) = x(nft+1)
      x(nft+1) = 0.
      sign = +1.
      go to 20002
10001 stop 'dirctn bad to dfftr'
c
c           manipulate elements as appropropriate for a 1/2 length
c        complex fft, after the forward fft, or before the inverse.
20002 piovrn = pi*sign/float(nftby2)
      csign = cmplx(0.,sign)
      do 10 i = 3,nftby2,2
      j = nft-i+2
      c1 = cmplx(x(i)+x(j), x(i+1)-x(j+1))
      c2 = cmplx(x(i)-x(j), x(i+1)+x(j+1))
      w = piovrn*float(i/2)
      c3 = cmplx(cos(w),sin(w))*c2
      speci = c1 + csign*c3
      x(i) = real(speci)/2.
      x(i+1) = aimag(speci)/2.
      specj = conjg(c1) + csign*conjg(c3)
      x(j) = real(specj)/2.
      x(j+1) = aimag(specj)/2.
   10 continue
      x(nftby2+2) = -x(nftby2+2)
      if (.not.(forwrd)) go to 20004
c            include dt of integration, for forward transform...
      dt = delta
      do 9000  i = 1,nft
 9000 x(i) = x(i)*dt
c            adjust storage of the nyquist component...
      x(nft+1) = x(2)
      x(nft+2) = 0.
      x(2) = 0.
      go to 20005
20004 if (.not.(invrse)) go to 10002
      x1 = x(1)
      x(1) = (x1+x(2))/2.
      x(2) = (x1-x(2))/2.
c            do the inverse transform...
      call fft (x,nftby2,+1)
c            in the inverse transform, include the df of the integration
c            and a factor of 2 because only doing half the integration
c            (i.e., just over the positive freqs).
      twodf = 2.*delta
      do 9002  i = 1,nft
 9002 x(i) = x(i)*twodf
10002 continue
20005 return
      end
      subroutine fft(data,nn,isign)
c                                              a.shakal, 1/78, 10 jul 80
c        cooley-tukey 'fast fourier trnasform' in ansi fortran 77.
c
c           transform(j) = sum {data(i)*w**u(i-1)*(j-1)e}, where i and
c        j run from 1 to nn, and w = exp(sign*twopi*sqrtu-1e/nn).
c        data is a one-dimensional complex array (i.e., the real and
c        imaginary parts of the data are located immediately adjacent
c        in storage, such as fortran places them) whose length nn is
c        a power of two.  isign is +1 or -1, giving the sign of the
c        transform.  transform values are returned in array data,
c        replacing the input data.  the time is proportional to
c        n*log2(n), rather than the non-fft n**2.  modified from the
c        fortran ii coding from n.brenner's mit-ll tech rept.
c
      real data(1)
      pi = 3.1415926
c
      n = 2*nn
      j = 1
      do 5 i = 1,n,2
      if (.not.(i .lt. j)) go to 20001
      tempr = data(j)
      tempi = data(j+1)
      data(j) = data(i)
      data(j+1) = data(i+1)
      data(i) = tempr
      data(i+1) = tempi
20001 m = n/2
    3 if (.not.(j .gt. m)) go to 20004
      j = j-m
      m = m/2
      if (m .ge. 2) go to 3
20004 j = j+m
   5  continue
c
c
      mmax = 2
    6 if (.not.(mmax .ge. n)) go to 20007
      return
20007 if (.not.(mmax .lt. n)) go to 10001
      istep = 2*mmax
      pibymx = pi*float(isign)/float(mmax)
c
      do 8 m = 1,mmax,2
      theta = pibymx*float(m-1)
      wr = cos(theta)
      wi = sin(theta)
      do 8 i = m,n,istep
      j = i + mmax
      tempr = wr*data(j) - wi*data(j+1)
      tempi = wr*data(j+1) + wi*data(j)
      data(j) = data(i) - tempr
      data(j+1) = data(i+1) - tempi
      data(i) = data(i) + tempr
      data(i+1) = data(i+1) + tempi
   8  continue
      mmax = istep
      go to 6
10001 continue
20008 return
      end
      subroutine lowcas(dirctn,invrse,forwrd)
      character dirctn*7
      logical forwrd,invrse
      if(dirctn.eq.'forward') go to 1
      if(dirctn.eq.'inverse') go to 2
      write(1,100)dirctn
  100 format(1x,a7,2x,'is meaningless to dfftr, use forward or inverse
     *only')
      invrse=.false.
      forwrd=.false.
      return
    1 invrse=.false.
      forwrd=.true.
      return
    2 invrse=.true.
      forwrd=.false.
      return
      end


program gen_be_stage4_global

   use da_control, only : stderr, stdout, filename_len, pi, gaussian_lats
   use da_be_spectral, only : da_vv_to_v_spectral, da_initialize_h, &
      da_calc_power
   use da_tools_serial, only : da_get_unit,da_advance_cymdh

   implicit none

   character*10        :: start_date, end_date       ! Starting and ending dates.
   character*10        :: date, new_date             ! Current date (ccyymmddhh).
   character*10        :: variable                   ! Variable name
   character(len=filename_len)        :: filename                   ! Input filename.
   character*2         :: ck                         ! Loop index -> character.
   character*3         :: ce                         ! Member index -> character.
   integer             :: ni, nj, nk                 ! Dimensions read in.
   integer             :: num_states                 ! Number of data times.
   integer             :: sdate, cdate, edate        ! Starting, current ending dates.
   integer             :: interval                   ! Period between dates (hours).
   integer             :: k, member, n               ! Loop counters.
   integer             :: ne                         ! Number of ensemble members.
   integer             :: max_wavenumber             ! Smallest scale required (ni/2 - 1).
   integer             :: inc                        ! Jump between elements of vector in array.
   integer             :: lenr                       ! FFT array dimension (at least inc*(n-1)+1).
   integer             :: lensav                     ! wsave dimension (n+int(log(real(ni)))+4).
   integer             :: lenwrk                     ! Dimension of work array.
   integer             :: alp_size                   ! Ass. Leg. Pol. array size.
   integer             :: r_cvsize                   ! Real control variable array size.

   logical             :: first_time                 ! True if first time through loop.
   logical             :: testing_spectral           ! True if testing spectral transforms.
   real                :: pi_over_180                ! pi / 180
   real                :: coeffa, coeffb             ! Accumulating mean coefficients.
   real                :: variance                   ! Variance (sum of power spectra) .

   real, allocatable   :: field(:,:)                 ! Gridpoint field to be decomposed.

   real, allocatable   :: lat(:)                     ! Latitude (radians).
   real, allocatable   :: sinlat(:)                  ! sine(latitude).
   real, allocatable   :: coslat(:)                  ! cosine(latitude).
   real, allocatable   :: int_wgts(:)                ! Legendre integration weights.
   real, allocatable   :: lon(:)                     ! Longitude (radians).
   real, allocatable   :: sinlon(:)                  ! sine(longitude).
   real, allocatable   :: coslon(:)                  ! cosine(longitude).
   real, allocatable   :: wsave(:)                   ! Prime values for fast Fourier transform.
   real, allocatable   :: alp(:)                     ! Associated Legendre Polynomial.
   real, allocatable   :: power(:)                   ! Power spectrum (n).
   real, allocatable   :: total_power(:)             ! Total Power spectrum (averaged over time/members).

   real, allocatable   :: rcv(:)                     ! Control variable vector.

   namelist / gen_be_stage4_global_nl / start_date, end_date, interval, variable, gaussian_lats, &
                                        testing_spectral, ne, k

   integer :: ounit,iunit,namelist_unit

   stderr = 0
   stdout = 6

   call da_get_unit(ounit)
   call da_get_unit(iunit)
   call da_get_unit(namelist_unit)

   pi_over_180 = pi / 180.0

   write(unit=6,fmt='(a/)') "[1] Read in 2D perturbation fields for variable , variable"

   start_date = '2004030312'
   end_date = '2004033112'
   interval = 24
   variable = 'psi'
   gaussian_lats = .false.
   ne = 1
   k = 1

   open(unit=namelist_unit, file='gen_be_stage4_global_nl.nl', &
        form='formatted', status='old', action='read')
   read(namelist_unit, gen_be_stage4_global_nl)
   close(namelist_unit)

   write(ck,'(i2)')k
   if ( k < 10 ) ck = '0'//ck(2:2)

   read(start_date(1:10), fmt='(i10)')sdate
   read(end_date(1:10), fmt='(i10)')edate
   write(unit=6,fmt='(4a)') 'Computing horizontal power spectra for period' , start_date, 'to' , end_date
   write(unit=6,fmt='(a,i8,a)') 'Interval between dates =' , interval,' hours'
   write(unit=6,fmt='(a,i8)') 'Number of ensemble members at each time =', ne
   write(unit=6,fmt='(3a,i4)') 'Variable' , variable,' at level' , k

   date = start_date
   cdate = sdate
   first_time = .true.
   num_states = 1

   do while ( cdate <= edate )
      do member = 1, ne
         write(ce,'(i3.3)')member

         ! write(6,(5a,i4))    Calculate spectra for date , date, , variable , trim(variable), &
         !    and member , member

         ! Read in data for given variable/level/time/member:

         filename = trim(variable)//'/'//date(1:10)//'.'//trim(variable)
         filename = trim(filename)//'.e'//ce//'.'//ck
         open (iunit, file = filename, form='unformatted')
         read(iunit)ni, nj, nk ! nk not used.

         if ( first_time ) then
            write(6,'(a,3i8)')'    i, j, k dimensions are ', ni, nj, nk
            allocate( field(1:ni,1:nj) )
         end if
         read(iunit)field
         close(iunit)

         if ( first_time ) then

            write(unit=6,fmt='(a)') "Initialize spectral transforms"

            inc = 1
            lenr = inc * (ni - 1 ) + 1
            lensav = ni + int(log(real(ni))) + 4
            lenwrk = ni

            allocate( lat(1:nj) )
            allocate( sinlat(1:nj) )
            allocate( coslat(1:nj) )
            allocate( int_wgts(1:nj) )
            allocate( lon(1:ni) )
            allocate( sinlon(1:ni) )
            allocate( coslon(1:ni) )
            allocate( wsave(1:lensav) )

            max_wavenumber =  ni / 2 - 1
            allocate ( power(0:max_wavenumber) )
            allocate ( total_power(0:max_wavenumber) )
            total_power(:) = 0.0

            alp_size = ( nj + 1 ) * ( max_wavenumber + 1 ) * ( max_wavenumber + 2 ) / 4
            allocate( alp( 1:alp_size) )

            call da_initialize_h( ni, nj, max_wavenumber, lensav, alp_size, &
                                  wsave, lon, sinlon, coslon, lat, sinlat, coslat, &
                                  int_wgts, alp )

            r_cvsize = ( max_wavenumber + 1 ) * ( max_wavenumber + 2 )
            allocate( rcv( 1:r_cvsize) )

            ! Test horizontal transforms:
            ! if ( testing_spectral ) then
            !    call da_test_spectral( ni, nj, max_wavenumber, inc, lenr, lensav, lenwrk, &
            !       alp_size, r_cvsize, alp, wsave, int_wgts, field )
            ! end if
            first_time = .false.
         end if

         write(unit=6,fmt='(a)') "Perform gridpoint to spectral decomposition"

         call da_vv_to_v_spectral( ni, nj, max_wavenumber, inc, lenr, lensav, lenwrk, &
                                   alp_size, r_cvsize, alp, wsave, int_wgts, rcv, field )

         write(unit=6,fmt='(a)') "Calculate power spectra"

         call da_calc_power( max_wavenumber, r_cvsize, rcv, power )

         coeffa = 1.0 / real(num_states)
         coeffb = real(num_states-1) * coeffa

         do n = 0, max_wavenumber
            total_power(n) = total_power(n) * coeffb + power(n) * coeffa
            ! write(6,(2i4,2f18.6))num_states, n, power(n), total_power(n)
         end do

         num_states = num_states + 1
      end do  ! End loop over ensemble members.

      ! Calculate next date:
      call da_advance_cymdh( date, interval, new_date )
      date = new_date
      read(date(1:10), fmt='(i10)')cdate

   end do     ! End loop over times.

   variance = sum( total_power(0:max_wavenumber) )
   write(6,'(3a,i2,a,1pe15.5)')' Variable = ', trim(variable), ', Vertical Index = ', &
                                k, ', Variance = ', variance

   filename = trim(variable)//'/'//trim(variable)
   filename = trim(filename)//'.'//ck//'.spectrum'
   open (ounit, file = filename, form='unformatted')
   write(ounit)variable
   write(ounit)max_wavenumber, k
   write(ounit)total_power

end program gen_be_stage4_global