      subroutine nurbs(ioption,
     *                 k1,k2,k1points,k2points,
     *                 m1,m2,ia,ib,s,t,w,x,y,z,u,v,
     *                 irow,ipt,ict,icttot,
     *                 npoints,ntets,nbpoints,nbtets,
     *                 itoff,jtoff)
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE PROCESSES AN IGES TYPE "128" (A SURFACE).
C
C     INPUT ARGUMENTS -
C
C
C     OUTPUT ARGUMENTS -
C
C
C      CHANGE HISTORY -
C      $Log: nurbs.f,v $
C      Revision 2.00  2007/11/05 19:46:02  spchu
C      Import to CVS
C
CPVCS
CPVCS       Rev 1.3   08 Feb 2006 14:35:34   dcg
CPVCS    "enforce lower case - add external statements for shift routines
CPVCS    these changes needed to compile with absoft pro fortran"
CPVCS

CPVCS       Rev 1.2   30 Sep 2004 09:19:42   dcg

CPVCS    replace calls to real( with calls to dble(

CPVCS

CPVCS       Rev 1.1   03 Feb 2000 12:32:22   dcg

CPVCS

CPVCS       Rev 1.0   27 Jan 2000 12:30:58   dcg

CPVCS    Initial revision.

CPVCS
CPVCS       Rev 1.4   Fri Aug 28 14:25:00 1998   dcg
CPVCS    remove single precision constants
CPVCS
CPVCS       Rev 1.3   Mon Apr 14 16:55:58 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.2   Thu Oct 10 08:42:40 1996   het
CPVCS    Do an automatic addatt for "vels" to contain normal directions.
CPVCS
CPVCS       Rev 1.1   Thu Jun 27 14:51:56 1996   het
CPVCS    Put unit normals into the vels array for each NURB.
CPVCS
CPVCS       Rev 1.0   Tue Jan 30 15:20:20 1996   dcg
CPVCS    Initial revision.
C
C
C#######################################################################
C
      implicit none
      integer ioption,k1,k2,k1points,k2points,m1,m2,ia,ib,irow,
     *   ipt,ict,icttot,npoints,ntets,nbpoints,nbtets,itoff,jtoff,
     *  icmotype,ierror,length,lin,itin
      real*8 xarea,yarea,zarea,xf1,xf2,xf4,x1,y1,z1,
     * x2,y2,z2,x3,y3,z3,x4,y4,z4,xsum,ysum,zsum,bsum,term1,term2
      integer it,i1,i2,i3,nnodesmm,ntetsinc,inc,ninc,k,l,
     *   nelementsmm,npointsinc,idum,jdum,ilen,ityp,npsave,ntetsave
      real*8 xs,xt,bs,bt,gx,gy,gz,epsilon,smin,smax,tmin,tmax,
     *  ds1,dt1,t1,s1,dx1,dy1,dy,dx,xf3,rout
      integer ix,iy,ij,ip1j,ijp1,ip1jp1,j,ik2,kt,jt,i,js,ks,iout,lout,
     *  nxdum,mbndry,k1point,k2point,icscode,nx,ny,i4,ik1
      pointer(ipout,out)
      real*8 out(*)
      real*8 alargenumber
      parameter (alargenumber=1.0d+99)
C
C
C ######################################################################
C
      real*8 s(ia), t(ib)
      real*8 w(k1,k2), x(k1,k2), y(k1,k2), z(k1,k2)
      real*8 u(*), v(*)
C
      pointer (ipxs, xs(2,1000000))
      pointer (ipxt, xt(2,1000000))
      pointer (ipbs, bs(ia,1000000))
      pointer (ipbt, bt(ib,1000000))
      pointer (ipgx, gx(1000000))
      pointer (ipgy, gy(1000000))
      pointer (ipgz, gz(1000000))
C
      character*32 cmo
      character*32 isubname
      character*32 cvelnm
      character*8092 cbuff
C
      pointer (ipimt1, imt1)
      pointer (ipitp1, itp1)
      integer itp1(10000000), imt1(10000000)
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      real*8 xic(10000000), yic(10000000), zic(10000000)
      pointer(ipvels,vels)
      real*8 vels(3,1000000)
C
      pointer (ipitet, itet1)
      pointer (ipjtet, jtet1)
      integer itet1(4*1000000), jtet1(4*1000000)
      pointer (ipitetclr, itetclr)
      pointer (ipitettyp, itettyp)
      pointer (ipitetoff, itetoff)
      pointer (ipjtetoff, jtetoff)
      integer itetclr(1000000), itettyp(1000000),
     *        itetoff(1000000), jtetoff(1000000)
      integer ijtrg,ijtet
C
C ######################################################################
C
C
      data epsilon / 1.0d-10 /
C
C ######################################################################
C
      ijtet(idum,jdum,nxdum)=idum+(jdum-1)*(nxdum+1) + npsave
      ijtrg(idum,jdum,nxdum)=2*(idum-1+(jdum-1)*nxdum) + ntetsave
C
C ######################################################################
C
C
      isubname="nurbs"
C
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('nnodes',cmo,npoints,length,icmotype,ierror)
      call cmo_get_info('nelements',cmo,ntets,length,icmotype,ierror)
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
      call cmo_get_info('imt1',cmo,ipimt1,length,icmotype,ierror)
      call cmo_get_info('itp1',cmo,ipitp1,length,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,ipitetclr,length,icmotype,ierror)
      call cmo_get_info('itettyp',cmo,ipitettyp,length,icmotype,ierror)
      call cmo_get_info('itetoff',cmo,ipitetoff,length,icmotype,ierror)
      call cmo_get_info('jtetoff',cmo,ipjtetoff,length,icmotype,ierror)
      call cmo_get_info('itet',cmo,ipitet,length,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,length,icmotype,ierror)
C
      if(k1points.le.0) then
         k1point=k1
      else
         k1point=k1points
      endif
      if(k2points.le.0) then
         k2point=k2
      else
         k2point=k2points
      endif
C
      length=2*ia
      call mmgetblk("xs",isubname,ipxs,length,2,icscode)
      length=2*ib
      call mmgetblk("xt",isubname,ipxt,length,2,icscode)
      length=ia*(m1+1)
      call mmgetblk("bs",isubname,ipbs,length,2,icscode)
      length=ib*(m2+1)
      call mmgetblk("bt",isubname,ipbt,length,2,icscode)
      length=k1point*k2point
      call mmgetblk("gx",isubname,ipgx,length,2,icscode)
      call mmgetblk("gy",isubname,ipgy,length,2,icscode)
      call mmgetblk("gz",isubname,ipgz,length,2,icscode)
C
      smin=alargenumber
      smax=-smin
      js=0
      ks=0
      do 100 i=1,ia-1
C*****   if(s(i).ne.s(i+1)) then
         if(abs(s(i)-s(i+1)).gt.epsilon) then
            js=js+1
            xs(1,js)=s(i)
            xs(2,js)=s(i+1)
            smin=min(smin,xs(1,js),xs(2,js))
            smax=max(smax,xs(1,js),xs(2,js))
         else
            ks=ks+1
         endif
 100  continue
      tmin=alargenumber
      tmax=-tmin
      jt=0
      kt=0
      do 110 i=1,ib-1
C*****   if(t(i).ne.t(i+1)) then
         if(abs(t(i)-t(i+1)).gt.epsilon) then
            jt=jt+1
            xt(1,jt)=t(i)
            xt(2,jt)=t(i+1)
            tmin=min(tmin,xt(1,jt),xt(2,jt))
            tmax=max(tmax,xt(1,jt),xt(2,jt))
         else
            kt=kt+1
         endif
 110  continue
      ds1=(u(2)-u(1))/(k1point-1)
      dt1=(v(2)-v(1))/(k2point-1)
      t1=v(1)-dt1
      do 200 ik2=1,k2point
         t1=t1+dt1
         do 205 j=1,m2+1
            do 206 i=1,ib
               bt(i,j)=0.0
 206        continue
 205     continue
         do 210 i=1,ib-1
C*****      if(t1.ge.t(i).and.t1.le.t(i+1).and.t(i).ne.t(i+1)) then
            if((t1-t(i)).gt.-epsilon .and.
     *         (t1-t(i+1)).lt.epsilon .and.
     *         abs(t(i)-t(i+1)).gt.epsilon) then
               bt(i,1)=1
            else
               bt(i,1)=0
            endif
 210     continue
         do 220 j=1,m2
            do 230 i=1,ib-j-1
C*****         if(t(i+j).eq.t(i)) then
               if(abs(t(i+j)-t(i)).lt.epsilon) then
                  term1=0.0
               else
                  term1=(t1-t(i))/(t(i+j)-t(i))
               endif
C*****         if(t(i+j+1).eq.t(i+1)) then
               if(abs(t(i+j+1)-t(i+1)).lt.epsilon) then
                  term2=0.0
               else
                  term2=(t(i+j+1)-t1)/(t(i+j+1)-t(i+1))
               endif
               bt(i,j+1)=term1*bt(i,j)+term2*bt(i+1,j)
 230        continue
 220     continue
         s1=u(1)-ds1
         do 240 ik1=1,k1point
            s1=s1+ds1
            do 245 j=1,m1+1
               do 246 i=1,ia
                  bs(i,j)=0.0
 246           continue
 245        continue
            do 250 i=1,ia-1
C*****         if(s1.ge.s(i).and.s1.le.s(i+1).and.s(i).ne.s(i+1)) then
               if((s1-s(i)).gt.-epsilon .and.
     *            (s1-s(i+1)).lt.epsilon .and.
     *            abs(s(i)-s(i+1)).gt.epsilon) then
                  bs(i,1)=1
               else
                  bs(i,1)=0
               endif
 250        continue
            do 260 j=1,m1
               do 270 i=1,ia-j-1
C*****            if(s(i+j).eq.s(i)) then
                  if(abs(s(i+j)-s(i)).lt.epsilon) then
                     term1=0.0
                  else
                     term1=(s1-s(i))/(s(i+j)-s(i))
                  endif
C*****            if(s(i+j+1).eq.s(i+1)) then
                  if(abs(s(i+j+1)-s(i+1)).lt.epsilon) then
                     term2=0.0
                  else
                     term2=(s(i+j+1)-s1)/(s(i+j+1)-s(i+1))
                  endif
                  bs(i,j+1)=term1*bs(i,j)+term2*bs(i+1,j)
 270           continue
 260        continue
            bsum=0.0
            xsum=0.0
            ysum=0.0
            zsum=0.0
            do 300 j=1,k2
               do 310 i=1,k1
                  bsum=bsum+w(i,j)*bt(j,m2+1)*bs(i,m1+1)
                  xsum=xsum+w(i,j)*x(i,j)*bt(j,m2+1)*bs(i,m1+1)
                  ysum=ysum+w(i,j)*y(i,j)*bt(j,m2+1)*bs(i,m1+1)
                  zsum=zsum+w(i,j)*z(i,j)*bt(j,m2+1)*bs(i,m1+1)
 310           continue
 300        continue
C*****      print *,ik1+(ik2-1)*k1point,xsum,ysum,bsum
            if(abs(bsum).lt.epsilon) then
               gx(ik1+(ik2-1)*k1point)=0.0
               gy(ik1+(ik2-1)*k1point)=0.0
               gz(ik1+(ik2-1)*k1point)=0.0
            else
               gx(ik1+(ik2-1)*k1point)=xsum/bsum
               gy(ik1+(ik2-1)*k1point)=ysum/bsum
               gz(ik1+(ik2-1)*k1point)=zsum/bsum
            endif
 240     continue
 200  continue
      call cmo_get_info('itp1',cmo,
     *                  ipitp1,length,icmotype,ierror)
      call cmo_get_info('imt1',cmo,
     *                  ipimt1,length,icmotype,ierror)
      call cmo_get_info('xic',cmo,
     *                  ipxic,length,icmotype,ierror)
      call cmo_get_info('yic',cmo,
     *                  ipyic,length,icmotype,ierror)
      call cmo_get_info('zic',cmo,
     *                  ipzic,length,icmotype,ierror)
      call cmo_get_attinfo('velname',cmo,iout,rout,cvelnm,
     *  ipout,lout,ityp,ierror)
      if(ierror.ne.0) cvelnm='vels'
      call cmo_get_info(cvelnm,cmo,ipvels,ilen,ityp,ierror)
      if(ierror.ne.0) then
         cbuff ='cmo/addatt/-def-/vels/VDOUBLE/vector/' //
     *          'nnodes/linear/permanent/gxa/0.0 ;  ' //
     *          'finish'
         call dotaskx3d(cbuff,ierror)
      endif
      call cmo_get_info(cvelnm,cmo,ipvels,lin,itin,ierror)
      call cmo_get_info('itetclr',cmo,
     *                  ipitetclr,length,icmotype,ierror)
      call cmo_get_info('itettyp',cmo,
     *                  ipitettyp,length,icmotype,ierror)
      call cmo_get_info('itetoff',cmo,
     *                  ipitetoff,length,icmotype,ierror)
      call cmo_get_info('jtetoff',cmo,
     *                  ipjtetoff,length,icmotype,ierror)
      call cmo_get_info('itet',cmo,
     *                  ipitet,length,icmotype,ierror)
      call cmo_get_info('jtet',cmo,
     *                  ipjtet,length,icmotype,ierror)
      ntetsave=ntets
      do 500 j=1,k2point-1
         do 510 i=1,k1point-1
            ij=i+(j-1)*k1point
            ip1j=(i+1)+(j-1)*k1point
            ijp1=i+j*k1point
            ip1jp1=(i+1)+j*k1point
            x1=gx(ij)
            y1=gy(ij)
            z1=gz(ij)
            x2=gx(ip1j)
            y2=gy(ip1j)
            z2=gz(ip1j)
            x3=gx(ip1jp1)
            y3=gy(ip1jp1)
            z3=gz(ip1jp1)
            x4=gx(ijp1)
            y4=gy(ijp1)
            z4=gz(ijp1)
            npsave=npoints
            nx=1
            ny=1
            dx1=1.0/dble(nx)
            dy1=1.0/dble(ny)
            dy=-dy1
            do 520 iy=1,ny+1
               dx=-dx1
               dy=dy+dy1
               do 530 ix=1,nx+1
                  dx=dx+dx1
                  xf1=(1.0-dx)*(1.0-dy)
                  xf2=dx*(1.0-dy)
                  xf3=dx*dy
                  xf4=(1.0-dx)*dy
                  npoints=npoints+1
                  call mmfindbk('xic',cmo,ipxic,length,icscode)
                  if((npoints+1).gt.length) then
                     npointsinc=npoints+1000
                     call cmo_set_info('nnodes',cmo,npointsinc,1,1,
     *                        ierror)
                     call mmgetlen(ipitetclr,nelementsmm,icscode)
                     call cmo_set_info('nelements',cmo,
     *                                 nelementsmm,1,1,ierror)
                     call cmo_newlen(cmo,ierror)
                     call cmo_get_info('itp1',cmo,
     *                                 ipitp1,length,icmotype,ierror)
                     call cmo_get_info('imt1',cmo,
     *                                 ipimt1,length,icmotype,ierror)
                     call cmo_get_info('xic',cmo,
     *                                 ipxic,length,icmotype,ierror)
                     call cmo_get_info('yic',cmo,
     *                                 ipyic,length,icmotype,ierror)
                     call cmo_get_info('zic',cmo,
     *                                 ipzic,length,icmotype,ierror)
                     call cmo_get_info(cvelnm,cmo,ipvels,lin,itin,
     *                         ierror)
                  endif
                  imt1(npoints)=1+mod(irow-1,64)
                  itp1(npoints)=0
                  xic(npoints)=xf1*x1+xf2*x2+xf3*x3+xf4*x4
                  yic(npoints)=xf1*y1+xf2*y2+xf3*y3+xf4*y4
                  zic(npoints)=xf1*z1+xf2*z2+xf3*z3+xf4*z4
                  vels(1,npoints)=0.0
                  vels(2,npoints)=0.0
                  vels(3,npoints)=0.0
 530          continue
 520       continue
           do 550 l=1,ny
              do 560 k=1,nx
                 if(ioption.eq.1) then
                    ninc=1
                 else
                    ninc=2
                 endif
                 call mmgetlen(ipitetclr,length,icscode)
                 if((ntets+ninc).gt.length) then
                    inc=1000
                    ntetsinc=ntets+inc
                    call cmo_set_info('nelements',cmo,ntetsinc,1,1,
     *                          ierror)
                    call mmfindbk('xic',cmo,ipxic,nnodesmm,icscode)
                    call cmo_set_info('nnodes',cmo,nnodesmm,1,1,ierror)
                    call cmo_newlen(cmo,ierror)
                    call cmo_get_info('itetclr',cmo,
     *                                ipitetclr,length,icmotype,ierror)
                    call cmo_get_info('itettyp',cmo,
     *                                ipitettyp,length,icmotype,ierror)
                    call cmo_get_info('itetoff',cmo,
     *                                ipitetoff,length,icmotype,ierror)
                    call cmo_get_info('jtetoff',cmo,
     *                                ipjtetoff,length,icmotype,ierror)
                    call cmo_get_info('itet',cmo,
     *                                ipitet,length,icmotype,ierror)
                    call cmo_get_info('jtet',cmo,
     *                                ipjtet,length,icmotype,ierror)
                 endif
                 if(ioption.eq.2) then
                    i1=ijtet(k  ,l  ,nx)
                    i2=ijtet(k+1,l  ,nx)
                    i3=ijtet(k+1,l+1,nx)
                    ntets=ntets+1
                    itetclr(ntets)=imt1(i1)
                    itettyp(ntets)=3
                    itetoff(ntets)=itoff
                    jtetoff(ntets)=jtoff
                    itoff=itoff+3
                    jtoff=jtoff+3
                    itet1(1+itetoff(ntets))=i1
                    itet1(2+itetoff(ntets))=i2
                    itet1(3+itetoff(ntets))=i3
                    jtet1(1+jtetoff(ntets))=-1
                    jtet1(2+jtetoff(ntets))=-1
                    jtet1(3+jtetoff(ntets))=-1
                    i1=ijtet(k  ,l  ,nx)
                    i2=ijtet(k+1,l+1,nx)
                    i3=ijtet(k  ,l+1,nx)
                    ntets=ntets+1
                    itetclr(ntets)=imt1(i1)
                    itettyp(ntets)=3
                    itetoff(ntets)=itoff
                    jtetoff(ntets)=jtoff
                    itoff=itoff+3
                    jtoff=jtoff+3
                    itet1(1+itetoff(ntets))=i1
                    itet1(2+itetoff(ntets))=i2
                    itet1(3+itetoff(ntets))=i3
                    jtet1(1+jtetoff(ntets))=-1
                    jtet1(2+jtetoff(ntets))=-1
                    jtet1(3+jtetoff(ntets))=-1
                 else
                    i1=ijtet(k  ,l  ,nx)
                    i2=ijtet(k+1,l  ,nx)
                    i3=ijtet(k+1,l+1,nx)
                    i4=ijtet(k  ,l+1,nx)
                    ntets=ntets+1
                    itetclr(ntets)=imt1(i1)
                    itettyp(ntets)=4
                    itetoff(ntets)=itoff
                    jtetoff(ntets)=jtoff
                    itoff=itoff+4
                    jtoff=jtoff+4
                    itet1(1+itetoff(ntets))=i1
                    itet1(2+itetoff(ntets))=i2
                    itet1(3+itetoff(ntets))=i3
                    itet1(4+itetoff(ntets))=i4
                    jtet1(1+jtetoff(ntets))=-1
                    jtet1(2+jtetoff(ntets))=-1
                    jtet1(3+jtetoff(ntets))=-1
                    jtet1(4+jtetoff(ntets))=-1
                 endif
 560           continue
 550        continue
 510     continue
 500  continue
      call cmo_get_info('xic',cmo,
     *                  ipxic,length,icmotype,ierror)
      call cmo_get_info('yic',cmo,
     *                  ipyic,length,icmotype,ierror)
      call cmo_get_info('zic',cmo,
     *                  ipzic,length,icmotype,ierror)
      call cmo_get_info(cvelnm,cmo,ipvels,lin,itin,ierror)
      call cmo_get_info('itet',cmo,
     *                  ipitet,length,icmotype,ierror)
      do it=ntetsave+1,ntets
         i1=itet1(itetoff(it)+1)
         i2=itet1(itetoff(it)+2)
         i3=itet1(itetoff(it)+3)
         x1=xic(i1)
         y1=yic(i1)
         z1=zic(i1)
         x2=xic(i2)
         y2=yic(i2)
         z2=zic(i2)
         x3=xic(i3)
         y3=yic(i3)
         z3=zic(i3)
         xarea=  (y2-y1)*(z3-z1)-(y3-y1)*(z2-z1)
         yarea=-((x2-x1)*(z3-z1)-(x3-x1)*(z2-z1))
         zarea=  (x2-x1)*(y3-y1)-(x3-x1)*(y2-y1)
         vels(1,i1)=vels(1,i1)+xarea
         vels(2,i1)=vels(2,i1)+yarea
         vels(3,i1)=vels(3,i1)+zarea
         vels(1,i2)=vels(1,i2)+xarea
         vels(2,i2)=vels(2,i2)+yarea
         vels(3,i2)=vels(3,i2)+zarea
         vels(1,i3)=vels(1,i3)+xarea
         vels(2,i3)=vels(2,i3)+yarea
         vels(3,i3)=vels(3,i3)+zarea
      enddo
      call cmo_set_info('nnodes',cmo,npoints,1,1,ierror)
      call cmo_set_info('nelements',cmo,ntets,1,1,ierror)
      call mmrelprt(isubname,icscode)
      goto 9999
 9999 continue
      return
      end


*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE DOLYDAY                          *
*                          ******************                          *
*                                                                      *
*           (D)ynamic gl(O)ba(L) phytogeograph(Y) model                *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE DOLYDAY(sla,c3,ftphen,ftagh,ftdth,leafls,stemls,
     &rootls,bbm,bb0,bbmax,bblim,ssm,sss,sslim,lairat,lat,dep,tmp,prc,
     &hum,cld,ca,soilc,soiln,minn,s1,s2,s3,s4,sn,lsn,adp,sfc,sw,sswc,
     &awl,kd,kx,daygpp,dayra,rlai,nppstore,nppstorx,nppstor2,maxevap,
     &daysoff,evap,tran,roff,interc,evbs,flow1,flow2,year,mnth,day,pet,
     &laimax,ht,leafv,stemv,rootv,leaflit,stemlit,rootlit,bb,ss,bbgs,
     &dsbb,tmem,maxlai,thty_dys,wtfc,wtwp,leafnpp,stemnpp,rootnpp,
     &yield,ft,resp,sm_trig,qdirect,qdiff,suma,tsumam,stemfr,
     &lmor_sc,nleaf,chill,dschill,fpr,gsm)

*----------------------------------------------------------------------*
      REAL*8 oi
      PARAMETER(oi = 21000.0d0)
*----------------------------------------------------------------------*
      REAL*8 bb0,bbmax,bblim,sslim,lat,dep,tmp,prc,hum,cld,ca,maxevap
      REAL*8 lairat,interc,evbs,leafv(3600),stemv(1000),rootv(1000),t
      REAL*8 soilc,soiln,rh,tk,rd,rn,pet,petmm,petv,laimax,q,qdiff
      REAL*8 qdirect,hrs,vpd,canga,lam,rho,s,gam,amx,gsn,dp2,pet2,wtfc
      REAL*8 etwt,etmm,ftagh,soilw,maxc,soil2g,can2a,daygpp,daynpp
      REAL*8 tmem(200),gsum,sapresp,sla,nppstorx,leafmol,ht,tf(13)
      REAL*8 eemm,daysoff,amax,respref,suma(360),can2g,cangs,svp,rlai
      REAL*8 wtwp,p,nppstor2,dayl,sum,canres,et,ee,flow1,flow2,tran,rem
      REAL*8 adp(4),evap,f2,sn,lsn,s1,s2,s3,s4,sfc(4),sw(4),awl(4),kd
      REAL*8 kx,f3,minn(3),roff,windspeed,leaflit,lflit,stemlit,smlit
      REAL*8 rootlit,rtlit,npp_eff,eff_dec,eff_age,eff,nppstore,stemnpp
      REAL*8 rootnpp,leafnpp,tfscale,s_gpp,s_rr,s_rn,s_sr,s_sn
      REAL*8 s_lr,s_ln,sswc(4),maxlai,yield,yld,resp,fpr,dayra,gsm
      REAL*8 sm_trig(30),s1in,tsumam,stemfr,lmor_sc(3600),nleaf
      INTEGER leafls,stemls,rootls,bbm,ssm,sss,ftphen,c3,thty_dys,ft
      INTEGER mnth,i,iter,no_day,ndsum(12),lai,day,year,bb,bbgs
      INTEGER ftdth,ss,dsbb,chill,dschill
      LOGICAL veg
      INCLUDE 'param.inc'

      maxlai = 11.9d0
*      print*,rlai,day,mnth

*      if ((day.eq.1).and.(mnth.eq.1)) print*,tmp,prc,hum,cld

*----------------------------------------------------------------------*
* SET parameter for THROUGHFALL.                                       *
*----------------------------------------------------------------------*
       tf(1) = 1.0d0
       tf(2) = 0.95d0
       tf(3) = 0.935d0
       tf(4) = 0.92d0
       tf(5) = 0.905d0
       tf(6) = 0.89d0
       tf(7) = 0.875d0
       tf(8) = 0.86d0
       tf(9) = 0.845d0
       tf(10)= 0.83d0
       tf(11)= 0.815d0
       tf(12)= 0.80d0
       tf(13)= 0.785d0

       tfscale = 2.75d0
       DO i=1,13
         tf(i) = 1.0d0 - tfscale*(1.0d0 - tf(i))
       ENDDO

*----------------------------------------------------------------------*
* Data input for number of days for each month of the year 'ndays',    *
* the mid julian day of each month 'ndsum'.                            *
*----------------------------------------------------------------------*
      DATA ndsum/16,46,75,106,136,167,197,228,259,289,320,350/

      p = 101325.0d0

      s_gpp = 0.0d0
      s_rr = 0.0d0
      s_rn = 0.0d0
      s_lr = 0.0d0
      s_ln = 0.0d0
      s_sr = 0.0d0
      s_sn = 0.0d0

      rem = rlai - int(rlai)
      lai = int(rlai) + 1

*----------------------------------------------------------------------*
* INITIALISATIONS.                                                     *
*----------------------------------------------------------------------*
* Night-time respiration ? CHECK
      rd = 0.82E-6
* maxc, moisture response parameter
      maxc = 690.0d0/622.6d0
* Leaf molecular weight.
      IF (sla.GT.0.0d0) THEN
        leafmol = 1.0d0/(sla*18.0d0)
      ELSE
        leafmol =0.0d0
      ENDIF

c initialisation a faire a chaque fois
      IF ((ft.EQ.1).OR.(ft.EQ.2)) THEN
         veg = .FALSE.
      ELSE
         veg = .TRUE.
      ENDIF

*----------------------------------------------------------------------*
* Water model variables and rain generater.                            *
*----------------------------------------------------------------------*
      iter = 30

c unsused anymore... so not important if set to this value every day.
c Better: should be remove from nppcalc
      amx = -1000.0d0
      amax = -1000.0d0

*----------------------------------------------------------------------*
      soilw = s1 + s2 + s3 + s4
      soil2g = soilw/(dep*10.0d0)
      IF (soil2g.GT.1.0d0) soil2g = 1.0d0

*----------------------------------------------------------------------*
* Bare ground IF statement                                             *
*----------------------------------------------------------------------*
      IF (.NOT.(veg)) rlai = 0.0d0
*----------------------------------------------------------------------*

      t = tmp
      tk = 273.0d0 + t
      rh = hum
*      abmin = tmp(mnth,day)*1.29772d0 - 19.5362d0
      IF (rh.GT.95.0d0)  rh=95.0d0
      IF (rh.LT.30.0d0)  rh=30.0d0

* Sapwood respiration N.B. 8.3144 J/K/mol= Universal gas constant.
*     sapresp = exp(21.6d0 - 5.367e4/(8.3144d0*tk))
      sapresp = 0.4d0*exp(0.06d0*t)*0.1d0
      sapresp = 0.4d0*exp(0.02d0*t)*0.35d0

* Converted to a monthly figure (N.B. 24 hour day).
*          sapresp = (sapresp*3600.0d0*24.0d0*30.0d0)/1000000.0d0
* Use daily value
      sapresp = (sapresp*3600.0d0*24.0d0)/1000000.0d0

* Totalled for the year.
      IF (soil2g.GT.wtwp) THEN
        respref = sapresp*p_resp*((soil2g - wtwp)/min(1.0d0,(wtfc - wtwp
     &)))**p_kgw
      ELSE
        respref = 0.0d0
      ENDIF

      IF (t.LT.0.0d0) then
        respref = 0.0d0
      ENDIF

*      if (day.eq.1) print'(i4,6f10.4)',mnth,respref,sapresp,t,
*     &((soil2g - wtwp)/min(1.0d0,(wtfc - wtwp)))**p_kgw

*----------------------------------------------------------------------*
* Calculate daily potential evapotraspiration for each month.          *
*----------------------------------------------------------------------*
      hrs = dayl(lat,no_day(year,mnth,day,thty_dys))
      CALL PFD(lat,no_day(year,mnth,day,thty_dys),hrs,cld,qdirect,qdiff,
     &q)
c          print *,'irrad=',q
c     &      ,pfd_without_cloud(lat,no_day(year,mnth,day,thty_dys),hrs)
*      print'(''direct diff '',i3,2f10.5)',mnth,qdirect,qdiff

      t = tmp
      lam = 2500.0d0 - (2.367d0*t)
      s = 48.7d0*exp(0.0532d0*t)
      rn = 0.96d0*(q*1000000.0d0/4.0d0 + 208.0d0 + 6.0d0*t)
      rn = rn*0.52d0
      pet = (1.26d0*s*rn)/(s + 66.0d0)*p_pet
      petmm = (pet*3600.0d0)/(lam*1000.0d0)*10.0d0
      IF (petmm.GT.0.0d0) THEN
        petv = petmm/1.0d0
      ELSE
        petv = 0.0d0
      ENDIF
      pet = petv

*----------------------------------------------------------------------*

*----------------------------------------------------------------------*
c     canga=k^2 u / (log[(z-d)/z0])^2
c     k=von Karman constant. k=0.41
c     z=reference height
c     d=zero plane displacement
c     z0=roughness length

      windspeed= 5.0d0 ! in m/s
      canga = 0.168d0*windspeed/log((200.0d0 -
     &0.7d0*ht)/(0.1d0*ht))**2

      npp_eff = 0.0d0
      sum = 0.0d0
      eff_dec = 0.75d0
      eff_age = 90.0d0
      DO i=1,leafls
        IF (i.LE.eff_age) THEN
          eff = 1.0d0
        ELSE
          eff = eff_dec + real(leafls - i)*(1.0d0 - eff_dec)/
     &(real(leafls) - eff_age + 1.0d0)
        ENDIF
        npp_eff = npp_eff +  leafv(i)*eff
        sum = sum + leafv(i)
      ENDDO
      IF (abs(sum-rlai).gt.0.001) THEN
        WRITE(*,*) 'leafv not = rlai ',SUM,RLAI,mnth,day,nppstore
*        STOP
      ENDIF
      IF (sum.GT.0.0d0) THEN
        npp_eff = npp_eff/sum
      ELSE
        npp_eff = 0.0d0
      ENDIF
*      npp_eff = 1.0d0

      DO i=1,359
        suma(361-i) = suma(360-i)
      ENDDO

      IF (veg) THEN
        CALL NPPCALC(npp_eff,c3,maxc,soilc,soiln,minn,soil2g,wtwp,wtfc,
     &rd,rlai,t,rh,ca,oi,rn,qdirect,qdiff,can2a,can2g,canres,suma(1),
     &amx,amax,gsum,hrs,canga/1.3d0,p,mnth,day,nleaf,fpr,gsm)

c      write(*,*) 'o',canga,can2a,can2g,canres,suma,gsum

*----------------------------------------------------------------------*
* Calculate the canopy conductance.                                    *
*----------------------------------------------------------------------*
        cangs = 8.3144d0*tk/p*can2g
        cangs = 1.6d0*cangs             ! convert CO2 gs into H2O gs
        gsn = cangs
*----------------------------------------------------------------------*
      ELSE
        can2a = 0.0d0
        can2g = 0.0d0
        canres = 0.d0
        cangs = 0.0d0
        gsn = 0.0d0
        suma(1) = 0.0d0
      ENDIF

      dp2 = prc
      pet2 = petv

*----------------------------------------------------------------------*
*                      EVAPOTRANSPIRATION                              *
*----------------------------------------------------------------------*
* Penman-Monteith equation for evapotranspiration.                     *
* Units of ET = W/m2  (CHECK) N.B. Conductances in moles.              *
*----------------------------------------------------------------------*
      svp = 6.108d0*exp((17.269d0*t)/(237.3d0 + t))*100.0d0
      vpd = (1.0d0 - rh/100.0d0)*svp
      lam = 2500.0d0 - 2.367d0*t
      rho = 1288.4d0 - 4.103d0*t
      s = 48.7d0*exp(0.0532d0*t)
      gam = 101325.0d0*1.012d0/(0.622d0*lam)

      IF ((rlai.GT.0.1d0).AND.(soil2g.GT.wtwp)) THEN
        et = (s*rn + rho*1.012d0*canga*vpd)/(s + gam*(1.0d0 +
     &canga/gsn))*p_et
c            print *,'gsn=',gsn
c            print *,'vpd=',vpd
c watch dog ajoute par ghislain
        IF (et.LT.0.0d0) THEN
*           print *,'et is negativ et=',et
           et=0.0d0
        ENDIF

        etwt = (et*3600.0d0*hrs)/lam
        etmm = etwt/1000.0d0
        IF (etmm.GT.0.0d0) THEN
          IF (etmm/hrs.GT.maxevap)  maxevap = etmm/hrs
        ENDIF
      ELSE
        et = 0.0d0
        etwt = 0.0d0
        etmm = 0.0d0
      ENDIF
      etmm = etmm

      ee = (s*rn + rho*1.012d0*canga*vpd)/(s + gam)
      eemm = (ee*3600.0d0*hrs)/(lam*1000.0d0)

c     added by Ghislain 20/10/03
      IF (ee.LT.0.0d0) THEN
*        print *,'ee is negativ ee=',ee,rn
*        print*,canga,s,rho
*        stop
        ee=0.0d0
        eemm=0.0d0
      ENDIF

      pet = eemm
      pet2 = pet
      petv = pet

*----------------------------------------------------------------------*
* Set switch 'stseas' to find when a new growing season has started.   *
* 'stseas = 1' for the first day of a new growing season.              *
*----------------------------------------------------------------------*

      soil2g = soilw/(dep*10.0d0)

      CALL HYDROLOGY(adp,sfc,sw,sswc,awl,kd,kx,tf,s1,s2,s3,s4,sn,lsn,
     &eemm,etmm,pet2,dp2,s1in,t,rlai,evap,tran,roff,interc,evbs,iter,f2,
     &f3,ft,dep)
      soilw = s1 + s2 + s3 + s4
      soil2g = soilw/(dep*10.0d0)

      if ((mnth.eq.4).and.(day.eq.-20)) print*,mnth,day,soilw,etmm

      DO i=1,29
        sm_trig(31-i) = sm_trig(30-i)
      ENDDO
      sm_trig(1) = (s1in - 0.0d0*evbs)

      flow1 = flow1 + f2/10.0d0
      flow2 = flow2 + f3/10.0d0

*----------------------------------------------------------------------*
*                         DAILY npp                                    *
*----------------------------------------------------------------------*
      daynpp = can2a*3600.0d0*hrs/1000000.0d0 -
     &canres*3600.0d0*(24.0d0-hrs)/1000000.0d0

*      print*,'gpp & resp ',12.0*can2a*3600.0d0*hrs/1000000.0d0,
*     &12.0*canres*3600.0d0*(24.0d0-hrs)/1000000.0d0

      if (day.eq.115)  print*,'canres ',mnth,canres

      daygpp= can2a*3600.0d0*hrs*12.0d0/1000000.0d0
      dayra = canres*3600.0d0*(24.0d0-hrs)/1000000.0d0

      s_gpp = s_gpp + can2a*3600.0d0*hrs*12.0d0/1000000.0d0
      s_lr = s_lr + canres*3600.0d0*(24.0d0-hrs)/1000000.0d0

      IF (veg) THEN
        nppstore = nppstore + daynpp
        IF (ftphen.EQ.1) THEN
          CALL PHENOLOGY1(ftagh,ftdth,bbm,bb0,bbmax,bblim,ssm,sss,sslim,
     &nppstore,leafnpp,stemnpp,rootnpp,tran,rlai,lai,lairat,rem,
     &leafls,stemls,rootls,leafmol,respref,soil2g,wtwp,tmem,leafv,stemv,
     &rootv,daysoff,laimax,lflit,smlit,rtlit,mnth,day,s_ln,s_sr,s_sn,
     &s_rr,s_rn,bb,ss,bbgs,dsbb,nppstorx,nppstor2,daynpp,
     &maxlai,wtfc,yld,resp,sm_trig,suma,tsumam,stemfr,lmor_sc,
     &chill,dschill,canres*3600.0d0*(24.0d0-hrs)/1000000.0d0)
        ELSEIF (ftphen.EQ.2) THEN
          CALL PHENOLOGY2(bbm,bb0,bbmax,bblim,ssm,sss,sslim,
     &nppstore,leafnpp,stemnpp,rootnpp,tran,rlai,lai,lairat,rem,leafls,
     &stemls,rootls,leafmol,respref,soil2g,wtwp,tmem,leafv,stemv,rootv,
     &daysoff,laimax,lflit,smlit,rtlit,mnth,day,s_ln,s_sr,s_sn,s_rr,
     &s_rn,bb,ss,bbgs,dsbb,nppstorx,nppstor2,daynpp,maxlai,
     &wtfc,yld,resp,sm_trig,suma,tsumam,stemfr,lmor_sc,chill,
     &dschill,canres*3600.0d0*(24.0d0-hrs)/1000000.0d0)
        ELSE
          WRITE(*,*) 'No phenology defined for ',ftphen
          STOP
        ENDIF
        leaflit = leaflit + lflit*12.0d0*leafmol
        yield = yield + yld*12.0d0*leafmol
        stemlit = stemlit + smlit*12.0d0
        rootlit = rootlit + rtlit*12.0d0
      ENDIF
*----------------------------------------------------------------------*
* End of the DAILY LOOP.                                               *
*----------------------------------------------------------------------*

      qdirect = qdirect*hrs*3600.0d0
      qdiff = qdiff*hrs*3600.0d0

      END

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE DOLYMONTH                        *
*                          ********************                        *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE DOLYMONTH(ts,tc,avmnpet,avmnppt,avmnt,h2o,
     &flow1,flow2,c0,n0,minn,nfix,nci,slc,rlc,sln,srespm,
     &lchm,ca,site,year,yr0,yrf,speedc,soilc,soiln,mnth)
*----------------------------------------------------------------------*
      IMPLICIT NONE
c     arguments
      REAL*8 ts,tc,avmnpet,avmnppt,avmnt,h2o,flow1,flow2
      REAL*8 slnr,rlnr,scl,rcl,ca
      REAL*8 c0(8),n0(8),minn(3),nfix,soilc,soiln
      LOGICAL speedc
      INTEGER yr0,yrf,year,site,mnth
      REAL*8 srespm,lchm,nci(4)

c     variables
      REAL*8 ar,fms,fmr,tm,ft,cal,cap,cas,csp,csa,kr(8)
      REAL*8 ml,al,c(8),n(8)
      REAL*8 slc,rlc,sln
      REAL*8 scn,t0,t1
      REAL*8 fl(14)
      INTEGER ij

      if (mnth.eq.-4) stop

*----------------------------------------------------------------------*
* Calculate lignin to nitrogen ratios based on the C02 concentration.  *
*----------------------------------------------------------------------*
      slnr = 0.18d0*ca + 2.7d0
      rlnr = 0.18d0*ca + 2.7d0

      scl = 0.12d0   ! Fractions of surface carbon that are lignin.
      rcl = 0.35d0   ! Fractions of root carbon that are lignin.

      IF (slc*sln.GT.1e-6) THEN
        scn = slc/sln ! Ratio of surface carbon to nitrogen.
      ELSE
        scn = 10.0d0
      ENDIF

*----------------------------------------------------------------------*
* Compute monthly accumulation of values required by century.          *
*----------------------------------------------------------------------*
      CALL SETCENPAR(ts,tc,avmnpet,avmnppt,avmnt,h2o,flow2,slnr,
     &rlnr,ar,fms,fmr,scl,rcl,tm,ft,cal,cap,cas,csp,csa,kr)

*----------------------------------------------------------------------*
* Using century model compute the new carbon and nitrogen pools.       *
*----------------------------------------------------------------------*

      t0 = 0.0d0
      t1 = 1.0d0/12.0d0
      srespm = 0.0d0
      lchm = 0.0d0

      IF (soilc.gt.1000.0d0) THEN

        CALL CDYN(c0,c,t0,t1,slc,rlc,scl,rcl,kr,csa,cas,csp,cap,
     &cal,fms,fmr,ft,srespm,lchm,year,yr0,yrf,speedc)
        CALL FLOWS(c0,c,t0,t1,fl,slc,rlc,scl,rcl,fms,fmr,csa,csp,cas,
     &cap)
        CALL NDYN(n0,n,minn,t0,t1,fl,c,flow1,flow2,ts,
     &ml,al,scn,nfix,cal,nci,site)

        IF (srespm.lt.0.0) THEN
          WRITE(*,*) 'Error: soil respiration negative'
          WRITE(*,'(8f8.0)') c0
        ENDIF

      ELSE
        DO ij=1,8
          c(ij) = c0(ij)
          n(ij) = n0(ij)
        ENDDO
        soiln = soiln + minn(3)

        c(1) = c(1) + (1.0d0 - fms)*slc/12.0d0
        c(2) = c(2) + (1.0d0 - fmr)*rlc/12.0d0
        c(5) = c(5) + fms*slc/12.0d0
        c(6) = c(6) + fmr*rlc/12.0d0

        srespm = 0.0d0
        lchm = 0.0d0

      ENDIF

      soilc = 0.0d0
      soiln = 0.0d0
      DO ij=1,8
        soilc = soilc + c(ij)
        soiln = soiln + n(ij)
        c0(ij) = c(ij)
        n0(ij) = n(ij)
      ENDDO
      soiln = soiln + minn(3)

*      CALL SOILCLOSS(c0,soilcl,scl,kr,rcl,ft,cal)

      RETURN
      END


c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine checkfrus(nclu,nsurf,pp,pem,dvec,frusflag,tu_maxt)

c Used for the FSTU method.
c At every step, check to see of a hop would be energetically allowed
c to all other states.  If a hop is allowed to state K, set FRUSFLAG(K) = 0.
c Otherwise, FRUSFLAG(K) = 1.

      implicit none
      include 'param.f'
      include 'c_sys.f'

      integer nclu,frusflag(mnsurf)
      integer nsurf

      integer is,i,j
      double precision pem(mnsurf),gpem(3,mnat,mnsurf),
     & dvec(3,mnat,mnsurf,mnsurf),pp(3,mnat),
     & sectrm,a,b,a2,ab,radi,scr,deltae,tu_maxt(mnsurf),
     & talongd

c check for forbidden hops
      do is = 1,nsurft
       if (is.ne.nsurf) then
        deltae = pem(is) - pem(nsurf)
        a=0.0d0
        b=0.0d0
        do i=1,3
        do j=1,nclu
         scr=dvec(i,j,nsurf,is)/mm(j)
c        a = momentum.dot.dvec/mass
c        b = dvec.dot.dvec/mass
         a=a+scr*pp(i,j)
         b=b+scr*dvec(i,j,nsurf,is)
        enddo
        enddo
        a2=a*a
        ab=a/b
c       sectrm = deltae/kinetic energy along d
        if (b.gt.0.d0) then
c       DVEC is nonzero
        sectrm = 2.0d0*deltae*b/a2
        talongd = a2/b/2.d0 ! kinetic energy along d
        tu_maxt(is) = 0.5d0/(deltae - talongd)
        radi = 1.0d0-sectrm
        else
c       DVEC is zero, mark as frustrated
        radi = -1.d0
        tu_maxt(is) = 0.d0
        endif
c       if radi > 0 then delta > kinetic energy along d, so we can hop
c       note that for a hop down, sectrm is negative, so we can always hop
        if(radi.ge.0.0d0) then
c        successful hop
         frusflag(is) = 0
        else
c        frustrated hop
         frusflag(is) = 1
        endif
       else
        frusflag(is) = 0
       endif
      enddo

      return
      end


      SUBROUTINE LWP_SET_BRNG
     &          (tlat,tlon,bflag,op_lat,op_lon,brsltn,
     &           mxpath,nrpath,brng,rng,
     &           rxlat,rxlon,rxrho,rng_mx)

c     Returns a list of bearings for paths which span an operating area

c     tlat          transmitter latitude  in deg N
c     tlon          transmitter longitude in deg W
c     bflag         determines how the bearings are set
c     brsltn        bearing angle resolution in deg
c     brng          output list of bearing angles in deg
c     rng           output list of maximum ranges in km

c     mxpath        maximum number of bearings allowed
c     nrpath                number of bearings generated
c     rxlat         latitude  of receivers
c     rxlon         longitude of receivers
c     rxrho         range     to receivers in km
c     rng_mx        maximum range in km

      character*200 error_msg
      logical       flag
      integer       bflag

      dimension     op_lat(2),op_lon(2),brng(mxpath),rng(mxpath),
     &              rxlat(mxpath),rxlon(mxpath),rxrho(mxpath),
     &              brsltn(2),rbear(3),rhom(2),glat(2,24),glon(2,24)

c     Boundaries of low conductivity areas
      data      glat/  75.5,  82.5,    68.5,  75.5,    61.0,  68.5,
     &                 61.0,  68.5,    56.0,  61.0,    51.0,  61.0,
     &                 51.0,  52.5,    33.5,  36.0,    77.5,  80.0,
     &                 74.5,  77.0,    70.5,  74.5,    65.5,  69.5,
     &                 60.5,  65.5,    63.0,  70.5,    64.5,  68.0,
     &                 48.0,  59.5,    50.5,  59.5,   -18.5, -15.5,
     &                -26.0, -21.0,   -33.0, -26.0,   -72.5, -66.0,
     &                -90.0, -72.5,   -90.0, -67.5,   -90.0, -77.5/,
     &          glon/  96.0,  20.0,   123.5,  20.0,   118.0,  62.0,
     &                 52.0,  37.0,   111.0,  96.0,    78.0,  57.5,
     &                119.0, 116.5,    85.5,  80.0,   -13.0, -23.0,
     &                -58.0, -67.5,   -54.0, -57.0,   -64.0, -67.5,
     &                -58.5, -60.5,   -90.0,-120.0,  -165.5, 172.0,
     &                -90.0,-120.0,  -120.0,-137.0,    71.5,  68.0,
     &                 68.5,  66.5,    70.0,  68.5,    74.0,  60.0,
     &                150.0,  30.0,    30.0,-160.0,  -160.0, 150.0/,
     &          dtr/.01745329252/

      if (bflag .eq. 0) then

c        Bearings and ranges based on op area

c        Get initial bearing angles using parameters of the op area and
c        the fine bearing angle resolution
         rbear(3)=brsltn(2)
         call LWP_GET_BRNG (tlat,tlon,op_lat,op_lon,rbear,rhom)
         rng_mx=AMIN1(20000.,rhom(2))

c        Set up list of bearings and ranges to the edge of the op area
c        using the coarse bearing resolution
         brngmn=AINT(rbear(1)/brsltn(1)   )*brsltn(1)
         brngmx=AINT(rbear(2)/brsltn(1)+.9)*brsltn(1)
         if (brngmn .eq.   0. .and.
     &       brngmx .eq. 360.) brngmx=brngmx-brsltn(1)
         nrpath=0
         do br=brngmn,brngmx,brsltn(1)

            nrpath=nrpath+1
            brng(nrpath)=br
            call LWP_TO_EDGE
     &          (tlat,tlon,op_lat,op_lon,br,rng(nrpath))
         end do

c        Re-define first and last bearing angles, as required,
c        using the fine bearing angle resolution
         brng(  1  )=rbear(1)
         call LWP_TO_EDGE
     &       (tlat,tlon,op_lat,op_lon,brng(  1  ),rng(  1  ))

         if (brng(nrpath) .ne. 360.) then
c           Adjust the last bearing
            brng(nrpath)=rbear(2)
            call LWP_TO_EDGE
     &          (tlat,tlon,op_lat,op_lon,brng(nrpath),rng(nrpath))
         end if

c        Verify that angles start with values less than 360
         if (brng(1) .ge. 360.) then
            do j=1,nrpath
               brng(j)=brng(j)-360.
            end do
         end if

c        Some ranges may be zero because the paths just miss the
c        op area; adjust these paths to have the length of the
c        nearest path with finite length
         jm=0
         do while (jm .lt. nrpath .and. rng(jm+1) .eq. 0.)
            jm=jm+1
         end do
         if (jm .lt. nrpath) then

            do j=1,jm
               rng(j)=rng(jm+1)
            end do

            jm=nrpath+1
            do while (jm .gt. 1 .and. rng(jm-1) .eq. 0.)
               jm=jm-1
            end do

            if (jm .gt. 1) then
               do j=nrpath,jm,-1
                  rng(j)=rng(jm-1)
               end do
            end if
         else

            do j=1,nrpath
               rng(j)=rng_mx
            end do
         end if

c        Additional bearing angles needed to cover low
c        conductivity areas
         brngmn=brng(  1  )
         brngmx=brng(nrpath)
         rbear(3)=brsltn(2)
         do i=1,24

c           Get range of bearings which span the low conductivity area
            call LWP_GET_BRNG
     &          (tlat,tlon,glat(1,i),glon(1,i),rbear,rhom)

            brmin=rbear(1)
            brmax=rbear(2)
            br=brmin
            do while (br .le. brmax)
               b=amod(br,360.)
               if (brngmx .le. 360. .and.
     &            (b .gt. brngmn .and. b .lt. brngmx) .or.
     &             brngmx .gt. 360. .and.
     &            (b .gt. brngmn .or.  b .lt. brngmx-360.)) then

c                 Look for this bearing in the current list of bearings
                  flag=.true.
                  j=1
                  do while (flag .and. j .le. nrpath)
                     if (ABS(b-amod(brng(j),360.)) .lt. .5*brsltn(2))
     &                  flag=.false.
                     j=j+1
                  end do
                  if (flag) then ! another bearing may be required
                     if (brngmx .gt. 360. .and. b .lt. brngmn) b=b+360.

c                    Get the range to the edge of the op area
                     call LWP_TO_EDGE
     &                   (tlat,tlon,op_lat,op_lon,b,range)

                     if (rhom(1) .lt. range+1000.) then
c                       Add this bearing because the low conductivity
c                       area is within 1000 km of the op area
                        if (nrpath .eq. mxpath) then

                           write(error_msg,
     &                         '(''[LWP_SET_BRNG]: '',
     &                           ''Too many bearings'')')
                           call LWPC_ERROR ('ERROR',error_msg)

                        else

c                          Insert the new bearing into the list
                           if (b .lt. brng(nrpath)) then
                              j=1
                              do while (b .gt. brng(j))
                                 j=j+1
                              end do
                              do k=nrpath+1,j+1,-1
                                 brng(k)=brng(k-1)
                                 rng(k)=rng(k-1)
                              end do
                           else
                              j=nrpath+1
                           end if
                           nrpath=nrpath+1
                           brng(j)=b
                           rng(j)=range
                        end if
                     end if
                  end if
               end if
               br=br+brsltn(2)
            end do
         end do

c        Re-define ranges to the edge of the op area
         do nb=1,nrpath
            call LWP_TO_EDGE
     &          (tlat,tlon,op_lat,op_lon,brng(nb),rng(nb))
         end do

c        Some ranges may be zero because the paths just miss the op
c        area; adjust these paths to have the length of the nearest
c        path with finite length
         jm=0
         do while (jm .lt. nrpath .and. rng(jm+1) .eq. 0.)
            jm=jm+1
         end do
         if (jm .lt. nrpath) then

            do j=1,jm
               rng(j)=rng(jm+1)
            end do

            jm=nrpath+1
            do while (jm .gt. 1 .and. rng(jm-1) .eq. 0.)
               jm=jm-1
            end do

            if (jm .gt. 1) then
               do j=nrpath,jm,-1
                  rng(j)=rng(jm-1)
               end do
            end if
         else

            do j=1,nrpath
               rng(j)=rng_mx
            end do
         end if

c        Finally, adjust the ranges so that paths are at least as long
c        as the longest adjacent one.  First, find the longest path.
         j0=1
         rngmax=rng(1)
         do j=2,nrpath
            if (rngmax .lt. rng(j)) then
               j0=j
               rngmax=rng(j)
            end if
         end do

         if (j0 .eq. 1) then

c           The longest path is the first one
c           Start at J0 and go around to the last path
            if (ABS(brng(nrpath)-brng(1)) .le. brsltn(1)+brsltn(2)) then
               rjm1=rng(nrpath)
            else
               rjm1=0.
            end if
            do j=1,nrpath-1
               rj=rng(j)
               rjp1=rng(j+1)
               if (rng(j) .lt. AMAX1(rjm1,rj,rjp1))
     &             rng(j)=AMAX1(rjm1,rj,rjp1)
               rjm1=rj
            end do
            rj=rng(nrpath)
            if (ABS(brng(nrpath)-brng(1)) .le. brsltn(1)+brsltn(2)) then
               rjp1=rng(1)
            else
               rjp1=0.
            end if
            rng(nrpath)=AMAX1(rjm1,rj,rjp1)

         else
     &   if (j0 .eq. nrpath) then

c           The longest path is the last one
c           Start at J0 and go around to the first path
            if (ABS(brng(nrpath)-brng(1)) .le. brsltn(1)+brsltn(2)) then
               rjp1=rng(1)
            else
               rjp1=0.
            end if
            do j=nrpath,2,-1
               rj=rng(j)
               rjm1=rng(j-1)
               if (rng(j) .lt. AMAX1(rjm1,rj,rjp1))
     &             rng(j)=AMAX1(rjm1,rj,rjp1)
               rjp1=rj
            end do
            rj=rng(1)
            if (ABS(brng(nrpath)-brng(1)) .le. brsltn(1)+brsltn(2)) then
               rjm1=rng(nrpath)
            else
               rjm1=0.
            end if
            rng(1)=AMAX1(rjm1,rj,rjp1)
         else

c           The longest path is an intermediate one
c           First, start at J0 and go around to the last path
            rjm1=rng(j0-1)
            do j=j0,nrpath-1
               rj=rng(j)
               rjp1=rng(j+1)
               if (rng(j) .lt. AMAX1(rjm1,rj,rjp1))
     &             rng(j)=AMAX1(rjm1,rj,rjp1)
               rjm1=rj
            end do
            rj=rng(nrpath)
            if (ABS(brng(nrpath)-brng(1)) .le. brsltn(1)+brsltn(2)) then
               rjp1=rng(1)
            else
               rjp1=0.
            end if
            rng(nrpath)=AMAX1(rjm1,rj,rjp1)
c           Now, start at J0 and go around to the first path
            rjp1=rng(j0+1)
            do j=j0,2,-1
               rj=rng(j)
               rjm1=rng(j-1)
               if (rng(j) .lt. AMAX1(rjm1,rj,rjp1))
     &             rng(j)=AMAX1(rjm1,rj,rjp1)
               rjp1=rj
            end do
            rj=rng(1)
            if (ABS(brng(nrpath)-brng(1)) .le. brsltn(1)+brsltn(2)) then
               rjm1=rng(nrpath)
            else
               rjm1=0.
            end if
            rng(1)=AMAX1(rjm1,rj,rjp1)
         end if

         if (brng(nrpath) .eq. 360.) then
c           This is a 0 to 360 fan of bearings;
c           drop the one at 360 since it is redundant
            nrpath=nrpath-1
         end if
      else
     &if (bflag .eq. 1) then

c        User specified bearings
         do j=1,nrpath
            rng(j)=rng_mx
         end do
      else
     &if (bflag .eq. 2) then

c        Bearings based on list of receivers
         do j=1,nrpath

            call GCDBR
     &          ((tlon-rxlon(j))*dtr,(90.-tlat)*dtr,(90.-rxlat(j))*dtr,
     &           r,b,0)
            rxrho(j)=r*6366.197
            brng(j)=b/dtr
            rng(j)=rng_mx
         end do
      else

         write(error_msg,
     &       '(''[LWP_SET_BRNG]: '',
     &         ''Invalid value for BFLAG: '',i3)') bflag
         call LWPC_ERROR ('ERROR',error_msg)
      end if

c     Now make sure that the bearings are in the range 0 to 360
      if (nrpath .gt. 1) then
         do j=1,nrpath
            if (brng(j) .ge. 360.) brng(j)=brng(j)-360.
         end do
      end if

      RETURN
      END      ! LWP_SET_BRNG


C$Procedure GFSUBC (GF, subpoint vector coordinate search )

      SUBROUTINE GFSUBC (  TARGET, FIXREF, METHOD,
     .                     ABCORR, OBSRVR, CRDSYS,
     .                     COORD,  RELATE, REFVAL,
     .                     ADJUST, STEP,   CNFINE,
     .                     MW,     NW,     WORK,   RESULT )

C$ Abstract
C
C     Determine time intervals for which a coordinate of an
C     subpoint position vector satisfies a numerical constraint.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     GF
C     SPK
C     CK
C     TIME
C     WINDOWS
C
C$ Keywords
C
C     COORDINATE
C     GEOMETRY
C     SEARCH
C     EVENT
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'gf.inc'
      INCLUDE               'zzgf.inc'
      INCLUDE               'zzabcorr.inc'
      INCLUDE               'zzholdd.inc'

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      CHARACTER*(*)         TARGET
      CHARACTER*(*)         FIXREF
      CHARACTER*(*)         METHOD
      CHARACTER*(*)         ABCORR
      CHARACTER*(*)         OBSRVR
      CHARACTER*(*)         CRDSYS
      CHARACTER*(*)         COORD
      CHARACTER*(*)         RELATE
      DOUBLE PRECISION      REFVAL
      DOUBLE PRECISION      ADJUST
      DOUBLE PRECISION      STEP
      DOUBLE PRECISION      CNFINE ( LBCELL : * )
      INTEGER               MW
      INTEGER               NW
      DOUBLE PRECISION      WORK   ( LBCELL : MW, NW )
      DOUBLE PRECISION      RESULT ( LBCELL : * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     LBCELL     P   SPICE Cell lower bound
C     CNVTOL     P   Convergence tolerance
C     TARGET     I   Name of the target body
C     FIXREF     I   Body fixed frame associated with TARGET
C     METHOD     I   Name of method type for subpoint calculation
C     ABCORR     I   Aberration correction flag
C     OBSRVR     I   Name of the observing body
C     CRDSYS     I   Name of the coordinate system containing COORD
C     COORD      I   Name of the coordinate of interest
C     RELATE     I   Relational operator
C     REFVAL     I   Reference value
C     ADJUST     I   Adjustment value for absolute extrema searches
C     STEP       I   Step size used for locating extrema and roots
C     CNFINE     I   SPICE window to which the search is confined
C     MW         I   Workspace window size
C     NW         I   The number of workspace windows needed for
C                    the search
C     WORK      I-O  Array of workspace windows
C     RESULT    I-O  SPICE window containing results
C
C$ Detailed_Input
C
C     TARGET   the string name of a target body.  Optionally, you may
C              supply the integer ID code for the object as an
C              integer string.  For example both 'MOON' and '301'
C              are legitimate strings that indicate the moon is the
C              target body.
C
C              The target and observer define a position vector
C              that points from the observer to the target.
C
C     FIXREF   the string name of the body-fixed, body-centered
C              reference frame associated with the target body TARGET.
C
C              The SPICE frame subsystem must recognize the 'fixref'
C              name.
C
C     METHOD   the string name of the method to use for the subpoint
C              calculation. The accepted values for METHOD:
C
C                 'Near point: ellipsoid'   The sub-observer point
C                                           computation uses a
C                                           triaxial ellipsoid to
C                                           model the surface of the
C                                           target body. The
C                                           sub-observer point is
C                                           defined as the nearest
C                                           point on the target
C                                           relative to the
C                                           observer.
C
C                 'Intercept: ellipsoid'    The sub-observer point
C                                           computation uses a
C                                           triaxial ellipsoid to
C                                           model the surface of the
C                                           target body. The
C                                           sub-observer point is
C                                           defined as the target
C                                           surface intercept of the
C                                           line containing the
C                                           observer and the
C                                           target's center.
C
C              The METHOD string lacks sensitivity to case, embedded,
C              leading and trailing blanks.
C
C     ABCORR   the string description of the aberration corrections to
C              apply to the state evaluations to account for one-way
C              light time and stellar aberration.
C
C              Any aberration correction accepted by the SPICE
C              routine SPKEZR is accepted here. See the header
C              of SPKEZR for a detailed description of the
C              aberration correction options. For convenience,
C              the options are listed below:
C
C                 'NONE'     Apply no correction. Returns the "true"
C                            geometric state.
C
C                 'LT'       "Reception" case:  correct for
C                            one-way light time using a Newtonian
C                            formulation.
C
C                 'LT+S'     "Reception" case:  correct for
C                            one-way light time and stellar
C                            aberration using a Newtonian
C                            formulation.
C
C                 'CN'       "Reception" case:  converged
C                            Newtonian light time correction.
C
C                'CN+S'     "Reception" case:  converged
C                            Newtonian light time and stellar
C                            aberration corrections.
C
C                 'XLT'      "Transmission" case:  correct for
C                            one-way light time using a Newtonian
C                            formulation.
C
C                 'XLT+S'    "Transmission" case:  correct for
C                            one-way light time and stellar
C                            aberration using a Newtonian
C                            formulation.
C
C                 'XCN'      "Transmission" case:  converged
C                            Newtonian light time correction.
C
C                 'XCN+S'    "Transmission" case:  converged
C                            Newtonian light time and stellar
C                            aberration corrections.
C
C              The ABCORR string lacks sensitivity to case, leading
C              and trailing blanks.
C
C     OBSRVR   the string name of an observing body.  Optionally, you
C              may supply the ID code of the object as an integer
C              string. For example, both 'EARTH' and '399' are
C              legitimate strings to indicate the observer as Earth.
C
C     CRDSYS   the string name of the coordinate system for which the
C              coordinate of interest is a member
C
C     COORD    the string name of the coordinate of interest in CRDSYS
C
C              The supported coordinate systems and coordinate names:
C
C          Coordinate System (CRDSYS)   Coordinates (COORD)  Range
C
C          'RECTANGULAR'              'X'
C                                     'Y'
C                                     'Z'
C
C          'LATITUDINAL'              'RADIUS'
C                                     'LONGITUDE'        (-Pi,Pi]
C                                     'LATITUDE'         [-Pi/2,Pi/2]
C
C          'RA/DEC'                   'RANGE'
C                                     'RIGHT ASCENSION'  [0,2Pi)
C                                     'DECLINATION'      [-Pi/2,Pi/2]
C
C          'SPHERICAL'                'RADIUS'
C                                     'COLATITUDE'       [0,Pi]
C                                     'LONGITUDE'        (-Pi,Pi]
C
C          'CYLINDRICAL'              'RADIUS'
C                                     'LONGITUDE'        [0,2Pi)
C                                     'Z'
C
C          'GEODETIC'                 'LONGITUDE'        (-Pi,Pi]
C                                     'LATITUDE'         [-Pi/2,Pi/2]
C                                     'ALTITUDE'
C
C          'PLANETOGRAPHIC'           'LONGITUDE'        [0,2Pi)
C                                     'LATITUDE'         [-Pi/2,Pi/2]
C                                     'ALTITUDE'
C
C                 The ALTITUDE coordinates have a constant value
C                 of zero +/- roundoff for ellipsoid targets.
C
C                 Limit searches for coordinate events in the GEODETIC
C                 and PLANETOGRAPHIC coordinate systems to TARGET bodies
C                 with axial symmetry in the equatorial plane, i.e.
C                 equality of the body X and Y radii (oblate or prolate
C                 spheroids).
C
C     RELATE   the string or character describing the relational
C              operator used to define a constraint on the selected
C              coordinate of the subpoint vector. The result
C              window found by this routine indicates the time intervals
C              where the constraint is satisfied. Supported values of
C              RELATE and corresponding meanings are shown below:
C
C                 '>'       The coordinate value is greater than the
C                           reference value REFVAL.
C
C                 '='       The coordinate value is equal to the
C                           reference value REFVAL.
C
C                 '<'       The coordinate value is less than the
C                           reference value REFVAL.
C
C                 'ABSMAX'  The coordinate value is at an absolute
C                           maximum.
C
C                 'ABSMIN'  The coordinate value is at an absolute
C                           minimum.
C
C                 'LOCMAX'  The coordinate value is at a local
C                           maximum.
C
C                 'LOCMIN'  The coordinate value is at a local
C                           minimum.
C              The caller may indicate that the region of interest
C              is the set of time intervals where the quantity is
C              within a specified measure of an absolute extremum.
C              The argument ADJUST (described below) is used to
C              specify this measure.
C
C              Local extrema are considered to exist only in the
C              interiors of the intervals comprising the confinement
C              window:  a local extremum cannot exist at a boundary
C              point of the confinement window.
C
C              The RELATE string lacks sensitivity to case, leading
C              and trailing blanks.
C
C     REFVAL   the double precision reference value used together with
C              the argument RELATE to define an equality or inequality
C              to satisfy by the selected coordinate of the subpoint
C              vector. See the discussion of RELATE above for
C              further information.
C
C               The units of REFVAL correspond to the type as defined
C               by COORD, radians for angular measures, kilometers for
C               distance measures.
C
C     ADJUST   a double precision value used to modify searches for
C              absolute extrema: when RELATE is set to ABSMAX or ABSMIN
C              and ADJUST is set to a positive value, GFSUBC finds
C              times when the subpoint position vector coordinate is
C              within ADJUST radians/kilometers of the specified
C              extreme value.
C
C              For RELATE set to ABSMAX, the RESULT window contains
C              time intervals when the position vector coordinate has
C              values between ABSMAX - ADJUST and ABSMAX.
C
C              For RELATE set to ABSMIN, the RESULT window contains
C              time intervals when the position vector coordinate has
C              values between ABSMIN and ABSMIN + ADJUST.
C
C              ADJUST is not used for searches for local extrema,
C              equality or inequality conditions.
C
C     STEP     the double precision time step size to use in the search.
C
C              STEP must be short enough to for a search using this step
C              size to locate the time intervals where coordinate
C              function of the subpoint vector is monotone increasing or
C              decreasing. However, STEP must not be *too* short, or
C              the search will take an unreasonable amount of time.
C
C              For coordinates other than LONGITUDE and RIGHT ASCENSION,
C              the step size must be shorter than the shortest interval,
C              within the confinement window, over which the coordinate
C              is monotone increasing or decreasing.
C
C              For LONGITUDE and RIGHT ASCENSION, the step size must
C              be shorter than the shortest interval, within the
C              confinement window, over which either the sin or cos
C              of the coordinate is monotone increasing or decreasing.
C
C              The choice of STEP affects the completeness but not
C              the precision of solutions found by this routine; the
C              precision is controlled by the convergence tolerance.
C              See the discussion of the parameter CNVTOL for
C              details.
C
C              STEP has units of TDB seconds.
C
C     CNFINE   a double precision SPICE window that confines the time
C              period over which the specified search is conducted.
C              CNFINE may consist of a single interval or a collection
C              of intervals.
C
C              In some cases the confinement window can be used to
C              greatly reduce the time period that must be searched
C              for the desired solution. See the Particulars section
C              below for further discussion.
C
C              See the Examples section below for a code example
C              that shows how to create a confinement window.
C
C              CNFINE must be initialized by the caller using the
C              SPICELIB routine SSIZED.
C
C     MW       is a parameter specifying the length of the SPICE
C              windows in the workspace array WORK (see description
C              below) used by this routine.
C
C              MW should be set to a number at least twice as large
C              as the maximum number of intervals required by any
C              workspace window. In many cases, it's not necessary to
C              compute an accurate estimate of how many intervals are
C              needed; rather, the user can pick a size considerably
C              larger than what's really required.
C
C              However, since excessively large arrays can prevent
C              applications from compiling, linking, or running
C              properly, sometimes MW must be set according to
C              the actual workspace requirement. A rule of thumb
C              for the number of intervals NINTVLS needed is
C
C                  NINTVLS  =  2*N  +  ( M / STEP )
C
C              where
C
C                  N     is the number of intervals in the confinement
C                        window
C
C                  M     is the measure of the confinement window, in
C                        units of seconds
C
C                  STEP  is the search step size in seconds
C
C              MW should then be set to
C
C                  2 * NINTVLS
C
C     NW       is a parameter specifying the number of SPICE windows
C              in the workspace array WORK (see description below)
C              used by this routine. NW should be set to the
C              parameter NWMAX; this parameter is declared in the
C              include file gf.inc. (The reason this dimension is
C              an input argument is that this allows run-time
C              error checking to be performed.)
C
C     WORK     is an array used to store workspace windows. This
C              array should be declared by the caller as shown:
C
C                 INCLUDE 'gf.inc'
C                    ...
C
C                 DOUBLE PRECISION    WORK ( LBCELL : MW, NWMAX )
C
C              where MW is a constant declared by the caller and
C              NWMAX is a constant defined in the SPICELIB INCLUDE
C              file gf.inc. See the discussion of MW above.
C
C              WORK need not be initialized by the caller.

C
C     RESULT   a double precision SPICE window which will contain the
C              search results. RESULT must be initialized using
C              a call to SSIZED. RESULT must be declared and initialized
C              with sufficient size to capture the full set of time
C              intervals  within the search region on which the
C              specified constraint is satisfied.
C
C              If RESULT is non-empty on input, its contents
C              will be discarded before GFSUBC conducts its
C              search.
C
C$ Detailed_Output
C
C     WORK     the input workspace array, modified by this
C              routine. The caller should re-initialize this array
C              before attempting to use it for any other purpose.
C
C     RESULT   the SPICE window of intervals, contained within the
C              confinement window CNFINE, on which the specified
C              constraint is satisfied.
C
C              If the search is for local extrema, or for absolute
C              extrema with ADJUST set to zero, then normally each
C              interval of RESULT will be a singleton: the left and
C              right endpoints of each interval will be identical.
C
C              If no times within the confinement window satisfy the
C              constraint, RESULT will be returned with a
C              cardinality of zero.
C
C$ Parameters
C
C     LBCELL   the integer value defining the lower bound for
C              SPICE Cell arrays (a SPICE window is a kind of cell).
C
C     CNVTOL   is the convergence tolerance used for finding
C              endpoints of the intervals comprising the result
C              window. CNVTOL is also used for finding intermediate
C              results; in particular, CNVTOL is used for finding the
C              windows on which the specified coordinate is increasing
C              or decreasing. CNVTOL is used to determine when binary
C              searches for roots should terminate: when a root is
C              bracketed within an interval of length CNVTOL; the
C              root is considered to have been found.
C
C              The accuracy, as opposed to precision, of roots found
C              by this routine depends on the accuracy of the input
C              data. In most cases, the accuracy of solutions will be
C              inferior to their precision.
C
C     See INCLUDE file gf.inc for declarations and descriptions of
C     parameters used throughout the GF system.
C
C$ Exceptions
C
C     1)  In order for this routine to produce correct results,
C         the step size must be appropriate for the problem at hand.
C         Step sizes that are too large may cause this routine to miss
C         roots; step sizes that are too small may cause this routine
C         to run unacceptably slowly and in some cases, find spurious
C         roots.
C
C         This routine does not diagnose invalid step sizes, except
C         that if the step size is non-positive, an error is signaled
C         by a routine in the call tree of this routine.
C
C     2)  Due to numerical errors, in particular,
C
C            - truncation error in time values
C            - finite tolerance value
C            - errors in computed geometric quantities
C
C         it is *normal* for the condition of interest to not always be
C         satisfied near the endpoints of the intervals comprising the
C         RESULT window. One technique to handle such a situation,
C         slightly contract RESULT using the window routine WNCOND.
C
C     3)  If the window size MW is less than 2 or not an even value,
C         the error SPICE(INVALIDDIMENSION) will signal.
C
C     4)  If the window size of RESULT is less than 2, the error
C         SPICE(INVALIDDIMENSION) will signal.
C
C     5)  If an error (typically cell overflow) occurs during
C         window arithmetic, the error will be diagnosed by a routine
C         in the call tree of this routine.
C
C     6)  If the relational operator RELATE is not recognized, an
C         error is signaled by a routine in the call tree of this
C         routine.
C
C     7)  If the size of the workspace is too small, an error is
C         signaled by a routine in the call tree of this routine.
C
C     8)  If ADJUST is negative, an error is signaled by a routine in
C         the call tree of this routine.
C
C     9)  If either of the input body names do not map to NAIF ID
C         codes, an error is signaled by a routine in the call tree of
C         this routine.
C
C     10) If required ephemerides or other kernel data are not
C         available, an error is signaled by a routine in the call tree
C         of this routine.
C
C     11) If a body has unequal equatorial radii, a search for
C         coordinate events in the GEODETIC or PLANETOGRAPHIC
C         coordinate systems will cause the SPICE(NOTSUPPORTED) error
C         to signal.
C
C$ Files
C
C     Appropriate SPK and PCK kernels must be loaded by the calling
C     program before this routine is called.
C
C     The following data are required:
C
C        - SPK data: the calling application must load ephemeris data
C          for the targets, observer, and any intermediate objects in
C          a chain connecting the targets and observer that cover the
C          time period specified by the window CNFINE. If aberration
C          corrections are used, the states of target and observer
C          relative to the solar system barycenter must be calculable
C          from the available ephemeris data. Typically ephemeris data
C          are made available by loading one or more SPK files using
C          FURNSH.
C
C        - If non-inertial reference frames are used, then PCK
C          files, frame kernels, C-kernels, and SCLK kernels may be
C          needed.
C
C     Such kernel data are normally loaded once per program run, NOT
C     every time this routine is called.
C
C$ Particulars
C
C     This routine provides a simpler, but less flexible interface
C     than does the routine GFEVNT for conducting searches for
C     subpoint position vector coordinate value events.
C     Applications that require support for progress reporting,
C     interrupt handling, non-default step or refinement functions, or
C     non-default convergence tolerance should call GFEVNT rather than
C     this routine.
C
C     This routine determines a set of one or more time intervals
C     within the confinement window when the selected coordinate of
C     the subpoint position vector satisfies a caller-specified
C     constraint. The resulting set of intervals is returned as a SPICE
C     window.
C
C     Below we discuss in greater detail aspects of this routine's
C     solution process that are relevant to correct and efficient
C     use of this routine in user applications.
C
C
C     The Search Process
C     ==================
C
C     Regardless of the type of constraint selected by the caller, this
C     routine starts the search for solutions by determining the time
C     periods, within the confinement window, over which the specified
C     coordinate function is monotone increasing and monotone
C     decreasing. Each of these time periods is represented by a SPICE
C     window. Having found these windows, all of the coordinate
C     function's local extrema within the confinement window are known.
C     Absolute extrema then can be found very easily.
C
C     Within any interval of these "monotone" windows, there will be at
C     most one solution of any equality constraint. Since the boundary
C     of the solution set for any inequality constraint is contained in
C     the union of
C
C        - the set of points where an equality constraint is met
C        - the boundary points of the confinement window
C
C     the solutions of both equality and inequality constraints can be
C     found easily once the monotone windows have been found.
C
C
C     Step Size
C     =========
C
C     The monotone windows (described above) are found using a two-step
C     search process. Each interval of the confinement window is
C     searched as follows: first, the input step size is used to
C     determine the time separation at which the sign of the rate of
C     change of coordinate will be sampled. Starting at
C     the left endpoint of an interval, samples will be taken at each
C     step. If a change of sign is found, a root has been bracketed; at
C     that point, the time at which the time derivative of the
C     coordinate is zero can be found by a refinement process, for
C     example, using a binary search.
C
C     Note that the optimal choice of step size depends on the lengths
C     of the intervals over which the coordinate function is monotone:
C     the step size should be shorter than the shortest of these
C     intervals (within the confinement window).
C
C     The optimal step size is *not* necessarily related to the lengths
C     of the intervals comprising the result window. For example, if
C     the shortest monotone interval has length 10 days, and if the
C     shortest result window interval has length 5 minutes, a step size
C     of 9.9 days is still adequate to find all of the intervals in the
C     result window. In situations like this, the technique of using
C     monotone windows yields a dramatic efficiency improvement over a
C     state-based search that simply tests at each step whether the
C     specified constraint is satisfied. The latter type of search can
C     miss solution intervals if the step size is longer than the
C     shortest solution interval.
C
C     Having some knowledge of the relative geometry of the target and
C     observer can be a valuable aid in picking a reasonable step size.
C     In general, the user can compensate for lack of such knowledge by
C     picking a very short step size; the cost is increased computation
C     time.
C
C     Note that the step size is not related to the precision with which
C     the endpoints of the intervals of the result window are computed.
C     That precision level is controlled by the convergence tolerance.
C
C
C     Convergence Tolerance
C     =====================
C
C     As described above, the root-finding process used by this routine
C     involves first bracketing roots and then using a search process
C     to locate them. "Roots" are both times when local extrema are
C     attained and times when the coordinate function is equal to a
C     reference value. All endpoints of the intervals comprising the
C     result window are either endpoints of intervals of the
C     confinement window or roots.
C
C     Once a root has been bracketed, a refinement process is used to
C     narrow down the time interval within which the root must lie.
C     This refinement process terminates when the location of the root
C     has been determined to within an error margin called the
C     "convergence tolerance." The default convergence tolerance
C     used by this routine is set by the parameter CNVTOL (defined
C     in gf.inc).
C
C     The value of CNVTOL is set to a "tight" value so that the
C     tolerance doesn't become the limiting factor in the accuracy of
C     solutions found by this routine. In general the accuracy of input
C     data will be the limiting factor.
C
C     The user may change the convergence tolerance from the default
C     CNVTOL value by calling the routine GFSTOL, e.g.
C
C        CALL GFSTOL( tolerance value )
C
C     Call GFSTOL prior to calling this routine. All subsequent
C     searches will use the updated tolerance value.
C
C     Setting the tolerance tighter than CNVTOL is unlikely to be
C     useful, since the results are unlikely to be more accurate.
C     Making the tolerance looser will speed up searches somewhat,
C     since a few convergence steps will be omitted. However, in most
C     cases, the step size is likely to have a much greater effect
C     on processing time than would the convergence tolerance.
C
C
C     The Confinement Window
C     ======================
C
C     The simplest use of the confinement window is to specify a time
C     interval within which a solution is sought. However, the
C     confinement window can, in some cases, be used to make searches
C     more efficient. Sometimes it's possible to do an efficient search
C     to reduce the size of the time period over which a relatively
C     slow search of interest must be performed.
C
C     Practical use of the coordinate search capability would likely
C     consist of searches over multiple coordinate constraints to find
C     time intervals that satisfies the constraints. An
C     effective technique to accomplish such a search is
C     to use the result window from one search as the confinement window
C     of the next.
C
C     Longitude and Right Ascension
C     =============================
C
C     The cyclic nature of the longitude and right ascension coordinates
C     produces branch cuts at +/- 180 degrees longitude and 0-360
C     longitude. Round-off error may cause solutions near these branches
C     to cross the branch. Use of the SPICE routine WNCOND will contract
C     solution windows by some epsilon, reducing the measure of the
C     windows and eliminating the branch crossing. A one millisecond
C     contraction will in most cases eliminate numerical round-off
C     caused branch crossings.
C
C$ Examples
C
C     The numerical results shown for these examples may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     The examples shown below require a "standard" set of SPICE
C     kernels. We list these kernels in a meta kernel named
C     'standard.tm'.
C
C        KPL/MK
C
C           This meta-kernel is intended to support operation of SPICE
C           example programs. The kernels shown here should not be
C           assumed to contain adequate or correct versions of data
C           required by SPICE-based user applications.
C
C           In order for an application to use this meta-kernel, the
C           kernels referenced here must be present in the user's
C           current working directory.
C
C           The names and contents of the kernels referenced
C           by this meta-kernel are as follows:
C
C              File name                     Contents
C              ---------                     --------
C              de414.bsp                     Planetary ephemeris
C              pck00008.tpc                  Planet orientation and
C                                            radii
C              naif0008.tls                  Leapseconds
C
C
C           \begindata
C
C           KERNELS_TO_LOAD = ( '/kernels/gen/lsk/naif0008.tls'
C                               '/kernels/gen/spk/de414.bsp'
C                               '/kernels/gen/pck/pck00008.tpc'
C                             )
C
C      Example(1):
C
C      Find the time during 2007 for which the subpoint position vector
C      of the sun on earth in the IAU_EARTH frame lies within a geodetic
C      latitude-longitude "box" defined as
C
C         16 degrees <= latitude  <= 17 degrees
C         85 degrees <= longitude <= 86 degrees
C
C      This problem requires four searches, each search on one of the
C      box restrictions. The user needs also realize the temporal
C      behavior of latitude greatly differs from that of the longitude.
C      The sub-observer point latitude varies between approximately
C      23.44 degrees and -23.44 degrees during the year. The
C      sub-observer point longitude varies between -180 degrees and
C      180 degrees in one day.
C
C           PROGRAM GFSUBC_EX1
C           IMPLICIT              NONE
C
C     C
C     C     Include GF parameter declarations:
C     C
C           INCLUDE               'gf.inc'
C
C     C
C     C     SPICELIB functions
C     C
C           DOUBLE PRECISION      SPD
C           DOUBLE PRECISION      DPR
C           DOUBLE PRECISION      RPD
C           INTEGER               WNCARD
C
C     C
C     C     Local variables and initial parameters.
C     C
C           INTEGER               LBCELL
C           PARAMETER           ( LBCELL = -5 )
C
C     C
C     C     Create 50 windows.
C     C
C           INTEGER               MAXWIN
C           PARAMETER           ( MAXWIN = 1000 )
C
C     C
C     C     One window consists of two intervals.
C     C
C           INTEGER               NINTRVL
C           PARAMETER           ( NINTRVL = MAXWIN *2 )
C
C           INTEGER               STRLEN
C           PARAMETER           ( STRLEN = 40 )
C
C           CHARACTER*(STRLEN)    TIMFMT
C           CHARACTER*(STRLEN)    BEGSTR
C           CHARACTER*(STRLEN)    ENDSTR
C           CHARACTER*(STRLEN)    TARGET
C           CHARACTER*(STRLEN)    OBSRVR
C           CHARACTER*(STRLEN)    ABCORR
C           CHARACTER*(STRLEN)    METHOD
C           CHARACTER*(STRLEN)    FIXREF
C           CHARACTER*(STRLEN)    CRDSYS
C           CHARACTER*(STRLEN)    COORD
C           CHARACTER*(STRLEN)    RELATE
C
C           DOUBLE PRECISION      STEP
C           DOUBLE PRECISION      CNFINE  ( LBCELL : NINTRVL )
C           DOUBLE PRECISION      RESULT1 ( LBCELL : NINTRVL )
C           DOUBLE PRECISION      RESULT2 ( LBCELL : NINTRVL )
C           DOUBLE PRECISION      RESULT3 ( LBCELL : NINTRVL )
C           DOUBLE PRECISION      RESULT4 ( LBCELL : NINTRVL )
C           DOUBLE PRECISION      WORK    ( LBCELL : NINTRVL, NWMAX )
C           DOUBLE PRECISION      BEGTIM
C           DOUBLE PRECISION      ENDTIM
C           DOUBLE PRECISION      LEFT
C           DOUBLE PRECISION      RIGHT
C           DOUBLE PRECISION      REFVAL
C           DOUBLE PRECISION      ADJUST
C           DOUBLE PRECISION      RAD    ( 2 )
C           DOUBLE PRECISION      LON    ( 2 )
C           DOUBLE PRECISION      LAT    ( 2 )
C           DOUBLE PRECISION      TRGEPC
C           DOUBLE PRECISION      LPOS   ( 3 )
C           DOUBLE PRECISION      RPOS   ( 3 )
C           DOUBLE PRECISION      SRFVEC ( 3 )
C
C           INTEGER               COUNT
C           INTEGER               I
C
C     C
C     C     Load kernels.
C     C
C           CALL FURNSH ('/kernels/standard.tm')
C
C           TIMFMT = 'YYYY-MON-DD HR:MN:SC.###### (TDB) ::TDB ::RND'
C
C     C
C     C     Initialize windows RESULT and CNFINE.
C     C
C           CALL SSIZED ( NINTRVL, RESULT1 )
C           CALL SSIZED ( NINTRVL, RESULT2 )
C           CALL SSIZED ( NINTRVL, RESULT3 )
C           CALL SSIZED ( NINTRVL, RESULT4 )
C           CALL SSIZED ( 2,      CNFINE )
C
C     C
C     C     Store the time bounds of our search interval in
C     C     the CNFINE confinement window.
C     C
C           CALL STR2ET ( '2007 JAN 01', BEGTIM )
C           CALL STR2ET ( '2008 JAN 01', ENDTIM )
C
C           CALL WNINSD ( BEGTIM, ENDTIM, CNFINE )
C
C     C
C     C     The latitude varies relatively slowly (46 degrees) during
C     C     the year. The extrema occur approximately every six months.
C     C     Search using a step size less than half that value
C     C     (180 days). For this example use ninety days (in units
C     C     of seconds).
C     C
C           STEP   = SPD()*90.D0
C
C     C
C     C     Perform four searches to determine the times when the
C     C     latitude- longitude box restriction conditions apply to the
C     C      subpoint vector.
C     C
C     C     Use geodetic coordinates.
C     C
C           ADJUST = 0.D0
C           TARGET = 'EARTH'
C           OBSRVR = 'SUN'
C           METHOD = 'Near point: ellipsoid'
C           FIXREF = 'IAU_EARTH'
C           CRDSYS = 'GEODETIC'
C           ABCORR = 'NONE'
C
C     C
C     C     Perform the searches such that the result window of a search
C     C     serves as the confinement window of the subsequent search.
C     C
C
C     C
C     C     Since the latitude coordinate varies slowly and is well
C     C     behaved over the time of the confinement window, search
C     C     first for the windows satisfying the latitude requirements,
C     C     then use that result as confinement for the
C     C     longitude search.
C     C
C           COORD  = 'LATITUDE'
C           REFVAL = 16.D0 * RPD()
C           RELATE = '>'
C
C           CALL GFSUBC (  TARGET,  FIXREF,
C          .               METHOD,  ABCORR, OBSRVR,
C          .               CRDSYS,  COORD,
C          .               RELATE,  REFVAL,
C          .               ADJUST,  STEP,  CNFINE,
C          .               NINTRVL, NWMAX, WORK, RESULT1 )
C
C           REFVAL = 17.D0 * RPD()
C           RELATE = '<'
C
C           CALL GFSUBC (  TARGET,  FIXREF,
C          .               METHOD,  ABCORR, OBSRVR,
C          .               CRDSYS,  COORD,
C          .               RELATE,  REFVAL,
C          .               ADJUST,  STEP,  RESULT1,
C          .               NINTRVL, NWMAX, WORK, RESULT2 )
C
C     C
C     C     Now the longitude search.
C     C
C           COORD  = 'LONGITUDE'
C
C     C
C     C     Reset the step size to something appropriate for the 360
C     C     degrees in 24 hours domain. The longitude shows near
C     C     linear behavior so use a step size less than half the period
C     C     of twelve hours. Ten hours will suffice in this case.
C     C
C           STEP   = SPD() * (10.D0/24.D0)
C
C           REFVAL = 85.D0 * RPD()
C           RELATE = '>'
C
C
C           CALL GFSUBC (  TARGET,  FIXREF,
C          .               METHOD,  ABCORR, OBSRVR,
C          .               CRDSYS,  COORD,
C          .               RELATE,  REFVAL,
C          .               ADJUST,  STEP,   RESULT2,
C          .               NINTRVL, NWMAX, WORK, RESULT3 )
C
C     C
C     C     Contract the endpoints of each window to account
C     C     for possible round-off error at the -180/180 degree branch.
C     C
C     C     A contraction value of a millisecond should eliminate
C     C     any round-off caused branch crossing.
C     C
C           CALL WNCOND ( 1D-3, 1D-3, RESULT3 )
C
C           REFVAL = 86.D0 * RPD()
C           RELATE = '<'
C
C           CALL GFSUBC (  TARGET,  FIXREF,
C          .               METHOD,  ABCORR, OBSRVR,
C          .               CRDSYS,  COORD,
C          .               RELATE,  REFVAL,
C          .               ADJUST,  STEP,   RESULT3,
C          .               NINTRVL, NWMAX, WORK, RESULT4 )
C
C     C
C     C     Check the number of intervals in the result window.
C     C
C           COUNT = WNCARD(RESULT4)
C
C     C
C     C     List the beginning and ending points in each interval
C     C     if RESULT contains data.
C     C
C           IF ( COUNT .EQ. 0 ) THEN
C              WRITE(*, '(A)') 'Result window is empty.'
C           ELSE
C
C              DO I = 1, COUNT
C
C     C
C     C           Fetch the endpoints of the Ith interval
C     C           of the result window.
C     C
C                 CALL WNFETD ( RESULT4, I, LEFT, RIGHT  )
C
C                 CALL TIMOUT ( LEFT, TIMFMT, BEGSTR )
C                 CALL TIMOUT ( RIGHT, TIMFMT, ENDSTR )
C
C     C
C     C           Determine the latitude and longitude of the subpoint
C     C           at the event interval boundaries.
C     C
C                 CALL SUBPNT ( METHOD, TARGET, LEFT, FIXREF, ABCORR,
C          .                    OBSRVR, LPOS, TRGEPC, SRFVEC )
C                 CALL RECLAT ( LPOS, RAD(1), LON(1), LAT(1) )
C
C                 CALL SUBPNT ( METHOD, TARGET, RIGHT, FIXREF, ABCORR,
C          .                    OBSRVR, RPOS, TRGEPC, SRFVEC )
C                 CALL RECLAT ( RPOS, RAD(2), LON(2), LAT(2) )
C
C
C                 WRITE(*,*) 'From : ',BEGSTR,LAT(1)*DPR(),LON(1)*DPR()
C                 WRITE(*,*) 'To   : ',ENDSTR,LAT(2)*DPR(),LON(2)*DPR()
C                 WRITE(*,*) ' '
C
C              END DO
C
C           END IF
C
C           END
C
C   The program outputs:
C
C   Time intervals                                Lat         Lon
C
C   From : 2007-MAY-05 06:14:04.637734 (TDB)      16.0543561  86.
C   To   : 2007-MAY-05 06:18:04.621907 (TDB)      16.0551478  85.0000042
C
C   From : 2007-MAY-06 06:13:59.583483 (TDB)      16.3371472  86.
C   To   : 2007-MAY-06 06:17:59.569239 (TDB)      16.3379265  85.0000042
C
C   From : 2007-MAY-07 06:13:55.102939 (TDB)      16.6154436  86.
C   To   : 2007-MAY-07 06:17:55.090299 (TDB)      16.6162103  85.0000042
C
C   From : 2007-MAY-08 06:13:51.202604 (TDB)      16.8891626  86.
C   To   : 2007-MAY-08 06:17:51.191583 (TDB)      16.8899165  85.0000042
C
C   From : 2007-AUG-06 06:23:17.282927 (TDB)      16.6807174  86.
C   To   : 2007-AUG-06 06:27:17.264009 (TDB)      16.6799616  85.0000042
C
C   From : 2007-AUG-07 06:23:10.545441 (TDB)      16.4064108  86.
C   To   : 2007-AUG-07 06:27:10.524925 (TDB)      16.4056426  85.0000042
C
C   From : 2007-AUG-08 06:23:03.233995 (TDB)      16.1276778  86.
C   To   : 2007-AUG-08 06:27:03.211889 (TDB)      16.1268975  85.0000042
C
C$ Restrictions
C
C     1) The kernel files to be used by this routine must be loaded
C        (normally using the SPICELIB routine FURNSH) before this
C        routine is called.
C
C     2) This routine has the side effect of re-initializing the
C        coordinate quantity utility package.  Callers may
C        need to re-initialize the package after calling this routine.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     E.D. Wright    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 05-SEP-2012 (EDW)
C
C        Edit to comments to correct search description.
C
C        Implemented use of ZZHOLDD to allow user to alter convergence
C        tolerance.
C
C        Removed the STEP > 0 error check. The GFSSTP call includes
C        the check.
C
C-   SPICELIB Version 1.0.1, 22-AUG-2009 (EDW)
C
C       Edited argument descriptions.
C
C       Edit to Example description, replaced "intercept" with
C       "sub-observer point."
C
C-   SPICELIB Version 1.0.0, 17-FEB-2009 (NJB) (EDW)
C
C-&

C$ Index_Entries
C
C     GF subpoint coordinate search
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      LOGICAL               GFBAIL
      INTEGER               SIZED
      LOGICAL               EVEN

      EXTERNAL              GFBAIL

C
C     Routines to set step size, refine transition times
C     and report work.
C
      EXTERNAL              GFREFN
      EXTERNAL              GFREPI
      EXTERNAL              GFREPU
      EXTERNAL              GFREPF
      EXTERNAL              GFSTEP

C
C     Local parameters
C
      INTEGER               LNSIZE
      PARAMETER           ( LNSIZE = 80 )

      INTEGER               QNPARS
      PARAMETER           ( QNPARS = 10 )

      LOGICAL               NOBAIL
      PARAMETER           ( NOBAIL = .FALSE. )

      LOGICAL               NORPT
      PARAMETER           ( NORPT  = .FALSE. )

C
C     Local variables
C
      DOUBLE PRECISION      TOL
      LOGICAL               OK

C
C     Quantity definition parameter arrays:
C
      CHARACTER*(LNSIZE)    QCPARS ( QNPARS )
      CHARACTER*(LNSIZE)    QPNAMS ( QNPARS )
      CHARACTER*(LNSIZE)    DREF

      DOUBLE PRECISION      QDPARS ( QNPARS )
      DOUBLE PRECISION      DVEC   ( 3 )

      INTEGER               QIPARS ( QNPARS )

      LOGICAL               QLPARS ( QNPARS )

C
C     Define no-use values for DVEC and DREF
C
      DATA                  DVEC  / 0.D0, 0.D0, 0.D0 /
      DATA                  DREF  / ' '  /

      SAVE                  DVEC
      SAVE                  DREF

C
C     Standard SPICE error handling.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     Check into the error subsystem.
C
      CALL CHKIN( 'GFSUBC' )

C
C     Confirm minimum window sizes.
C
      IF ( MW .LT. 2 .OR. .NOT. EVEN(MW) ) THEN

         CALL SETMSG ( 'Workspace window size was #; size must be '
     .   //            'at least 2 and an even value.'            )
         CALL ERRINT ( '#',  MW                                    )
         CALL SIGERR ( 'SPICE(INVALIDDIMENSION)'                   )
         CALL CHKOUT ( 'GFSUBC'                                    )
         RETURN

      END IF

      IF ( SIZED(RESULT) .LT. 2 ) THEN

         CALL SETMSG ( 'Result window size was #; size must be '
     .   //            'at least 2.'                               )
         CALL ERRINT ( '#', SIZED(RESULT)                          )
         CALL SIGERR ( 'SPICE(INVALIDDIMENSION)'                   )
         CALL CHKOUT ( 'GFSUBC'                                    )
         RETURN

      END IF

C
C     Set up a call to GFEVNT specific to the subpoint coordinate
C     search.
C
      QPNAMS(1) = 'TARGET'
      QCPARS(1) =  TARGET

      QPNAMS(2) = 'OBSERVER'
      QCPARS(2) =  OBSRVR

      QPNAMS(3) = 'ABCORR'
      QCPARS(3) =  ABCORR

      QPNAMS(4) = 'COORDINATE SYSTEM'
      QCPARS(4) =  CRDSYS

      QPNAMS(5) = 'COORDINATE'
      QCPARS(5) =  COORD

      QPNAMS(6) = 'REFERENCE FRAME'
      QCPARS(6) =  FIXREF

      QPNAMS(7) = 'VECTOR DEFINITION'
      QCPARS(7) =  SOBDEF

      QPNAMS(8) = 'METHOD'
      QCPARS(8) =  METHOD

      QPNAMS(9) = 'DREF'
      QCPARS(9) =  DREF

      QPNAMS(10) = 'DVEC'
      QDPARS(1)  = DVEC(1)
      QDPARS(2)  = DVEC(2)
      QDPARS(3)  = DVEC(3)

C
C     Set the step size.
C
      CALL GFSSTP (STEP)

C
C     Retrieve the convergence tolerance, if set.
C
      CALL ZZHOLDD ( ZZGET, GF_TOL, OK, TOL )

C
C     Use the default value CNVTOL if no stored tolerance value.
C
      IF ( .NOT. OK ) THEN

         TOL = CNVTOL

      END IF

C
C     Initialize the RESULT window to empty.
C
      CALL SCARDD ( 0, RESULT)

C
C     Look for solutions.
C
C     Progress report and interrupt options are set to .FALSE.
C
      CALL GFEVNT ( GFSTEP,   GFREFN,  'COORDINATE',
     .              QNPARS,   QPNAMS,   QCPARS,
     .              QDPARS,   QIPARS,   QLPARS,
     .              RELATE,   REFVAL,   TOL,
     .              ADJUST,   CNFINE,   NORPT,
     .              GFREPI,   GFREPU,   GFREPF,
     .              MW,       NW,       WORK,
     .              NOBAIL,  GFBAIL,    RESULT )

      CALL CHKOUT( 'GFSUBC' )
      RETURN

      END