!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
module hpsi_sub

interface hpsi
  module procedure hpsi_R,hpsi_C
end interface hpsi

contains

!===================================================================================================================================

SUBROUTINE hpsi_R(tpsi,htpsi,ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
                 ,V_local,ix_sta,ix_end,iy_sta,iy_end,iz_sta,iz_end,Nspin &
                 ,idx,idy,idz,lap0,lapt,is_table &
                 ,NI,Nps,Nlma,ia_table,Mps,Jxyz,uV,uVu &
                 ,nproc_Mxin_mul,irank_overlap,icomm_overlap,icomm_pseudo)
  use update_overlap_sub, only: update_overlap_R
  use stencil_sub, only: stencil_R
  implicit none
  integer,intent(in)  :: ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
                        ,ix_sta,ix_end,iy_sta,iy_end,iz_sta,iz_end,Nspin &
                        ,idx(ix_sta-4:ix_end+4),idy(iy_sta-4:iy_end+4),idz(iz_sta-4:iz_end+4) &
                        ,is_table(Norb) &
                        ,NI,Nps,Nlma,ia_table(Nlma),Mps(NI),Jxyz(3,Nps,NI) &
                        ,nproc_Mxin_mul,irank_overlap(6),icomm_overlap,icomm_pseudo
  real(8),intent(in)  :: tpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb) &
                        ,V_local(ix_sta:ix_end,iy_sta:iy_end,iz_sta:iz_end,1:Nspin) &
                        ,lap0,lapt(4,3),uV(Nps,Nlma),uVu(Nlma)
  real(8),intent(out) :: htpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb)
  !
  integer :: is,iorb

  if(nproc_Mxin_mul.ne.1) then
    call update_overlap_R(tpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb) &
                         ,ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb,4 &
                         ,ix_sta,ix_end,iy_sta,iy_end,iz_sta,iz_end,irank_overlap,icomm_overlap)
  end if

! stencil

  do iorb=1,Norb
    is = is_table(iorb)
    call stencil_R(tpsi(:,:,:,iorb),htpsi(:,:,:,iorb),ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end &
                  ,V_local(:,:,:,is),ix_sta,ix_end,iy_sta,iy_end,iz_sta,iz_end &
                  ,idx,idy,idz,lap0,lapt)

  end do

! pseudopotential

  call pseudo_R(tpsi,htpsi,ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
               ,NI,Nps,Nlma,ia_table,Mps,Jxyz,uV,uVu &
               ,nproc_Mxin_mul,icomm_pseudo)

  return
end subroutine hpsi_R

!===================================================================================================================================

SUBROUTINE hpsi_C(tpsi,htpsi,ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb & ! wavefunctions
                 ,V_local,ix_sta,ix_end,iy_sta,iy_end,iz_sta,iz_end,Nspin &         ! local potential
                 ,idx,idy,idz,lap0,lapt &                                           ! stencil
                 ,is_table,Nk &                                                     ! spin table & # of k points
                 ,NI,Nps,Nlma,ia_table,Mps,Jxyz,uV,uVu &                            ! pseudo potential
                 ,nproc_Mxin_mul,irank_overlap,icomm_overlap,icomm_pseudo &         ! MPI
                 ,ik_table,nabt,kAc,exp_ikr,ttpsi)                                  ! k vector & ttpsi
  use update_overlap_sub, only: update_overlap_C
  use stencil_sub, only: stencil_C
  implicit none
  integer   ,intent(in)  :: ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
                           ,ix_sta,ix_end,iy_sta,iy_end,iz_sta,iz_end,Nspin &
                           ,idx(ix_sta-4:ix_end+4),idy(iy_sta-4:iy_end+4),idz(iz_sta-4:iz_end+4) &
                           ,is_table(Norb),Nk &
                           ,NI,Nps,Nlma,ia_table(Nlma),Mps(NI),Jxyz(3,Nps,NI) &
                           ,nproc_Mxin_mul,irank_overlap(6),icomm_overlap,icomm_pseudo
  complex(8),intent(in)  :: tpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb)
  real(8)   ,intent(in)  :: V_local(ix_sta:ix_end,iy_sta:iy_end,iz_sta:iz_end,1:Nspin) &
                           ,lap0,lapt(4,3),uV(Nps,Nlma),uVu(Nlma)
  complex(8),intent(out) :: htpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb)
  !
  integer   ,optional,intent(in)  :: ik_table(Norb)
  real(8)   ,optional,intent(in)  :: nabt(4,3),kAc(Nk,3)
  complex(8),optional,intent(in)  :: exp_ikr(Nps,NI,Nk)
  complex(8),optional,intent(out) :: ttpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb)
  !
  integer :: is,iorb,ik,ix,iy,iz
  real(8) :: k_nabt(4,3),k2
  logical :: if_kAc

  if_kAc = present(kAc)

  if(nproc_Mxin_mul.ne.1) then
    call update_overlap_C(tpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb) &
                       ,ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb,4 &
                       ,ix_sta,ix_end,iy_sta,iy_end,iz_sta,iz_end,irank_overlap,icomm_overlap)
  end if

! stencil

  do iorb=1,Norb
    is = is_table(iorb)

    if(if_kAc) then
      ik = ik_table(iorb)
      k2 = 0.5d0* sum(kAc(ik,:)**2)
      k_nabt(:,1) = kAc(ik,1) * nabt(:,1)
      k_nabt(:,2) = kAc(ik,2) * nabt(:,2)
      k_nabt(:,3) = kAc(ik,3) * nabt(:,3)
    else
      k2 = 0d0
      k_nabt = 0d0
    end if

    call stencil_C(tpsi(:,:,:,iorb),htpsi(:,:,:,iorb),ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end &
                  ,V_local(:,:,:,is),ix_sta,ix_end,iy_sta,iy_end,iz_sta,iz_end &
                  ,idx,idy,idz,lap0+k2,lapt,k_nabt)

  end do

! subtraction

  if(present(ttpsi)) then
    do iorb=1,Norb
      is = is_table(iorb)
      do iz=iz_sta,iz_end
        do iy=iy_sta,iy_end
          do ix=ix_sta,ix_end
            ttpsi(ix,iy,iz,iorb) = htpsi(ix,iy,iz,iorb) - V_local(ix,iy,iz,is) * tpsi(ix,iy,iz,iorb)
          end do
        end do
      end do
    end do
  end if

! pseudopotential

  call pseudo_C(tpsi,htpsi,ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
               ,NI,Nps,Nlma,ia_table,Mps,Jxyz,uV,uVu &
               ,Nk,nproc_Mxin_mul,icomm_pseudo &
               ,ik_table,exp_ikr)

  return
end subroutine hpsi_C

!===================================================================================================================================

subroutine pseudo_R(tpsi,htpsi,ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
                   ,NI,Nps,Nlma,ia_table,Mps,Jxyz,uV,uVu &
                   ,nproc_Mxin_mul,icomm_pseudo)
  use salmon_communication, only: comm_summation
  implicit none
  integer,intent(in)  :: ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
                        ,NI,Nps,Nlma,ia_table(Nlma),Mps(NI),Jxyz(3,Nps,NI) &
                        ,nproc_Mxin_mul,icomm_pseudo
  real(8),intent(in)  :: tpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb)
  real(8),intent(in)  :: uV(Nps,Nlma),uVu(Nlma)
  !
  real(8),intent(out) :: htpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb)
  !
  integer :: ilma,ia,j,ix,iy,iz,iorb
  real(8) :: uVpsi,wrk
  real(8),allocatable :: uVpsibox(:,:),uVpsibox2(:,:)

  if(nproc_Mxin_mul.ne.1) then

    allocate(uVpsibox(Nlma,Norb),uVpsibox2(Nlma,Norb))

    do iorb=1,Norb
      do ilma=1,Nlma
        ia = ia_table(ilma)
        uVpsi=0.d0
        do j=1,Mps(ia)
          ix = Jxyz(1,j,ia)
          iy = Jxyz(2,j,ia)
          iz = Jxyz(3,j,ia)
          uVpsi = uVpsi + uV(j,ilma) * tpsi(ix,iy,iz,iorb)
        end do
        uVpsi = uVpsi * uVu(ilma)
        uVpsibox(ilma,iorb) = uVpsi
      end do
    end do
    call comm_summation(uVpsibox,uVpsibox2,Nlma*Norb,icomm_pseudo)
    do iorb=1,Norb
      do ilma=1,Nlma
        ia = ia_table(ilma)
        do j=1,Mps(ia)
          ix = Jxyz(1,j,ia)
          iy = Jxyz(2,j,ia)
          iz = Jxyz(3,j,ia)
          wrk = uVpsibox2(ilma,iorb) * uV(j,ilma)
          htpsi(ix,iy,iz,iorb) = htpsi(ix,iy,iz,iorb) + wrk
        end do
      end do
    end do

    deallocate(uVpsibox,uVpsibox2)

  else

    do iorb=1,Norb
      do ilma=1,Nlma
        ia = ia_table(ilma)
        uVpsi=0.d0
        do j=1,Mps(ia)
          ix = Jxyz(1,j,ia)
          iy = Jxyz(2,j,ia)
          iz = Jxyz(3,j,ia)
          uVpsi = uVpsi + uV(j,ilma) * tpsi(ix,iy,iz,iorb)
        end do
        uVpsi = uVpsi * uVu(ilma)
        do j=1,Mps(ia)
          ix = Jxyz(1,j,ia)
          iy = Jxyz(2,j,ia)
          iz = Jxyz(3,j,ia)
          wrk = uVpsi * uV(j,ilma)
          htpsi(ix,iy,iz,iorb) = htpsi(ix,iy,iz,iorb) + wrk
        end do
      end do
    end do

  end if

  return
end subroutine pseudo_R

!===================================================================================================================================

subroutine pseudo_C(tpsi,htpsi,ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
                   ,NI,Nps,Nlma,ia_table,Mps,Jxyz,uV,uVu &
                   ,Nk,nproc_Mxin_mul,icomm_pseudo &
                   ,ik_table,exp_ikr)
  use salmon_communication, only: comm_summation
  implicit none
  integer   ,intent(in) :: ipx_sta,ipx_end,ipy_sta,ipy_end,ipz_sta,ipz_end,Norb &
                          ,NI,Nps,Nlma,ia_table(Nlma),Mps(NI),Jxyz(3,Nps,NI) &
                          ,Nk,nproc_Mxin_mul,icomm_pseudo
  complex(8),intent(in) :: tpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb)
  real(8)   ,intent(in) :: uV(Nps,Nlma),uVu(Nlma)
  !
  integer   ,optional,intent(in) :: ik_table(Norb)
  complex(8),optional,intent(in) :: exp_ikr(Nps,NI,Nk)
  !
  complex(8),intent(out) :: htpsi(ipx_sta:ipx_end,ipy_sta:ipy_end,ipz_sta:ipz_end,1:Norb)
  !
  integer    :: ilma,ia,j,ix,iy,iz,ik,iorb
  complex(8) :: uVpsi,wrk
  complex(8),allocatable :: uVpsibox(:,:),uVpsibox2(:,:)

  if(nproc_Mxin_mul.ne.1) then

    allocate(uVpsibox(Nlma,Norb),uVpsibox2(Nlma,Norb))
    if(present(exp_ikr)) then

      do iorb=1,Norb
        ik = ik_table(iorb)
        do ilma=1,Nlma
          ia = ia_table(ilma)
          uVpsi=0.d0
          do j=1,Mps(ia)
            ix = Jxyz(1,j,ia)
            iy = Jxyz(2,j,ia)
            iz = Jxyz(3,j,ia)
            uVpsi = uVpsi + uV(j,ilma) * exp_ikr(j,ia,ik) * tpsi(ix,iy,iz,iorb)
          end do
          uVpsi = uVpsi * uVu(ilma)
          uVpsibox(ilma,iorb) = uVpsi
        end do
      end do
      call comm_summation(uVpsibox,uVpsibox2,Nlma*Norb,icomm_pseudo)
      do iorb=1,Norb
        ik = ik_table(iorb)
        do ilma=1,Nlma
          ia = ia_table(ilma)
          do j=1,Mps(ia)
            ix = Jxyz(1,j,ia)
            iy = Jxyz(2,j,ia)
            iz = Jxyz(3,j,ia)
            wrk = conjg(exp_ikr(j,ia,ik)) * uVpsibox2(ilma,iorb) * uV(j,ilma)
            htpsi(ix,iy,iz,iorb) = htpsi(ix,iy,iz,iorb) + wrk
          end do
        end do
      end do

    else

      do iorb=1,Norb
        do ilma=1,Nlma
          ia = ia_table(ilma)
          uVpsi=0.d0
          do j=1,Mps(ia)
            ix = Jxyz(1,j,ia)
            iy = Jxyz(2,j,ia)
            iz = Jxyz(3,j,ia)
            uVpsi = uVpsi + uV(j,ilma) * tpsi(ix,iy,iz,iorb)
          end do
          uVpsi = uVpsi * uVu(ilma)
          uVpsibox(ilma,iorb) = uVpsi
        end do
      end do
      call comm_summation(uVpsibox,uVpsibox2,Nlma*Norb,icomm_pseudo)
      do iorb=1,Norb
        do ilma=1,Nlma
          ia = ia_table(ilma)
          do j=1,Mps(ia)
            ix = Jxyz(1,j,ia)
            iy = Jxyz(2,j,ia)
            iz = Jxyz(3,j,ia)
            wrk = uVpsibox2(ilma,iorb) * uV(j,ilma)
            htpsi(ix,iy,iz,iorb) = htpsi(ix,iy,iz,iorb) + wrk
          end do
        end do
      end do

    end if
    deallocate(uVpsibox,uVpsibox2)

  else

    if(present(exp_ikr)) then

      do iorb=1,Norb
        ik = ik_table(iorb)
        do ilma=1,Nlma
          ia = ia_table(ilma)
          uVpsi=0.d0
          do j=1,Mps(ia)
            ix = Jxyz(1,j,ia)
            iy = Jxyz(2,j,ia)
            iz = Jxyz(3,j,ia)
            uVpsi = uVpsi + uV(j,ilma) * exp_ikr(j,ia,ik) * tpsi(ix,iy,iz,iorb)
          end do
          uVpsi = uVpsi * uVu(ilma)
          do j=1,Mps(ia)
            ix = Jxyz(1,j,ia)
            iy = Jxyz(2,j,ia)
            iz = Jxyz(3,j,ia)
            wrk = conjg(exp_ikr(j,ia,ik)) * uVpsi * uV(j,ilma)
            htpsi(ix,iy,iz,iorb) = htpsi(ix,iy,iz,iorb) + wrk
          end do
        end do
      end do

    else

      do iorb=1,Norb
        do ilma=1,Nlma
          ia = ia_table(ilma)
          uVpsi=0.d0
          do j=1,Mps(ia)
            ix = Jxyz(1,j,ia)
            iy = Jxyz(2,j,ia)
            iz = Jxyz(3,j,ia)
            uVpsi = uVpsi + uV(j,ilma) * tpsi(ix,iy,iz,iorb)
          end do
          uVpsi = uVpsi * uVu(ilma)
          do j=1,Mps(ia)
            ix = Jxyz(1,j,ia)
            iy = Jxyz(2,j,ia)
            iz = Jxyz(3,j,ia)
            wrk = uVpsi * uV(j,ilma)
            htpsi(ix,iy,iz,iorb) = htpsi(ix,iy,iz,iorb) + wrk
          end do
        end do
      end do

    end if

  end if

  return
end subroutine pseudo_C

!===================================================================================================================================

end module hpsi_sub


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PY2FRM
C...An interface from a two-fermion generator to include
C...parton showers and hadronization.

      SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Commonblocks.
      include 'inc/pyjets'
      include 'inc/pydat1'
C...Local arrays.
      DIMENSION IJOIN(2),INTAU(2)

C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
      IF(ICOM.EQ.0) THEN
        MSTU(28)=0
        CALL PYHEPC(2)
      ENDIF

C...Loop through entries and pick up all final fermions/antifermions.
      I1=0
      I2=0
      DO 100 I=1,N
      IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
      KFA=ABS(K(I,2))
      IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
        IF(K(I,2).GT.0) THEN
          IF(I1.EQ.0) THEN
            I1=I
          ELSE
            CALL PYERRM(16,'(PY2FRM:) more than one fermion')
          ENDIF
        ELSE
          IF(I2.EQ.0) THEN
            I2=I
          ELSE
            CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
          ENDIF
        ENDIF
      ENDIF
  100 CONTINUE

C...Check that event is arranged according to conventions.
      IF(I1.EQ.0.OR.I2.EQ.0) THEN
        CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
      ENDIF
      IF(I2.LT.I1) THEN
        CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
      ENDIF

C...Check whether fermion pair is quarks or leptons.
      IF(ABS(K(I1,2)).LT.10.AND.ABS(K(I2,2)).LT.10) THEN
        IQL12=1
      ELSEIF(ABS(K(I1,2)).GT.10.AND.ABS(K(I2,2)).GT.10) THEN
        IQL12=2
      ELSE
        CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
      ENDIF

C...Decide whether to allow or not photon radiation in showers.
      MSTJ(41)=2
      IF(IRAD.EQ.0) MSTJ(41)=1

C...Do colour joining and parton showers.
      IP1=I1
      IP2=I2
      IF(IQL12.EQ.1) THEN
        IJOIN(1)=IP1
        IJOIN(2)=IP2
        CALL PYJOIN(2,IJOIN)
      ENDIF
      IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
        PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
     &  (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
        CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
      ENDIF

C...Do fragmentation and decays. Possibly except tau decay.
      IF(ITAU.EQ.0) THEN
        NTAU=0
        DO 110 I=1,N
        IF(ABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
          NTAU=NTAU+1
          INTAU(NTAU)=I
          K(I,1)=11
        ENDIF
  110   CONTINUE
      ENDIF
      CALL PYEXEC
      IF(ITAU.EQ.0) THEN
        DO 120 I=1,NTAU
        K(INTAU(I),1)=1
  120   CONTINUE
      ENDIF

C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
      IF(ICOM.EQ.0) THEN
        MSTU(28)=0
        CALL PYHEPC(1)
      ENDIF

      END


!
! rhOver - a FORTRAN program to determine magnetic anisotropy and related
! properties for dysprosium(III) single-ion magnets by semi-empirical approaches
! Copyright (C) 2014-2019 Michael Böhme <boehme.mic@gmail.com>
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!

module global_c

     ! constants
     double precision, parameter :: au2pm = 5.2917721E-01
     double precision, parameter :: au2kJpmol = 2625.49953026d0
     double precision, parameter :: au2rcm = 219474.63633664d0
     double precision, parameter :: au2K = 315774.62979379d0
     double precision, parameter :: Pi = 3.1415926535897932d0
     double precision, parameter :: TwoPi = 2d0 * Pi
     double precision, parameter :: FourPi = 4d0 * Pi
     double precision, parameter :: SqrtPi = 1.7724538509055160
     integer, parameter :: sMaxBuffer = 256
     integer, parameter :: iMaxAtoms = 256
     integer, parameter :: iMaxCGTOs = 10000
     integer, parameter :: iMaxMOs = 10000
     double precision :: TotalNuclearCharge, LigTotalCharge, TotalElCharge

     character (len=sMaxBuffer) :: XFilenameMin, DEPPFile
     character (len=sMaxBuffer) :: OLFile
     character (len=sMaxBuffer) :: MOFile
     character (len=sMaxBuffer) :: JobTitle, SHostname, SWorkDir
     character (len=sMaxBuffer) :: GPFile

     double precision :: SphereRad = 1d0 / au2pm
     double precision :: DistMin = -0.01d0
     double precision :: QdivRThres = 0.0d0

     ! optimal parameters for Freeman/Watson
!      double precision :: Ln4fCutOff_I = 0.03d0
!      double precision :: Ln4fCutOff_O = 3.50d0
     ! optimal parameters for ANO-RCC
     double precision :: Ln4fCutOff_I = 0.02d0
     double precision :: Ln4fCutOff_O = 4.00d0
!      double precision :: Ln4fCutOff_O = 8.00d0
     double precision :: LFTCutOff_I = 0.00d0
     double precision :: LFTCutOff_O = 3.50d0
!      double precision :: LFTCutOff_O = 8.00d0
     double precision, parameter :: Ahlrichs_Alpha = 0.6d0
     integer :: nGrid

     ! mJ state:
     !  1 = +/- 15/2,
     !  2 = +/- 13/2,
     !  3 = +/- 11/2,
     !  4 = +/-  9/2,
     !  5 = +/-  7/2,
     !  6 = +/-  5/2,
     !  7 = +/-  3/2,
     !  8 = +/-  1/2
     integer :: mJ = 1

     ! radial wave function:
     !  1 = ANO-RCC 4f basis set for Dy(0) (as used in the original JCC article),
     !  2 = Freeman-Watson 1962 for Dy(III)
     !  3 = CASSCF/DKH2/ANO-RCC-based Dy(III) (M. Böhme 2019, unpublished)
     integer :: iRadWF = 1

     ! file units
     integer, parameter :: uEner = 12
     integer, parameter :: uInp  = 13
     integer, parameter :: uXYZ  = 14
     integer, parameter :: uMolF = 15
     integer, parameter :: uPotF = 16

     integer :: NRad, NLigSpher, NLigGP, NGP
     integer :: NLigRadShells
     ! global program options
     logical :: OVerbose, OGenPotE, OMagVec, OGenXYZ, OAngstrom, OMax, OTraj, OPruning, ORandRot, ONoDEPPFile
     logical :: OOldRInts, OPrintBasis, OPrintMulliken, OCFOnly, OIESMode, ODelete4f, OExpert
     logical :: OSkipMom, OLDAX, OMixedMode, ODeleteAll
     logical :: OPCM, OSternheimer
     logical :: OExportGPs
     logical :: OUHF
     logical :: OTurbomole, OFNoTurbomole

     ! LAPACK
     logical :: LAPACKInit = .FALSE.
     integer :: NArraySize, LWORKSize, RWORKSize, NArraySizeLDA, lapackstatus
     complex*16, dimension(16, 16) :: LFMatrix
     complex*16, dimension(:), allocatable :: LWorkArr
     double precision, dimension(:), allocatable :: RWorkArr
     double precision, dimension(16) :: EigenValues
     character :: LAPACKJobType, LAPACKMatrixType

     ! Ligand-field theory
     logical :: CFInit = .FALSE.
     double precision, dimension(0:6) :: StevMultFac, OldRadInts, SternheimerShieldings
     double complex, dimension(-2:2,1:16, 1:16) :: StevOp2Mat, HermOp2O, HermOp2W, TensorOp2Mat
     double complex, dimension(-4:4,1:16, 1:16) :: StevOp4Mat, HermOp4O, HermOp4W, TensorOp4Mat
     double complex, dimension(-6:6,1:16, 1:16) :: StevOp6Mat, HermOp6O, HermOp6W, TensorOp6Mat
     double precision, dimension(6, 0:6) :: StevPLM, StevLam
     double precision, dimension(0:15, 16) :: WFDecomp
     double precision, dimension(0:6,-6:6) :: ARkq, BRkq
     double complex, dimension(0:6,-6:6) :: BWkq
     integer :: MaxKRank
     double precision, dimension(0:6) :: LFPScalingFactors
     ! mJ coefficients
     double precision, dimension(8,4) :: coeff

     ! basis set
     integer :: NPGTO = 0
     integer :: NumPGTO, NumCGTO, NumDelPGTO
     integer :: NCustomCharges = 0

     ! origin of Dy(III)
     double precision :: EDyX, EDyY, EDyZ
     integer :: CAtomID = 0

     double precision :: Energy_SUM
     double precision :: TotDensMO, TotDensDS, TotNormWF
     double precision :: LinScanX1, LinScanY1, LinScanX2, LinScanY2, LinScanDX, LinScanDY
     integer :: LinScanS

     double precision :: NumberOf4fElectrons = 9d0

     ! Stevens-factors A_2, A_4, A_6 for Dy(III)
     ! J. Sievers, Z. Phys. B., 1982 (45), 289--296
     double precision, dimension(8,3) :: StevensFactors_Dy = reshape( &
     (/ &
       (/ -0.33333333333E0, -0.200000000000E0, -0.08571428571E0 /), & ! 15/2
       (/  0.00952380952E0,  0.085714285710E0,  0.14285714286E0 /), & ! 13/2
       (/  0.18095238095E0,  0.200000000000E0, -0.12121212121E0 /), & ! 11/2
       (/  0.04040404040E0,  0.098124098120E0,  0.08924408924E0 /), & !  9/2
       (/  0.04484404484E0, -0.010212010210E0, -0.05727605728E0 /), & !  7/2
       (/ -0.08391608392E0,  0.058275058280E0, -0.10489510490E0 /), & !  5/2
       (/ -0.03496503497E0,  0.052895822130E0,  0.07799892415E0 /), & !  3/2
       (/  0.04034427111E0, -0.02241348395E0, -0.067240451856E0 /)  & !  1/2
     /), shape(StevensFactors_Dy), order=(/2, 1/) )

#ifdef _OPENMP
     integer :: omp_threads, omp_man_threads
#endif

end module global_c


	PROGRAM SHOCKSTUFF
C
C	PLOTS CDHF DATA TO DETERMINE SOME SHOCK PARAMETERS
C
	include		'wind_examples:wind_tm_routine_def.for'
	include		'wind_examples:wind_return_code_def.for'
	integer*4	ok
	integer*4	i,j,k,n,itemp
	integer*4	get_stream_name
	integer*4	wait_for_events			! an entry point
	integer*4	err_count
	character*80	stream
	character*4	event
	parameter	size=2048
	integer*4	return_size
	integer*4	temp_waves,iend,n2
	character*32	s
	real*8		mfi_scet(2000)
	real*8		swe_scet(2000)
	real*8		dp3_scet(2000)
	real*8		orb_scet(200)
	real*4		bmag(2000),bx(2000),by(2000),bz(2000)
	real*4		vmag(2000),vx(2000),vy(2000),vz(2000),dens(2000)
	real*4		dp3eden(2000),dp3iden(2000),tempe(2000),tempi(2000)
	real*8		xgse(200),ygse(200),zgse(200)
	real*8		scet
	real*4		vthp(2000)
	integer*4	major, minor
	character*80	file
	character*32	item
	integer*4	ios,ms,doy,msday,dds
	integer*4	NREM,NHRMN,IHRMN,yyyy,mon,dd,hh,mm,ss,IFASTSLOW
	INTEGER*4 CDHFCH,hkch,CH
	CHARACTER*11 YYMMDD
!
	COMMON /MODEL/ RTA,RTB,C
	common /pltblk1/ nmfi,mfi_scet,bx,by,bz,bmag
	common /pltblk2/ nswe,swe_scet,vx,vy,vz,vmag,dens
	common /pltblk3/ norb,orb_scet,xgse,ygse,zgse
	common /pltblk4/ n3dp,dp3_scet,dp3eden,dp3iden,tempi,tempe
	COMMON /HEADBL/ NHRMN,LAST,EVENT,FILE
C
	DIMENSION PLDATA(20,2)
	DATA TWOPI /6.2831853/
	DATA RTA,RTB,C /  25.6, 25.6, 14.6/
	DATA ALPHA,BETA,GAMMA /0.,1.,0./
	DATA X0,Y0,Z0 /14.6,1.,0./
	DATA RE /6.378E3/
C
C
C	GET STARTED
C
!
	ok = get_stream_name(stream)
	if (.not. ok) stop 'no file supplied.'
C
        if(stream.ne.'realtime') then
 10	  write(6,*)  'type hr,min to start, e.g. 0412'
	  read(5,*,err=10) NHRMN,LAST
	  type*,NHRMN,LAST
	  HH = NHRMN/100
	  MM = MOD(NHRMN,100)
	endif
c
  5	format(q,a)
  3	format(q,i10)
c
	ok = w_channel_open(CDHFCH,stream)
	if (.not. ok) stop 'Cannot open cdhf channel'
	scet = 0.
	call w_channel_position(CDHFCH,scet)
	print*,'cdhf file starts at scet ',scet
	dds = scet
	scet = float(dds) + hh/24. + mm/1440.
	print*,'set cdhf channel position to',scet
	call w_channel_position(CDHFCH,scet)
	print*,'cdhf channel position set to',scet
c
	ok = w_channel_filename(CDHFCH,file)
C	write(87,*) file
	print*,file
c
	get_tm_stream = 1
c
c	call w_ur8_to_ymd(scet,yyyy,mon,dd,hh,mm,ss,ms)

	  ok = w_event(CDHFCH,'CDF')
	if(ok.eq.82) then
	   scet = 10000.       	! artificially large
	   print*,'end of file'
	if (.not. ok) stop 'cannot get tds event'
	else
	  item = 'WIND_ORBIT_SCET_R8'
	  ok = w_item_r8(CDHFCH, item, orb_scet, 200, return_size)
	  norb = return_size
	  print*,'initial orb time',orb_scet(1),' size',return_size
	  item = 'WIND_ORBIT_X(GSE)_R8'
	  ok = w_item_r8(CDHFCH, item, XGSE, 200, return_size)
	  item = 'WIND_ORBIT_Y(GSE)_R8'
	  ok = w_item_r8(CDHFCH, item, YGSE, 200, return_size)
	  item = 'WIND_ORBIT_Z(GSE)_R8'
	  ok = w_item_r8(CDHFCH, item, ZGSE, 200, return_size)
	  print*,'initial orb x,y,z',xgse(1),ygse(1),zgse(1)
C
	  item = 'WIND_MFI_SCET_R8'
	  ok = w_item_r8(CDHFCH, item, mfi_scet, 2000, return_size)
	  nmfi = return_size
	  print*,'initial mfi time',mfi_scet(1),' size',return_size
	  print*,'last mfi time',mfi_scet(return_size)
	  item = 'WIND_MFI_BX(GSE)_R4'
	  ok = w_item_r4(CDHFCH, item, BX, 2000, return_size)
	  item = 'WIND_MFI_BY(GSE)_R4'
	  ok = w_item_r4(CDHFCH, item, BY, 2000, return_size)
	  item = 'WIND_MFI_BZ(GSE)_R4'
	  ok = w_item_r4(CDHFCH, item, BZ, 2000, return_size)
	  item = 'WIND_MFI_BMAG_R4'
	  ok = w_item_r4(CDHFCH, item, BMAG, 2000, return_size)
C
	  item = 'WIND_SWE_SCET_R8'
	  ok = w_item_r8(CDHFCH, item, swe_scet, 2000, return_size)
	  nswe = return_size
	  print*,'initial swe time',swe_scet(1),' size',return_size
	  item = 'WIND_swe_VX(GSE)_R4'
	  ok = w_item_r4(CDHFCH, item, VX, 2000, return_size)
	  item = 'WIND_swe_VY(GSE)_R4'
	  ok = w_item_r4(CDHFCH, item, VY, 2000, return_size)
	  item = 'WIND_swe_VZ(GSE)_R4'
	  ok = w_item_r4(CDHFCH, item, VZ, 2000, return_size)
	  item = 'WIND_swe_VMAG_R4'
	  ok = w_item_r4(CDHFCH, item, VMAG, 2000, return_size)
	  item = 'WIND_swe_density_R4'
	  ok = w_item_r4(CDHFCH, item, dens, 2000, return_size)
	  print*,'swe dens(1)',dens(1),'size',return_size
	  item = 'WIND_swe_thermal_spd_R4'
	  ok = w_item_r4(CDHFCH, item, vthp, 2000, return_size)
C
C	CLEAN OUT MISSING SWE DATA
C
	  NSWET = NSWE
	  DO N = 1,NSWE
		N1 = N
 100		IF(DENS(N).GT.1.E30.OR.DENS(N).LT.-1.E30) THEN
		  NSWET = MIN0(NSWET,2000) - 1
		print*,'remove n,dens',n,dens(n),' to',nswet
		  IF(NSWET.LE.N) GO TO 101
		  DO NN = N1,NSWET
		    SWE_SCET(NN) = SWE_SCET(NN+1)
		    DENS(NN) = DENS(NN+1)
		    VX(NN) = VX(NN+1)
		    VY(NN) = VY(NN+1)
		    VZ(NN) = VZ(NN+1)
		    VMAG(NN) = VMAG(NN+1)
		    VTHP(NN) = VTHP(NN+1)
		  ENDDO
		GO TO 100
		ENDIF
	  ENDDO
 101	  PRINT*,NSWE-NSWET,'  SWE DATA POINTS REMOVED'
	  NSWE = NSWET
C
	  item = 'WIND_3dp_scet_r8'
	  ok = w_item_r8(CDHFCH, item, dp3_scet, 2000, return_size)
	  n3dp = return_size
	  print*,'initial 3dp time',dp3_scet(1),' size',return_size
	  item = 'WIND_3dp_ion_temp_R4'
	  ok = w_item_r4(CDHFCH, item, tempi, 2000, return_size)
	  item = 'WIND_3dp_e_temp_R4'
	  ok = w_item_r4(CDHFCH, item, tempe, 2000, return_size)
	endif
c
C	do i = 1,40
C	  type*,'swe',swe_scet(i),dens(i),vthp(i)
C	enddo
C	do i = 1,40
C	  type*,'3dp',dp3_scet(i),tempe(i),tempi(i)
C	enddo

C	     call w_ur8_to_ymd(scetT,yyyy,mon,dd,hh,mm,ss,ms)
C	   ihrmn = 100*hh+mm

c	   write(s,'(i8.8,i6.6)',iostat=ios) mfi_scet(1), mfi_scet(2)
C	   mfi_scet = s(1:4)//'/'//s(5:6)//'/'//s(7:8)//' '//
C	1	s(9:10)//':'//s(11:12)//':'//s(13:14)

C	CALL PLTSTUFF(3)
	CALL PLTSTUFF(-1)
	STOP
	END
	options/extend_source
!------------------------------------------------------------------------------
	integer*4	function	get_stream_name(stream)
! This routine gets the user's TM stream type specification.
!
	implicit	none
	character*(*)	stream
	common /nrblk/ nrem,NHRMN,IFASTSLOW
	integer*4	iq,NREM,NHRMN,IFASTSLOW

10	  write(6,6)
	  read(5,5,err=10,end=20) iq, stream

 	if (iq .lt. 1) then
	   stream = 'offline'
	else if (stream(1:1) .eq. 'o' .or. stream(1:1) .eq. 'O') then
	   stream = 'offline'
	else if (stream(1:1) .eq. 'r' .or. stream(1:1) .eq. 'R') then
	   stream = 'realtime'
	else
	   ! assume the user entered the name of an offline file
	end if

	get_stream_name = 1

	print*,' get_stream_name got',stream

 20	return
c
  5	format(q,a)
  6	format(1x,'Enter TM stream type [O=offline (default), R=realtime ]: ',$)
c
	end

	SUBROUTINE PLTSTUFF(ITERM)
C
C	PLOT DATA V.S. TIME  1st PANEL B.N = SHOCK NORMAL ANGLE, 2nd
C	= DISTANCE RELATIVE TO SHOCK  (1. = AT AVERAGE SHOCK)  3rd =
C	SOLAR WIND PRESSURE,
C	DISTANCE RELATIVE TO MAGNETOPAUSE?  BETA?
C	ALFVEN MACH NO.,SONIC MACH NO, SUPERCRITICAL V.S. SUBCRITICAL?
C
	CHARACTER*120 STR
	CHARACTER*80 FILE
	CHARACTER*4 EVENT
	COMMON /HEADBL/ NHRMN,LAST,EVENT,FILE
	common /pltblk1/ nmfi,mfi_scet,bx,by,bz,bmag
	common /pltblk2/ nswe,swe_scet,vx,vy,vz,vmag,dens
	common /pltblk3/ norb,orb_scet,xgse,ygse,zgse
	common /pltblk4/ n3dp,dp3_scet,dp3eden,dp3iden,tempi,tempe
	COMMON /MODEL/ RTA,RTB,RTC
C
	COMMON /MONGOPAR/
     1  X1,X2,Y1,Y2,GX1,GX2,GY1,GY2,LX1,LX2,LY1,LY2,
     1  GX,GY,CX,CY,
     1  EXPAND,ANGLE,LTYPE,LWEIGHT,
     1  CHEIGHT,CWIDTH,CXDEF,CYDEF,PSDEF,PYDEF,COFF,
     1  TERMOUT,XYSWAPPED,NUMDEV,
     1  PI,USERVAR(10),AUTODOT
	INTEGER*4 LX1,LX2,LY1,LY2,LTYPE,LWEIGHT,NUMDEV
C
	real*8		mfi_scet(2000)
	real*8		swe_scet(2000)
	real*8		orb_scet(200)
	real*8		dp3_scet(2000)
	real*8		sday
	real*4		bmag(2000),bx(2000),by(2000),bz(2000)
	real*4		vmag(2000),vx(2000),vy(2000),vz(2000),dens(2000)
	real*4		dp3eden(2000),dp3iden(2000),tempe(2000),tempi(2000)
	real*8		xgse(200),ygse(200),zgse(200)
	integer*4	yyyy,mon,dd,doy,hh,mm,ss,ms
	DIMENSION YY(2048),PP(2048),TMFI(2048),RR(2048),TORB(200),T3DP(2000)
	DATA RE /6.378E3/    			! km
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
C
	HH = LAST/100
	MM = MOD(LAST,100)
	FDAYL = HH/24. + MM/1440.
C
	SWPAVR = 7.*(450.**2)
	XEND = 2250.
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(400.,400.,XEND,3100.)
	ENDIF
	call w_ur8_to_ydoy(mfi_scet(2),yyyy,doy,ms)
	call w_ur8_to_ymd(mfi_scet(2),yyyy,mon,dd,hh,mm,ss,ms)
	   write(STR,1202,iostat=ios) YYYY,MON,DD,DOY
 1202	format(' HOURS OF ',I4.4,'/',I2.2,'/',I2.2,'  DOY',I5)
C	   mfi_scet = s(1:4)//'/'//s(5:6)//'/'//s(7:8)//' '//
C	1	s(9:10)//':'//s(11:12)//':'//s(13:14)
C	  CALL MGOSETEXPAND(.75)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(500.,50.)                      ! hardcopy
	  ENDIF
	  CALL MGOPUTLABEL(53,STR,9)
C
	  CALL MGOSETEXPAND(1.)
C
	NDDS = MFI_SCET(1)
	SDAY = NDDS
	TFACT = 24.
	NW = 4
	DO N = 1,NMFI
	      fday = MFI_scet(n) - SDAY
  	      TMFI(N) = fday*tfact
	ENDDO
	DO N = 1,NORB
	      fday = ORB_scet(n) - SDAY
  	      TORB(N) = fday*tfact
	ENDDO
	DO N = 1,N3DP
	      fday = DP3_scet(n) - SDAY
  	      T3DP(N) = fday*tfact
	ENDDO
	DO JW = 1,NW
	  CALL MGOWINDOW(1,NW,JW)
c	  CALL MGOTICKSIZE(0.,0.,0.,0.)
	  YMAX = -1.E10
	  YMIN =  1.E10
	  FDAY = 0.
C
	  IF(JW.EQ.1) THEN
C
C		PLOT ANGLE BETWEEN B AND SHOCK NORMAL
C
	    N = 0
	    DOWHILE(FDAY.LE.FDAYL)
	      N = N+1
	       IF(N.GT.NMFI) GO TO 201
	      fday = MFI_scet(n) - SDAY
	      ORBTIME = FDAY*tfact
	      CALL DINTERP(TORB,XGSE,NORB,ORBTIME,X0,ERR)
	      CALL DINTERP(TORB,YGSE,NORB,ORBTIME,Y0,ERR)
	      CALL DINTERP(TORB,ZGSE,NORB,ORBTIME,Z0,ERR)
C	      BMAG0 = SQRT(BX0**2 + BY0**2 + BZ0**2)
	      R02 = Y0**2 + Z0**2
	      EXRATIO = (.5/RTC)*(X0 + SQRT(X0**2 + 4.*RTC*R02/RTA))
	      RR(N) = EXRATIO/RE
C
C	CALCULATE MODEL SHOCK NORMAL
C
	      SNX = 1.
	      SNY = 2.*Y0/RE/RTB
	      SNZ = 2.*Z0/RE/RTA
	      SNORM = SQRT(SNX**2 + SNY**2 + SNZ**2)
C	PRINT*,N,orbtime,SNORM,bMAG(N),BX(N)
	      BDOTN = (BX(N)*SNX + BY(N)*SNY + BZ(N)*SNZ)/SNORM/BMAG(N)
c	PRINT*,N,RR(N),snx,sny,snz
C	PRINT*,N,orbtime,bdotn,bx0,by0,bz0
  	      PP(N) = fday*tfact
	      NPPNT = N
	      YY(N) = ABS(BDOTN)
	      YMAX = AMAX1(YY(N),YMAX)
	      YMIN = AMIN1(YY(N),YMIN)
	    ENDDO
 201	    YMIN = AMAX1(YMIN,0.)
	    XLST = PP(NPPNT)
	    XRANGE = PP(NPPNT) - PP(1)
	    CALL MGOYLABEL(5,'BdotN')
C	    CALL MGOSETEXPAND(.8)
C	    CALL MGOXLABEL(16,'HOURS OF THE DAY')
C	    CALL MGOSETEXPAND(1.)
	  ENDIF
C
	  IF(JW.EQ.3) THEN
c	    CALL MGOTICKSIZE(0.,0.,-1.,-1.)
	    N = 0
	    DOWHILE(FDAY.LE.FDAYL)
	       N = N+1
	       IF(N.GT.NSWE) GO TO 202
	       fday = SWE_scet(n) - SDAY
  	       PP(N) = fday*tfact
	       NPPNT = N
c	       mm = mfi_scet(2)/100
C	       mm = mod(mm,100)
c	       hh = mfi_scet(2)/10000
C	       scett = float(dds) + hh/24. + mm/1440. + ss/86400.
C		B measurements are more frequent, so interpolate
c		B at SWE time
	      YY(N) = AMAX1(DENS(N),0.)*AMAX1(VMAG(N),0.)**2/SWPAVR
	      IF(YY(N).LT.5.E7)  YMAX = AMAX1(YY(N),YMAX)
	      IF(YY(N).GT.-50000.) YMIN = AMIN1(YY(N),YMIN)
	    ENDDO
 202	    XRANGE = PP(NPPNT) - PP(1)
	    XLST = PP(NPPNT)
	    CALL MGOYLABEL(12,'S.W.PRESSURE')
	    CALL MGOXLABEL(16,'HOURS OF THE DAY')
	  ENDIF
C
	  IF(JW.EQ.2) THEN
C
C	PLOT RATIO TO AVERAGE SHOCK POSITION
C
	    N = 0
	    DOWHILE(FDAY.LE.FDAYL)
	       N = N+1
	       IF(N.GT.NORB) GO TO 203
	       fday = ORB_scet(n) - sday
  	       PP(N) = FDAY*TFACT
	       NPPNT = N
	       YY(N) = RR(N)
	       YMAX = AMAX1(YY(N),YMAX)
	       IF(YY(N).GE.0.) YMIN = AMIN1(YY(N),YMIN)
	    ENDDO
 203	    YMIN = AMAX1(YMIN,0.)
	    XRANGE = PP(NPPNT) - PP(1)
	    XLST = PP(NPPNT)
	    CALL MGOYLABEL(11,'R/(SHOCK R)')
	    CALL MGOXLABEL(16,'HOURS OF THE DAY')
	  ENDIF
C
C
	  IF(JW.EQ.4) THEN
C
C	PLOT MACH NUMBERS, ALFVEN AND SONIC
C
	    N = 0
	    DOWHILE(FDAY.LE.FDAYL)
	       N = N+1
	       IF(N.GT.NSWE) GO TO 204
	       fday = swe_scet(n) - sday
  	       PP(N) = fday*tfact
	       NPPNT = N
c	       ss = mod(swe_scet(2),100)
c	       mm = mfi_scet(2)/100
C	       mm = mod(mm,100)
c	       hh = mfi_scet(2)/10000
C	       scett = float(dds) + hh/24. + mm/1440. + ss/86400.
C
C	CALCULATE MODEL SHOCK NORMAL
C
	      CALL DINTERP(TORB,XGSE,NORB,PP(N),X0,ERR)
	      CALL DINTERP(TORB,YGSE,NORB,PP(N),Y0,ERR)
	      CALL DINTERP(TORB,ZGSE,NORB,PP(N),Z0,ERR)
	      CALL INTERP(TMFI,BMAG,NMFI,PP(N),BMAG0,ERR)
	      SNX = 1.
	      SNY = 2.*Y0/RE/RTB
	      SNZ = 2.*Z0/RE/RTA
	      SNORM = SQRT(SNX**2 + SNY**2 + SNZ**2)
C
C	CALCULATE ALFVEN SPEED IN KM/SEC
C
	      IF(DENS(N).GT.0.)
     1		VALF = 21.9*BMAG0/SQRT(DENS(N))    ! Bmag in nT, dens in cu.cm.
C
C	CALCULATE ION SOUND SPEED IN KM/SEC
C
	      CALL DINTERP(T3DP,TEMPI,N3DP,PP(N),TI,ERR)
	      CALL DINTERP(T3DP,TEMPE,N3DP,PP(N),TE,ERR)
	      VSOUND = 3.E5*SQRT(AMAX1((3.*TI + TE),0.)/.935E9)
C
	      IF(DENS(N).GT.0.)
     1		VALF = 21.9*BMAG0/SQRT(DENS(N))    ! Bmag in nT, dens in cu.cm.
C
	      IF(VMAG(N).GT.0.)
     1	      VDOTN = (VX(N)*SNX + VY(N)*SNY + VZ(N)*SNZ)/SNORM
c	print*,n,vdotn,valf
	      IF(VALF.NE.0.) YY(N) = ABS(VDOTN/VALF)
	      IF(VSOUND.NE.0.) RR(N) = ABS(VDOTN/VSOUND)
	      IF(YY(N).LE. 30.) YMAX = AMAX1(YY(N),YMAX)
	      IF(RR(N).LE. 30.) YMAX = AMAX1(RR(N),YMAX)
	      YMIN = AMIN1(YY(N),YMIN)
c	PRINT*,N,PP(N),YMIN,YMAX,yy(n),VALF
	    ENDDO
 204	    YMIN = AMAX1(YMIN,0.)
	    CALL MGOYLABEL(8,'MACH NO.')
	    XRANGE = PP(NPPNT) - PP(1)
	    XLST = PP(NPPNT)
	  ENDIF
C
 200	XST = PP(1) - .003*XRANGE
	XLST = XLST + .003*XRANGE
	YRANGE = ABS(YMAX - YMIN)
	PRINT*,'JW,MIN,MAX Y',JW,YMIN,YMAX
	YMAX = YMAX + .02*YRANGE
	YMIN = YMIN - .02*YRANGE
	CALL MGOSETLIM(XST,YMIN,XLST,YMAX)
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	DO N = 1,NPPNT
	  YY(N) = AMIN1(YY(N),1.E10)
	  YY(N) = AMAX1(YY(N),-1.E10)
	ENDDO
	CALL MGOCONNECT(PP,YY,NPPNT)
	IF(JW.EQ.4) THEN
	  CALL MGOSETLTYPE(1)
	  CALL MGOCONNECT(PP,RR,NPPNT)
	  CALL MGOSETLTYPE(0)
	ENDIF
	CALL MGOSETEXPAND(.7)
	CALL MGOBOX(1,2)
C	PRINT*,'IN PLOT, FILE=',FILE
	CALL MGOSETEXPAND(1.)
	  CALL MGOSETEXPAND(.8)
	  CALL MGOPLOTID(FILE(31:42),'[.WIND]SHOCKSTUFF')
	  CALL MGOSETEXPAND(1.)
C
	ENDDO
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	ELSE
	  CALL MGOTCLOSE
	ENDIF
C
	RETURN
C
	END


subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    calctends       calculate u,v,t,p tendencies
!   prgmmr: kleist           org: np20                date: 2005-09-29
!
! abstract: compute tendencies for pressure, wind, and virtual
!           temperature
!
! program history log:
!   2005-09-29  kleist
!   2005-10-17  kleist - changes to improve computational efficiency
!   2005-11-21  kleist - add tracer tendencies, use new module
!   2006-04-12  treadon - replace sigi with bk5
!   2006-04-21  kleist - add divergence tendency
!   2006-07-31  kleist - changes to use ps instead of ln(ps)
!   2007-04-16  kleist - remove divergence tendency bits to outside
!   2007-05-08  kleist - add bits for fully generalized coordinate
!   2007-06-21  rancic - add pbl
!   2007-07-02  derber - move calculation of z_x, z_y into routine
!   2007-07-26 cucurull - add pri in argument list, call getprs_horiz;
!                         move getprs outside calctends;
!                         remove ps from argument list
!   2007-08-08  derber - optimize, remove calculation of t_over* and dp_over* unless needed.
!   2008-06-05  safford - rm unused vars and uses
!   2009-08-20  parrish - replace curvfct with curvx, curvy.  this allows tendency computation to
!                          work for any general orthogonal coordinate.
!   2010-11-03  derber - added threading
!   2012-03-11  tong - added condition to calculate cw tendency
!   2013-10-19  todling - revamp interface with fields now in bundles; still
!                         needs generalization
!   2013-10-28  todling - rename p3d to prse
!   2019-03-13  eliu - use derivative var table instead of the control var table
!   2019-05-09  eliu - point cloud water(cw) to derived value (cwgues) when cw is not in met_guess table
!
! usage:
!   input argument list:
!     z        - sfc terrain height
!     ps_x     - zonal derivative of ps
!     ps_y     - meridional derivative of ps
!     mype     - task id
!
!   output argument list:
!     p_t      - time tendency of 3d prs
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds,only: r_kind,i_kind
  use gridmod, only: lat2,lon2,nsig,istart,rlats,nlat,idvc5,bk5,&
     jstart,region_lat,eta2_ll,wrf_nmm_regional,nems_nmmb_regional,nlon,regional,&
     region_dx,region_dy,nthreads,jtstart,jtstop
  use constants, only: zero,half,one,two,rearth,rd,rcp,omega,grav
  use tendsmod, only: what9,prsth9,r_prsum9,r_prdif9,prdif9,pr_xsum9,pr_xdif9,pr_ysum9,&
     pr_ydif9,curvx,curvy,coriolis
  use derivsmod, only: dvars3d,cwgues
  use mpeu_util, only: getindex

  use gsi_bundlemod, only: gsi_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer

  use mpeu_util, only: die
  implicit none

! Declare passed variables
  integer(i_kind)                         ,intent(in   ) :: mype
  real(r_kind),dimension(lat2,lon2,nsig)  ,intent(inout) :: teta
  real(r_kind),dimension(lat2,lon2,nsig+1),intent(inout) :: pri
  type(gsi_bundle) :: guess
  type(gsi_bundle) :: xderivative
  type(gsi_bundle) :: yderivative
  type(gsi_bundle) :: tendency

! Declare local variables
  character(len=*),parameter::myname='calctends'
  real(r_kind),dimension(lat2,lon2):: z_x,z_y
  real(r_kind),dimension(lat2,lon2,nsig+1):: pri_x,pri_y
  real(r_kind),dimension(lat2,lon2):: sumkm1,sumvkm1,sum2km1,sum2vkm1
  real(r_kind) tmp,tmp2
  integer(i_kind) i,j,k,ix,ixm,ixp,jx,jxm,jxp,kk,icw,iq,ioz,ip3d
  real(r_kind) sumk,sumvk,sum2k,sum2vk,uuvv

  real(r_kind),dimension(:,:  ),pointer :: z   =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: u   =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: v   =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: t   =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: q   =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: oz  =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: cw  =>NULL()

  real(r_kind),dimension(:,:  ),pointer :: ps_x=>NULL()
  real(r_kind),dimension(:,:,:),pointer :: u_x =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: v_x =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: t_x =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: q_x =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: oz_x=>NULL()
  real(r_kind),dimension(:,:,:),pointer :: cw_x=>NULL()
  real(r_kind),dimension(:,:  ),pointer :: ps_y=>NULL()
  real(r_kind),dimension(:,:,:),pointer :: u_y =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: v_y =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: t_y =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: q_y =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: oz_y=>NULL()
  real(r_kind),dimension(:,:,:),pointer :: cw_y=>NULL()

  real(r_kind),dimension(:,:,:),pointer :: p_t =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: u_t =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: v_t =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: t_t =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: q_t =>NULL()
  real(r_kind),dimension(:,:,:),pointer :: oz_t=>NULL()
  real(r_kind),dimension(:,:,:),pointer :: cw_t=>NULL()

! Get all pointers:

! from guess ...
  call init_vars_('guess',guess)

! from longitudinal derivative ...
  call init_vars_('xderivative',xderivative)

! from latitudinal derivative ...
  call init_vars_('yderivative',yderivative)

! from tendency ...
  call init_vars_('tendency',tendency)

! NOTES:
!  - equations taken from NCEP Office Note 445 (Juang 2005)
!  - this is the nonlinear routine, which currently in the GSI is only
!    called based on the current guess solution.  As such, basic state
!    variables that are needed for the TLM are loaded here (in the *9
!    arrays)

  what9=zero

  call get_zderivs(z,z_x,z_y,mype)
! preliminaries
  call getprs_horiz(ps_x,ps_y,pri,pri_x,pri_y)

!  Loop over threads
!$omp parallel do schedule(dynamic,1) private(i,j,k,kk,jx,jxp,jxm,ixp,ixm,ix, &
!$omp                  tmp,tmp2,uuvv,sumk,sumvk,sum2k,sum2vk)

  do kk=1,nthreads
    if(wrf_nmm_regional.or.nems_nmmb_regional) then
      do j=jtstart(kk),jtstop(kk)
        jx=j+jstart(mype+1)-2
        jx=min(max(1,jx),nlon)
        jxp=jx+1
        jxm=jx-1
        if(jx==1) then
           jxp=2
           jxm=1
        elseif(jx==nlon) then
           jxp=nlon
           jxm=nlon-1
        end if
        do i=1,lat2
           ix=istart(mype+1)+i-2
           ix=min(max(ix,1),nlat)
           ixp=ix+1
           ixm=ix-1
           if(ix==1) then
              ixp=2
              ixm=1
           elseif(ix==nlat) then
              ixp=nlat
              ixm=nlat-1
           end if
           coriolis(i,j)=two*omega*sin(region_lat(ix,jx))
           curvx(i,j)=(region_dy(ix,jxp)-region_dy(ix,jxm))/((jxp-jxm)*region_dx(ix,jx)*region_dy(ix,jx))
           curvy(i,j)=(region_dx(ixp,jx)-region_dx(ixm,jx))/((ixp-ixm)*region_dx(ix,jx)*region_dy(ix,jx))
        end do
      end do
    else
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           ix=istart(mype+1)+i-2
           ix=min(max(ix,2),nlat-1)
           coriolis(i,j)=two*omega*sin(rlats(ix))
           curvx(i,j)=zero
           curvy(i,j)=-tan(rlats(ix))/rearth
        end do
      end do
    end if

    do k=1,nsig
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           r_prsum9(i,j,k)=one/(pri(i,j,k)+pri(i,j,k+1))
           prdif9(i,j,k)=pri(i,j,k)-pri(i,j,k+1)
           r_prdif9(i,j,k)=one/prdif9(i,j,k)
           pr_xsum9(i,j,k)=pri_x(i,j,k)+pri_x(i,j,k+1)
           pr_xdif9(i,j,k)=pri_x(i,j,k)-pri_x(i,j,k+1)
           pr_ysum9(i,j,k)=pri_y(i,j,k)+pri_y(i,j,k+1)
           pr_ydif9(i,j,k)=pri_y(i,j,k)-pri_y(i,j,k+1)
        end do
      end do
    end do

!   Compute horizontal part of tendency for 3d pressure (so dps/dt is the same
!   as prsth9(i,j,1) . . . also note that at the top, dp/dt=0
!   or: prsth9(i,j,nsig+1)=zero

    do j=jtstart(kk),jtstop(kk)
      do i=1,lat2
        prsth9(i,j,nsig+1)=zero
      end do
    end do
    do k=nsig,1,-1
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           prsth9(i,j,k)=prsth9(i,j,k+1) - ( u(i,j,k)*pr_xdif9(i,j,k) + &
                v(i,j,k)*pr_ydif9(i,j,k)    + (u_x(i,j,k) + v_y(i,j,k))* &
                prdif9(i,j,k) )
        end do
      end do
    end do

!   Compute horizontal part of tendency for T (needed for vertical velocity in hybrid theta coordinates)

    do k=1,nsig
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           tmp=-rd*t(i,j,k)*r_prsum9(i,j,k)
           t_t(i,j,k)=-u(i,j,k)*t_x(i,j,k) - v(i,j,k)*t_y(i,j,k)
           t_t(i,j,k)=t_t(i,j,k) -tmp*rcp * ( u(i,j,k)*pr_xsum9(i,j,k) + &
              v(i,j,k)*pr_ysum9(i,j,k) + &
              prsth9(i,j,k) + prsth9(i,j,k+1) )
        end do  !end do j
      end do    !end do i

    end do  !end do k

!   calculate vertical velocity term:  z(dp/dz) (zero at top/bottom interfaces)
!   if running global, and there is a c(k) coefficient, we call the vvel subroutine

    if ( (.not.regional) .AND. (idvc5==3)) then
      call getvvel(t,t_t,prsth9,prdif9,what9,jtstart(kk),jtstop(kk))
    else
      if(wrf_nmm_regional.or.nems_nmmb_regional) then
        do k=2,nsig
          do j=jtstart(kk),jtstop(kk)
             do i=1,lat2
                 what9(i,j,k)=prsth9(i,j,k)-eta2_ll(k)*prsth9(i,j,1)
             end do
          end do
        end do
      else
        do k=2,nsig
          do j=jtstart(kk),jtstop(kk)
             do i=1,lat2
                 what9(i,j,k)=prsth9(i,j,k)-bk5(k)*prsth9(i,j,1)
             end do
          end do
        end do
      end if
    end if ! end if on

!   load actual dp/dt here now, as prsth9 is reused in
!   what9(i,k,1) & what9(i,j,nsig+1) = zero
!   p_t(i,j,1) is the same as the surface pressure tendency

    ip3d=getindex(dvars3d,'prse')
    if (ip3d>0) then
       do k=1,nsig+1
         do j=jtstart(kk),jtstop(kk)
           do i=1,lat2
              p_t(i,j,k)=prsth9(i,j,k)-what9(i,j,k)
           end do
         end do
       end do
    endif

!   before big k loop, zero out the km1 summation arrays
    do j=jtstart(kk),jtstop(kk)
      do i=1,lat2
        sumkm1(i,j)=zero
        sum2km1(i,j)=zero
        sumvkm1(i,j)=zero
        sum2vkm1(i,j)=zero
      end do
    end do

!   Compute tendencies for wind components & Temperature

    icw =getindex(dvars3d,'cw')
    ioz =getindex(dvars3d,'oz')
    iq  =getindex(dvars3d,'q')
    ip3d=getindex(dvars3d,'prse')
    do k=1,nsig
      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           tmp=-rd*t(i,j,k)*r_prsum9(i,j,k)
           uuvv=u(i,j,k)*u(i,j,k)+v(i,j,k)*v(i,j,k)
           u_t(i,j,k)=-u(i,j,k)*u_x(i,j,k) - v(i,j,k)*u_y(i,j,k) + &
              coriolis(i,j)*v(i,j,k) + curvx(i,j)*uuvv
           u_t(i,j,k)=u_t(i,j,k) + pr_xsum9(i,j,k)*tmp - grav*z_x(i,j)

           v_t(i,j,k)=-u(i,j,k)*v_x(i,j,k) - v(i,j,k)*v_y(i,j,k) - &
              coriolis(i,j)*u(i,j,k) + curvy(i,j)*uuvv
           v_t(i,j,k)=v_t(i,j,k) + pr_ysum9(i,j,k)*tmp - grav*z_y(i,j)

!   horizontal advection of "tracer" quantities

           if (iq >0) q_t (i,j,k) = -u(i,j,k)*q_x (i,j,k) - v(i,j,k)*q_y (i,j,k)
           if (ioz>0) oz_t(i,j,k) = -u(i,j,k)*oz_x(i,j,k) - v(i,j,k)*oz_y(i,j,k)
           if (icw>0) cw_t(i,j,k) = -u(i,j,k)*cw_x(i,j,k) - v(i,j,k)*cw_y(i,j,k)

!   vertical flux terms

           if (k>1) then
              tmp = half*what9(i,j,k)*r_prdif9(i,j,k)
              u_t (i,j,k) = u_t (i,j,k) - tmp*(u (i,j,k-1)-u (i,j,k))
              v_t (i,j,k) = v_t (i,j,k) - tmp*(v (i,j,k-1)-v (i,j,k))
              t_t (i,j,k) = t_t (i,j,k) - tmp*(t (i,j,k-1)-t (i,j,k))
              if (iq >0) q_t (i,j,k) = q_t (i,j,k) - tmp*(q (i,j,k-1)-q (i,j,k))
              if (ioz>0) oz_t(i,j,k) = oz_t(i,j,k) - tmp*(oz(i,j,k-1)-oz(i,j,k))
              if (icw>0) cw_t(i,j,k) = cw_t(i,j,k) - tmp*(cw(i,j,k-1)-cw(i,j,k))
           end if
           if (k<nsig) then
              tmp = half*what9(i,j,k+1)*r_prdif9(i,j,k)
              u_t (i,j,k) = u_t (i,j,k) - tmp*(u (i,j,k)-u (i,j,k+1))
              v_t (i,j,k) = v_t (i,j,k) - tmp*(v (i,j,k)-v (i,j,k+1))
              t_t (i,j,k) = t_t (i,j,k) - tmp*(t (i,j,k)-t (i,j,k+1))
              if (iq >0) q_t (i,j,k) = q_t (i,j,k) - tmp*(q (i,j,k)-q (i,j,k+1))
              if (ioz>0) oz_t(i,j,k) = oz_t(i,j,k) - tmp*(oz(i,j,k)-oz(i,j,k+1))
              if (icw>0) cw_t(i,j,k) = cw_t(i,j,k) - tmp*(cw(i,j,k)-cw(i,j,k+1))
           end if
        end do  !end do j
      end do    !end do i

      do j=jtstart(kk),jtstop(kk)
        do i=1,lat2
           tmp = rd*t(i,j,k)*r_prsum9(i,j,k)
           tmp2 = prdif9(i,j,k)*r_prsum9(i,j,k)
           sumk=sumkm1(i,j)     + tmp*( pr_xdif9(i,j,k) - tmp2*pr_xsum9(i,j,k) )
           sumvk=sumvkm1(i,j)   + tmp*( pr_ydif9(i,j,k) - tmp2*pr_ysum9(i,j,k) )
           sum2k=sum2km1(i,j)   + t_x(i,j,k)*tmp2
           sum2vk=sum2vkm1(i,j) + t_y(i,j,k)*tmp2

           u_t(i,j,k) = u_t(i,j,k) - sumkm1(i,j) - rd*sum2km1(i,j) - sumk - rd*sum2k
           v_t(i,j,k) = v_t(i,j,k) - sumvkm1(i,j) - rd*sum2vkm1(i,j) - sumvk - rd*sum2vk

!   load up the km1 arrays for next k loop

           sumkm1(i,j)=sumk
           sumvkm1(i,j)=sumvk
           sum2km1(i,j)=sum2k
           sum2vkm1(i,j)=sum2vk
        end do
      end do
    end do  !end do k

    call turbl(u,v,pri,t,teta,z,u_t,v_t,t_t,jtstart(kk),jtstop(kk))

    if(.not.wrf_nmm_regional.and..not.nems_nmmb_regional)then
      do k=1,nsig

        do j=jtstart(kk),jtstop(kk)
           do i=1,lat2
              ix=istart(mype+1)+i-2
              if (ix == 1 .OR. ix == nlat) then
                 u_t(i,j,k)=zero
                 v_t(i,j,k)=zero
              end if
           end do
        end do

      end do  !end do k
    end if

  end do
!  End of threading loop

  return

  contains
  subroutine init_vars_ (thiscase,bundle)

  type(gsi_bundle) :: bundle
  character(len=*),intent(in) :: thiscase

  character(len=*),parameter::myname_=myname//'*init_vars_'
  integer(i_kind) ier,istatus

!NOTE: this is not general - and in many ways it's wired just as the original
!      code. However, this can be easily generalized by a little re-write
!      of the main code in the subroutine above - TO BE DONE.

  icw =getindex(dvars3d,'cw')
  ioz =getindex(dvars3d,'oz')
  iq  =getindex(dvars3d,'q')
  ip3d=getindex(dvars3d,'prse')

! If require guess vars available, extract from bundle ...
  if (trim(thiscase)=='guess') then
     ier=0
     call gsi_bundlegetpointer(bundle,'z' ,z   ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'u' ,u   ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'v' ,v   ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'tv',t   ,istatus)
     ier=ier+istatus
     if (iq>0) then
        call gsi_bundlegetpointer(bundle,'q' ,q   ,istatus)
        ier=ier+istatus
     endif
     if (ioz>0) then
        call gsi_bundlegetpointer(bundle,'oz',oz  ,istatus)
        ier=ier+istatus
     endif
     if (icw>0) then
        call gsi_bundlegetpointer(bundle,'cw',cw  ,istatus)
        if (istatus /=0) then
            cw => cwgues
            istatus=0
        endif
        ier=ier+istatus
     endif
  endif
  if (trim(thiscase)=='xderivative') then
     ier=0
     call gsi_bundlegetpointer(bundle,'ps',ps_x,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'u' ,u_x ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'v' ,v_x ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'tv',t_x ,istatus)
     ier=ier+istatus
     if (iq>0) then
        call gsi_bundlegetpointer(bundle,'q' ,q_x ,istatus)
        ier=ier+istatus
     endif
     if (ioz>0) then
        call gsi_bundlegetpointer(bundle,'oz',oz_x,istatus)
        ier=ier+istatus
     endif
     if (icw>0) then
        call gsi_bundlegetpointer(bundle,'cw',cw_x,istatus)
        ier=ier+istatus
     endif
  endif
  if (trim(thiscase)=='yderivative') then
     ier=0
     call gsi_bundlegetpointer(bundle,'ps',ps_y,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'u' ,u_y ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'v' ,v_y ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'tv',t_y ,istatus)
     ier=ier+istatus
     if (iq>0) then
        call gsi_bundlegetpointer(bundle,'q' ,q_y ,istatus)
        ier=ier+istatus
     endif
     if (ioz>0) then
        call gsi_bundlegetpointer(bundle,'oz',oz_y,istatus)
        ier=ier+istatus
     endif
     if (icw>0) then
        call gsi_bundlegetpointer(bundle,'cw',cw_y,istatus)
        ier=ier+istatus
     endif
  endif
  if(trim(thiscase)=='tendency') then
     ier=0
     call gsi_bundlegetpointer(bundle,'u' ,u_t ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'v' ,v_t ,istatus)
     ier=ier+istatus
     call gsi_bundlegetpointer(bundle,'tv',t_t ,istatus)
     ier=ier+istatus
     if (iq>0) then
        call gsi_bundlegetpointer(bundle,'q' ,q_t ,istatus)
        ier=ier+istatus
     endif
     if (ioz>0) then
        call gsi_bundlegetpointer(bundle,'oz',oz_t,istatus)
        ier=ier+istatus
     endif
     if (icw>0) then
        call gsi_bundlegetpointer(bundle,'cw',cw_t,istatus)
        ier=ier+istatus
     endif
     if (ip3d>0) then
        call gsi_bundlegetpointer(bundle,'prse',p_t,istatus)
        ier=ier+istatus
     endif
  endif
  if (ier/=0) then
      call die(myname_,': missing fields in '//trim(thiscase)//' ier=',ier)
  endif

  end subroutine init_vars_

end subroutine calctends


      SUBROUTINE WEIGEX(BUF,LBUF,IBUF,SCR,LSCR)
!     WEIGEX IS THE EXECUTION PHASE OF THE SEISMIC PROCESS WEIGHT, WHICH WEIGHTS
!  (SCALAR MULTIPLIES) A TRACE.  THE WEIGHT PARAMETERS MUST BE ON DISC FILE MUNIT
!  AND THE TRACE (WITH HEADER) MUST BE IN MEMORY LOCATION BUF.
!     SUBROUTINE WEIGED CONTAINS THE EXPLAINATION OF THE USER PARAMETERS AND THE
!  ORDER OF THE USER PARAMETERS ON DISC.
!
!  ARGUMENTS:
!  BUF    - THE TRACE TO BE WEIGHTED, INCLUDING THE TRACE HEADER.  THE FIRST
!           DATA SAMPLE MUST BE AT TIME DELAY.  THIS IS THE FLOATING
!           POINT (REAL) TRACE ARRAY.
!  LBUF   - THE LONG INTEGER TRACE ARRAY.  THIS IS REALLY THE SAME AS BUF, BUT
!           PRIME FORTRAN DOESN'T ALLOW EQUIVALENCING ANYTHING TO AN ARGUMENT.
!  IBUF   - THE SHORT INTEGER TRACE ARRAY.  NEEDED FOR 16 BIT TRACE HEADER
!           ADDRESSES.
!  SCR    - A SCRATCH ARRAY FOR READING THE PARAMETERS.  THEREFORE, SCR MUST
!           BE AT LEAST 56 32BIT WORDS BIG.  SCR MAY BE DESTROYED BY THE CALLING
!           ROUTINE.
!  LSCR   - THE SAME SCRATCH ARRAY BECAUSE OF THE EQUIVALENCING PROBLEM.
!
!  COPYRIGHTED BY:
!  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, NOVEMBER 1980
!
! mod 21 Feb 96 - record weight didn't work when ap assigned but data not in ap.
! mod 12 Aug 92 - multiple lists didn't work correctly when skipping records
! mod 7 March 91 to add parameter weight (record weight - all traces)
! modified 27 nov 89 - fill rather than multiply when weight is 0., because
!                      NaN * weight = NaN
! mod 22 Sep 99 - Add IHDR, LHDR, HDR, INVERSE
! mod Apr 06 - Fedora refuses to GOTO into the middle of another block
!  30 Aug 19 - account for nsamps being an unsigned integer.  Don' use common readt numdat
!              because shift may be in the procs list many times and I think the header in the
!              data may be more reliable - not sure of that statement, but weight didn't use numdat
!              before and everything seemed to work.
!
!
      PARAMETER (MAXTWP=200)                                            ! THE MAXIMUM NUMBER OF ELEMENTS THE USER ARRAY CAN BE
      DIMENSION BUF(111),LBUF(111),IBUF(111),SCR(111),LSCR(111)
      INTEGER*2 IBUF
      DIMENSION OLDTWP(MAXTWP),CURTWP(MAXTWP)
      COMMON /WEIGR/ MUNIT,NLISTS, npars, nwrds
      COMMON /SIOAP/ IASGND,IRELSE,IN,IOUT,NEXTAD,LAPSIZ,IFREE,IUSEAP
      COMMON /APMEM/ A(32766)
      COMMON /READT/ ILUN,NUMHDR
      INTEGER FNO, hdr
      LOGICAL FIRST
      SAVE
      DATA FIRST /.TRUE./, lastno/0/
!****
!****     FIND THE PARAMETER LIST (ON DISC) FOR THIS SHOT (RP)
!****
      ISIG=0
      IF(IBUF(15).EQ.2) RETURN                                          ! IS IT A DEAD TRACE
   10 CONTINUE                                                      ! GET THE FIRST PARAMETER LIST INT0 MEMORY ARRAY SCR
      IF(  FIRST ) THEN
          FIRST=.FALSE.
          CALL PODISC(MUNIT,1,0)
          CALL RDDISC(MUNIT,SCR,NWRDS,ISTAT)
          ISIG=1
          FNO=LSCR(1)
          LNO=LSCR(2)
          IADDWB=LSCR(3)
          NTWPS=LSCR(4)
          LTYPE=LSCR(5)
          lprint=LSCR(6)
          rweight1 = scr(7)
          ihdr = lscr(8)
          lhdr = lscr(9)
          hdr = lscr(10)
          inverse = lscr(11)
          itype = lscr(12)
          IF( ntwps .GT. 0 ) THEN
              DO I = 1, ntwps
                 CURTWP(I) = SCR(I+npars)
              ENDDO
              IF( inverse .EQ. 1 ) THEN
                  DO i = 2, ntwps, 2
                     IF( curtwp(i) .NE. 0. ) curtwp(i) = 1. / curtwp(i)
                  ENDDO
              ENDIF
          ENDIF
          IF( inverse .EQ. 1 .AND. rweight1 .NE. 0. )
     &        rweight1 = 1. / rweight1
          MLISTS=1
      ENDIF
      LNUM=LBUF(3)                                                      !  IS THE DATA ON TAPE SORTED BY SHOT
      TRNO=LBUF(4)                                                      ! THE TRACE NUMBER WITHIN THE SHOT
      IF( LBUF(7) .NE. 0 ) THEN
          TRNO=LBUF(7)                                                  ! THE TRACE NUMBER WITH AN RP
          LNUM=LBUF(6)                                                  !  OR BY RP
      ENDIF
   70 CONTINUE
      IF(LNUM.GE.FNO) GO TO 100                                         ! IS THIS SHOT BEFORE THIS PARAMTER LIST
      IF(MLISTS.EQ.1) RETURN                                            ! IS IT BEFORE THE FIRST LIST
      IF(LNUM.LE.LASTNO) THEN                                           ! IS IT IN OR BEFORE THE LAST LIST
         FIRST = .TRUE.
         GOTO 10
      ENDIF
      RETURN                                                            ! IF THE SHOT IS NOT SPECIFIED, LEAVE IT ALONE
  100 CONTINUE                                                          !  THE CURRENT SHOT (RP) IS >= LNO
      IF(LNUM.LE.LNO) GO TO 500                                         ! USE THE PARAMETERS OF THIS LIST
      IF(MLISTS.GE.NLISTS) RETURN                                       ! ANY MORE USER PARAM LISTS ON DISC
!****
!****   GET ANOTHER USER PARAMETER LIST FROM DISC
!****
      DO I=1,MAXTWP                                                 ! SAVE THE CURRENT PARMETER SET
  120    OLDTWP(I)=SCR(I+npars)
      ENDDO
      LASTNO=LNO
      NOTWPS=LSCR(4)
      ISIG=1
      MLISTS=MLISTS+1
      CALL RDDISC(MUNIT,LSCR,NWRDS,ISTAT)
      FNO=LSCR(1)
      LNO=LSCR(2)
      IADDWB=LSCR(3)
      NTWPS=LSCR(4)
      LTYPE=LSCR(5)
      lprint=LSCR(6)
      rweight1 = scr(7)
      ihdr = lscr(8)
      lhdr = lscr(9)
      hdr = lscr(10)
      inverse = lscr(11)
      IF( ntwps .GT. 0 ) THEN
          DO I = 1, ntwps
             CURTWP(I) = SCR(I+npars)
          ENDDO
          IF( inverse .EQ. 1 ) THEN
              DO i = 2, ntwps, 2
                 IF( curtwp(i) .NE. 0. ) curtwp(i) = 1. / curtwp(i)
              ENDDO
          ENDIF
      ENDIF
      IF( inverse .EQ. 1 .AND. rweight1 .NE. 0. )
     &    rweight1 = 1. / rweight1
      GO TO 70
!****
!****    NOW FIND THE WEIGHT FOR THE  TRACE NUMBER (OR RANGE)
!****
  500 IF( ISIG .NE. 0 ) THEN                                            ! IS A LIST IN SCR
          IADDWB=LSCR(3)
          NTWPS=LSCR(4)
          LTYPE=LSCR(5)
          lprint=LSCR(6)
          rweight1 = scr(7)
          ihdr = lscr(8)
          lhdr = lscr(9)
          hdr = lscr(10)
          inverse = lscr(11)
          itype = lscr(12)
          IF( ntwps .GT. 0 ) THEN
              DO I = 1, ntwps
                 CURTWP(I) = SCR(I+npars)
              ENDDO
              IF( inverse .EQ. 1 ) THEN
                  DO i = 2, ntwps, 2
                     IF( curtwp(i) .NE. 0. ) curtwp(i) = 1. / curtwp(i)
                  ENDDO
              ENDIF
          ENDIF
          IF( inverse .EQ. 1 .AND. rweight .NE. 0. )
     &        rweight = 1. / rweight
      ENDIF
      rweight = rweight1
      IF(LNUM.LT.FNO.OR.LNUM.GT.LNO) RETURN                             ! DOUBLE CHECK THAT WE GOT THE RIGHT LIST
!      NSAMPS=IBUF(58)
!****   number of samples is an unsigned short
      CALL ushort2long( ibuf(58), nsamps )
      IF( ihdr .NE. 0 ) THEN
          temp = REAL(ibuf(ihdr))
          IF( inverse .EQ. 1 ) temp = 1. / temp
          rweight = rweight * temp
      ENDIF
      IF( lhdr .NE. 0 ) THEN
          temp = FLOAT(lbuf(lhdr))
          IF( inverse .EQ. 1 ) temp = 1. / temp
          rweight = rweight * temp
      ENDIF
      IF( hdr .NE. 0 ) THEN
          temp = buf(hdr)
          IF( inverse .EQ. 1 ) temp = 1. / temp
          rweight = rweight * temp
      ENDIF
!****
!****   Do the Statistical stuff first
!****
      IF( itype .EQ. 1 ) THEN
          IF( in .EQ. 0 ) THEN
              CALL moment( buf(numhdr+1), nsamps,
     &             ave, adev, sdev, var, skew, curt )
          ELSE
              CALL moment( a(in), nsamps,
     &             ave, adev, sdev, var, skew, curt )
          ENDIF
          IF( IAND(lprint,16) .NE. 0 ) THEN
              PRINT *,' Record',lnum,' trace',trno,' statistics are:',
     &        ' ave=',ave,' adev=',adev,' sdev=',sdev,' var=',var,
     &        ' skew=',skew,' curt=',curt,' weight=',1./sdev
          ENDIF
          IF( ave .NE. 0 ) rweight = rweight / sdev
      ENDIF
!****
!****  Do the parameter WEIGHT (rweight = record weight = all traces)
!****
      IF( rweight .NE. 1. ) THEN
          IF( rweight .EQ. 0. ) ibuf(15) = 2
          IF( iuseap .EQ. 0 ) THEN                                      ! =0 if no ap
              IF( in .EQ. 0 ) THEN                                      ! = 0 if not in ap simulator or ap
                  IF( rweight .NE. 0. ) THEN
                      DO i = 1, nsamps
  502                    buf(numhdr+i) = buf(numhdr+i) * rweight
                      ENDDO
                  ELSE
                      DO i = 1, nsamps
  503                    buf(numhdr+i) = 0.
                      ENDDO
                  ENDIF
              ELSE
                  j = in -1
                  IF( rweight .NE. 0. ) THEN
                      DO i = 1, nsamps
  504                    a(j+i) = a(j+i) * rweight
                      ENDDO
                  ELSE
                      DO i = 1, nsamps
  505                    a(j+i) = 0.
                      ENDDO
                  ENDIF
              ENDIF
          ELSE
              CALL INAP(BUF(NUMHDR+1),NSAMPS)
              CALL APWR
              CALL APPUT(RWEIGHT,NEXTAD,1,2)
              CALL APWD
              CALL VSMUL(IN,1,NEXTAD,IN,1,NSAMPS)
          ENDIF
      ENDIF
!****
!****    Take care of the trace weights (TWP and XWP)
!****
      weight = 1.
      IF( ltype .EQ. 0 ) GOTO 590
      I=1
      IF(LTYPE.EQ.2) GO TO 507
      TEMP=LBUF(10)                                                     ! TRNO=ABS(LBUF(10) DOESN'T WORK!!!
      TRNO=ABS(TEMP)                                                    ! SET THE TRACE NO TO THE RANGE IF XWP WAS GIVEN
  507 CONTINUE
  510 IF(TRNO.EQ.CURTWP(I)) GO TO 550
!**** WATCH OUT FOR ROUND OFF PROBLEMS ON THE RANGE
      IF(TRNO.GT.CURTWP(I)-.0001.AND.TRNO.LT.CURTWP(I)+.0001) GO TO 550
      I=I+2
      IF(I.LE.NTWPS) GO TO 510
      GOTO 590
  550 WEIGHT=CURTWP(I+1)
      IF(WEIGHT.EQ.0.) IBUF(15)=2
      IF(IUSEAP.NE.0.AND.IASGND.NE.0) GO TO 580
      IF(IN.NE.0.AND.IUSEAP.EQ.0) GO TO 570
      IF( weight .NE. 0. ) THEN
          DO ii = 1, nsamps
  560        BUF(NUMHDR+II) = BUF(NUMHDR+II)*WEIGHT
          ENDDO
      ELSE
          DO ii = 1, nsamps
  565        buf(numhdr+ii) = 0.
          ENDDO
      ENDIF
      GO TO 590
  570 J=IN-1                                                            ! THE DATA IS IN APMEM
      IF( weight .NE. 0. ) THEN
          DO II=1,NSAMPS
  575        A(J+II)=A(J+II)*WEIGHT
          ENDDO
      ELSE
          DO ii = 1, nsamps
  576        a(j+ii) = 0.
          ENDDO
      ENDIF
      GO TO 590
  580 CALL INAP(BUF(NUMHDR+1),NSAMPS)
      CALL APWR
      CALL APPUT(WEIGHT,NEXTAD,1,2)
      CALL APWD
      CALL VSMUL(IN,1,NEXTAD,IN,1,NSAMPS)
  590 IF( IAND(lprint,8) .NE. 0 ) THEN
          x = 1.
          IF( weight .NE. 1. ) x = weight
          IF( rweight .NE. 1. ) x = rweight
          IF( weight .NE. 1. .AND. rweight .NE. 1.) x = weight * rweight
          IF( x .NE. 1. ) PRINT 600,LNUM,TRNO, x
  600    FORMAT(' RECORD ',I10,' TRACE ',F9.3,' IS MULTIPLIED BY ',G8.3)
      ENDIF
      RETURN
      END


      Subroutine FKSHEX(ibuf,buf,lbuf,iscr,scr,lscr)
!-------------------------------------------------------------------------------
!
!    This is a test version of FKSHFT, a routine to extrapolate FK
! transformed input data. It uses a Phase shift to lower or raise the apparent
! recording depth of the input data
!
! Inputs:
!    BUF - The complex frequency trace to be migrated
!   IBUF - The integer*2 equivalent of buf. Used to pass trace header info
!   LBUF - The integer*4 equivalent of buf. Used to pass trace header info
!   SCR/ISCR/LSCR/ - Scratch array and its integer equivalents.
!
! Outputs:
!    BUF - contains the migrated trace.
!
! Called from : CONTRO
!
! Externals :
!  PODISC, RDDISC    : Disk i/o routines
!  INAP
! Non-AP version
!  RECTC, POLARC     : Coordinate conversion routines
!-------------------------------------------------------------------------------
! mod 8 Apr 09 - Use common numdat rather than segy header word ISAMPPTR
! mod 5 Jun 09 - Forgot to divide by 2 on the above

!
      integer SZAPMEM, SZTRANP
      parameter (SZAPMEM = 65537)
      parameter (SZTRANP = 262144)                                      ! Size of /TRANP/: Transpose array at 512 x512
! parameter definitions for the stop signal istop
      integer STOPNOTR, STOPTR, NOSTOP
      parameter (STOPNOTR  = -1)                                        ! last call but no trace passed
      parameter (STOPTR    =  1)                                        ! last call and a trace passed
      parameter (NOSTOP    =  0)                                        ! normal call to the routine
! parameter for AP
      integer CLEARAP, USEAP, NOAP
      integer DATINAP
      parameter (USEAP    = 1)                                          ! There is an AP available
      parameter (NOAP     = 0)                                          ! No AP available
      parameter (CLEARAP  = 0)                                          ! Get data out of AP simulator
      parameter (DATINAP   = 1)

      integer     CRAYEBC, NORMEBC
      parameter ( CRAYEBC  = 400)
      parameter ( NORMEBC  = 2*CRAYEBC)
      integer     CRAYBIN, NORMBIN
      parameter ( CRAYBIN  =  50)
      parameter ( NORMBIN  = 2*CRAYBIN)
      integer    NTRCPTR, NAUXPTR, IFMTPTR, IDTYPPTR, INKPTR, ITSIPTR
      integer    ITDELPTR, IVERSPTR
      parameter (NTRCPTR  =  7)
      parameter (NAUXPTR  =  8)
      parameter (IFMTPTR  = 13)
      parameter (IDTYPPTR = 31)
      parameter (INKPTR   = 32)
      parameter (ITSIPTR  = 33)
      parameter (ITDELPTR = 34)
      parameter (IVERSPTR = 35)
      integer IBMFP, INT16, INT32, HOSTFP
      parameter (IBMFP  = 1)
      parameter (INT32  = 2)
      parameter (INT16  = 3)
      parameter (HOSTFP = 5)
      integer    IDTX, IDFKRCT, IDFKPLR, IDTP, IDFKPLRU
      parameter (IDTX     = 1)
      parameter (IDFKRCT  = 2)
      parameter (IDFKPLR  = 3)
      parameter (IDTP     = 7)
      parameter (IDFKPLRU = 8)
      integer  CURVERS
      parameter( CURVERS = 210)
      integer  CRAYTHDR, NORMTHDR
      parameter ( CRAYTHDR =  30)
      parameter ( NORMTHDR = 2*CRAYTHDR)
!
      common /SEGYPTR/ LLSEQPTR, LRSEQPTR, LSHOTPTR, LSHTRPTR, LRPNPTR,
     *                 LRPTRPTR, ITRIDPTR, LDISTPTR, LWBDPTR,  LSXCOPTR,
     *                 LRXCOPTR, IDELMPTR, ISTMPTR,  IENDMPTR, ISAMPPTR,
     *                 ISIPTR,   IYRPTR,   IDAYPTR,  IHRPTR,   IMINPTR,
     *                 ISECPTR,  IGMTPTR,  LDELSPTR, LSMUSPTR, LEMUSPTR,
     *                 LSISPTR,  LWBTSPTR, LGATPTR,  LSSMSPTR, LESMSPTR,
     *                 LSBPTR
      integer    LIVETR, DEADTR
      parameter (LIVETR  = 1)
      parameter (DEADTR  = 2)
      integer    CREATTMP, RESERVEU, CREATNEW, OPENOLD
      parameter (CREATTMP   = 1)
      parameter (RESERVEU   = 2)
      parameter (CREATNEW   = 3)
      parameter (OPENOLD    = 4)
      integer    RLUNIT, RLDLCLS, RLCLS
      parameter (RLUNIT  = 1)
      parameter (RLCLS   = 2)
      parameter (RLDLCLS = 3)
      integer    POSABS, POSREL, DSKSTRT
      parameter (POSABS     = 1)
      parameter (POSREL     = 2)
      parameter (DSKSTRT    = 0)
      integer   EOF
      parameter  (EOF = -1)
      integer CDRECT, CDPOLAR, CDPOLARU
      parameter ( CDRECT   = 1)
      parameter ( CDPOLAR  = 2)
      parameter ( CDPOLARU = 3)
      integer BoxCar
      parameter (BoxCar = 5)
!
      Parameter (NSCLRS = 7)
      Parameter (PI = 3.141592654)
!
      common /SIOAP/ iasgnd,irelse,in,iout,nextad,lapsiz,ifree,iuseap,
     *               idecim
      common /READT/ilun,numhdr,numdat,iunhdr,ireelm,intrcs,ifmt,nskip,
     *               secs,lrenum,isrcf,idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc
      common /FKSHIFT/ v,nfint,lprint,dx,dt, realk, zextrap, to
      common /APMEM/ ap(SZAPMEM)
!
      dimension lbuf(1111),buf(1111), scr(1111),lscr(1111)
      integer*2 ibuf(1111),iscr(1111)
      integer   txsius
      integer   LocCoord
      logical   first
      save
!
      data first /.true./, nxdone/0/
!
      if (first) then
        first = .false.
!
!..                       Read the time delay/sample interval from READT common
        txsius = itxsi                                                  ! t-x sample interval in us
        delay  = itxdel/1000.                                           ! & time delay in secs.
!
        if (idtype.eq.IDFKRCT) then
           LocCoord = CDRECT
        else if ((idtype.eq.IDFKPLR).OR.(idtype.eq.IDFKPLRU)) then
           LocCoord = CDPOLAR
        else
          print *, ' *** FKSHFT Error *** ',
     *           ' The input data is not in the FK domain.'
          STOP
        endif
        nv    = 1                                                       ! Only a single velocity allowed
        nx    = 2* (nfktrc-1)                                           ! Calcalate no. of output traces
        if(dt.le.0.)
     *    dt  = FLOAT(txsius)/1.0E6                                     ! Delta t
        dk    = 2.*pi/(float(nx)*dx)                                    ! Delta k (distance between wavenumbers)
!        nw    = ibuf(ISAMPPTR)/2                                        ! The number of frequencies
        nw = numdat / 2
        dw    = 2.*pi/(float(nw)*dt)                                    ! Delta w (distance between frequencies)
        vnorm = v*v / (dw*dw)                                           ! (v** 2  normalized wrt sampling rate
!        nwrds = ibuf(ISAMPPTR)                                          ! No. of 32 bit words in the complex trace
        nwrds = numdat
        nt    = nwrds / 2                                               ! No. of time samples
        realk = 0.                                                      ! Wavenumber of the initial input trace
!
        td   = zextrap/v * dw
        tadj = (to - delay) * dw
!
        delay = to
        itxdel =  nint(delay * 1000.)                                   ! update delay in common block
      endif                                                             ! of FKSHFT initialization
!
!***********************                                ***********************
!*                          Start
!***********************                                ***********************
!
      call inap(buf(numhdr+1),nwrds)                                    ! Assume inap puts it at ap location 1
      vskso = vnorm * realk * realk                                     ! ( (v * k)/(dw) ) ** 2
!
!..                                  Host memory (Non-AP) version
      if ( iuseap.eq.NOAP ) then
        if ( LocCoord.eq.CDPOLAR ) then
          call rectc( nw, lscr, ap(in), ap(in+nw) )                     ! Convert to rect coords
          do 1010 j = 1, nwrds, 2
            ap(in+j-1) = scr(j)
            ap(in+j)   = scr(j+1)
 1010     continue
        endif
!
        if ( IAND(lprint,2).eq.2) then
          print '(/A)','Debug Info FKSHFT: Host memory version '
          print *,'Trace No: ', nxdone,' Wavenumber: ', realk
          print *,'No of w (nw): ', nw,' No of ranges (nx): ', nx,
     *            ' (v*k)/(dw)**2 (vkso): ',vskso
          print *,'AP address In: ', in, ' Nextad: ', nextad
          print *,'Delay: ', delay,' Adjust: ', tadj/dw,
     *                                 ' T extrap: ', td/dw
        endif
!
        call PSFK(vskso, ap(in), ap(nextad), nw, scr, scr, tadj, td)
!
        if ( LocCoord.eq.CDRECT) then
          do i  = 1, nwrds                                         ! Shift address of migrated trace
 1040       ap(in+i-1) = ap(nextad+i-1)
          enddo
        else if ( LocCoord.eq.CDPOLAR ) then
          call polarc(nw,ap(nextad),scr(1),scr(nw+1))
          do 1050 i=1,nw
            ap(in+i-1)    = scr(i)
            ap(in+nw+i-1) = scr(nw+i)
 1050     continue
        endif
      endif                                                             ! of Non-AP version
!
      realk  = realk  + dk                                              ! Increment the wavenumber
      nxdone = nxdone + 1                                               ! & the number of traces completed
      RETURN
      end