*dk,try4to4x
      subroutine try4to4xv(iepos,it,iflag,ntet,mtet,
     *         xmegah,xmegadet,xmegaerr,
     *         npoints,ntets,toldamage,iopt2to2)
C
C ######################################################################
C
C     PURPOSE -
C
C        This routine attempts flipping 4-to-4 type connections.
C
C     INPUT ARGUMENTS -
C
C        iepos    - the edge position
C        it       - the tet number
C
C     OUTPUT ARGUMENTS -
C
C        iflag    - the success flag:
C                      0 => flip was not performed
C                      1 => flip was performed
C
C     CHANGE HISTORY -
C
C        $Log: try4to4xv.f,v $
C        Revision 2.00  2007/11/09 20:04:05  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.11   18 Jun 2003 08:12:04   dcg
CPVCS    check value of iopt2to2, if zero skip interface recons
CPVCS
CPVCS       Rev 1.10   05 Jan 2001 12:58:08   dcg
CPVCS    use dble in place of float so as not to lose digits
CPVCS
CPVCS       Rev 1.9   Fri Aug 28 14:25:38 1998   dcg
CPVCS    remove single precision constants
CPVCS
CPVCS       Rev 1.8   Wed Jun 17 11:55:50 1998   dcg
CPVCS    call testdamage only if this is an interface flip
CPVCS
CPVCS       Rev 1.7   Tue Jun 16 13:26:22 1998   dcg
CPVCS    more changes for ivoronoi = -2
CPVCS
CPVCS       Rev 1.3   Tue May 26 17:09:28 1998   dcg
CPVCS    test for correct tet material types before attempting flip
C
C ######################################################################
C
      implicit none
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"

C arguments
C   (iepos,it,iflag,ntet,mtet,xmegah,xmegadet,xmegaerr,
C                             npoints,ntets,toldamage,iopt2to2)

      integer iepos,it,iflag
      integer ntet(*),mtet(*)
      real*8 xmegah(*), xmegadet(*), xmegaerr(*)
      integer npoints,ntets
      real*8 toldamage
      integer iopt2to2

C variables
      integer nmulti
      data nmulti/200/

      integer idold(16),idnew(16),jdold(16),jdnew(16)
      integer imt1a(200),ichain(200)

      integer  i,it2,it3,it4,it5,ifac,ifac2,ifac3,
     *      ifac4, ierror, length,icmotype,ierflg,
     *      i1,i2,i3,i4,i5,i6,ipos2,ipos3,iflg1,iflg2,
     *      ifour,ier,j,k,kpe,nsd,n,m,iofs,jj,ipar,i3b,i4b,
     *      ict,imtx,iflg,ipar1

      logical flip,interface1,interface2,itsttp

      real*8 xxlarge,val1,val2,vol1,vol2,vol3,vol4,
     *       valinit,en,em

      real*8 alargenumber
      parameter (alargenumber= 1.0d+30)
C
      real*8 crosx1,crosy1,crosz1,volume
      crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
     *              (yic(k)-yic(i))*(zic(j)-zic(i))
      crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
     *              (xic(j)-xic(i))*(zic(k)-zic(i))
      crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
     *              (xic(k)-xic(i))*(yic(j)-yic(i))
      volume(i1,i2,i3,i4)=(xic(i4)-xic(i1))*crosx1(i1,i2,i3)+
     *                    (yic(i4)-yic(i1))*crosy1(i1,i2,i3)+
     *                    (zic(i4)-zic(i1))*crosz1(i1,i2,i3)
C
C ######################################################################
C BEGIN begin
C
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,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('itetclr',cmo,ipitetclr,length,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,length,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,length,icmotype,ierror)
C
      endif
C
C     ******************************************************************
C
C
      xxlarge=alargenumber
      val1=xxlarge
      val2=xxlarge
      valinit=1.0e-14
      iflag=0
      ifour=4
C
C     ***************************************************************
C
C     DETERMINE WHETHER OR NOT A 4-TO-4 FLIP IS POSSIBLE
C
      interface1=.false.
      interface2=.false.
      iofs=4*(iepos-1)
      ifac3 = jtet(ielist(iofs+3),it)
      if(iopt2to2.eq.0.and.ifac3.ge.mbndry) go to 9999
      if (ifac3.gt.mbndry) then
         ifac3=ifac3-mbndry
         interface1=.true.
      endif
      ifac4 = jtet(ielist(iofs+4),it)
      if(iopt2to2.eq.0.and.ifac4.ge.mbndry) go to 9999
      if (ifac4.gt.mbndry) then
         ifac4=ifac4-mbndry
         interface2=.true.
      endif
      if(ifac3 .eq.mbndry.or.
     *   ifac4.eq.mbndry) then
            goto 9999
      endif
      it2=0.25*dble(ifac3)+0.9
      it3=0.25*dble(ifac4)+0.9
      i1=itet(ielist(iofs+1),it)
      i2=itet(ielist(iofs+2),it)
      i3=itet(ielist(iofs+3),it)
      i4=itet(ielist(iofs+4),it)
      i5=itet1(ifac3)
      i6=itet1(ifac4)
C
      ipos2=0
      ipar1=0
      if(interface1) then
         call getchain(i4,
     *             ichain,imt1a,nmulti,ict,ipar)
         if(itsttp('intrface',itp1(itet(1,it2))))call getchain(
     *             itet(1,it2),ichain,imt1a,nmulti,ict,ipar1)
         if (ipar.eq.ipar1) ipos2=1
         if(itsttp('intrface',itp1(itet(2,it2))))call getchain(
     *             itet(2,it2),ichain,imt1a,nmulti,ict,ipar1)
         if (ipar.eq.ipar1) ipos2=2
         if(itsttp('intrface',itp1(itet(3,it2))))call getchain(
     *             itet(3,it2),ichain,imt1a,nmulti,ict,ipar1)
         if (ipar.eq.ipar1) ipos2=3
         if(itsttp('intrface',itp1(itet(4,it2))))call getchain(
     *             itet(4,it2),ichain,imt1a,nmulti,ict,ipar1)
         if (ipar.eq.ipar1) ipos2=4
      else
         if(itet(1,it2).eq.i4) ipos2=1
         if(itet(2,it2).eq.i4) ipos2=2
         if(itet(3,it2).eq.i4) ipos2=3
         if(itet(4,it2).eq.i4) ipos2=4
      endif
      if(ipos2.eq.0) go to 9999
      ifac = jtet(ipos2,it2)
      if(iopt2to2.eq.0.and.ifac.ge.mbndry) go to 9999
      if (ifac.gt.mbndry) then
         ifac=ifac-mbndry
         if(.not.interface2)go to 9999
      else
         if(interface2) go to 9999
      endif
      if (ifac.eq.mbndry.or.kfix(1,it2).ne.0.or.
     *   kfix(2,it2).ne.0.or.kfix(3,it2).ne.0.or.
     *   kfix(4,it2).ne.0) then
         goto 9999
      endif
      it4=0.25*dble(ifac)+0.9
      if(it4.eq.it3.or.it4.eq.it) go to 9999
C
      ipos3=0
      ipar1=0
      if(interface2) then
         call getchain(i3,
     *             ichain,imt1a,nmulti,ict,ipar)
         if(itsttp('intrface',itp1(itet(1,it3))))call getchain(
     *             itet(1,it3),ichain,imt1a,nmulti,ict,ipar1)
         if (ipar.eq.ipar1) ipos3=1
         if(itsttp('intrface',itp1(itet(2,it3))))call getchain(
     *             itet(2,it3),ichain,imt1a,nmulti,ict,ipar1)
         if (ipar.eq.ipar1) ipos3=2
        if(itsttp('intrface',itp1(itet(3,it3)))) call getchain(
     *             itet(3,it3),ichain,imt1a,nmulti,ict,ipar1)
         if (ipar.eq.ipar1) ipos3=3
        if(itsttp('intrface',itp1(itet(4,it3)))) call getchain(
     *             itet(4,it3),ichain,imt1a,nmulti,ict,ipar1)
         if (ipar.eq.ipar1) ipos3=4
      else
         if(itet(1,it3).eq.i3) ipos3=1
         if(itet(2,it3).eq.i3) ipos3=2
         if(itet(3,it3).eq.i3) ipos3=3
         if(itet(4,it3).eq.i3) ipos3=4
      endif
      if(ipos3.eq.0) go to 9999
      ifac2 = jtet(ipos3,it3)
      if (ifac2.gt.mbndry) then
         ifac2=ifac2-mbndry
         if(.not.interface1) go to 9999
      else
         if(interface1) go to 9999
      endif
      if (ifac2.eq.mbndry.or.kfix(1,it3).ne.0.or.
     *   kfix(2,it3).ne.0.or.kfix(3,it3).ne.0.or.
     *   kfix(4,it3).ne.0) then
         goto 9999
      endif
      it5=0.25*dble(ifac2)+0.9
C
      if(it4.ne.it5) then
         goto 9999
      endif
      vol1=volume(itet(1,it),itet(2,it),itet(3,it),itet(4,it))
      vol2=volume(itet(1,it2),itet(2,it2),itet(3,it2),itet(4,it2))
      vol3=volume(itet(1,it3),itet(2,it3),itet(3,it3),itet(4,it3))
      vol4=volume(itet(1,it4),itet(2,it4),itet(3,it4),itet(4,it4))
      if(  min(vol1,vol2,vol3,vol4).le.0) goto 9999
C
C     _________________________________________________________
C
C     EVALUATE THE TWO 4-TO-4 POSSIBILITIES
C
C   try flip to connection i3-i5 if ifac4 and ifac are either
C   both interface or all are interior faces
C
      iflg1=0
      iflg2=0
      if((.not.interface2.and..not.interface1).or.
     *   (interface2)) then
         iflg=1
         if(interface2)call testdamage(i1,i3,i2,i5,iflg,toldamage)
         if (iflg.eq.1) then
            call test4to4(i3,i1,i6,i2,i4,i5,iflg1)
         else
            iflg1=0
         endif
      endif
      if (iflg1.eq.1)  then
           if ((imt1(itet(1,it)).ne.imt1(itet(1,it3))).or.
     *       (imt1(itet(1,it2)).ne.imt1(itet(1,it4)))) go to 125
           n=4
           ntet(1)=it
           ntet(2)=it2
           ntet(3)=it3
           ntet(4)=it4
           do j=1,n
              xmegadet(ntet(j))=-1.0
              xmegaerr(ntet(j))=-1.0
           enddo
           m=4
           mtet(1)=ntets+1
           mtet(2)=ntets+2
           mtet(3)=ntets+3
           mtet(4)=ntets+4
           do j=1,m
              xmegadet(mtet(j))=-1.0
              xmegaerr(mtet(j))=-1.0
           enddo
           itet(1,mtet(1))=i5
           itet(2,mtet(1))=i2
           itet(3,mtet(1))=i3
           itet(4,mtet(1))=i4
           itet(1,mtet(2))=i3
           itet(2,mtet(2))=i1
           itet(3,mtet(2))=i5
           itet(4,mtet(2))=i4
           itet(1,mtet(3))=i3
           itet(2,mtet(3))=i5
           itet(3,mtet(3))=i6
           itet(4,mtet(3))=i2
           itet(1,mtet(4))=i1
           itet(2,mtet(4))=i3
           itet(3,mtet(4))=i5
           itet(4,mtet(4))=i6
           kpe=4
           nsd=3
           call b3dnxm (n,ntet,en,m,mtet,em,
     *                         npoints,nsd,xic,yic,zic,xmegah,
     *                         ntets,kpe,itet,xmegadet,xmegaerr,
     *                         flip)
           if(flip) then
C
C  do the flip
C
             iofs=4*(iepos-1)
             i1=itet(ielist(iofs+1),it)
             i2=itet(ielist(iofs+2),it)
             i3=itet(ielist(iofs+3),it)
             i4=itet(ielist(iofs+4),it)
             i5=itet1(ifac3)
             i6=itet1(ifac4)
             if (interface2) then
                imtx=imt1(i6)
                call getchain(i3,
     *             ichain,imt1a,nmulti,ict,ipar)
                 if (ict.eq.0) go to 9999
                 do jj=1,ict
                    if (imt1a(jj) .eq. imtx) then
                       i3b=ichain(jj)
                       goto 120
                    endif
                enddo
 120            continue
                call fnd4to4i(it,it2,it3,it4,i1,i2,i3,i3b,i4,
     *            i5,i6,idold,jdold,
     *            npoints,ntets)
                call flp4to4i(it,it2,it3,it4,idold,jdold,npoints,
     *            ntets)
             else
                call find4to4(it,iepos,it2,it3,it4,i1,i2,i3,i4,
     *            i5,i6,1,idold,jdold,idnew,jdnew,
     *            npoints,ntets,ierflg)
                call flip4to4(it,it2,it3,it4,idold,jdold,npoints,
     *            ntets)
             endif
             iflag=1
             go to 9999
           endif
      endif
C
C   flip to connection i4-i6 if ifac3 and ifac2 are either
C   both interface or all are interior faces
C
 125  if((.not.interface2.and..not.interface1).or.
     *   (interface1)) then
         iflg=1
         if(interface1)call testdamage(i1,i4,i2,i6,iflg,toldamage)
         if (iflg.eq.1) then
            call test4to4(i4,i1,i3,i2,i5,i6,iflg2)
         else
            iflg2=0
         endif
      endif
      if (iflg2.eq.1) then
           if ((imt1(itet(1,it)).ne.imt1(itet(1,it3))).or.
     *       (imt1(itet(1,it2)).ne.imt1(itet(1,it4)))) go to 9999
           n=4
           ntet(1)=it
           ntet(2)=it2
           ntet(3)=it3
           ntet(4)=it4
           do j=1,n
              xmegadet(ntet(j))=-1.0
              xmegaerr(ntet(j))=-1.0
           enddo
           m=4
           mtet(1)=ntets+1
           mtet(2)=ntets+2
           mtet(3)=ntets+3
           mtet(4)=ntets+4
           do j=1,m
              xmegadet(mtet(j))=-1.0
              xmegaerr(mtet(j))=-1.0
           enddo
           itet(1,mtet(1))=i2
           itet(2,mtet(1))=i6
           itet(3,mtet(1))=i4
           itet(4,mtet(1))=i3
           itet(1,mtet(2))=i1
           itet(2,mtet(2))=i6
           itet(3,mtet(2))=i3
           itet(4,mtet(2))=i4
           itet(1,mtet(3))=i2
           itet(2,mtet(3))=i6
           itet(3,mtet(3))=i5
           itet(4,mtet(3))=i4
           itet(1,mtet(4))=i1
           itet(2,mtet(4))=i5
           itet(3,mtet(4))=i6
           itet(4,mtet(4))=i4
           kpe=4
           nsd=3
           call b3dnxm (n,ntet,en,m,mtet,em,
     *                         npoints,nsd,xic,yic,zic,xmegah,
     *                         ntets,kpe,itet,xmegadet,xmegaerr,
     *                         flip)
           if(flip) then
C
C  do the flip
C
             iofs=4*(iepos-1)
             i1=itet(ielist(iofs+1),it)
             i2=itet(ielist(iofs+2),it)
             i3=itet(ielist(iofs+3),it)
             i4=itet(ielist(iofs+4),it)
             i5=itet1(ifac3)
             i6=itet1(ifac4)
             if (interface1) then
                imtx=imt1(i5)
                call getchain(i4,
     *             ichain,imt1a,nmulti,ict,ipar)
                 if (ict.eq.0) go to 9999
                 do jj=1,ict
                    if (imt1a(jj) .eq. imtx) then
                       i4b=ichain(jj)
                       goto 121
                    endif
                enddo
 121            continue
                call fnd4to4ix(it,it2,it3,it4,i1,i2,i3,i4b,i4,
     *            i5,i6,idold,jdold,
     *            npoints,ntets)
                call flp4to4i(it,it2,it3,it4,idold,jdold,npoints,
     *            ntets)
                itetclr(it2)=itetclr(it)
                itetclr(it3)=itetclr(it4)
             else
                call find4to4(it,iepos,it2,it3,it4,i1,i2,i3,i4,
     *            i5,i6,2,idold,jdold,idnew,jdnew,
     *            npoints,ntets,ierflg)
                call flip4to4(it,it2,it3,it4,idnew,jdnew,npoints,
     *            ntets)
             endif
             iflag=1
             go to 9999
           endif
      endif
C
      goto 9999
 9999 continue
      return
      end


      SUBROUTINE TRAXY
C++
C
C TRAXY.F V1.92 Convert X,Y pixel position to drizzle output position
C
C This task uses coefficients held in a text file to define
C geometrical distortions.
C
C This code uses the F77/VOS for IRAF i/o.
C It may be compiled and linked using a command like:
C
C xc -p stsdas tranback.f drutil.f x_tranback.x <dir>libiraf77.a
C
C History:
C
C First quick version, 17th April 1997
C
C V0.2 modified to have the centre position as parameters, 4th Sept 97
C
C V0.3 added a rotation around the centre, 19th August 1998, STScI
C      also specified "align" and chip size.
C
C V0.31 possibility to have coeffs="" for simple linear case, 25th August 98
C
C V0.4 with full set of drizzle parameter for compatibility with
C      TRANBACK and release of STECF IRAF package. 17th December 1999
C
C V0.5 modified to use new calling sequences for some DRUTIL routines
C      and hence fix bugs, November 2001
C
C V1.0 using the full geometrical possibilities available in Drizzle V2.6.
C      December 2001
C
C V1.1 return to 3 decimal places and small code tinyup
C      January 2002
C
C V1.2 using new DRIVAL call
C      Richard Hook, ST-ECF, 27th February 2002
C
C V1.3 using packaged coefficient file access and hence fixing bug
C      Richard Hook, ST-ECF, 11th March 2002
C
C V1.4 write out results to IRAF parameters and added silent flag
C      for more convenient scripting application
C      Richard Hook, ST-ECF/STScI, 4th September 2002
C
C V1.5 WTRAXY version for WCS tests,
C      Richard Hook, ST-ECF/STScI, 19th March 2003
C
C V1.6 include distortion image support,,
C      Richard Hook, ST-ECF/STScI, 26th August 2003
C
C V1.7 using double precision for almost everything
C      Richard Hook, ST-ECF/STScI, 21st October 2003
C
C V1.8 added PREFIX parameter
C       Richard Hook, ST-ECF/STScI, 23rd October 2003
C
C V1.9 added refpix support
C       Richard Hook, ST-ECF/STScI, 5th December 2003
C
C V1.91 Modified to use common callable code
C       Warren Hack, STScI, 25th June 2004
C
C--
      IMPLICIT NONE

C Local variables
      INTEGER ISTAT,NXIN,NYIN,NXOUT,NYOUT
      INTEGER COTY,CONUM,COMAX,ID
      PARAMETER (COMAX=100)

      DOUBLE PRECISION XCO(COMAX),YCO(COMAX)
      DOUBLE PRECISION XIN,YIN,YOUT,XOUT
      DOUBLE PRECISION RA,DEC
      INTEGER IID,IRD,DATTYP,NDIMS,DDIMS(7)
      CHARACTER*80 INIM,OUTIM
      CHARACTER*1 PREFIX
      CHARACTER*132 CHARS
      CHARACTER*45 VERS
      CHARACTER*8 CTYPE1,CTYPE2

C Geometrical parameters, the standard set
      DOUBLE PRECISION SCALE,ROT,XSH,YSH,LAM
      DOUBLE PRECISION XSH2,YSH2,ROT2,XSCALE,YSCALE
      DOUBLE PRECISION RACEN,DECCEN,XREFP,YREFP,WCSIN(8),WCSOUT(8)
      DOUBLE PRECISION ORIENT,OUTSCL
      CHARACTER*80 COEFFS,SHFTUN,XGEOIM,YGEOIM
      CHARACTER*8 SHFR2,SHFTFR,ALIGN,GEOMOD
      INTEGER PXG,PYG,XGDIM,YGDIM
      LOGICAL DISIM

      REAL MEMR(1)
      COMMON /MEM/MEMR

      DOUBLE PRECISION PI
      PARAMETER (PI=3.141592653589793D0)

      LOGICAL ROTFIR
      LOGICAL USEWCS
      LOGICAL ROTF2
      LOGICAL SECPAR
      LOGICAL SILENT

C-- Start of executable code
      VERS='TRAXY Version 1.92 (10th February 2005)'

C Get the noise flag
      CALL UCLGSB('silent',SILENT,ISTAT)

C First announce the version
      IF(.NOT.SILENT) CALL UMSPUT('+ '//VERS,1,0,ISTAT)

C Allow WCS mode (WTRAXY/TRAXY switch)
CCC      CALL UCLGST('geomode',GEOMOD,ISTAT)
      GEOMOD='user'

C Get all the geometrical parameters
      CALL GTGEPA(GEOMOD,COEFFS,LAM,XGEOIM,YGEOIM,
     :             SCALE,ROT,XSH,YSH,SHFTFR,SHFTUN,ALIGN,
     :             XSCALE,YSCALE,XSH2,YSH2,ROT2,SHFR2,
     :             OUTSCL,RACEN,DECCEN,XREFP,YREFP,ORIENT)

C If so, check for image names (output is optional)
      IF(GEOMOD.EQ.'wcs') THEN
         CALL UCLGST('inimage',INIM,ISTAT)
         CALL UCLGST('refim',OUTIM,ISTAT)
         USEWCS=.TRUE.
      ELSE
         USEWCS=.FALSE.
      ENDIF

C Open the files and read the WCS from the headers
      IF(USEWCS) THEN
         IF(INIM.EQ.' ') THEN
            CALL UMSPUT('! No input image specified',
     :                  1,0,ISTAT)
            GO TO 99
         ELSE
            CALL UIMOPN(INIM,1,IID,ISTAT)
            IF(ISTAT.NE.0) THEN
               CALL UMSPUT('! Unable to open input image',
     :                     1,0,ISTAT)
               GO TO 99
            ELSE
               CALL UMSPUT('-Reading WCS from '//INIM,1,0,ISTAT)
            ENDIF

            CALL GETWCS(IID,WCSIN,CTYPE1,CTYPE2,ISTAT)
            IF(ISTAT.NE.0) THEN
               CALL UMSPUT(
     : '! Unable to get WCS from reference image',
     :                     1,0,ISTAT)
               GO TO 99
            ENDIF

C Get the dimensions and use them
            CALL UIMGID(IID,DATTYP,NDIMS,DDIMS,ISTAT)
            IF(NDIMS.NE.2) THEN
               CALL UMSPUT(
     :   '! Input image is not two dimensional',
     :                          1,0,ISTAT)
               GO TO 99
            ELSE
               NXIN=DDIMS(1)
               NYIN=DDIMS(2)
            ENDIF
         ENDIF

C If we have a reference image we need to try to get its WCS for
C use as the output
C
C Note that this can have a prefix (CCCD1_1 etc)
         IF(OUTIM.NE.' ') THEN

C Get the prefix character
            CALL UCLGST('refpref',PREFIX,ISTAT)

            CALL UIMOPN(OUTIM,1,IRD,ISTAT)
            IF(ISTAT.NE.0) THEN
               CALL UMSPUT('! Unable to open output image',
     :                     1,0,ISTAT)
               GO TO 99
            ELSE
               CALL UMSPUT('-Reading WCS from '//OUTIM,1,0,ISTAT)
               IF(PREFIX.NE.' ') THEN
                  CALL UMSPUT('-Using prefix: '//PREFIX,1,0,ISTAT)
               ENDIF
            ENDIF

            IF(PREFIX.NE.' ') THEN
               CALL GTPWCS(IRD,PREFIX,WCSOUT,CTYPE1,CTYPE2,ISTAT)
            ELSE
               CALL GETWCS(IRD,WCSOUT,CTYPE1,CTYPE2,ISTAT)
            ENDIF

            IF(ISTAT.NE.0) THEN
               CALL UMSPUT(
     : '! Unable to get WCS from reference image',
     :                     1,0,ISTAT)
               GO TO 99
            ENDIF

C Get the dimensions and use them
            CALL UIMGID(IRD,DATTYP,NDIMS,DDIMS,ISTAT)
            IF(NDIMS.NE.2) THEN
               CALL UMSPUT(
     :   '! Reference image is not two dimensional',
     :                          1,0,ISTAT)
               GO TO 99
            ELSE
               NXOUT=DDIMS(1)
               NYOUT=DDIMS(2)
            ENDIF
         ELSE

C If there is no output image then we read the output WCS from the
C user supplied values and convert to a WCS representation
            CALL SETWCS(OUTSCL,ORIENT,XREFP,RACEN,
     :                  YREFP,DECCEN,WCSOUT)
            CALL UMSPUT(
     : '-Defining output WCS from user-specified parameters',
     :      1,0,ISTAT)

         ENDIF
      ENDIF

C Convert the secondary parameters into suitable units
      ROT2=ROT2*PI/180.0
      IF(SHFR2.eq.'input') THEN
         ROTF2=.FALSE.
      ELSE
         ROTF2=.TRUE.
      ENDIF

C Give a warning message if secondary parameters will have an effect
      IF(XSCALE.NE.1.0D0 .OR. YSCALE.NE.1.0D0 .OR.
     :   XSH2.NE.0.0D0 .OR. YSH2.NE.0.0D0 .OR. ROT2.NE.0.0D0) THEN
       IF(.NOT.SILENT) CALL UMSPUT(
     : '! Warning, secondary geometric transform is being used',
     :               1,0,ISTAT)
        SECPAR=.TRUE.
      ELSE
        SECPAR=.FALSE.
      ENDIF

      IF(SHFTFR.EQ.'input') THEN
         ROTFIR=.FALSE.
      ELSE
         ROTFIR=.TRUE.
      ENDIF

      IF(SHFTUN.EQ.'output') THEN
         XSH=XSH*SCALE
         YSH=YSH*SCALE
      ENDIF

C Get the geometric distortion coefficient information
C Note that no image is available so coeffs="header" will fail
      CALL GETGEO(COEFFS,ID,LAM,
     :            COTY,COMAX,CONUM,XCO,YCO,ISTAT)
      IF(ISTAT.NE.0) THEN
         CALL UMSPUT(
     :  '! WTRAXY: Error, failed to get distortion coefficients',
     :  1,0,ISTAT)
          GO TO 99
      ENDIF

C  Read in any distortion image corrections, if specified
C  PXG,PYG will default to 2x2 arrays when DISIM returns as FALSE.
C
      CALL GGEOIM(XGEOIM,YGEOIM,PXG,PYG,XGDIM,YGDIM,DISIM)

C Get the X,Y pixel position to be transformed
      CALL UCLGSD('xin',XIN,ISTAT)
      CALL UCLGSD('yin',YIN,ISTAT)

C Also get the chip size - in and out
C Not needed for GEOMOD='wcs'
      IF(.NOT.USEWCS) THEN
         CALL UCLGSI('nxin',NXIN,ISTAT)
         CALL UCLGSI('nyin',NYIN,ISTAT)
      ENDIF

      IF(.NOT.USEWCS .AND. OUTIM.NE.' ') THEN
         CALL UCLGSI('nxout',NXOUT,ISTAT)
         CALL UCLGSI('nyout',NYOUT,ISTAT)
      ENDIF

C Convert to radians
      ROT=ROT*PI/180.0D0

C Transform the position
C Note that this is exactly the same as that in Drizzle
C Double precision version
      IF(NINT(XIN) .GT. 1 .AND. NINT(XIN) .LT. NXIN-1 .AND.
     :   NINT(YIN) .GT. 1 .AND. NINT(YIN) .LT. NYIN-1) THEN

         CALL DRIVAL(XIN,YIN,1,NXIN,NYIN,NXOUT,NYOUT,.FALSE.,
     :            XSH,YSH,ROT,SCALE,ALIGN,ROTFIR,
     :            SECPAR,XSH2,YSH2,ROT2,XSCALE,YSCALE,SHFR2,ROTF2,
     :            USEWCS,WCSIN,WCSOUT,
     :            COTY,CONUM,XCO,YCO,
     :            DISIM,MEMR(PXG),MEMR(PYG),XGDIM,YGDIM,XOUT,YOUT)
      ELSE
         CALL DRIVAL(XIN,YIN,1,NXIN,NYIN,NXOUT,NYOUT,.FALSE.,
     :            XSH,YSH,ROT,SCALE,ALIGN,ROTFIR,
     :            SECPAR,XSH2,YSH2,ROT2,XSCALE,YSCALE,SHFR2,ROTF2,
     :            USEWCS,WCSIN,WCSOUT,
     :            COTY,CONUM,XCO,YCO,
     :            .FALSE.,MEMR(PXG),MEMR(PYG),XGDIM,YGDIM,XOUT,YOUT)
      ENDIF

C Write out the result
      IF(.NOT.SILENT) THEN
         WRITE(CHARS,
     :  '('' Xin,Yin: '',2F12.5'' Xout,Yout: '',2F12.5)')
     : XIN,YIN,XOUT,YOUT
         CALL UMSPUT(CHARS,1,0,ISTAT)

C If in WCS mode also report the sky position
         IF(USEWCS) THEN
            CALL XY2RD(XOUT,YOUT,RA,DEC,WCSOUT)
            WRITE(CHARS,
     : '('' RA: '',F12.7,'' Dec: '',F12.7,'' (deg)'')')
     :    RA,DEC
            CALL UMSPUT(CHARS,1,0,ISTAT)
         ENDIF
      ENDIF

C Also write the result to the CL
      CALL UCLPSD('xout',XOUT,ISTAT)
      CALL UCLPSD('yout',YOUT,ISTAT)

C End of main TRAXY module
 99   CONTINUE

C If allocated, free the distortion image memory
      IF(PXG.NE.0) CALL UDMFRE(PXG,6,ISTAT)
      IF(PYG.NE.0) CALL UDMFRE(PYG,6,ISTAT)

      RETURN
      END


      subroutine gensl1
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine sets up for and calls the necessary routines to
CD1  solve the heat and mass transfer equations with full
CD1  jacobian (unsymmetric, 2n by 2n).
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/gensl1.f_a  $
CD2
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:06   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:06:34   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:09:28   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:24:10   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:02:34   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:41:46 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.16   Fri Apr 26 15:20:50 1996   gaz
CD2 coding added for mdnodes
CD2
CD2    Rev 1.15   Wed Jan 17 08:57:30 1996   hend
CD2 Removed nonconstant parameter statement for IBM
CD2
CD2    Rev 1.14   Tue Jan 16 14:31:08 1996   hend
CD2 Added capability for 5,6, and n degrees of freedom
CD2
CD2    Rev 1.13   Fri Jan 12 17:48:52 1996   llt
CD2 changed mmgetblk agruments
CD2
CD2    Rev 1.12   Wed Jan 10 12:28:56 1996   hend
CD2 Corrected ECD Number
CD2
CD2    Rev 1.11   Wed Jan 10 12:01:46 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.10   08/02/95 17:30:40   llt
CD2 moved where sto5 was getting released
CD2
CD2    Rev 1.9   06/01/95 16:48:06   gaz
CD2 minor corrections f0=-1
CD2
CD2    Rev 1.8   04/25/95 09:06:34   llt
CD2 retrieved lost log history information
CD2
CD2    Rev 1.7   03/23/95 18:50:46   gaz
CD2 No change.
CD2
CD2    Rev 1.6   03/23/95 18:43:56   gaz
CD2 gaz changed bp to abs(bp in one if block
CD2
CD2    Rev 1.5   03/23/95 18:26:36   gaz
CD2 gaz changes to call to rdof_new and tolerance options
CD2
CD2    Rev 1.4   03/10/95 10:45:48   llt
CD2 removed unneeded pointers - gaz
CD2
CD2    Rev 1.3   05/11/94 16:14:50   llt
CD2 bug fixes - gaz
CD2
CD2    Rev 1.2   03/23/94 14:43:12   robinson
CD2 Additional cleanup of memory management
CD2
CD2    Rev 1.1   03/18/94 15:59:32   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:24:22   pvcs
CD2 original version in process of being certified
CD2
C**********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  2.3.2 Heat- and mass-transfer equations
CD3  2.5.2 Solve nonlinear equation set at each time step
CD3
C**********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C***********************************************************************

      use davidi
      use comflow
      use comhi
      use comgi
      use comfi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
      use comriv
      use comcouple
      implicit none

      integer ndex(2)
      integer i, id, neqp1, nsizea, nsizea1
      integer iparchek,kb,jj,i1,i2,i3,i4,j
      real a11
      real*8 dumn(100),term
      real*8, allocatable :: sto5(:,:)
      real*8, allocatable :: dum(:)
      real*8  facr, fdum2, tollr, tolls, tmch_new, tmch_old, bp_max
      save tmch_old
      parameter(iparchek =0)
      neqp1=neq+1
c test of coefficients
       if(iparchek.eq.1) then
       write(ierr,*) 'fe coef. neighbors'
       write(ierr,*)
       do i = 1,neq
        write(ierr,*)' vol node ', i,' = ', sx1(i)
        i1 = nelm(i)+1
        i2 = nelmdg(i)-1
        do j = i1,i2
         kb = nelm(j)
         i3 = nelmdg(kb)+1
         i4 = nelm(kb+1)
         do jj = i3,i4
         if(nelm(jj).eq.i) then
          iw = istrw(jj-neqp1)
          if(iw.gt.0) then
           a11 = sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
          else
           a11 = 0.0
          endif
          write(ierr,355)i,kb,iw,a11
          go to 899
         endif
        enddo
899     continue
       enddo
        i1 = nelmdg(i)+1
        i2 = nelm(i+1)
        do j = i1,i2
         kb = nelm(j)
         iw = istrw(j-neqp1)
          if(iw.gt.0) then
           a11 = sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
          else
           a11 = 0.0
          endif
         write(ierr,355)i,kb,iw,a11
        enddo
       enddo
355   format(i6,1x,i6,1x,i6,1x,f12.3)
       stop
       endif
c     zero out arrays
c
c  check for possible stopping on variable changes
c
      if(iad.ge.1) then
       if(nr_stop.eq.2) then
        fdum=-1.0
        go to 999
       endif
      endif
c
      do i=1,neq
         bp(i+nrhs(1))=0.0
         bp(i+nrhs(2))=0.0
      enddo
      nsizea1=nelm(neqp1)-neqp1
      nsizea=4*nsizea1
      do i=1,nsizea
         a(i)=0.0
      enddo
      fdum2=0.
      do id=1,neq
        if(iriver.eq.2.and.id.gt.neq_primary) then
         call geneq1_well(id)
        else if(ianpe.ne.0) then
         call geneq1_ani(id)
        else
         call geneq1(id)
        endif
      enddo
      do id=1,neq
         if(ps(id).le.0.0) then
            a(nelmdg(id)-neqp1+nmat(1))=sx1(id)
            bp(id+nrhs(1))=0.0
         endif
      enddo

c     call md_modes to complete equations for multiply defined nodes
c don't need to call geneqmdnode (through md_nodes) gaz
c     if(imdnode.ne.0) call md_nodes(3,0,0)

      call dual(10)
c
c possible correction for rate-limited gdpm model
c
      call gdpm_corr(1)
c
c s kelkar for debugging 3/20/12
c      call extract_adiag
c      call extract_nodal_equations(2627)
c
      if(islord.ne.0) call switch(nmat,nmatb,islord,2,1,nsizea1)
      if(islord.ne.0) call switchb(bp,nrhs,nrhsb,islord,2,1,neq)
c
c normalize equations
c
      call normal_dof(neq,a,bp,nelm,nmat,nrhs,nelmdg
     &     ,ndex,2,dumn(1),dumn(37),dumn(73),0,fdum2)
      if(ndex(1).lt.0) then
         write(ierr,*)
     & '>>> cannot normalize, stopping, i=',abs(ndex(1)),'<<<'
         if(iout.ne.0) then
          write(iout,*)
     & '>>> cannot normalize, stopping, i=',abs(ndex(1)),'<<<'
         endif
         if(iptty.ne.0) then
          write(iptty,*)
     & '>>> cannot normalize, stopping, i=',abs(ndex(1)),'<<<'
         endif
         stop
      endif

      fdum=sqrt(fdum2)
      if(fdum.eq.0.0) go to 999
      if(iad.eq.0) then
         f0=max(fdum*epe,tmch)
      endif
      if(fdum1.lt.0.0.and.iad.ne.0) then
	  bp_max = 0.0
         do i=1,neq
            bp_max= max(abs(bp(i+nrhs(1))),abs(bp(i+nrhs(2))),bp_max)
         enddo
	 if(bp_max.lt.tmch.and.nr_stop.eq.0) then
         fdum=-1.0
         go to 999
       else
         f0=-1.0
	   if(iad.eq.1) tmch_old = bp_max
	   tmch_new = min(bp_max,tmch_old)
	   tmch_old = tmch_new
	 endif
      endif
      if(f0.gt.0.0d00) then
         if(fdum.le.f0.and.iad.ne.0) goto 999
         facr=1.0d00
         tolls=max(facr*f0,min(g1*fdum,g2*fdum2))
         tollr=tolls*g3
         if(tmch*g3.gt.tollr) tollr=tmch*g3
      else if(f0.le.0.0d00) then
         tollr=tmch_new*g3
      endif

c     time=second(ghv)
c
c      times=second(0.0)
      iter=maxsolve
      call storage_derivatives(1,1)

      if(irdof.eq.0) then
c
c       full solution
c

         allocate(dum(neq*8))
         if(gdpm_flag.eq.0) then
            if (igauss .gt. 1) then
               call solve_new(neq,a,b,bp,nmat,nb,nrhs,nelm,nop,
     &              north,tollr,irb,iirb,npvt,gmres,dum,piv,
     &              h,c,ss,g,y,iter,iback,2,iptty,maxor,accm)
            else
               call solve_new(neq,a,b,bp,nmat,nmat,nrhs,nelm,nelm,
     &              north,tollr,irb,iirb,npvt,gmres,dum,piv,
     &              h,c,ss,g,y,iter,iback,2,iptty,maxor,accm)
            end if
         else
            if (igauss .gt. 1) then
               call solve_dual(neq_primary,neq,a,b,bp,nmat,nb,nrhs,
     &              nelm,nelm_primary,nop,north,tollr,irb,iirb,
     &              npvt,gmres,dum,piv,h,c,ss,g,y,iter,iback,2,
     &              iptty,maxor,igdpm,maxgdpmlayers,ngdpm_layers,
     &              nelmdg,accm,mdof_sol)
            else
               call solve_dual(neq_primary,neq,a,b,bp,nmat,nmat,nrhs,
     &              nelm,nelm_primary,nelm_primary,north,tollr,irb,iirb,
     &              npvt,gmres,dum,piv,h,c,ss,g,y,iter,iback,2,iptty,
     &              maxor,igdpm,maxgdpmlayers,ngdpm_layers,nelmdg,
     &              accm,mdof_sol)
            end if
         endif
	   deallocate(dum)
         itert=itert+iter
         itotals=itotals+iter
         minkt=minkt+mink
      else

         allocate(sto5(neq,2))
         allocate(dum(neq*8))
         if (igauss .gt. 1) then
            call rdof_new(neq,a,b,bp,nmat,nb,nrhs,nelm,nop,north
     *           ,tollr,irb,iirb,npvt,gmres,dum,piv
     *           ,h,c,ss,g,y,iter,iback,2,iptty,maxor
     *           ,overf,irdof,icoupl,0,sto5,accm)
         else
            call rdof_new(neq,a,b,bp,nmat,nmat,nrhs,nelm,nelm,north
     *           ,tollr,irb,iirb,npvt,gmres,dum,piv
     *           ,h,c,ss,g,y,iter,iback,2,iptty,maxor
     *           ,overf,irdof,icoupl,0,sto5,accm)
         end if
         deallocate(sto5)
         deallocate(dum)

         itert=itert+iter
         itotals=itotals+iter
         minkt=minkt+mink
      endif

      call storage_derivatives(0,1)
      if(islord.ne.0) call switch(nmat,nmatb,islord,2,2,nsizea1)
      if(islord.ne.0) call switchb(bp,nrhs,nrhsb,islord,2,2,neq)
      call dual(11)

 999  continue

      return
      end
c.............................................................

      subroutine extract_adiag
c s kelkar 3/20/12. extract diagonal elements of 'a'
      use comai, only : neq
      use combi, only : nelmdg
      use comei, only : a
      use davidi, only : nmat
      implicit none

      integer idisk

      real*8 adiagsk(2*neq)

      do idisk=1,neq
         adiagsk(idisk) = a(nelmdg(idisk)-neq-1+nmat(1))
         adiagsk(idisk+neq) = a(nelmdg(idisk)-neq-1+nmat(4))
      enddo

      return
      end
c...........................................................

      subroutine extract_nodal_equations(idisk)
c s kelkar 3/20/12. extract rows of a corrosponding
c to the node is]disk from the 'a' matrix
      use comai, only : neq, ierr, l
      use combi, only : nelmdg, nelm
      use comei, only : a
      use comgi, only : bp
      use davidi, only : nmat, nrhs
      implicit none

      integer idisk,iblock, jdisk, indsk,ii1,ii2, j,k,iq
      integer neqp1
      integer kbsk(20), inda, kbp

      real*8 aeqsk(20,4)

      neqp1=neq+1

      ii1=nelm(idisk)+1
      ii2=nelm(idisk+1)

      iq=0
      do j=ii1,ii2
         iq=iq+1
         kbsk(iq)=nelm(j)
         do k=1,4
            inda = j-neqp1+nmat(k)
            aeqsk(iq,k)=a(inda)
         enddo
      enddo

      write(ierr,*)' Time step is:', l
      write(ierr,*)' Node I: ', idisk
      write(ierr,*)(kbsk(j),j=1,iq)
 9991 format(30(2x,i10))
      do k=1,4
         kbp=1
         if(k.gt.2)kbp=2
         write(ierr,9992)(aeqsk(j,k),j=1,iq),bp(nrhs(kbp)+idisk)
      enddo
 9992 format(30(2x,g12.5))

      return
      end
c...........................................................


C-----------------------------------------------------------------------
C  Naval Observatory Vector Astrometry Software (NOVAS)
C  C Edition, Version 3.1
C
C  jplint.f: Interface to JPL ephemeris-access software use w/ solsys2.c
C
C  U. S. Naval Observatory
C  Astronomical Applications Dept.
C  Washington, DC
C  http://www.usno.navy.mil/USNO/astronomical-applications
C-----------------------------------------------------------------------

C-----------------------------------------------------------------------
      SUBROUTINE jplint (tjdtdb,target,center, posvel,error)
C
C---PURPOSE:    To serve as the interface between the JPL Fortran
C               code that accesses the solar system ephemerides; returns
C               the position and velocity of the body at the input time.
C
C---REFERENCES: JPL. 2007, "JPL Planetary and Lunar Ephemerides: Export
C                   Information," (Pasadena, CA: JPL)
C                   http://ssd.jpl.nasa.gov/?planet_eph_export.
C
C---INPUT
C   ARGUMENTS:  tjdtdb = TDB Julian date at which the body's position
C                        and velocity is desired.
C                        (Double precision)
C               target = Body identification number for the "target"
C                        point;  Mercury = 1,...,Pluto = 9,
C                        Moon = 10, Sun = 11, Solar system barycenter =
C                        12, Earth-Moon barycenter = 13.
C                        (Integer)
C               center = Body identification number for the "origin"
C                        point;  Mercury = 1,...,Pluto = 9,
C                        Moon = 10, Sun = 11, Solar system barycenter =
C                        12, Earth-Moon barycenter = 13.
C                        (Integer)
C
C---OUTPUT
C   ARGUMENTS:  posvel = Array containing the position and velocity
C                        components (rectangular coordinates on the
C                        equator and equinox of J2000.0) of 'target'
C                        relative to 'origin'.  The units are AU and
C                        AU/day, respectively.
C
C---COMMON
C   BLOCKS:     None.
C
C---ROUTINES
C   CALLED:     SUBROUTINE const (JPL supplied)
C               SUBROUTINE pleph (JPL supplied)
C
C---VER./DATE/
C   PROGRAMMER: V1.0/10-97/JAB (USNO/AA)
C               V1.1/10-10/JLB (USNO/AA) update references
C
C---NOTES:      1. The arguments of JPL subroutine 'pleph' have changed
C                  several times over the course of years.  This
C                  subroutine ('jplint') supports the version supplied by
C                  JPL in their software package provided on the 1997
C                  CD-ROM (see reference).
C               2. Any future changes to the JPL arguments should be
C                  accomodated in this subroutine ('jplint'), keeping
C                  its arguments constant.  This should minimize impact
C                  on the calling program.
C
C-----------------------------------------------------------------------

C-----'cdim' is simply an upper limit on the number of constants stored
C     in the ephemeris header.  It can be adjusted when the actual value
C     ('nvals') is known.

      INTEGER cdim
      PARAMETER (cdim = 400)

      CHARACTER name(cdim)*6

      INTEGER target, center, nvals, error, i

      DOUBLE PRECISION tjdtdb, limits(3), value(cdim), posvel(6)

C-----Call JPL subroutine 'const' to get the time limits of the
C     ephemeris.

      CALL const ( name,value,limits,nvals)

C-----Check that the input time is within the ephemeris limits.
C     Return the position and velocity of the body if it is.

      IF ((tjdtdb .LT. limits(1)) .OR. (tjdtdb .GT. limits(2))) THEN
         error = 1
         DO 10 i = 1,6
            posvel(i) = 0.0d0
   10    CONTINUE
       ELSE
         error = 0
         CALL pleph (tjdtdb,target,center, posvel)
      END IF

      RETURN
      END

C-----------------------------------------------------------------------
      SUBROUTINE jplihp (tjdtdb,target,center, posvel,error)
C
C---PURPOSE:    To serve as the interface between the JPL Fortran
C               code that accesses the solar system ephemerides; returns
C               the position and velocity of the body at the input time.
C
C---REFERENCES: JPL. 2007, "JPL Planetary and Lunar Ephemerides: Export
C                   Information," (Pasadena, CA: JPL)
C                   http://ssd.jpl.nasa.gov/?planet_eph_export.
C
C---INPUT
C   ARGUMENTS:  tjdtdb = Array containing the TDB Julian date at which
C                        the body's position and velocity is desired.
C                        The Julian date may be split any way (although
C                        the first element is usually the "integer"
C                        part, and the second element is the
C                        "fractional" part).  (Double precision)
C               target = Body identification number for the "target"
C                        point;  Mercury = 1,...,Pluto = 9,
C                        Moon = 10, Sun = 11, Solar system barycenter =
C                        12, Earth-Moon barycenter = 13.
C                        (Integer)
C               center = Body identification number for the "origin"
C                        point;  Mercury = 1,...,Pluto = 9,
C                        Moon = 10, Sun = 11, Solar system barycenter =
C                        12, Earth-Moon barycenter = 13.
C                        (Integer)
C
C---OUTPUT
C   ARGUMENTS:  posvel = Array containing the position and velocity
C                        components (rectangular coordinates on the
C                        equator and equinox of J2000.0) of 'target'
C                        relative to 'origin'.  The units are AU and
C                        AU/day, respectively.
C
C---COMMON
C   BLOCKS:     None.
C
C---ROUTINES
C   CALLED:     SUBROUTINE const (JPL supplied)
C               SUBROUTINE dpleph (JPL supplied)
C
C---VER./DATE/
C   PROGRAMMER: V1.0/12-06/JAB (USNO/AA)
C               V1.1/10-10/JLB (USNO/AA) update references
C
C---NOTES:      1. The arguments of JPL subroutine 'pleph' have changed
C                  several times over the course of years.  This
C                  subroutine ('jplihp') supports the version supplied by
C                  JPL in their software package provided on the 1997
C                  CD-ROM (see reference).
C               2. Any future changes to the JPL arguments should be
C                  accomodated in this subroutine ('jplihp'), keeping
C                  its arguments constant.  This should minimize impact
C                  on the calling program.
C
C-----------------------------------------------------------------------

C-----'cdim' is simply an upper limit on the number of constants stored
C     in the ephemeris header.  It can be adjusted when the actual value
C     ('nvals') is known.

      INTEGER cdim
      PARAMETER (cdim = 400)

      CHARACTER name(cdim)*6

      INTEGER target, center, nvals, error, i

      DOUBLE PRECISION tjdtdb(2), tjd, limits(3), value(cdim),
     . posvel(6)

C-----Call JPL subroutine 'const' to get the time limits of the
C     ephemeris.

      CALL const ( name,value,limits,nvals)

C-----Check that the input time is within the ephemeris limits.
C     Return the position and velocity of the body if it is.

      tjd = tjdtdb(1) + tjdtdb(2)
      IF ((tjd .LT. limits(1)) .OR. (tjd .GT. limits(2))) THEN
         error = 1
         DO 10 i = 1,6
            posvel(i) = 0.0d0
   10    CONTINUE
       ELSE
         error = 0
         CALL dpleph (tjdtdb,target,center, posvel)
      END IF

      RETURN
      END


      subroutine tpadv(aadh,aadhh,aadhv,aaphi,abdh,abdhh,abdhv,
     $ abdoth,abdot,abdotv,adadhh,adadhv,adbdhh,adbdhv,adbdth,adbdtv,
     $ adh,adhfe,adhh,adhv,adhfs,adhfsd,advfe,advfs,advfsd,afcnst,
     $ al10,amu,aslm,aphi,aprehw,apresg,apresh,apx,avcnst,axhfe,axhfs,
     $ axhfsd,axlke,axlks,axlksd,axvfe,axvfs,axvfsd,bdh,bdhh,bdhv,
     $ bdot,bdoth,bdotv,dadhh,dadhv,dbdhh,dbdhv,dbdth,dbdtv,dhfe,dhfs,
     $ dhfsd,dvfe,dvfs,dvfsd,eact,ehfac,farad,hact,iact,iapxmx,iktmax,
     $ imchmx,imech,iopg,iopt,ipbtmx,ipch,ipchmx,ipcv,ipcvmx,ixrn1,
     $ ixrn2,jpfcmx,jpress,jptffl,jsol,jtemp,narxmx,narxt,narxth,nbasp,
     $ nbaspd,nbt,nbtd,nbtmax,ncmpr,ndrsr,ndrsrd,nmut,nmutmx,nopgmx,
     $ noptmx,noutpt,nptkmx,nptmax,nrct,nrctmx,nrk,nslt,nsltmx,nst,
     $ nstmax,ntpr,ntprmx,ntprt,nttkmx,nttyo,nweope,nwndpc,nxt,nxtmax,
     $ pmu,presg,presh,press,pressb,pressd,pslamn,ptk,rcnstv,rconst,rk,
     $ rkb,rtcnst,tempc,tempcb,tempcd,tempcu,tempk,time1,trkb,ttk,
     $ uphase,uspec,wfac,xhfe,xhfs,xhfsd,xi1,xlke,xlks,xlksd,xvfe,
     $ xvfs,xvfsd)
c
c     This subroutine changes the temperature and pressure and
c     recomputes all temperature-pressure dependent data. Here tempcd
c     and pressd are the last temperature and pressure, respectively,
c     at which the data were evaluated.
c
c     This subroutine is called by:
c
c       EQ6/path.f
c       EQ6/eqshel.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer iapxmx,iktmax,imchmx,ipbtmx,ipchmx,ipcvmx,jpfcmx,narxmx,
     $ nbtmax,nmutmx,nopgmx,noptmx,nptkmx,nptmax,nrctmx,nsltmx,nstmax,
     $ ntprmx,nttkmx,nxtmax
c
      integer noutpt,nttyo
c
      integer iact(imchmx,2,nrctmx),imech(2,nrctmx),iopg(nopgmx),
     $ iopt(noptmx),jsol(nxtmax),narxt(ntprmx),narxth(2),nbasp(nbtmax),
     $ nbaspd(nbtmax),ncmpr(2,nptmax),ndrsr(2,nstmax),ndrsrd(2,nstmax),
     $ nrk(2,nrctmx)
c
      integer ipch,ipcv,ixrn1,ixrn2,jpress,jptffl,jtemp,nbt,nbtd,nmut,
     $ nrct,nslt,nst,ntpr,ntprt,nweope,nwndpc,nxt
c
      character*48 uspec(nstmax)
      character*24 uphase(nptmax)
c
      real*8 tempcu(ntprmx)
c
      real*8 aadh(narxmx,ntprmx),aadhh(narxmx,ntprmx),
     $ aadhv(narxmx,ntprmx),aaphi(narxmx,ntprmx),
     $ abdh(narxmx,ntprmx),abdhh(narxmx,ntprmx),abdhv(narxmx,ntprmx),
     $ abdot(narxmx,ntprmx),abdoth(narxmx,ntprmx),abdotv(narxmx,ntprmx),
     $ adadhh(narxmx,ntprmx,ipchmx),adadhv(narxmx,ntprmx,ipcvmx),
     $ adbdhh(narxmx,ntprmx,ipchmx),adbdhv(narxmx,ntprmx,ipcvmx),
     $ adbdth(narxmx,ntprmx,ipchmx),adbdtv(narxmx,ntprmx,ipcvmx),
     $ adhfe(narxmx,ntprmx,ipchmx),adhfs(narxmx,ntprmx,ipchmx,nstmax),
     $ adhfsd(narxmx,ntprmx,ipchmx,nstmax),advfe(narxmx,ntprmx,ipcvmx),
     $ advfs(narxmx,ntprmx,ipcvmx,nstmax),
     $ advfsd(narxmx,ntprmx,ipcvmx,nstmax),
     $ aprehw(narxmx,ntprmx),apresg(narxmx,ntprmx),apresh(5,2),
     $ axhfe(narxmx,ntprmx),axhfs(narxmx,ntprmx,nstmax),
     $ axhfsd(narxmx,ntprmx,nstmax),axlke(narxmx,ntprmx),
     $ axlks(narxmx,ntprmx,nstmax),axlksd(narxmx,ntprmx,nstmax),
     $ axvfe(narxmx,ntprmx),axvfs(narxmx,ntprmx,nstmax),
     $ axvfsd(narxmx,ntprmx,nstmax)
c
      real*8 dadhh(ipchmx),dadhv(ipcvmx),dbdhh(ipchmx),dbdhv(ipcvmx),
     $ dbdth(ipchmx),dbdtv(ipcvmx),dhfe(ipchmx),dhfs(ipchmx,nstmax),
     $ dhfsd(ipchmx,nstmax),dvfe(ipcvmx),dvfs(ipcvmx,nstmax),
     $ dvfsd(ipcvmx,nstmax),xhfs(nstmax),xhfsd(nstmax),xlks(nstmax),
     $ xlksd(nstmax),xvfs(nstmax),xvfsd(nstmax)
c
      real*8 adh,adhh,adhv,aphi,bdh,bdhh,bdhv,bdot,bdoth,bdotv,
     $ prehw,presg,presh,press,xhfe,xlke,xvfe
c
      real*8 amu(jpfcmx,nmutmx),aslm(jpfcmx,0:ipbtmx,nsltmx),
     $ pmu(nmutmx),pslamn(0:ipbtmx,nsltmx)
c
      real*8 apx(iapxmx,nxtmax),wfac(iktmax,nxtmax)
c
      real*8 eact(imchmx,2,nrctmx),hact(imchmx,2,nrctmx),
     $ ptk(nptkmx),rk(imchmx,2,nrctmx),rkb(imchmx,2,nrctmx),
     $ trkb(imchmx,2,nrctmx),ttk(nttkmx)
c
      real*8 afcnst,al10,avcnst,ehfac,farad,pressb,pressd,rcnstv,
     $ rconst,rtcnst,tempc,tempcb,tempcd,tempk,time1,xi1
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer nwpclm
c
      logical qnewp,qnewt
c
      real*8 dp,dt,pxl,pxu,toldt,toldp
c
c-----------------------------------------------------------------------
c
c     nwpclm  = maximum number of repeated warnings regarding problems
c                associated with pressure corrections
c     nwndpc = number of warnings of no data to support pressure
c                corrections
c     nweope = number of warnings of excursions outside the recommended
c                pressure envelope
c
      data nwpclm /5/
c
c     toldt = tolerance for recalculating temperature-dependent data (C)
c     toldp = tolerance for recalculating pressure-dependent data (bars)
c
      data toldt / 1.e-4 /, toldp /1.e-4 /
c
c-----------------------------------------------------------------------
c
c     Compute the new temperature.
c
      call gtemp(afcnst,al10,iopt,jtemp,noptmx,noutpt,nttkmx,
     $ nttyo,rconst,rtcnst,tempc,tempcb,tempk,time1,ttk,xi1)
c
      dt = tempc - tempcd
      qnewt = .false.
      if (abs(dt) .gt. toldt) then
c
c       Determine the corresponding temperature range flag.
c
        call gntpr(ntpr,ntprmx,ntprt,tempc,tempcu)
c
        qnewt = .true.
c
c       Compute thermodynamic data for the current temperature.
c
        call evdata(aadh,aadhh,aadhv,aaphi,abdh,abdhh,abdhv,
     $  abdot,abdoth,abdotv,adadhh,adadhv,adbdhh,adbdhv,adbdth,adbdtv,
     $  adh,adhfe,adhh,adhv,adhfs,adhfsd,advfe,advfs,advfsd,afcnst,
     $  al10,amu,aslm,aphi,aprehw,apresg,apresh,apx,avcnst,axhfe,
     $  axhfs,axhfsd,axlke,axlks,axlksd,axvfe,axvfs,axvfsd,bdh,bdhh,
     $  bdhv,bdot,bdoth,bdotv,dadhh,dadhv,dbdhh,dbdhv,dbdth,dbdtv,
     $  dhfe,dhfs,dhfsd,dvfe,dvfs,dvfsd,ehfac,farad,iapxmx,iktmax,
     $  iopg,iopt,ipbtmx,ipch,ipchmx,ipcv,ipcvmx,ixrn1,ixrn2,jpfcmx,
     $  jptffl,jsol,narxmx,narxt,narxth,ncmpr,nmut,nmutmx,nopgmx,
     $  noptmx,noutpt,nptmax,nslt,nsltmx,nst,nstmax,ntpr,ntprmx,nttyo,
     $  nxt,nxtmax,pmu,prehw,presg,presh,press,pslamn,rconst,rcnstv,
     $  rtcnst,tempc,tempk,uphase,uspec,wfac,xhfe,xhfs,xhfsd,xlke,xlks,
     $  xlksd,xvfe,xvfs,xvfsd)
c
c       Compute kinetic data for the current temperature.
c
        call evratc(eact,hact,iact,imchmx,imech,nrct,nrctmx,nrk,
     $  rk,rkb,rtcnst,tempk,trkb)
c
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute the new pressure.
c
      call gpress(iopt,jpress,noptmx,noutpt,nptkmx,nttyo,presg,
     $ presh,press,pressb,time1,ptk,xi1)
c
c     Skip pressure corrections if the pressure is tracking on the
c     data file reference pressure curve.
c
      if (jpress .le. 0) go to 990
c
c     Skip pressure corrections if the temperature and pressure
c     haven't changed significantly.
c
      dp = press - pressd
      qnewp = abs(dp) .gt. toldp
      if (.not.qnewt .and. .not.qnewp) go to 990
c
c     Skip pressure corrections if the pressure happens to match the
c     data file reference pressure curve value.
c
      dp = press - presg
      if (abs(dp) .le. toldp) go to 990
c
c     Make pressure corrections, if the requisite data are available.
c
      if (ipcv .lt. 0) then
c
c       There are no data to support needed pressure corrections.
c
        if (nwndpc .le. nwpclm) then
          write (noutpt,1000) press,presg,dp
          write (nttyo,1000) press,presg,dp
 1000     format(/' * Warning - (EQ6/tpadv) The supporting data file',
     $    /7x,'contains no data to support making thermodynamic',
     $    /7x,'pressure corrections. No such corrections will be made.',
     $    /7x,'The current pressure is ',1pg12.5,' bars, the standard',
     $    /7x,'grid pressure is ',g12.5,' bars, and the pressure',
     $    /7x,'difference is ',g12.5,' bars.')
          if (nwndpc .eq. nwpclm) then
            write (noutpt,1010)
            write (nttyo,1010)
 1010       format(/' This warning will not be repeated during the',
     $      /7x,'rest of this run.')
          endif
          nwndpc = nwndpc + 1
        endif
      else
        if (abs(dp) .gt. prehw) then
c
c         The pressure is outside the recommended envelope.
c
          pxu = presg + prehw
          pxl = presg - prehw
          if (pxl .le. 0.) pxl = 0.
          write (noutpt,1020) press,pxl,pxu,tempc
          write (nttyo,1020) press,pxl,pxu,tempc
 1020     format(/' * Warning - (EQ6/tpadv) The current pressure',
     $    /7x,'of ',1pg12.5,' bars is outside the recommended',
     $    /7x,'pressure envelope of ',g12.5,' to ',g12.5,' bars',
     $    /7x,'at ',0pf6.2,' C.')
          if (nweope .eq. nwpclm) then
            write (noutpt,1010)
            write (nttyo,1010)
          endif
          nweope = nweope + 1
        endif
c
c       Make pressure corrections to the thermodynamic data.
c
        call pcorrx(avcnst,dhfs,dvfs,ipch,ipchmx,ipcv,ipcvmx,
     $  nbasp,nbt,nbtmax,ndrsr,nst,nstmax,presg,press,xhfs,
     $  xlks,xvfs)
c
c       Calling sequence substitutions:
c         dhfsd for dhfs
c         dvfsd for dvfs
c         nbaspd for nbasp
c         nbtd for nbt
c         ndrsrd for ndrsr
c         xhfsd for xhfs
c         xlksd for xlks
c         xvfsd for xvfs
c
        call pcorrx(avcnst,dhfsd,dvfsd,ipch,ipchmx,ipcv,ipcvmx,
     $  nbaspd,nbtd,nbtmax,ndrsrd,nst,nstmax,presg,press,xhfsd,
     $  xlksd,xvfsd)
c
c       Make pressure corrections to the kinetic data.
c
c         Presently there are no such corrections.
c
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  990 tempcd = tempc
      pressd = press
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
c
      end