      subroutine fkfiex( buf, cbuf, ibuf, scr, lscr, iscr )
c-------------------------------------------------------------------------------
c
c  FKFIEX is the execution phase of the SIOSEIS seismic process FKFILT.
c  FKFILT performs filtering in the FK domain. See subroutine FKFIED for the
c  user description.
c
c     The input traces are supplied with wavenumbers varying from k = 0 to +Nyq
c  Each trace contains frequencies from -Nyq to + Nyq. This arrangement is the
c  one supplied by the 2D FFT and is convenient for the F-K migration.
c  However it differs from the conceptual model of the user which has
c  wavenumbers running from -Nyq -> 0 -> Nyq and only positive frequencies.
c
c    This setup is convenient for velocities filtering since lines are sorted
c  by FKFIED into increasing order, but care must be taken to add appropriate
c  velocity lines near v = 0 if the user wants different velocity filters in
c  0+ & 0-. Care is also need to ensure proper continuity of filter across
c  v (inf).
c
c     Conversely filters defined in terms of dips are consistent with the
c  conceptual model, since they vary smoothly from -inf -> 0 -> +inf, but are a
c  odds with the way the traces are given to FKFIEX. Thus the input dip lines
c  are converted to velocities as part of the input process.
c
c Inputs:
c    buf/cbuf/ibuf  : Equivalenced set of arrays holding the trace (header+data)
c    scr/lscr/iscr) : Equivalence set of scratch arrays.
c
c Outputs:
c    buf/cbuf/ibuf  : Filtered version of trace
c
c Call Chain:
c    CONTRO:FKFIEX
c
c Externals:
c   ClcWpt, FrmWnd                                                      ! Local fkfiex subroutines
c   INAP, RLSEAP EXIT
c   PODISC, RDDISC                                                      ! disk i/o
c
c Mdofications
c      10/12/88 ajh.  ( SZAPMEM )
c Last Modified
c      12/20/88 ajh   Altered Logic of line addition at v = 0
c                     Changed definition of vzerop
c                     Added more Debug info
c      3/16/89 ajh  Added read of binary header info through common /READT/
c     7 Nov 91 pch  Add reinitialization stuff for prestack.
c 8 Apr 09 - Use common numdat rather than segy header word ISAMPPTR
c 27 Sept 10 - Don't cal FrmWnd if cut/pass goes across 0

      integer SZAPMEM, SZTRANP
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (SZTRANP = 262144)                                      ! Size of /TRANP/: Transpose array at 512x512
C 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
C
C 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)                                         ! Data is in the AP
c This include file include all (?) of the parameters needed to define SIOSEIS
c I/O routines. In particular it defines positions of objects in the SEGY
c headers & constants for these values
c
c EBCDIC HEADER
c Declare Header lengths. These are the length of the EXTERNAL disk image in
c host words.
      integer     CRAYEBC, NORMEBC
      parameter ( CRAYEBC  = 400)
      parameter ( NORMEBC  = 2*CRAYEBC)
c
c BINARY HEADER
      integer     CRAYBIN, NORMBIN
      parameter ( CRAYBIN  =  50)                                       ! length of external disk image
      parameter ( NORMBIN  = 2*CRAYBIN)
c
c  The position of objects in the Binary header
      integer    NTRCPTR,IFMTPTR, IDTYPPTR, INKPTR, ITSIPTR
      integer    ITDELPTR
      parameter (NTRCPTR  =  7)                                         ! No of traces / gather
      parameter (IFMTPTR  = 13)                                         ! The SEGY Format of the data
      parameter (IDTYPPTR = 31)                                         ! The Domain/ID of the data e.q. T-X data
      parameter (INKPTR   = 32)                                         ! The No. of wavenumbers in an f-k dataset
      parameter (ITSIPTR  = 33)                                         ! Record of tx sample interval in us
      parameter (ITDELPTR = 34)                                         ! Record of tx time delay in ms.
c
c..Constants for SEGY Format (IFMTPTR)
      integer IBMFP, INT16, INT32, HOSTFP
      parameter (IBMFP  = 1)                                            ! IBM floating point
      parameter (INT32  = 2)
      parameter (INT16  = 3)
      parameter (HOSTFP = 5)                                            ! Host FP. In actuality Host FP >= 5
c
c.. Data Domains/Types (IDTYPPTR)
      integer    IDTX, IDFKRCT, IDFKPLR, IDFKPLRU
      parameter (IDTX     = 1)
      parameter (IDFKRCT  = 2)
      parameter (IDFKPLR  = 3)
      parameter (IDFKPLRU = 8)
c
c TRACE HEADER
c.. Declare header length on external disk files. Internal length is given by
c Numhdr in common block READT.
      integer  CRAYTHDR, NORMTHDR
      parameter ( CRAYTHDR =  30)                                       ! Length of external disk image
      parameter ( NORMTHDR = 2*CRAYTHDR)
c
      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
C
c.. Define Constants for Trace Header
c
c.. Constants for Trace ID (ITRIDPTR)
      integer    LIVETR, DEADTR                                         ! Parameters for trace Type
      parameter (LIVETR  = 1)
      parameter (DEADTR  = 2)
C
c.. Define constants for use with the DISKIO subroutines getfil, frefil,
c podisc
c GETFIL constants
      integer    CREATTMP, CREATNEW
      parameter (CREATTMP   = 1)                                        ! Create a temporary file
      parameter (CREATNEW   = 3)                                        ! Create a new named file
c FREFIL constants
      integer    RLDLCLS
      parameter (RLDLCLS = 3)
c PODISC constants
      integer    POSABS, POSREL, DSKSTRT
      parameter (POSABS     = 1)
      parameter (POSREL     = 2)
      parameter (DSKSTRT    = 0)                                        ! The starting position on the disk
c fkfilt.inc
c Include file for the FK filter routines FKFIED & FKFIEX
c
      integer    NSETSP, DBLSETSP
      parameter (NSETSP = 20 )                                          ! The max. no. of FKFIED input values
      parameter (DBLSETSP  = 2*NSETSP)
c
      integer    SINGPARM                                               ! The number of single valued params
      parameter( SINGPARM = 6)
c
      integer     FILNOTST , FILTERR, FILTVEL, FILTDIP
      parameter ( FILNOTST  = -8)                                       ! Declare constants for the filter types
      parameter ( FILTERR   = -7)
      parameter ( FILTVEL   =  1)
      parameter ( FILTDIP   =  2)
c
      integer    CUT, PASS, ATINF
      parameter (CUT = 2, PASS = 1)
      parameter ( ATINF = 2)                                            ! Constant signifying lines near v = inf
c
      Integer PCdir, CPdir, PCinf, CPinf
      Parameter (PCdir =  Cut - Pass)
      Parameter (CPdir = Pass - Cut)
      Parameter (PCinf = AtInf * PCdir)
      Parameter (CPinf = AtInf * CPdir)
c
      Integer INITWDW
      Parameter (INITWDW = 32)
      Parameter (NOINIT  = 0)
c
c..                         Declare constants for the available window types
      integer     NUMWINDT
      parameter (NUMWINDT = 8)                                          ! The number of available window types
      Integer Hamming, Hanning, Gaussian, Bartlett, Rectang
      Integer Blackman, ExctBlck, BlckHarr
      Parameter (Hamming  = 1)
      Parameter (Hanning  = 2)
      Parameter (Gaussian = 3)
      Parameter (Bartlett = 4)                                          ! Triangular Window
      Parameter (RectAng  = 5)
      Parameter (BlackMan = 6)
      Parameter (ExctBlck = 7)                                          ! Exact Blackman
      Parameter (BlckHarr = 8)
c
c..                              Parameters for the window options
      Integer    NUMWOPT
      parameter (NUMWOPT = 3)                                           ! The number of windowing options
      Integer  BYA, BYK, BYW
      Parameter (ByA = 1)
      Parameter (ByK = 2)
      Parameter (ByW = 3)
C PROGRAM
c
      dimension buf(111),scr(111),lscr(111)
      integer*2 ibuf(111), iscr(111)
      complex   cbuf(111)
c
      common /FKFILT/ munit, nlists, kTrace
      common /SIOAP/ iasgnd,irelse,in,iout,nextad,lapsiz,ifree,iuseap
      common /APMEM/ ap(SZAPMEM)
      common /READT/lun,numhdr,numdat,iunhdr,ireeln,intrcs,ifmt,nskip,
     *               secs,lrenum,isrcf,idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc
c
      real    vLine(DBLSETSP + 2)
      integer vType(DBLSETSP + 2), wPt(DBLSETSP + 2)
      integer FiltTyp, wBase, Offs
      integer BasAddr0, BasAddr1
      integer Taper
      logical first, Found
c
      save
c
      data first/.TRUE./, kTrace/-1/
c
      if (first) then
          first = .FALSE.
          if ( (idtype.ne.IDFKRCT).AND.(idtype.ne.IDFKPLR).AND.
     *        (idtype.ne.IDFKPLRU) ) then
             print *,' ***  FKFILT ERROR  ***  The input must be ',
     *               ' in the FK domain.'
              STOP
          endif
c
          call podisc( munit, POSABS, DSKSTRT)                          ! Get single parameters
          call rddisc( munit, scr, SINGPARM, istat )
c
          dx      = scr(1)                                              ! trace spacing
          iwindo  = lscr(2)                                             ! type of window function
          lprint  = lscr(3)                                             ! debug print option
          iwopt   = lscr(4)                                             ! manner in which to apply window
          FiltTyp = lscr(5)                                             ! Type of filter
          nLine   = lscr(6)                                             ! Number of filter lines
c
c         call podisc( iunhdr, POSABS, NORMEBC+DSKSTRT )
c         call rddisc( iunhdr, scr, NORMBIN, istat )                    ! read Binary Header
          nk     = 2*nfktrc - 1                                         ! The no. of wavenumbers
          dt     = itxsi / 1.0E6                                        ! Sample interval in secs
          if (IAND(lprint,2).ne.0) then
            print *,'FKFIEX Initialization info'
            print *,'dx: ', dx,' nk: ', nk,' dt: ', dt
            print *,'No. of Filter Lines (nLine): ', nLine
          endif
c
c..                                   Calculate the constants
c          nsamps = ibuf(ISAMPPTR)                                       ! The no. of 4 byte samples
          nsamps = numdat
c          nw     = ibuf(ISAMPPTR) / 2                                   ! The no. of frequencies
          nw = numdat / 2
          wBase  = nw / 2 + 1                                           ! The 0 frequency position
          If (FiltTyp.eq.FILTDIP) dx = 0.001                            ! Includes allowance for mS.
          vnorm  = float(nk) * dx / dt / float(nw)                      ! Non dimensioning velocity
          pnorm  = 1. / vnorm
          vinfp  = float(nw)                                            ! Velocity  ~ Inf
          vzerop = 1./ float(nk)                                        ! Velocity  = 0+
c
          BasAddr0  = DBLSETSP + 1                                      ! Set base address in scr for type info
          BasAddr1  = BasAddr0 + 1
c
          call rddisc( munit, scr, DBLSETSP, istat )                    ! Read in filter lines
          call rddisc( munit, lscr(BasAddr1), DBLSETSP, istat )         ! & cut/pass
c
          found   = .False.                                             ! Look for filter lines stradling zero
          i       = 1
  5       continue
            i     = i + 1
            if ((scr(i) * scr(i-1) ) .le. 0.) then
              found = .true.
              izm   = i - 1                                             ! Index of  last line <  0
              izp   = i                                                 ! Index of first line >= 0
            endif
          if ( (.not.Found).AND.(i.lt.nLine) ) go to 5
c
          if (.not.Found) then                                          ! Filter Line do not straddle zero
            if(scr(1).lt.0.) then
              izm = nLine                                               ! -ve Lines only
              izp = nLine + 1
              lscr(BasAddr0+izp) = lscr(BasAddr0+1)
            else                                                        ! +ve Lines only
              izm = 0
              izp = 1
              lscr(BasAddr0+izm) = lscr(BasAddr0+nline)
            endif
          endif
c...            *** Input lines were defined as dips : Convert to velocities ***
          If (FiltTyp.eq.FILTDIP) then
            j          = izp
            do 10 i = 1, izm                                            ! Convert -ve Dips
              j        = j - 1                                          ! Reverse index to preserve ordering
              vLine(j) = pnorm / scr(i)
              vType(j) = lscr(BasAddr0 + i)
  10        continue
c
c..                 Filter lines differ across v = 0 so add lines at v = 0+ & 0-
            if ( lscr(BasAddr0+1).ne.lscr(BasAddr0+nLine) ) then
              vLine(izm+1) = -vzerop
              vLine(izm+2) =  vzerop
              vType(izm+1) = lscr(BasAddr0 + 1)
              vType(izm+2) = lscr(BasAddr0 + nLine)
              ntop         = nLine + 2
              izm          = izm   + 2
            else
              ntop         = nLine
            endif
c
            if ( Found .AND. (scr(izp).eq.0.) ) then                    ! A line at zero dip ?
              vLine(izm+1) = vInfp                                      ! Convert to inf. velocity
            else
              vLine(izm+1) = pnorm/scr(nLine)
            endif
            vType(izm+1) = lscr(BasAddr0 + nLine)
c
            j = nTop + 1                                                ! Convert +ve dips to velocity
            do 20 i = izp, nLine-1
              j        = j - 1
              vLine(j) = pnorm / scr(i)
              vType(j) = lscr(BasAddr0 + i)
  20        continue
c
            nLine        = nTop
c....                                ***  Filter lines are given as velocity ***
          else if (FiltTyp.eq.FILTVEL) then
c
            do 25 i = 1, izm                                            ! Normalize -ve velocities
              vLine(i) = pnorm * scr(i)
              vType(i) = lscr(BasAddr0 + i)
  25        continue
c..
            Offs = 0
            izpp = izp + 1
            if ( Found.and.(scr(izp).eq.0.) ) then                      ! Line at v = 0
              vLine(izp)  = -vzerop                                     ! Split into 0+ & 0- lines
              vLine(izpp) =  vzerop
              vType(izp)  = lscr(BasAddr0 + izp)
              vType(izpp) = lscr(BasAddr0 + izp)
              izp         = izpp                                        ! Adjust to first v > 0
              Offs        = 1                                           ! Added a line
c
c...                                            Line types differ across v = 0.
            else if ( lscr(BasAddr0+izm).ne.lscr(BasAddr0+izp) ) then
              vLine(izp)  = -vzerop
              vLine(izpp) =  vzerop                                     ! Add lines at v = 0+ & 0-
              vType(izp)  = lscr(BasAddr0 + izm)
              vType(izpp) = lscr(BasAddr0 + izp)
              Offs        = 2
            endif
c
            do 30 i = izp, nLine                                        ! Normalize +ve velocities
              vLine(i + Offs) = pnorm * scr(i)
              vType(i + Offs) = lscr(BasAddr0 + i)
 30         continue
c
            nLine = nLine + Offs                                        ! Allow for added lines
          endif                                                         ! of if FiltTyp =
          if (IAND(lprint,2).ne.0) then
            print '(/A)','FKFIEX : Normalized Velocities'
            print *,'Adjusted No. of Filter Lines (nLine): ', nLine
            do 40 i = 1, nLine
              if (vType(i).eq.CUT) then
                print *,' Cut Velocity : ', Vline(i)
              else if (vType(i).eq.PASS) then
                print *,'Pass Velocity : ', Vline(i)
              else
                print *,'     Velocity : ', Vline(i),' Type : ',vType(i)
              endif
  40        continue
          endif
      Endif                                                             ! of if First
c
c*************************                             *************************
c*                      Start of the Main Filtering loop
c*************************                             *************************
c
      call inap( buf(numhdr+1), nsamps )                                ! Put the data in the AP
      BasAddr0            = NextAd - 1                                  ! Base address in the AP for window
      BasAddr1            = NextAd
      ap(BasAddr0 + wbase) = 0.                                         ! Zero frequency
      kTrace              = kTrace + 1                                  ! Current wavenumber (k)
c
c***                                *** Generate a Window function for trace ***
c
      If (kTrace.eq.0) then                                             ! This is the Zero wavenumber Trace
        wPt(1)     = wbase - 1
        wPt(nLine) = wbase
      else                                                              ! Wavenumber <> 0
        call ClcWpt(0, wPt, kTrace, vLine, nLine, nw)
c..                                     Position of Line Intercepts on the trace
        iprev = wPt(1)
        i     = 1
c
  120   If ( (iprev.lt.nw).AND.(i.lt.nLine) ) then
          i = i + 1
          if (wPt(i).gt.iprev) then                                     ! Gaps between lines
            if (vType(i).eq.vType(i-1))then                             ! Simple pass/cut sector
              If (vType(i).eq.CUT ) then
                 val = 0.0
              else                                                      ! if pass then
                 val = 1.0
              endif
              do 130 jj = iprev + 1, wPt(i)
  130           ap(BasAddr0 + jj) = val
            else                                                        ! Taper at ends of pass/cut
              Taper = vType(i) - vType(i-1)                             ! Pass -> Cut or Cut -> Pass ?
              IF( vLine(i)*vLine(i-1) .GE. 0 ) call FrmWnd
     *         ( iwindo, iwopt, vLine(i-1), vLine(i), kTrace,
     *         iprev+1-wbase, wPt(i)-wbase, ap(BasAddr1 + iprev), Taper)
c
            endif                                                       ! of vType(i) <> vType(i-1)
          endif                                                         ! of Gaps between lines
          iprev = wpt(i)
          go to 120
        endif                                                           ! of iprev < nw & i < nLine
      endif                                                             ! of Wavenumber <> 0
c
c...                                Check the form of the sector across v = inf
      if (vType(1).eq.vType(nLine)) then                                ! Simple pass/cut sector
          if (vType(1).eq.CUT ) then
            val = 0.0
          else                                                          ! if pass
            val = 1.0
          endif
          do 150 jj = 1, wPt(1)
 150        ap(BasAddr0 + jj) = val
          do 160 jj = wPt(nLine)+1, nw
 160        ap(BasAddr0 + jj) = val
      else                                                              ! Else tapering at v(inf)
        Taper = ATINF * (vType(1) - vType(nLine))
c..                                                  Taper large -ve velocities
        call FrmWnd(iwindo, iwopt, vLine(1), vLine(nLine), kTrace,
     *                1 - wbase, wPt(1) - wbase, ap(BasAddr1), Taper)
c..                                                  Taper large +ve velocities
        call FrmWnd(iwindo, iwopt, vLine(1), vLine(nLine), kTrace,
     *                  wPt(nLine)+1-wbase, nw-wbase,
     *                  ap(BasAddr1 + wPt(nline)), Taper)
      endif
c
c*************************                             *************************
c                       Multiply Trace by its Window Fn
c*************************                             *************************
c
      If ( (idtype.eq.IDFKPLR).OR.idtype.eq.IDFKPLRU ) then
        do 200 i = 1, nw
 200    ap(i) = ap(i) * ap(BasAddr0 + i)
      else if (idtype.eq.IDFKRCT) then
        j = -1
        do 210 i = BasAddr0 + 1, BasAddr0 + nw
          j       = j + 2
          ap(j)   = ap(j)   * ap(i)
          ap(j+1) = ap(j+1) * ap(i)
 210    continue
      endif
c
      iout = CLEARAP                                                    ! Get the modified trace out of the Ap
      call rlseap( buf(NumHdr+1), nsamps)
      RETURN
      end
c++
c++
      Subroutine ClcWpt(type, wPt, k, v, nLine, nw)
c------------------------------------------------------------------------------
c    ClcWpt calculates the positions at which the filtering lines cross the
c current trace. These positions are returned as indices of the input trace in
c the integer array wPt. The indices are chosen to be the nearest index below
c the actual crossing line.
c
c Inputs:
c   type      This is an index denoting the form of the filtering lines.
c             Currently ignored as all lines are currently are radial lines
c             from the origin.
c   k         The input wavenumber trace k E [0,nk/2]
c   v(nLine)  The array of normalized velocities for the filter lines
c   nLine     The number of filter lines.
c   nw        The length of the input trace. Frequencies are assumed to run
c             -Nyq -> 0 -> +Nyq - dw
c Outputs:
c    wpt(nLine)  The array of returned indices
c
c Call Chain:
c    CONTRO:FKFIEX:ClcWpt
c
c Externals:
c    IBLW
c
c Last Modified:
c    10/6/88 ajh
c
c------------------------------------------------------------------------------
c
      integer type
      integer k, nw
      integer nLine
      integer wpt(nLine)
      real      v(nLine)
c
      integer wbase, iblw
c
      wbase = nw/2 + 1                                                  ! Position of the zero frequency sample
      do 10 i = 1, nLine
        wpt(i)   = iBlw(v(i) * k) + wbase                               ! Calculate crossing position
        if(wPt(i).lt.0) then                                            ! Make sure wpt in [0,nw]
          wPt(i) = 0
        else if (wPt(i).gt.nw) then
          wPt(i) = nw
        endif
  10  continue
      RETURN
      end
C**
c**
      Integer Function Iblw(x)
c-------------------------------------------------------------------------------
c Iblw returns the nearest integer below a real value x. Not the integer part.
c-------------------------------------------------------------------------------
c
      real x
c
      if(x.ge.0.) then
        Iblw = Int(x)
      else
        Iblw = Int(x) - 1
      endif
      RETURN
      end
c++
c++
      Subroutine FrmWnd(iwindo,iwopt,vst,vend,k,stPt,endPt,buf,dir)
c-------------------------------------------------------------------------------
c   FrmWnd calculates the half window function between vst & vend for the
c points stPt to endPt. vst & vend are real so the window does not necessarily
c start & finish on integer values.
c
c Inputs:
c   iwindo Type of window function
c   iwopt  Variable for windowing
c          = BYA - Window as a function of angle
c          = BYW - Window as a function of frequency
c          = BYK - Window as a function of wavenumber
c
c   vst    Start velocity of filter
c   vend   Final velocity of filter
c    stPt  First point in window
c   EndPt  Last point in window
c
c    dir  Direction of the windowing function
c         = PCDIR - The window is from pass at vst to cut vend
c         = CPDIR - The window is from cut at vst to pass vend
c         = PCINF - The velocity lines straddle v infinity +ve v is pass
c         = CPINF - "       "       "       "       "      +ve v is cut
c
c Outputs:
c   buf(stPt:EndPt)                                                     ! buffer in which to place window fn
c
c Call Chain:
c    CONTRO:FKFIEX:FrmWnd
c
c Externals:
c    Fwindw
c
c Last Modified:
c    10/6/88 ajh
c-------------------------------------------------------------------------------
c
C INCLUDE FILES
c fkfilt.inc
c Include file for the FK filter routines FKFIED & FKFIEX
c
      integer    NSETSP, DBLSETSP
      parameter (NSETSP = 20 )                                          ! The max. no. of FKFIED input values
      parameter (DBLSETSP  = 2*NSETSP)
c
      integer    SINGPARM                                               ! The number of single valued params
      parameter( SINGPARM = 6)
c
      integer     FILNOTST , FILTERR, FILTVEL, FILTDIP
      parameter ( FILNOTST  = -8)                                       ! Declare constants for the filter types
      parameter ( FILTERR   = -7)
      parameter ( FILTVEL   =  1)
      parameter ( FILTDIP   =  2)
c
      integer    CUT, PASS, ATINF
      parameter (CUT = 2, PASS = 1)
      parameter ( ATINF = 2)                                            ! Constant signifying lines near v = inf
c
      Integer PCdir, CPdir, PCinf, CPinf
      Parameter (PCdir =  Cut - Pass)
      Parameter (CPdir = Pass - Cut)
      Parameter (PCinf = AtInf * PCdir)
      Parameter (CPinf = AtInf * CPdir)
c
      Integer INITWDW
      Parameter (INITWDW = 32)
      Parameter (NOINIT  = 0)
c
c..                         Declare constants for the available window types
      integer     NUMWINDT
      parameter (NUMWINDT = 8)                                          ! The number of available window types
      Integer Hamming, Hanning, Gaussian, Bartlett, Rectang
      Integer Blackman, ExctBlck, BlckHarr
      Parameter (Hamming  = 1)
      Parameter (Hanning  = 2)
      Parameter (Gaussian = 3)
      Parameter (Bartlett = 4)                                          ! Triangular Window
      Parameter (RectAng  = 5)
      Parameter (BlackMan = 6)
      Parameter (ExctBlck = 7)                                          ! Exact Blackman
      Parameter (BlckHarr = 8)
c
c..                              Parameters for the window options
      Integer    NUMWOPT
      parameter (NUMWOPT = 3)                                           ! The number of windowing options
      Integer  BYA, BYK, BYW
      Parameter (ByA = 1)
      Parameter (ByK = 2)
      Parameter (ByW = 3)
C PROGRAM
c
      integer iwindo, iwopt
      real    vst, vend
      integer stPt, EndPt
      real    buf(stPt:EndPt)
      integer dir
c
      parameter (DUMV = 0.)
c
      integer DirLcl
      real    Fwindw
c
      if (endPt.lt.StPt) then
        print *, '*** FKFIEX (FrmWnd) ERROR *** ',
     *           ' FrmWnd stPt > Endpt', StPt,endPt
        STOP
      endif
c
      rk = float(k)                                                     ! Convert wavenumber to real
c
      if ((dir.eq.PCDIR).OR.(dir.eq.CPDIR)) then                        !.... Simple window
        if (iwopt.eq.BYA) then
            buf(StPt) = Fwindw(ATan(stPt/rk), ATan(vst), ATan(vend),
     *                          iwindo, dir, INITWDW )
c
        do 10 i = StPt, EndPt
  10      buf(i) = Fwindw(ATan(i/rk), Dumv, Dumv, iwindo,dir, NOINIT)
        else if (iwopt.eq.BYW) then
          buf(StPt) = Fwindw(float(StPt), rk*vst, rk*vend, iwindo,
     *                                                  dir, INITWDW )
          do 20 i = StPt, EndPt
  20        buf(i) = Fwindw(float(i), Dumv, Dumv, iwindo, dir, NOINIT)
        else if (iwopt.eq.BYK) then
          do 30 i = StPt, EndPt
  30        buf(i) = Fwindw( rk, i/vst, i/vend, iwindo, dir, INITWDW )
        endif
c
      else                                                              !........ Filter lines across vinf
        if(dir.eq.PCINF) then
          dirLcl = PCDIR
        else
          dirLcl = CPDIR
        endif
c
        if (iwopt.eq.BYW) then
           print *,'**** FKFILT(FrmWnd) Warning *** ',
     *                'Cannot window as a fn. of w across v = inf'
           print *, 'Using Angle (BYA) instead'
        endif
c
        if (iwopt.eq.BYA .OR. iwopt.eq.BYW) then
           buf(StPt) = Fwindw(ATan(rk/stPt), ATan(1./vst),
     *                         ATan(1./vend), iwindo, dirLcl,INITWDW)
             do 110 i = StPt, EndPt
 110         buf(i) = Fwindw(ATan(rk/i), DumV, DumV, iwindo,
     *                                                dirLcl, NOINIT)
        else if (iwopt.eq.BYK) then
          do 120 i = StPt, EndPt
 120       buf(i) = Fwindw(rk, i/vst, i/vend, iwindo, dirLcl,INITWDW)
        endif
      endif                                                             ! of (dir == PCDIR) | (dir == CPDIR)
      RETURN
      end
c++
c++
      Real Function Fwindw(theta, start, end, iwindo, dir, init)
c------------------------------------------------------------------------------
c   Fwindw returns the value of a window function . The windows supported
c are the standard SIOSEIS ones.
c
c Inputs:
c   theta  Value within the window. Within Fwindw it is normalized to [0,1] wrt
c          the total range of the window |end - start|
c          = 0  => complete pass
c          = 1  => cut off end of window
c
c   start  Start value of window. Used only on Initialization
c   end    End   value of window.  "    "    "    "    "    "
c   iwindo The type of window to be applied
c   dir    Direction of windowing
c          = PCDIR - The window is from pass to cut
c          = CPDIR - The window is from cut to pass
c
c Last Modified:
c   10/6/88 ajh.
c------------------------------------------------------------------------------
c
      real    theta
      real    start, end
      integer iwindo
      integer dir
c
      Parameter ( PI    = 3.1415927)
      Parameter ( TWOPI = 2. * PI)
      Parameter ( BETA  = 0.5)                                          ! Width constant for Gaussian window
c
      integer    DirLcl
c
      save thetaSt, thetaEnd, Range, b2
c
C INCLUDE FILES
c fkfilt.inc
c Include file for the FK filter routines FKFIED & FKFIEX
c
      integer    NSETSP, DBLSETSP
      parameter (NSETSP = 20 )                                          ! The max. no. of FKFIED input values
      parameter (DBLSETSP  = 2*NSETSP)
c
      integer    SINGPARM                                               ! The number of single valued params
      parameter( SINGPARM = 6)
c
      integer     FILNOTST , FILTERR, FILTVEL, FILTDIP
      parameter ( FILNOTST  = -8)                                       ! Declare constants for the filter types
      parameter ( FILTERR   = -7)
      parameter ( FILTVEL   =  1)
      parameter ( FILTDIP   =  2)
c
      integer    CUT, PASS, ATINF
      parameter (CUT = 2, PASS = 1)
      parameter ( ATINF = 2)                                            ! Constant signifying lines near v = inf
c
      Integer PCdir, CPdir, PCinf, CPinf
      Parameter (PCdir =  Cut - Pass)
      Parameter (CPdir = Pass - Cut)
      Parameter (PCinf = AtInf * PCdir)
      Parameter (CPinf = AtInf * CPdir)
c
      Integer INITWDW
      Parameter (INITWDW = 32)
      Parameter (NOINIT  = 0)
c
c..                         Declare constants for the available window types
      integer     NUMWINDT
      parameter (NUMWINDT = 8)                                          ! The number of available window types
      Integer Hamming, Hanning, Gaussian, Bartlett, Rectang
      Integer Blackman, ExctBlck, BlckHarr
      Parameter (Hamming  = 1)
      Parameter (Hanning  = 2)
      Parameter (Gaussian = 3)
      Parameter (Bartlett = 4)                                          ! Triangular Window
      Parameter (RectAng  = 5)
      Parameter (BlackMan = 6)
      Parameter (ExctBlck = 7)                                          ! Exact Blackman
      Parameter (BlckHarr = 8)
c
c..                              Parameters for the window options
      Integer    NUMWOPT
      parameter (NUMWOPT = 3)                                           ! The number of windowing options
      Integer  BYA, BYK, BYW
      Parameter (ByA = 1)
      Parameter (ByK = 2)
      Parameter (ByW = 3)
C PROGRAM
c
c...                                Initialize the window variables
      DirLcl = dir
c
      if ( init.eq.INITWDW ) then                                       ! Test for INIT bit
c****  pcdir =1, cpdir = -1
        if (DirLcl.eq.PCDIR) then
          thetaSt  = start
          thetaEnd = end
        else if (DirLcl.eq.CPDIR) then
          thetaSt  = end
          thetaEnd = start
        else
          stop '*** Error *** Fwindw incorrect direction specified'
        endif
c
        range = thetaEnd - thetaSt
        if (iwindo.eq.GAUSSIAN)
     *         b2 = 2 * BETA * BETA
      endif
c
      thetaN = (theta - thetaSt) / range                                ! Normalize theta to [0,1]
c
      if ( thetaN .lt.0.) then
        print '(A,G12.3)',
     *        '*** Fwindw Warning *** Normalized theta < 0 ', ThetaN
        thetaN = 0.
      else if (thetaN.gt.1.) then
        print '(A,G12.3)',
     *        '*** Fwindw Warning  *** Normalized theta > 1 ', ThetaN
        thetaN = 1.
      endif
c
      if (iwindo.eq.HAMMING) then
         Fwindw = 0.54 + 0.46 * Cos(PI * thetaN)
      else if (iwindo.eq.HANNING) then
         Fwindw = 0.5 + 0.5 * Cos(PI * thetaN)
      else if (iwindo.eq.GAUSSIAN) then
         Fwindw = Exp( -thetaN*b2)
      else if (iwindo.eq.BARTLETT) then
         Fwindw = 1. - ThetaN
      else if (iwindo.eq.RECTANG) then
         Fwindw = 1.
      else if (iwindo.eq.BLACKMAN) then
         Temp = PI * ThetaN
         Fwindw = 0.42 + 0.5 * Cos(temp) + 0.08 * Cos( 2 * temp)
      else if (iwindo.eq.EXCTBLCK) then
         Temp = PI * ThetaN
         Fwindw = 0.42659071 + 0.49656062 * Cos(temp) +
     *             0.07684867 * Cos( 2 * temp)
      else if (iwindo.eq.BLCKHARR) then
         Temp = PI * ThetaN
         Fwindw = 0.35875 + 0.48829 * Cos(temp) +
     *             0.14128 * Cos( 2 * temp) + 0.01168 * Cos(3 * temp)
      endif
c
      RETURN
      end


!=======================================================================
!  P_Plant, Plant phosphorus model.
!
!  DETERMINES PLANT P TRANSFORMATIONS
!  Computes P concentration and total content for four plant
!    components: shoot (leaf + stem), root, shell and seed.
!  Optimum P concentration for each component is based on 3
!    stages:
!    (1) stage A (e.g., emergence)
!    (2) stage B (e.g., first flower)
!    (3) stage C (e.g., physiological maturity)
!  Optimum and minimum P concentrations for each plant component /
!    stage are read from the species file.
!  Fraction of development between stages is sent from each plant
!    routine.  This routine linearly interpolates optimum and
!    minimum P concentrations between stages.
!  Two options to read in P concentrations for either Shoot or for
!    Leaf and Stem, as well as for root, shell and seed. Use
!    -99 for data option not used. Logical variable, UseShoots, is
!    set to TRUE when values of shoots are used, FALSE if leaf and stem
!    are used.
!-----------------------------------------------------------------------
!  REVISION HISTORY
!  08/../1997 AG  Written.
!  09/../1997 AG  Built into CERES 3.1.
!  09/../1998 AG  Built into CERES 3.5.
!  01/../1999 AG  Replaced ISTAGE with XSTAGE in wh.
!  06/../1999 AG  Added residue P carry-over.
!  08/../1999 AG  Added seasonal analysis initalization option.
!  09/19/2003 AJG Brought into modular format and linked to the
!                 CENTURY-based SOM/residue module.
!  12/17/2003 AJG Renamed all the CH_ and CHEM_ variables to P_ variables.
!  02/12/2004 AJG Renamed the subroutine from CHEM_GEN to P_GEN.
!  03/23/2004 CHP Removed soil components
!  03/24/2004 CHP Added to CSM
!  09/17/2004 CHP Made generic for all plant routines to use a single routine.
!-----------------------------------------------------------------------
!  Called by: CROPGRO, MZ_CERES, RI_CERES...
!  Calls:     P_UPTAKE, OPPHOS
!=======================================================================
      SUBROUTINE P_Plant (DYNAMIC, ISWPHO,                !I Control
     &    CROP, FILECC, MDATE, YRPLT,                     !I Crop
     &    SPi_AVAIL,                                      !I Soils
     &    Leaf_kg, Stem_kg, Root_kg, Shel_kg, Seed_kg,    !I Mass
     &    PhFrac1, PhFrac2,                               !I Phase
     &    RLV,                           !RWU,            !I Roots
     &    SenSoilP, SenSurfP,                             !I Senescence
     &    PCNVEG,                                         !I N conc.
     &    PestShut, PestRoot, PestShel, PestSeed,         !I Pest damage
     &    ShutMob, RootMob, ShelMob,                      !I Mobilized
     &    PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, !O P conc.
     &    PShut_kg, PRoot_kg, PShel_kg, PSeed_kg,         !O P amts.
     &    PStres1, PStres2,                               !O P stress
     &    PUptake)                                        !O P uptake

!     ------------------------------------------------------------------
!     Send DYNAMIC to accomodate emergence calculations
!       (DYNAMIC=EMERG) within the integration section of CROPGRO.
!     ------------------------------------------------------------------
      USE ModuleDefs
      IMPLICIT  NONE
      SAVE
!     ------------------------------------------------------------------
!     Interface variables
!     ------------------------------------------------------------------
!     INPUT
      INTEGER      DYNAMIC        !Processing control
      CHARACTER*1  ISWPHO         !P switch (Y or N)
      CHARACTER*2  CROP           !2-character crop code
      CHARACTER*92 FILECC         !Path and name of species file
      INTEGER      MDATE          !Maturity date
      INTEGER      YRPLT          !Planting date

      REAL         SPi_AVAIL(NL)  !P available for uptake (kg/ha)

      !State variables - mass (kg/ha) - includes new growth
      REAL         Leaf_kg        !Leaf mass (kg/ha)
      REAL         Stem_kg        !Stem mass (kg/ha)
      REAL         Root_kg        !Root mass (kg/ha)
      REAL         Shel_kg        !Shell mass (kg/ha)
      REAL         Seed_kg        !Seed mass (kg/ha)

      REAL         PhFrac1      !Fraction phys time betw St 1 & St 2
      REAL         PhFrac2      !Fraction phys time betw St 2 & St 3
      REAL         RLV(NL)        !Root length density
      REAL         SenSoilP       !P senesced from leaf + stem
      REAL         SenSurfP       !P senesced from roots
      REAL         PCNVEG         !N percentage in veg. tissue
      !Pest damage variables:
      REAL         PestShut       !Pest damage to leaf and stem
      REAL         PestRoot       !Pest damage to root
      REAL         PestShel       !Pest damage to shell
      REAL         PestSeed       !Pest damage to seed
      !Plant mass lost due to mobilization of N and C
      REAL         ShutMob        !Mobilization loss for leaf and stem
      REAL         RootMob        !Mobilization loss for roots
      REAL         ShelMob        !Mobilization loss for shells

!     OUTPUT
      REAL         PConc_Shut     !P conc in shoots (kg[P]/kg[shoots])
      REAL         PConc_Root     !P conc in roots (kg[P]/kg[roots])
      REAL         PConc_Veg      !P conc in veg tissue (kg[P]/kg[veg])
      REAL         PStres1        !P stress for partitioning
      REAL         PStres2        !P stress for photosynthesis
      REAL         PUptake(NL)    !P uptake by soil layer (kg/ha)

!     ------------------------------------------------------------------
      CHARACTER*6, PARAMETER :: ERRKEY = 'PPLANT'
      LOGICAL UseShoots
      INTEGER I

!     Shoot mass -- leaf + stem (kg/ha)
      REAL Shut_kg    !, ShutNew_kg

!     Change (increase or decrease) to P variable per day
      REAL DeltPShut, DeltPRoot, DeltPShel, DeltPSeed

!     Daily values of optimum and minimum and actual P concs.
      REAL PConc_Shut_opt, PConc_Root_opt, PConc_Shel_opt,PConc_Seed_opt
      REAL PConc_Shut_min, PConc_Root_min, PConc_Shel_min,PConc_Seed_min
      REAL PConc_Shel, PConc_Seed, PConc_Plant

!     P state variables by weight (kg/ha)
      REAL PShut_kg, PRoot_kg, PShel_kg, PSeed_kg, PPlant_kg

!     Misc.
      REAL PShutDem, PRootDem, PShelDem, PSeedDem, PTotDem
      REAL PSTRESS_RATIO
      REAL PUptakeProf
      REAL Plant_kg
      REAL N2P, N2P_max, N2P_min
      REAL PestShutP, PestRootP, PestShelP, PestSeedP
!      REAL PShutMob, PRootMob, PShelMob   !, PTotMob
!      REAL PShutMobPool, PRootMobPool, PShelMobPool

!     From species file:
      REAL, DIMENSION(3) :: PCShutOpt, PCRootOpt, PCShelOpt, PCSeedOpt
      REAL, DIMENSION(3) :: PCLeafOpt, PCStemOpt
      REAL, DIMENSION(3) :: PCShutMin, PCRootMin, PCShelMin, PCSeedMin
      REAL, DIMENSION(3) :: PCLeafMin, PCStemMin
      REAL, DIMENSION(3) :: N2Pmin, N2Pmax
      REAL SRATPHOTO, SRATPART
      REAL FracPMobil, FracPUptake

      Real PValue !Function

!***********************************************************************
!***********************************************************************
!     SEASONAL INITIALIZATION: RUN ONCE PER SEASON.
!***********************************************************************
      IF (DYNAMIC == SEASINIT .OR. DYNAMIC .EQ. RUNINIT) THEN
!     ------------------------------------------------------------------
      IF (CROP .NE. 'FA' .AND.
     &   (ISWPHO .EQ. 'Y' .OR. ISWPHO .EQ. 'H')) THEN
        CALL P_IPPLNT(FILECC,
     & N2Pmax, N2Pmin,
     & PCShutMin, PCLeafMin, PCStemMin, PCRootMin, PCShelMin, PCSeedMin,
     & PCShutOpt, PCLeafOpt, PCStemOpt, PCRootOpt, PCShelOpt, PCSeedOpt,
     & FracPMobil, FracPUptake, SRATPHOTO, SRATPART, UseShoots)
      ENDIF

!     ------------------------------------------------------------------
      Call P_Demand(DYNAMIC,
     &    PConc_Root, PConc_Root_min, PConc_Root_opt,     !Input
     &    PConc_Shel, PConc_Shel_min, PConc_Shel_opt,     !Input
     &    PConc_Shut, PConc_Shut_min, PConc_Shut_opt,     !Input
     &    PConc_Seed_opt, PRoot_kg, PSeed_kg, PShel_kg,   !Input
     &    PShut_kg, Root_kg, RootMob, Seed_kg, Shel_kg,   !Input
     &    ShelMob, Shut_kg, ShutMob,                      !Input
     &    DeltPRoot, DeltPSeed, DeltPShel, DeltPShut,     !I/O
     &    PRootDem, PSeedDem, PShelDem, PShutDem,         !Output
     &    PTotDem)                                        !Output

!     ------------------------------------------------------------------
!     Initialize uptake variables - do this even if P not modelled.
      CALL P_Uptake (DYNAMIC,
     &    N2P_min, PCNVeg, PConc_Veg, PTotDem,            !Input
     &    RLV, SPi_AVAIL,                                 !Input
     &    N2P, PUptake, PUptakeProf)                      !Output

!     Optimum P concentration
      PConc_Shut_opt = 0.0
      PConc_Root_opt = 0.0
      PConc_Shel_opt = 0.0
      PConc_Seed_opt = 0.0

!     Minimum P concentration
      PConc_Shut_min = 0.0
      PConc_Root_min = 0.0
      PConc_Shel_min = 0.0
      PConc_Seed_min = 0.0

!     P concentration variables (fraction of plant tissue)
      PConc_Shut  = 0.0
      PConc_Root  = 0.0
      PConc_Shel  = 0.0
      PConc_Seed  = 0.0
      PConc_Plant = 0.0

!     P[kg/ha] variables
      PShut_kg  = 0.0
      PRoot_kg  = 0.0
      PShel_kg  = 0.0
      PSeed_kg  = 0.0
      PPlant_kg = 0.0

!     Demand variables
      PShutDem = 0.0
      PRootDem = 0.0
      PShelDem = 0.0
      PSeedDem = 0.0
      PTotDem  = 0.0

      PStres1 = 1.0
      PStres2 = 1.0
      PSTRESS_RATIO = 1.0

!     P in senesced tissue
      SenSoilP = 0.0
      SenSurfP = 0.0

!     N:P ratio
      N2P = 0.0

!     Initial shoot mass
      Shut_kg = 0.0

      IF (ISWPHO == 'N') RETURN

      CALL OPPlantP(DYNAMIC, MDATE, YRPLT,
     &  PConc_Shut_opt, PConc_Root_opt, PConc_Shel_opt, PConc_Seed_opt,
     &  PConc_Shut_min, PConc_Root_min, PConc_Shel_min, PConc_Seed_min,
     &  PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, PConc_Plant,
     &  PShut_kg, PRoot_kg, PShel_kg, PSeed_kg, PPlant_kg,
     &  Shut_kg, Root_kg, Shel_kg, Seed_kg, N2P, PTotDem,
     &  SenSoilP, SenSurfP, PhFrac1, PhFrac2,
     &  PStres1, PStres2, PSTRESS_RATIO, PUptakeProf,
     &  PestShutP, PestRootP, PestShelP, PestSeedP)

!***********************************************************************
!***********************************************************************
!     EMERGENCE
!***********************************************************************
      ELSEIF (DYNAMIC == EMERG) THEN
!-----------------------------------------------------------------------
      PTotDem = 0.0
      Shut_kg = Leaf_kg + Stem_kg

!     Optimum P concentration in vegetative matter at emergence (fraction)
      IF (UseShoots) THEN
        PConc_Shut_opt = PCShutOpt(1)
      ELSE
        PConc_Shut_opt = (PCLeafOpt(1)*Leaf_kg + PCStemOpt(1)*Stem_kg) /
     &                        Shut_kg
      ENDIF
      PConc_Root_opt = PCRootOpt(1)
      PConc_Shel_opt = PCShelOpt(1)
      PConc_Seed_opt = PCSeedOpt(1)

!     Initial P concentration in vegetative matter at emergence (fraction)
      PConc_Shut = PConc_Shut_opt
      PConc_Root = PConc_Root_opt
      PConc_Shel = PConc_Shel_opt
      PConc_Seed = PConc_Seed_opt

!     Total plant weight
      Plant_kg = Shut_kg + Root_kg + Shel_kg + Seed_kg
!     What about nodules, tubers, etc.???

!     Plant P (kg/ha)
      PShut_kg = PConc_Shut * Shut_kg
      PRoot_kg = PConc_Root * Root_kg
      PShel_kg = PConc_Shel * Shel_kg
      PSeed_kg = PConc_Seed * Seed_kg
      PPlant_kg = PShut_kg + PRoot_kg + PShel_kg + PSeed_kg

      CALL OPPlantP(DYNAMIC, MDATE, YRPLT,
     &  PConc_Shut_opt, PConc_Root_opt, PConc_Shel_opt, PConc_Seed_opt,
     &  PConc_Shut_min, PConc_Root_min, PConc_Shel_min, PConc_Seed_min,
     &  PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, PConc_Plant,
     &  PShut_kg, PRoot_kg, PShel_kg, PSeed_kg, PPlant_kg,
     &  Shut_kg, Root_kg, Shel_kg, Seed_kg, N2P, PTotDem,
     &  SenSoilP, SenSurfP, PhFrac1, PhFrac2,
     &  PStres1, PStres2, PSTRESS_RATIO, PUptakeProf,
     &  PestShutP, PestRootP, PestShelP, PestSeedP)

!***********************************************************************
!***********************************************************************
!     DAILY INTEGRATION
!***********************************************************************
      ELSEIF (DYNAMIC == INTEGR) THEN
!-----------------------------------------------------------------------
      Shut_kg = Leaf_kg + Stem_kg
      Plant_kg = Shut_kg + Root_kg + Shel_kg + Seed_kg

      IF (.NOT. UseShoots .AND. Shut_kg > 0) THEN
        DO I = 1, 3
          PCShutOpt(I) = (PCLeafOpt(I)*Leaf_kg + PCStemOpt(I)*Stem_kg) /
     &                                    Shut_kg
          PCShutMin(I) = (PCLeafMin(I)*Leaf_kg + PCStemMin(I)*Stem_kg) /
     &                                    Shut_kg
        ENDDO
      ENDIF

!-----------------------------------------------------------------------
!     Initialize delta variables
      DeltPShut = 0.0
      DeltPRoot = 0.0
      DeltPShel = 0.0
      DeltPSeed = 0.0

!-----------------------------------------------------------------------
!     Senesced plant matter - reduce P
      PShut_kg  = PShut_kg - SenSurfP
      PRoot_kg  = PRoot_kg - SenSoilP
      PPlant_kg = PPlant_kg - (SenSoilP + SenSurfP)

!     Pest damage
      PestShutP = PestShut * PConc_Shut
      PestRootP = PestRoot * PConc_Root
      PestShelP = PestShel * PConc_Shel
      PestSeedP = PestSeed * PConc_Seed

      PShut_kg  = PShut_kg - PestShutP
      PRoot_kg  = PRoot_kg - PestRootP
      PShel_kg  = PShel_kg - PestShelP
      PSeed_kg  = PSeed_kg - PestSeedP

      PPlant_kg = PPlant_kg -
     &        (PestShutP + PestRootP + PestShelP + PestSeedP)

!     ------------------------------------------------------------------
!     Calculate optimum and minimum P concentrations in plant tissue.
!     ------------------------------------------------------------------
      PConc_Shut_opt =  PValue(PhFrac1, PhFrac2, PCShutOpt)
      PConc_Root_opt =  PValue(PhFrac1, PhFrac2, PCRootOpt)
      PConc_Shel_opt =  PValue(PhFrac1, PhFrac2, PCShelOpt)
      PConc_Seed_opt =  PValue(PhFrac1, PhFrac2, PCSeedOpt)

      PConc_Shut_min =  PValue(PhFrac1, PhFrac2, PCShutMin)
      PConc_Root_min =  PValue(PhFrac1, PhFrac2, PCRootMin)
      PConc_Shel_min =  PValue(PhFrac1, PhFrac2, PCShelMin)
      PConc_Seed_min =  PValue(PhFrac1, PhFrac2, PCSeedMin)

      N2P_max =  PValue(PhFrac1, PhFrac2, N2Pmax)
      N2P_min =  PValue(PhFrac1, PhFrac2, N2Pmin)

!-----------------------------------------------------------------------
!     CALCULATE DEMANDS in kg/ha
      Call P_Demand(DYNAMIC,
     &    PConc_Root, PConc_Root_min, PConc_Root_opt,     !Input
     &    PConc_Shel, PConc_Shel_min, PConc_Shel_opt,     !Input
     &    PConc_Shut, PConc_Shut_min, PConc_Shut_opt,     !Input
     &    PConc_Seed_opt, PRoot_kg, PSeed_kg, PShel_kg,   !Input
     &    PShut_kg, Root_kg, RootMob, Seed_kg, Shel_kg,   !Input
     &    ShelMob, Shut_kg, ShutMob,                      !Input
     &    DeltPRoot, DeltPSeed, DeltPShel, DeltPShut,     !I/O
     &    PRootDem, PSeedDem, PShelDem, PShutDem,         !Output
     &    PTotDem)                                        !Output

!-----------------------------------------------------------------------
!     P uptake
      CALL P_Uptake (DYNAMIC,
     &    N2P_min, PCNVeg, PConc_Veg, PTotDem,            !Input
     &    RLV, SPi_AVAIL,                                 !Input
     &    N2P, PUptake, PUptakeProf)                      !Output

!-----------------------------------------------------------------------
      CALL P_Partition(
     &    FracPMobil, PConc_Root_min, PConc_Shel_min,     !Input
     &    PConc_Shut_min, PRootDem, PRoot_kg, PSeedDem,   !Input
     &    PShelDem, PShel_kg, PShutDem, PShut_kg,         !Input
     &    PUptakeProf, Root_kg, Shel_kg, Shut_kg,         !Input
     &    DeltPRoot, DeltPSeed, DeltPShel, DeltPShut)     !I/O

!------------------------------------------------------------------------
!     P mass in plant matter (kg/ha)
      PShut_kg  = PShut_kg + DeltPShut
      PRoot_kg  = PRoot_kg + DeltPRoot
      PShel_kg  = PShel_kg + DeltPShel
      PSeed_kg  = PSeed_kg + DeltPSeed
      PPlant_kg = PPlant_kg + PUptakeProf

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

C     CALCULATE P CONCENTRATIONS (fractions)
      IF (Seed_kg > 0.) THEN
        PConc_Seed = PSeed_kg / Seed_kg
      ELSE
        PConc_Seed = 0.
      ENDIF

      IF (Shel_kg > 0.) THEN
        PConc_Shel = PShel_kg / Shel_kg
      ELSE
        PConc_Shel = 0.
      ENDIF
C MA problem of transfer of shoot ( stems) to panicle at grain filling
      IF (Shut_kg > 0.) THEN
        PConc_Shut = PShut_kg / Shut_kg
      ELSE
        PConc_Shut = 0.
      ENDIF

      IF (Root_kg > 0.) THEN
        PConc_Root = PRoot_kg / Root_kg
      ELSE
        PConc_Root = 0.
      ENDIF

      IF (Plant_kg > 0.) THEN
        PConc_Plant = PPlant_kg / Plant_kg
      ELSE
        PConc_Plant = 0.0
      ENDIF

!     Vegetative P concentration for N:P ratio
      IF (Shut_kg + Root_kg > 1.E-6) THEN
        PConc_Veg = (PConc_Shut * Shut_kg + PConc_Root * Root_kg) /
     &         (Shut_kg + Root_kg) * 100.
      ENDIF

!-----------------------------------------------------------------------
!     From MB's P_Partition
C     Calculate PSTRESS_RATIO
        PSTRESS_RATIO = MIN(1.0, (PConc_Shut - PConc_Shut_Min) /
     &                       (PConc_Shut_opt - PConc_Shut_Min))

C     Calculate PStres1 (Photosynthesis)
      IF (PSTRESS_RATIO .GE. SRATPHOTO) THEN
        PStres1 = 1.0
      ELSEIF (PSTRESS_RATIO < SRATPHOTO .AND. PSTRESS_RATIO > 1.E-6)THEN
        PStres1 = PSTRESS_RATIO / SRATPHOTO
      ELSE
        PStres1 = 0.0
      ENDIF

C     Calculate PStres2 (Partitioning)
      IF (PSTRESS_RATIO .GE. SRATPART) THEN
        PStres2 = 1.0
      ELSEIF (PSTRESS_RATIO < SRATPART .AND. PSTRESS_RATIO > 1.E-6) THEN
        PStres2 = PSTRESS_RATIO / SRATPART
      ELSE
        PStres2 = 0.0
      ENDIF

!***********************************************************************
!***********************************************************************
!     DAILY OUTPUT AND SEASONAL SUMMARY
!***********************************************************************
      ELSEIF (DYNAMIC == OUTPUT .OR. DYNAMIC == SEASEND) THEN
!-----------------------------------------------------------------------
      CALL OPPlantP(DYNAMIC, MDATE, YRPLT,
     &  PConc_Shut_opt, PConc_Root_opt, PConc_Shel_opt, PConc_Seed_opt,
     &  PConc_Shut_min, PConc_Root_min, PConc_Shel_min, PConc_Seed_min,
     &  PConc_Shut, PConc_Root, PConc_Shel, PConc_Seed, PConc_Plant,
     &  PShut_kg, PRoot_kg, PShel_kg, PSeed_kg, PPlant_kg,
     &  Shut_kg, Root_kg, Shel_kg, Seed_kg, N2P, PTotDem,
     &  SenSoilP, SenSurfP, PhFrac1, PhFrac2,
     &  PStres1, PStres2, PSTRESS_RATIO, PUptakeProf,
     &  PestShutP, PestRootP, PestShelP, PestSeedP)

      SenSoilP   = 0.0
      SenSurfP   = 0.0
      PUptakeProf = 0.0

!***********************************************************************
!***********************************************************************
!     END OF DYNAMIC IF CONSTRUCT
!***********************************************************************
      ENDIF
!-----------------------------------------------------------------------

      RETURN
      END SUBROUTINE P_Plant
C=======================================================================

!-----------------------------------------------------------------------
! Variable definitions - updated 09-29-2004
!-----------------------------------------------------------------------
! CHAR           Contains the contents of last record read
! CROP           Two-character crop identification code
! DeltPRoot      Portion of P uptake that is allocated to root (g[P]/m2)
! DeltPSeed      Portion of P uptake that is allocated to seed (g[P]/m2)
! DeltPShel      Portion of P uptake that is allocated to shell (g[P]/m2)
! DeltPShut      Portion of P uptake that is allocated to leaf and stem
!                 (g[P]/m2)
! ERR            Error code for file operation
! ERRKEY         Subroutine name for error file
! FILECC         Path plus filename for species file (*.spe)
! FOUND          Indicator that good data was read from file by subroutine
!                  FIND (0 - End-of-file encountered, 1 - NAME was found)
! FracPMobil     Portion of P in vegetative tissue which is available for
!                  mining to supply seed and shell P demand (fraction)
! ISECT          Indicator of completion of IGNORE routine: 0 - End of file
!                  encountered, 1 - Found a good line to read, 2 - End of
!                  Section in file encountered denoted by * in column 1.
! ISWPHO         Phosphorus simulation switch (Y or N)
! Leaf_kg        Mass of leaf tissue (kg[leaf]/ha)
! LeafNew_kg     Mass of today's new growth of leaves (kg[leaf]/ha)
! LNUM           Current line number of input file
! LUNCRP         Logical unit number for FILEC (*.spe file)
! MDATE          Harvest maturity date (YYYYDDD)
! MSG            Text array containing information to be written to
!                  WARNING.OUT file.
! NL             Maximum number of soil layers = 20
! NLAYR          Actual number of soil layers
! PCLeafMin(3)   Minimum P concentration in leaf defined at three critical
!                  stages (g[P]/g[leaf])
! PCLeafOpt(3)   Optimum P concentration in leaf defined at three critical
!                  stages (g[P]/g[leaf])
! PConc_Plant    P concentration in whole plant (g[P]/g[plant])
! PConc_Root     P concentration in root (g[P]/g[root])
! PConc_Root_Min Minimum P concentration in root (g[P]/g[root])
! PConc_Root_Opt Optimum P concentration in root (g[P]/g[root])
! PConc_Seed     Concentration of P in seed (g[P]/g[seed])
! PConc_Seed_Min Minimum P concentration in seed (g[P]/g[seed])
! PConc_Seed_Opt Optimum P concentration in seed (g[P]/g[seed])
! PConc_Shel     Concentration of P in shell (g[P]/g[shell])
! PConc_Shel_Min Minimum P concentration in shell (g[P]/g[shell])
! PConc_Shel_Opt Optimum P concentration in shell (g[P]/g[shell])
! PConc_Shut     P concentration in shoots (leaf and stem) (g[P]/g[shoot])
! PConc_Shut_Min Minimum P concentration in leaf and stem (g[P]/g[shoot])
! PConc_Shut_Opt Optimum P concentration in leaf and stem (g[P]/g[shoot])
! PCRootMin(3)   Minimum P concentration in root defined at three critical
!                  stages (g[P]/g[root])
! PCRootOpt(3)   Optimum P concentration in root defined at three critical
!                  stages (g[P]/g[root])
! PCSeedMin(3)   Minimum P concentration in seed defined at three critical
!                  stages (g[P]/g[seed])
! PCSeedOpt(3)   Optimum P concentration in seed defined at three critical
!                  stages (g[P]/g[seed])
! PCShelMin(3)   Minimum P concentration in shell defined at three critical
!                  stages (g[P]/g[shell])
! PCShelOpt(3)   Optimum P concentration in shell defined at three critical
!                  stages (g[P]/g[shell])
! PCShutMin(3)   Minimum P concentration in leaf and stem defined at three
!                  critical stages (g[P]/g[shoot])
! PCShutOpt(3)   Optimum P concentration in leaf and stem defined at three
!                  critical stages (g[P]/g[shoot])
! PCStemMin(3)   Minimum P concentration in stem defined at three critical
!                  stages (g[P]/g[stem])
! PCStemOpt(3)   Optimum P concentration in stem defined at three critical
!                  stages (g[P]/g[stem])
! PHFRAC1_2      Fraction of physiological time which has occurred between
!                  first and second critical phases for computation of
!                  optimum and minimum plant P concentrations
! PHFRAC2_3      Fraction of physiological time which has occurred between
!                  second and third critical phases for computation of
!                  optimum and minimum plant P concentrations
! Pi_Avail(L)    Soil P which is available for uptake by plants. (ppm)
! Plant_kg       Mass of plant (kg/ha)
! PlantNew_kg    Mass of today's new growth of plant tissue (kg/ha)
! PMined         P mined from leaf, stem and root for seed or shell demand
!                 (kg[P]/ha)
! PMinedSd       P mined from leaf, stem and root for seed demand
!                 (kg[P]/ha)
! PMinedSl       P mined from leaf, stem and root for shell demand
!                 (kg[P]/ha)
! PPlant_kg      P content in whole plant (kg[P]/ha)
! PRoot_kg       P in roots (kg[P]/ha)
! PRoot_Min      Minimum P for root growth (kg[P]/ha)
! PRootDem       Root demand for P (kg[P]/ha)
! PSeed_kg       P content in seed (kg[P]/ha)
! PSeedDem       P demand by seed (g[P]/m2)
! PShel_kg       P content in shell (kg[P]/ha)
! PShelDem       P demand by shell (g[P]/m2)
! PShut_kg       P in shoots (leaf and stem) (kg[P]/ha)
! ShutPMin       Minimum P for root growth (kg[P]/ha)
! PShutDem       Shoot demand for P (kg[P]/ha)
! PSTRES1        P stress which affects vegetative partitioning  (1=no
!                  stress, 0=max stress)
! PSTRES2        P stress factor for reducing photosynthate (1=no stress,
!                  0=max stress)
! PSTRESS_RATIO  Ratio of P in vegetative tissue to optimum P as a measure
!                  of plant stress (g[P]/g[P])
! PSUPPLY        Supply of P from root uptake (kg[P]/ha)
! PTotDem        Total daily plant demand for P (kg[P]/ha)
! PUptake(L)     Plant uptake of P in soil layer L (kg[P]/ha/d)
! PUptakeProf    Plant uptake of P over whole soil profile (kg[P]/ha/d)
! PMine_Avail    P in vegetative tissue which is available for mining for
!                  growth of seed and shell (kg[P]/ha)
! P_Mobil_max    Maximum amount of P in vegetative tissue which can be
!                  mined today (kg[P]/ha)
! RLV(L)         Root length density for soil layer L
!                 (cm[root] / cm3[soil])
! Root_kg        Root mass (kg/ha)
! RootMineFrac   Fraction of mined P which is taken from roots
! RootNew_kg     Mass of today's new growth of roots (kg/ha)
! RWU(L)         Root water uptake from soil layer L (cm/d)
! SECTION        Section name in input file
! Seed_kg        Seed mass (kg/ha)
! SeedNew_kg     Mass of today's new growth of seed (kg/ha)
! SenSoilP       P in senesced root and nodule tissue (kg[P]/ha/d)
! SenSurfP       P in senesced canopy tissue (kg[P]/ha/d)
! Shel_kg        Shell mass (kg/ha)
! ShelNew_kg     Mass of today's new growth of shell (kg/ha)
! Shut_kg        Shoots mass (kg/ha)
! ShutMineFrac   Fraction of mined P which is taken from shoots
! ShutNew_kg     Mass of today's new growth of shoots (kg/ha)
! SRATPART       Minimum value of the ratio of P in vegetative tissue to
!                  the optimum P, below which vegetative partitioning will
!                  be affected (g[P]/g[P])
! SRATPHOTO      Minimum value of the ratio of P in vegetative tissue to
!                  the optimum P, below which reduced photosynthesis will
!                  occur (g[P]/g[P])
! Stem_kg        Stem mass (kg/ha)
! StemNew_kg     Mass of today's new growth of stem (kg/ha)
! UseShoots      Logical variable (true or false), indicates whether input
!                  from crop routine and species file will be for shoots
!                  (true) or leaf and stem (false)
! YRPLT          Planting date (YYYYDDD)
!-----------------------------------------------------------------------
!       END SUBROUTINE PLANT
!=======================================================================


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Physical Conditions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!Initial physics variables and final  values. for temp, density and time
initialTemp=10.0;maxTemp=300
initialDens=1.00d2;finalDens=1.00d5
currentTime=0.0;finalTime=5.0d6

!radfield in habing, cosmic ray ionisation rates as multiple of standard
radfield=1.0;zeta=1.0

!Scale freeze out efficiency by an aribtrary value.
fr=1.0;

!Size of cloud set by inner and outer radii (rin and rout). used to calculate extinction.
!baseAv is extinction at cloud edge
!points is number of parcels to run model for. spaced  evenly between rin and rout
rout=0.05;rin=0;baseAv=2.0; points=1

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Behavioural switches
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!switch (0/1) -> finish model run at (finalTime/finalDens)
switch=0

!collapse (0/1/2/3/4) 1/0 are on/off for standard free-fall. 2/3/4 are different collapse modes noted in cloud.f90
!collape=0/1 ONLY if not using cloud.f90
!In all cases collapse=1 lets chem.f90 know it should call  densdot in the physics module to get time derivative of density and include it in ODES
!Any other values tells it to use density value as set by physics module
collapse=1
!for collapse=1 can introduce factor bc to slow freefall
bc=1.0

!phase chooses behaviour. Phase=1 runs a simple cloud and Phase=2 runs the physics of the chosen module (eg.hot core or c-shock)
phase=1;

!non-thermal Desorption. Turn it all on/offwith desorb. Can also turn off h2, cosmic ray induced and uv induced individually.
desorb=1;
h2desorb=1;crdesorb=1;uvdesorb=1 !Non-thermal desorption methods (roberts et al. 2007)
thermdesorb=1 !continuous thermal desorption -not currently recommended so turned off by default.

!Set to 1 to immediately add all grain surface material to gas phase.
instantSublimation=0

!ion sets ionization fraction of carbon. See chem.f90:initialise
ion=2

!cloud module specific variable for phase 2, temp profile depends on mass of star
!Tempindx selects mass: 1=1Msol,2=5,3=10M,4=15M,5=25M,6=60M
tempIndx=3

!cshock module specific variable, uncomment or comment as  needed
vs=40.0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Initial Abundances
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!You can scale the abundances of all elements heavier than He by this factor
metallicity=1.0

!Below we have some initial elemental abundances which are then scaled by the metallicty above
! fh is fraction of H initially in H atoms. Total H is always 1.

! initial fractional abundances of elements(from Jenkins et al. 2009 Table 4)
! We use the heavily depleted case as we expect most UCLCHEM models to treat gas where
! dust formation has occured and elemets are depleted.
fh=0.5;fhe = 0.1;fc  = 1.77d-04;fo  = 3.34d-04;fn  = 6.18d-05
fs  = 3.51d-6;fmg = 2.256d-07;fsi = 1.78d-06;fcl = 3.39d-08;
fp=7.78d-08 !ffe=2.01d-7;
ff = 3.6d-08 !fp depleted 1/100 of solar from Asplund 2009

! !initial fractional abundances of elements(from Asplund et al. 2009 ARAA table 1 -SOLAR)
! !note fh is fraction of H initially in H atoms. Total H is always 1.
! fh=0.5;fhe = 0.1;fc  = 2.6d-04;fo  = 4.6d-04;fn  = 6.1d-05
! fs  = 1.318d-05;fmg = 3.981d-05;fsi = 1.0d-07;fcl = 3.162d-07;
! fp=2.57d-09 ; ff = 3.6d-08 !fp depleted 1/100 of solar

! These elements are not typically used. We do not recommend any particular value
fd=0.0;fli=0.0;fna=0.0;fpah=0.0;f15n=0.0;f13c=0.0;f18O=0.0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Input and output Files
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!A full output of abundances is written by default. Additionally, name species here for
!a columnated output of time,density,temperature and abundances of those species
!Fortran will reject this array if species with shorter names are not padded with spaces at the end.
!array commented so it does not override array in input file.
!If no array is passed in input, no column file is written
!outSpecies=(/'CO ','H2S','OCS','CS '/)

!writeStep sets how often columns written out. Columns written every n steps for writeStep=n.
writeStep=1

!Final abundances are written to abundSaveFile if one is provided
!if abundLoadFile is provided, the initial abundances are read from that file.
abundSaveFile="output/start.dat"
!Full output written to outputFlie
outputFile="output/full.dat"
!columnated output of time,dens,temp and outSpecies written to column file
!only works if outSpecies list is supplied via python wrap or input parameter file
columnFile='output/column.dat'

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!More complicated parameters that affect core code below. Do not alter without reading articles associated  !
!with each process. eg chemistry variables below are reference in rates.f90                                 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!Chemistry variables
!Description and use found in rate.f90
!Desorption treatment is described in Roberts et al. 2007, these are rates and efficiencies of processes that cause desorption
ebmaxh2=1.21d3;epsilon=0.01;ebmaxcrf=1.21d3;uvcreff=1.0d-3
ebmaxcr=1.21d3;phi=1.0d5;ebmaxuvcr=1.0d4; uv_yield=0.1
omega=0.5;