*DECK SSIDI
      SUBROUTINE SSIDI (A, LDA, N, KPVT, DET, INERT, WORK, JOB)
C***BEGIN PROLOGUE  SSIDI
C***PURPOSE  Compute the determinant, inertia and inverse of a real
C            symmetric matrix using the factors from SSIFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1A, D3B1A
C***TYPE      SINGLE PRECISION (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
C             SYMMETRIC
C***AUTHOR  Bunch, J., (UCSD)
C***DESCRIPTION
C
C     SSIDI computes the determinant, inertia and inverse
C     of a real symmetric matrix using the factors from SSIFA.
C
C     On Entry
C
C        A       REAL(LDA,N)
C                the output from SSIFA.
C
C        LDA     INTEGER
C                the leading dimension of the array A.
C
C        N       INTEGER
C                the order of the matrix A.
C
C        KPVT    INTEGER(N)
C                the pivot vector from SSIFA.
C
C        WORK    REAL(N)
C                work vector.  Contents destroyed.
C
C        JOB     INTEGER
C                JOB has the decimal expansion  ABC  where
C                   If  C .NE. 0, the inverse is computed,
C                   If  B .NE. 0, the determinant is computed,
C                   If  A .NE. 0, the inertia is computed.
C
C                For example, JOB = 111  gives all three.
C
C     On Return
C
C        Variables not requested by JOB are not used.
C
C        A      contains the upper triangle of the inverse of
C               the original matrix.  The strict lower triangle
C               is never referenced.
C
C        DET    REAL(2)
C               determinant of original matrix.
C               Determinant = DET(1) * 10.0**DET(2)
C               with 1.0 .LE. ABS(DET(1)) .LT. 10.0
C               or DET(1) = 0.0.
C
C        INERT  INTEGER(3)
C               the inertia of the original matrix.
C               INERT(1)  =  number of positive eigenvalues.
C               INERT(2)  =  number of negative eigenvalues.
C               INERT(3)  =  number of zero eigenvalues.
C
C     Error Condition
C
C        A division by zero may occur if the inverse is requested
C        and  SSICO  has set RCOND .EQ. 0.0
C        or  SSIFA  has set  INFO .NE. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SCOPY, SDOT, SSWAP
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891107  Modified routine equivalence list.  (WRB)
C   891107  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SSIDI
      INTEGER LDA,N,JOB
      REAL A(LDA,*),WORK(*)
      REAL DET(2)
      INTEGER KPVT(*),INERT(3)
C
      REAL AKKP1,SDOT,TEMP
      REAL TEN,D,T,AK,AKP1
      INTEGER J,JB,K,KM1,KS,KSTEP
      LOGICAL NOINV,NODET,NOERT
C***FIRST EXECUTABLE STATEMENT  SSIDI
      NOINV = MOD(JOB,10) .EQ. 0
      NODET = MOD(JOB,100)/10 .EQ. 0
      NOERT = MOD(JOB,1000)/100 .EQ. 0
C
      IF (NODET .AND. NOERT) GO TO 140
         IF (NOERT) GO TO 10
            INERT(1) = 0
            INERT(2) = 0
            INERT(3) = 0
   10    CONTINUE
         IF (NODET) GO TO 20
            DET(1) = 1.0E0
            DET(2) = 0.0E0
            TEN = 10.0E0
   20    CONTINUE
         T = 0.0E0
         DO 130 K = 1, N
            D = A(K,K)
C
C           CHECK IF 1 BY 1
C
            IF (KPVT(K) .GT. 0) GO TO 50
C
C              2 BY 2 BLOCK
C              USE DET (D  S)  =  (D/T * C - T) * T  ,  T = ABS(S)
C                      (S  C)
C              TO AVOID UNDERFLOW/OVERFLOW TROUBLES.
C              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG.
C
               IF (T .NE. 0.0E0) GO TO 30
                  T = ABS(A(K,K+1))
                  D = (D/T)*A(K+1,K+1) - T
               GO TO 40
   30          CONTINUE
                  D = T
                  T = 0.0E0
   40          CONTINUE
   50       CONTINUE
C
            IF (NOERT) GO TO 60
               IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1
               IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1
               IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1
   60       CONTINUE
C
            IF (NODET) GO TO 120
               DET(1) = D*DET(1)
               IF (DET(1) .EQ. 0.0E0) GO TO 110
   70             IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80
                     DET(1) = TEN*DET(1)
                     DET(2) = DET(2) - 1.0E0
                  GO TO 70
   80             CONTINUE
   90             IF (ABS(DET(1)) .LT. TEN) GO TO 100
                     DET(1) = DET(1)/TEN
                     DET(2) = DET(2) + 1.0E0
                  GO TO 90
  100             CONTINUE
  110          CONTINUE
  120       CONTINUE
  130    CONTINUE
  140 CONTINUE
C
C     COMPUTE INVERSE(A)
C
      IF (NOINV) GO TO 270
         K = 1
  150    IF (K .GT. N) GO TO 260
            KM1 = K - 1
            IF (KPVT(K) .LT. 0) GO TO 180
C
C              1 BY 1
C
               A(K,K) = 1.0E0/A(K,K)
               IF (KM1 .LT. 1) GO TO 170
                  CALL SCOPY(KM1,A(1,K),1,WORK,1)
                  DO 160 J = 1, KM1
                     A(J,K) = SDOT(J,A(1,J),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1)
  160             CONTINUE
                  A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1)
  170          CONTINUE
               KSTEP = 1
            GO TO 220
  180       CONTINUE
C
C              2 BY 2
C
               T = ABS(A(K,K+1))
               AK = A(K,K)/T
               AKP1 = A(K+1,K+1)/T
               AKKP1 = A(K,K+1)/T
               D = T*(AK*AKP1 - 1.0E0)
               A(K,K) = AKP1/D
               A(K+1,K+1) = AK/D
               A(K,K+1) = -AKKP1/D
               IF (KM1 .LT. 1) GO TO 210
                  CALL SCOPY(KM1,A(1,K+1),1,WORK,1)
                  DO 190 J = 1, KM1
                     A(J,K+1) = SDOT(J,A(1,J),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1)
  190             CONTINUE
                  A(K+1,K+1) = A(K+1,K+1) + SDOT(KM1,WORK,1,A(1,K+1),1)
                  A(K,K+1) = A(K,K+1) + SDOT(KM1,A(1,K),1,A(1,K+1),1)
                  CALL SCOPY(KM1,A(1,K),1,WORK,1)
                  DO 200 J = 1, KM1
                     A(J,K) = SDOT(J,A(1,J),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1)
  200             CONTINUE
                  A(K,K) = A(K,K) + SDOT(KM1,WORK,1,A(1,K),1)
  210          CONTINUE
               KSTEP = 2
  220       CONTINUE
C
C           SWAP
C
            KS = ABS(KPVT(K))
            IF (KS .EQ. K) GO TO 250
               CALL SSWAP(KS,A(1,KS),1,A(1,K),1)
               DO 230 JB = KS, K
                  J = K + KS - JB
                  TEMP = A(J,K)
                  A(J,K) = A(KS,J)
                  A(KS,J) = TEMP
  230          CONTINUE
               IF (KSTEP .EQ. 1) GO TO 240
                  TEMP = A(KS,K+1)
                  A(KS,K+1) = A(K,K+1)
                  A(K,K+1) = TEMP
  240          CONTINUE
  250       CONTINUE
            K = K + KSTEP
         GO TO 150
  260    CONTINUE
  270 CONTINUE
      RETURN
      END


    Program dtrsna_example

!     DTRSNA Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dlange, dtrevc, dtrsna
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eps, tnorm
      Integer :: i, info, ldt, ldvl, ldvr, ldwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: s(:), sep(:), t(:, :), vl(:, :), &
        vr(:, :), work(:, :)
      Integer, Allocatable :: iwork(:)
      Logical :: select(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DTRSNA Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldt = n
      ldvl = n
      ldvr = n
      ldwork = n
      Allocate (s(n), sep(n), t(ldt,n), vl(ldvl,n), vr(ldvr,n), &
        work(ldwork,n+6), iwork(2*n-1))

!     Read T from data file

      Read (nin, *)(t(i,1:n), i=1, n)

!     Calculate the left and right eigenvectors of T

      Call dtrevc('Both', 'All', select, n, t, ldt, vl, ldvl, vr, ldvr, n, m, &
        work, info)

!     Estimate condition numbers for all the eigenvalues and right
!     eigenvectors of T

      Call dtrsna('Both', 'All', select, n, t, ldt, vl, ldvl, vr, ldvr, s, &
        sep, n, m, work, ldwork, iwork, info)

!     Print condition numbers of eigenvalues and right eigenvectors

      Write (nout, *) 'S'
      Write (nout, 100) s(1:m)
      Write (nout, *)
      Write (nout, *) 'SEP'
      Write (nout, 100) sep(1:m)

!     Calculate approximate error estimates (using the 1-norm)

      eps = epsilon(1.0E0_dp)
      tnorm = dlange('1-norm', n, n, t, ldt, work)
      Write (nout, *)
      Write (nout, *) 'Approximate error estimates for eigenvalues ', &
        'of T (machine-dependent)'
      Write (nout, 100)(eps*tnorm/s(i), i=1, m)
      Write (nout, *)
      Write (nout, *) 'Approximate error estimates for right ', &
        'eigenvectors of T (machine-dependent)'
      Write (nout, 100)(eps*tnorm/sep(i), i=1, m)

100   Format ((3X,1P,7E11.1))
    End Program


C++*****************************************************************
C Program magni_int
C to compute integrated magnitudes of the shells
C
C JLP
C Version 30-03-89
C--*****************************************************************
	PROGRAM MAGNI_INT
	REAL MAGNI,XINT
	PRINT 20
20	FORMAT(' Program MAGNI_INT, to compute total',
     1	' magnitude of the shells',/,
     1	' Enter the integrated magnitude of the',
     1	' shells,    (one by one, and enter 0 to exit) : ')

	XINT=0.

300	PRINT 40
40	FORMAT (' ==: ',$)
	READ(5,*) MAGNI
	IF(MAGNI.NE.0.)THEN
	  XINT = 10**(-0.4*MAGNI) + XINT
	  GO TO 300
	ENDIF

	MAGNI=-2.5*LOG10(XINT)
	PRINT *,' ==> Total magnitude: ',MAGNI
	STOP
	END


c colorrgb
      include 'VICMAIN_FOR'
      subroutine main44
      parameter (maxns=30000,maxpix=10,maxcolors=30)

      integer*4 inunit(maxpix),outunit(3),def,nl,ns,status
      integer*4 line(maxcolors),samp(maxcolors)
      real*4 buf(maxns,maxpix),obuf(maxns,3)
      real*4 red_target(maxcolors),green_target(maxcolors)
      real*4 rpar(maxcolors*5),blue_target(maxcolors)
      real*4 dn(maxpix,maxcolors)
      real*8 c(maxcolors,maxpix+1),cl(maxcolors),wts(maxcolors)
      real*8 red_coef(maxpix+1),green_coef(maxpix+1)
      real*8 blue_coef(maxpix+1),r,g,b

c parameters
      call xveaction('SA',' ')
      call xvpcnt('INP',nin)
      call xvparm('COLOR',rpar,npar,def,300)
      call xvparm('AREA',nlw,n,def,maxcolors)
      if(npar.gt.0)then
        ncolors=npar/5
        if(ncolors.lt.nin+2)then
          write(*,*)'Requires at least ',nin+2,' colors'
          call abend()
        endif
        if(ncolors*5.ne.npar)then
          write(*,*)'Incorrect number of color parameters'
          call abend()
        endif
        write(*,*)'Data from parameters:'
        write(*,*)' color line  sample    red    green      blue'
        k=1
        do i=1,ncolors
          line(i)=nint(rpar(k))
          k=k+1
          samp(i)=nint(rpar(k))
          k=k+1
          red_target(i)=rpar(k)
          k=k+1
          green_target(i)=rpar(k)
          k=k+1
          blue_target(i)=rpar(k)
          k=k+1
          write(*,10)i,line(i),samp(i),red_target(i),green_target(i),
     +      blue_target(i)
        enddo
10      format(3i6,3f10.2)
      else
        ncolors=0
      endif

c open all inputs
      do i=1,nin
        call xvunit(inunit(i),'INP',i,status,' ')
        call xvopen(inunit(i),status,'U_FORMAT','REAL',' ')
        if(i.eq.1)then
          call xvget(inunit(i),status,'NL',nl,'NS',ns,' ')
          if(ns.gt.maxns)then
            call xvmessage('Input image line too long',' ')
            call abend
          endif
        endif
      enddo

c open all outputs
      do i=1,3
        call xvunit(outunit(i),'OUT',i,status,' ')
        call xvopen(outunit(i),status,'O_FORMAT','BYTE',
     +    'U_FORMAT','REAL','OP','WRITE',' ')
      enddo

c read cal file
      if(ncolors.eq.0)then
        write(*,*)'Reading calibration file'
        nu=nin+1
        call read_calibration_file(red_coef,green_coef,blue_coef,nin+1)
        goto 50
      endif

c get the input dn's
      write(*,*)' color  Dn values from the images -->'
      do i=1,ncolors
        do j=1,nin
          sum=0.0
          isum=0
          do m=line(i)-nlw/2,line(i)+nlw/2
            call xvread(inunit(j),buf(1,j),status,'LINE',m,' ')
            do n=samp(i)-nlw/2,samp(i)+nlw/2
              isum=isum+1
              sum=sum+buf(n,j)
            enddo
          enddo
          dn(j,i)=sum/isum
        enddo
        write(*,11)i,(dn(j,i),j=1,nin)
      enddo
11    format(i6,11f9.1)

c solve for the least squares relation between input and target color.
c target_color=c1*dn1+c2*dn2+...+cn*dnn+c
      ne=ncolors
      nu=nin+1
      do i=1,ncolors
        do j=1,nin
          c(i,j)=dn(j,i)
          cl(i)=red_target(i)
          wts(i)=1.d0
        enddo
        c(i,nu)=1.d0
      enddo
      call lsqp(ind,ne,nu,c,cl,wts,red_coef,maxcolors)
      if(ind.ne.0)then
        write(*,*)'Singular solution for red'
        stop
      endif
      do i=1,ncolors
        cl(i)=green_target(i)
      enddo
      call lsqp(ind,ne,nu,c,cl,wts,green_coef,maxcolors)
      if(ind.ne.0)then
        write(*,*)'Singular solution for green'
        stop
      endif
      do i=1,ncolors
        cl(i)=blue_target(i)
      enddo
      call lsqp(ind,ne,nu,c,cl,wts,blue_coef,maxcolors)
      if(ind.ne.0)then
        write(*,*)'Singular solution for blue'
        stop
      endif

c write results
      write(*,*)'Writing calibration file'
      call write_calibration_file(red_coef,green_coef,blue_coef,nin+1)

50    continue
c create output r g b.
      do j=1,nl
        do k=1,nin
          call xvread(inunit(k),buf(1,k),status,'LINE',j,' ')
        enddo
        do i=1,ns
          r=red_coef(nu)
          g=green_coef(nu)
          b=blue_coef(nu)
          do k=1,nin
            r=r+red_coef(k)*buf(i,k)
            g=g+green_coef(k)*buf(i,k)
            b=b+blue_coef(k)*buf(i,k)
          enddo
          if(r.lt.0.0)r=0.0
          if(r.gt.255.)r=255.
          if(g.lt.0.0)g=0.0
          if(g.gt.255.)g=255.
          if(b.lt.0.0)b=0.0
          if(b.gt.255.)b=255.
          obuf(i,1)=r
          obuf(i,2)=g
          obuf(i,3)=b
        enddo
        do k=1,3
          call xvwrit(outunit(k),obuf(1,k),status,'LINE',j,' ')
        enddo
      enddo

      return
      end

c***********************************************************************
      subroutine read_calibration_file(
     + coefX,coefY,coefZ,ntable)
      real*8 coefX(ntable),coefY(ntable),coefZ(ntable)

      open(unit=10,file='color_calibration.txt',
     + access='SEQUENTIAL',
     + form='FORMATTED',iostat=ios,status='OLD')
      if(ios.gt.0)then
        write(*,*)'cannot open calibration file:'
        write(*,*)'color_calibration.txt'
        stop
      endif

      read(unit=10,fmt=*,iostat=ios) (coefX(i),i=1,ntable)
      if(ios.gt.0)then
        write(*,*)'read error on calibration file'
        stop
      endif
      if(ios.lt.0)then  ! EOF
        write(*,*)'EOF error on calibration file'
        stop
      endif

      read(unit=10,fmt=*,iostat=ios) (coefY(i),i=1,ntable)
      if(ios.gt.0)then
        write(*,*)'read error on calibration file'
        stop
      endif
      if(ios.lt.0)then  ! EOF
        write(*,*)'EOF error on calibration file'
        stop
      endif

      read(unit=10,fmt=*,iostat=ios) (coefZ(i),i=1,ntable)
      if(ios.gt.0)then
        write(*,*)'read error on calibration file'
        stop
      endif
      if(ios.lt.0)then  ! EOF
        write(*,*)'EOF error on calibration file'
        stop
      endif

      close(unit=10)
      return
      end

c***********************************************************************
      subroutine write_calibration_file(
     +   coefX,coefY,coefZ,ntable)
      real*8 coefX(ntable),coefY(ntable),coefZ(ntable)

      open(unit=10,file='color_calibration.txt',
     + access='SEQUENTIAL',
     + form='FORMATTED',iostat=ios,status='UNKNOWN')
      if(ios.gt.0)then
        write(*,*)'cannot open calibration file'
        stop
      endif

      write(unit=10,fmt=*,iostat=ios) (coefX(i),i=1,ntable)
      if(ios.gt.0)then
        write(*,*)'read error on calibration file'
        stop
      endif
      if(ios.lt.0)then  ! EOF
        write(*,*)'EOF error on calibration file'
        stop
      endif

      write(unit=10,fmt=*,iostat=ios) (coefY(i),i=1,ntable)
      if(ios.gt.0)then
        write(*,*)'read error on calibration file'
        stop
      endif
      if(ios.lt.0)then  ! EOF
        write(*,*)'EOF error on calibration file'
        stop
      endif

      write(unit=10,fmt=*,iostat=ios) (coefZ(i),i=1,ntable)
      if(ios.gt.0)then
        write(*,*)'read error on calibration file'
        stop
      endif
      if(ios.lt.0)then  ! EOF
        write(*,*)'EOF error on calibration file'
        stop
      endif

      close(unit=10)
      return
      end

c***********************************************************************
      SUBROUTINE LSQP(ind,NE,NU,C,CL,wts,X1,len)
C
C1    GENERAL LEAST SQUARES SOLUTION OF NE EQUATIONS WITH NU UNKNOWNS,
C     C(I,1)*X1(1)+C(I,2)*X1(2)+...+C(I,NU)=CL(I) OF EQUAL WEIGHTS,WITH
C     I RANGING FROM 1 TO NE.
C
C2    THE INFORMATION FROM THE MAIN PROGRAM IS:
C          C(I,J) = COEFFICIENT MATRIX
C          CL(I) = ARRAY OF FREE TERMS
C          NE = NUMBER OF EQUATIONS
C          NU=NUMBER OF UNKNOWNS
c          wts=weight for each input point
C
C3    THE INFORMATION RETURNED TO THE MAIN PROGRAM IS:
C          X1(J) = COMPUTED VALUES OF THE UNKNOWNS
C
C5    ALL THE STATEMENTS BELOW ARE VALID FOR ANY NU LARGER THAN 1 AND
C     ANY NE LARGER THAN NU.
C
      parameter (id=11)
      REAL*8  A(id,id),AL(id),R(id,id),RL(id)
      real*8 Q(id,id),X(id),SUM
      REAL*8 C(len,id),CL(len),X1(id),wts(len)

      ind=0
      DO 57 J = 1,NU
      DO 57 I=1,NU
      A(I,J)=0.
      R(I,J)=0.
57    Q(I,J)=0.
      DO 100 I=1,NU
      DO 100 J=1,NU
      DO 100 K=1,NE
100   A(I,J)=A(I,J)+C(K,I)*C(K,J)*wts(k)
      DO 102 I=1,NU
      AL(I)=0.
      DO 102 K=1,NE
102   AL(I)=AL(I)+C(K,I)*CL(K)*wts(k)
      NUM=NU-1
      NUP=NU+1
      DO 110 I=1,NUM
      K=I+1
      DO 110 J=K,NU
      if(a(i,i).eq.0.d0)goto 999
      R(I,J)=A(I,J)/A(I,I)
      DO 110 L=1,I
110   A(K,J)=A(K,J)-R(L,K)*A(L,J)
      if(a(1,1).eq.0.d0)goto 999
      RL(1)=AL(1)/A(1,1)
      DO 125 I=2,NU
      DO 122 J=1,I
122   AL(I)=AL(I)-R(J,I)*AL(J)
      if(a(i,i).eq.0.d0)goto 999
125   RL(I)=AL(I)/A(I,I)
       X(NU)=RL(NU)
      DO 131 I=1,NUM
      IX=NU-I
      IXI=IX+1
      SUM=0.
      DO 130 J=IXI,NU
130   SUM=SUM-R(IX,J)* X(J)
131    X(IX)=RL(IX)+SUM
      DO 200 J=1,NU
200   X1(J)=X(J)
      RETURN
999   ind=1
      return
      END


module module_rational

  implicit none
  private
  public :: rational
  public :: rational_simplify
  public :: assignment (=)
  public :: operator (//)
  public :: operator (+)
  public :: operator (-)
  public :: operator (*)
  public :: operator (/)
  public :: operator (<)
  public :: operator (<=)
  public :: operator (>)
  public :: operator (>=)
  public :: operator (==)
  public :: operator (/=)
  public :: abs
  public :: int
  public :: modulo
  type rational
    integer :: numerator
    integer :: denominator
  end type rational
  interface assignment (=)
    module procedure assign_rational_int, assign_rational_real
  end interface
  interface operator (//)
    module procedure make_rational
  end interface
  interface operator (+)
    module procedure rational_add
  end interface
  interface operator (-)
    module procedure rational_minus, rational_subtract
  end interface
  interface operator (*)
    module procedure rational_multiply
  end interface
  interface operator (/)
    module procedure rational_divide
  end interface
  interface operator (<)
    module procedure rational_lt
  end interface
  interface operator (<=)
    module procedure rational_le
  end interface
  interface operator (>)
    module procedure rational_gt
  end interface
  interface operator (>=)
    module procedure rational_ge
  end interface
  interface operator (==)
    module procedure rational_eq
  end interface
  interface operator (/=)
    module procedure rational_ne
  end interface
  interface abs
    module procedure rational_abs
  end interface
  interface int
    module procedure rational_int
  end interface
  interface modulo
    module procedure rational_modulo
  end interface

contains

  recursive function gcd (i, j) result (res)
    integer, intent (in) :: i
    integer, intent (in) :: j
    integer :: res
    if (j == 0) then
      res = i
    else
      res = gcd (j, modulo (i, j))
    end if
  end function gcd

  function rational_simplify (r) result (res)
    type (rational), intent (in) :: r
    type (rational) :: res
    integer :: g
    g = gcd (r % numerator, r % denominator)
    res = r % numerator / g // r % denominator / g
  end function rational_simplify

  function make_rational (numerator, denominator) result (res)
    integer, intent (in) :: numerator
    integer, intent (in) :: denominator
    type (rational) :: res
    res = rational (numerator, denominator)
  end function make_rational

  subroutine assign_rational_int (res, i)
    type (rational), intent (out), volatile :: res
    integer, intent (in) :: i
    res = i // 1
  end subroutine assign_rational_int

  subroutine assign_rational_real (res, x)
    type (rational), intent(out), volatile :: res
    real, intent (in) :: x
    integer :: x_floor
    real :: x_frac
    x_floor = floor (x)
    x_frac = x - x_floor
    if (x_frac == 0) then
      res = x_floor // 1
    else
      res = (x_floor // 1) + (1 // floor (1 / x_frac))
    end if
  end subroutine assign_rational_real

  function rational_add (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    type (rational) :: res
    res = r % numerator * s % denominator + r % denominator * s % numerator // &
        & r % denominator * s % denominator
  end function rational_add

  function rational_minus (r) result (res)
    type (rational), intent (in) :: r
    type (rational) :: res
    res = - r % numerator // r % denominator
  end function rational_minus

  function rational_subtract (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    type (rational) :: res
    res = r % numerator * s % denominator - r % denominator * s % numerator // &
        & r % denominator * s % denominator
  end function rational_subtract

  function rational_multiply (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    type (rational) :: res
    res = r % numerator * s % numerator // r % denominator * s % denominator
  end function rational_multiply

  function rational_divide (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    type (rational) :: res
    res = r % numerator * s % denominator // r % denominator * s % numerator
  end function rational_divide

  function rational_lt (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    type (rational) :: r_simple
    type (rational) :: s_simple
    logical :: res
    r_simple = rational_simplify (r)
    s_simple = rational_simplify (s)
    res = r_simple % numerator * s_simple % denominator < &
        & s_simple % numerator * r_simple % denominator
  end function rational_lt

  function rational_le (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    type (rational) :: r_simple
    type (rational) :: s_simple
    logical :: res
    r_simple = rational_simplify (r)
    s_simple = rational_simplify (s)
    res = r_simple % numerator * s_simple % denominator <= &
        & s_simple % numerator * r_simple % denominator
  end function rational_le

  function rational_gt (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    type (rational) :: r_simple
    type (rational) :: s_simple
    logical :: res
    r_simple = rational_simplify (r)
    s_simple = rational_simplify (s)
    res = r_simple % numerator * s_simple % denominator > &
        & s_simple % numerator * r_simple % denominator
  end function rational_gt

  function rational_ge (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    type (rational) :: r_simple
    type (rational) :: s_simple
    logical :: res
    r_simple = rational_simplify (r)
    s_simple = rational_simplify (s)
    res = r_simple % numerator * s_simple % denominator >= &
        & s_simple % numerator * r_simple % denominator
  end function rational_ge

  function rational_eq (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    logical :: res
    res = r % numerator * s % denominator == s % numerator * r % denominator
  end function rational_eq

  function rational_ne (r, s) result (res)
    type (rational), intent (in) :: r
    type (rational), intent (in) :: s
    logical :: res
    res = r % numerator * s % denominator /= s % numerator * r % denominator
  end function rational_ne

  function rational_abs (r) result (res)
    type (rational), intent (in) :: r
    type (rational) :: res
    res = sign (r % numerator, r % denominator) // r % denominator
  end function rational_abs

  function rational_int (r) result (res)
    type (rational), intent (in) :: r
    integer :: res
    res = r % numerator / r % denominator
  end function rational_int

  function rational_modulo (r) result (res)
    type (rational), intent (in) :: r
    integer :: res
    res = modulo (r % numerator, r % denominator)
  end function rational_modulo

end module module_rational


! *****************************COPYRIGHT*******************************
! (C) Crown copyright Met Office. All rights reserved.
! For further details please refer to the file COPYRIGHT.txt
! which you should have received as part of this distribution.
! *****************************COPYRIGHT*******************************
!
! Physics which is used by the driver, e.g. a standard
! saturation calculation
!
!
Module common_physics

  Use typeKind
  Use physconst

  implicit none

  Interface qsaturation
     module procedure qsaturation_sp, qsaturation_dp
  end Interface

  Interface qisaturation
     module procedure qisaturation_sp, qisaturation_dp
  end Interface

contains

  REAL(SP) FUNCTION Qsaturation_sp (T, p)
    IMPLICIT NONE
    !
    ! Function to return the saturation mr over water
    ! Based on tetans formular
    ! QS=3.8/(P*EXP(-17.2693882*(T-273.15)/(T-35.86))-6.109)
    !
    real(sp), INTENT (IN) :: T, p
    ! Temperature in Kelvin
    ! Pressure in mb
    real(sp), PARAMETER::tk0c = 273.15, qsa1 = 3.8, qsa2 = - 17.2693882, &
         qsa3 = 35.86, qsa4 = 6.109
    ! Temperature of freezing in Kelvin
    ! Top in equation to calculate qsat
    ! Constant in qsat equation
    ! Constant in qsat equation
    ! Constant in qsat equation
    !
    if (T > qsa3 .and. p * EXP (qsa2 * (t - tk0c) / (T - qsa3) ) &
            > qsa4)then
       Qsaturation_sp = qsa1 / (p * EXP (qsa2 * (t - tk0c) / (T - qsa3) ) &
            - qsa4)
    else
       qsaturation_sp=0.
    end if

  END FUNCTION Qsaturation_sp

  REAL(DP) FUNCTION Qsaturation_dp (T, p)
    IMPLICIT NONE
    !
    ! Function to return the saturation mr over water
    ! Based on tetans formular
    ! QS=3.8/(P*EXP(-17.2693882*(T-273.15)/(T-35.86))-6.109)
    !
    real(dp), INTENT (IN) :: T, p
    ! Temperature in Kelvin
    ! Pressure in mb
    real(dp), PARAMETER::tk0c = 273.15, qsa1 = 3.8, qsa2 = - 17.2693882, &
         qsa3 = 35.86, qsa4 = 6.109
    ! Temperature of freezing in Kelvin
    ! Top in equation to calculate qsat
    ! Constant in qsat equation
    ! Constant in qsat equation
    ! Constant in qsat equation
    !
    if (T > qsa3 .and. p * EXP (qsa2 * (t - tk0c) / (T - qsa3) ) &
            > qsa4)then
       Qsaturation_dp = qsa1 / (p * EXP (qsa2 * (t - tk0c) / (T - qsa3) ) &
            - qsa4)
    else
       qsaturation_dp=0.
    end if

  END FUNCTION Qsaturation_dp

  REAL(SP) FUNCTION QIsaturation_sp (T, p)
    IMPLICIT NONE
    !
    ! Function to return the saturation mr over ice
    ! Based on tetans formular
    ! QS=3.8/(P*EXP(-21.8745584*(T-273.15)/(T-7.66))-6.109)
    !
    real(sp), INTENT (IN) :: T, p
    ! Temperature in Kelvin
    ! Pressure in mb
    real(sp), PARAMETER::tk0c = 273.15, qsa1 = 3.8, qsa2 = -21.8745584, &
         qsa3 = 7.66, qsa4 = 6.109
    ! Temperature of freezing in Kelvin
    ! Top in equation to calculate qsat
    ! Constant in qsat equation
    ! Constant in qsat equation
    ! Constant in qsat equation
    !
    if (T > qsa3 .and. p * EXP (qsa2 * (t - tk0c) / (T - qsa3) ) &
            > qsa4)then
       Qisaturation_sp = qsa1 / (p * EXP (qsa2 * (t - tk0c) / (T - qsa3) ) &
            - qsa4)
    else
       Qisaturation_sp=0.
    end if

  End FUNCTION QIsaturation_sp

  REAL(DP) FUNCTION QIsaturation_dp (T, p)
    IMPLICIT NONE
    !
    ! Function to return the saturation mr over ice
    ! Based on tetans formular
    ! QS=3.8/(P*EXP(-21.8745584*(T-273.15)/(T-7.66))-6.109)
    !
    real(dp), INTENT (IN) :: T, p
    ! Temperature in Kelvin
    ! Pressure in mb
    real(dp), PARAMETER::tk0c = 273.15, qsa1 = 3.8, qsa2 = -21.8745584, &
         qsa3 = 7.66, qsa4 = 6.109
    ! Temperature of freezing in Kelvin
    ! Top in equation to calculate qsat
    ! Constant in qsat equation
    ! Constant in qsat equation
    ! Constant in qsat equation
    !
    if (T > qsa3 .and. p * EXP (qsa2 * (t - tk0c) / (T - qsa3) ) &
            > qsa4)then
       Qisaturation_dp = qsa1 / (p * EXP (qsa2 * (t - tk0c) / (T - qsa3) ) &
            - qsa4)
    else
       Qisaturation_dp=0.
    end if

  End FUNCTION QIsaturation_dp

  Subroutine salr(z,tsurf,psurf,qsurf,theta_salr)

    Implicit None

    real(wp), intent(in)  :: z(:)          ! height grid (m)
    real(wp), intent(in)  :: tsurf         ! surface temperature (K)
    real(wp), intent(in)  :: psurf         ! surface pressure (Pa)
    real(wp), intent(in)  :: qsurf         ! surface vapour mixing
                                           ! ratio (kg/kg)
    real(wp), intent(out) :: theta_salr(:) ! theta on saturated adiabat

    ! local variables
    integer, parameter :: nfinelevs=1000
    integer :: k, nz, k2
    real(wp) :: dz, qs, tbar, p_mb, l, xi, exner
    real(wp), dimension(0:nfinelevs) :: t, p, q, z_fine

    ! parameters for stratosphere
    real(wp), parameter :: z_pause=16.0e3 ! height tropopause
    real(wp), parameter :: n=0.02         ! bv freq
    real(wp) :: strat_const, n2g

    real(wp), allocatable :: tsalr(:), psalr(:)

    nz=size(z)
    allocate(tsalr(nz))
    allocate(psalr(nz))

    ! calculate refernce profile on fine grid
    dz=(z(nz)+1.)/float(nfinelevs)
    do k=0,nfinelevs
       z_fine(k)=k*dz ! could add zsurf
    end do

    strat_const=g*g/(cp*n*n)
    n2g=n*n/g

    t(0)=tsurf
    p(0)=psurf

    do k=0,nfinelevs-1

       p_mb=0.01*p(k)
       if (t(k) .ge. tk0c) then
          qs=qsaturation(t(k),p_mb)
          l=rlvap
       else
          qs=qsaturation(t(k),p_mb) ! qisaturation(t(k),p_mb)
          l=rlvap                   ! rlsub
       endif

       if (qsurf .le. qs) then
          q(k)=qsurf
          t(k+1)=t(k)-g*dz/cp
       else
          ! constant bv=0.02 in stratosphere
          if (z_fine(k+1) .ge. z_pause) then
             q(k)=0.0
             t(k+1)=exp(n2g*(z_fine(k+1)-z_fine(k)))*(t(k)-strat_const)+strat_const
          else
             q(k)=qs
             t(k+1)=t(k)-g*dz*(1.0+l*qs/(r*t(k))) /       &
                  (cp+l**2.0*qs/(Rw*t(k)**2.0))
          endif
       endif

       tbar=2.0*t(k+1)*t(k)/(t(k)+t(k+1))
       p(k+1)=p(k)*exp(-g*dz/(r*tbar))

    end do
    q(nfinelevs)=0.0

    ! interpolate profile to model grid
    do k=1,nz
       do k2=0,nfinelevs-1
          if (z_fine(k2+1) .gt. z(k)) exit
       end do
       xi=(z(k)-z_fine(k2))/(z_fine(k2+1)-z_fine(k2))
       tsalr(k)=(1.0-xi)*t(k2)+xi*t(k2+1)
       psalr(k)=(1.0-xi)*p(k2)+xi*p(k2+1)
    end do

    ! obtain potential temperature
    do k=1,nz
       exner=(psalr(k)/p0)**r_on_cp
       theta_salr(k)=tsalr(k)/exner
    end do
    theta_salr(1)=theta_salr(2)

    deallocate(psalr)
    deallocate(tsalr)

  end subroutine salr

end Module common_physics


      double precision function xx (j)
      implicit double precision (a-h, o-z)
c     x grid point at index j, x = log(r), r=exp(x)
      parameter (delta = 0.050 000 000 000 000)
      parameter (c88   = 8.800 000 000 000 000)
c     xx = -8.8 + (j-1)*0.05
      xx = -c88 + (j-1)*delta
      return
      end

      double precision function rr(j)
      implicit double precision (a-h, o-z)
c     r grid point at index j
      rr = exp (xx(j))
      return
      end

      function ii(r)
      implicit double precision (a-h, o-z)
c     index of grid point immediately below postion r
      parameter (delta = 0.050 000 000 000 000)
      parameter (c88   = 8.800 000 000 000 000)
c     ii = (log(r) + 8.8) / 0.05 + 1
      ii = int((log(r) + c88) / delta + 1)
      return
      end


c       this file contains the following user-callable routines:
c
c
c       routine idzr_svd computes an approximation of specified rank
c       to a given matrix, in the usual SVD form U S V^*,
c       where U has orthonormal columns, V has orthonormal columns,
c       and S is diagonal.
c
c       routine idzp_svd computes an approximation of specified
c       precision to a given matrix, in the usual SVD form U S V^*,
c       where U has orthonormal columns, V has orthonormal columns,
c       and S is diagonal.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idzr_svd(m,n,a,krank,u,v,s,ier,r)
c
c       constructs a rank-krank SVD  u diag(s) v^*  approximating a,
c       where u is an m x krank matrix whose columns are orthonormal,
c       v is an n x krank matrix whose columns are orthonormal,
c       and diag(s) is a diagonal krank x krank matrix whose entries
c       are all nonnegative. This routine combines a QR code
c       (which is based on plane/Householder reflections)
c       with the LAPACK routine zgesdd.
c
c       input:
c       m -- first dimension of a and u
c       n -- second dimension of a, and first dimension of v
c       a -- matrix to be SVD'd
c       krank -- desired rank of the approximation to a
c
c       output:
c       u -- left singular vectors of a corresponding
c            to the k greatest singular values of a
c       v -- right singular vectors of a corresponding
c            to the k greatest singular values of a
c       s -- k greatest singular values of a
c       ier -- 0 when the routine terminates successfully;
c              nonzero when the routine encounters an error
c
c       work:
c       r -- must be at least
c            (krank+2)*n+8*min(m,n)+6*krank**2+8*krank
c            complex*16 elements long
c
c       _N.B._: This routine destroys a. Also, please beware that
c               the source code for this routine could be clearer.
c
        implicit none
        character*1 jobz
        integer m,n,k,krank,ifadjoint,ldr,ldu,ldvadj,lwork,
     1          info,j,ier,io
        real*8 s(krank)
        complex*16 a(m,n),u(m,krank),v(n*krank),r(*)
c
c
        io = 8*min(m,n)
c
c
        ier = 0
c
c
c       Compute a pivoted QR decomposition of a.
c
        call idzr_qrpiv(m,n,a,krank,r,r(io+1))
c
c
c       Extract R from the QR decomposition.
c
        call idz_retriever(m,n,a,krank,r(io+1))
c
c
c       Rearrange R according to ind.
c
        call idz_permuter(krank,r,krank,n,r(io+1))
c
c
c       Use LAPACK to SVD r,
c       storing the krank (krank x 1) left singular vectors
c       in r(io+krank*n+1 : io+krank*n+krank*krank).
c
        jobz = 'S'
        ldr = krank
        lwork = 2*(krank**2+2*krank+n)
        ldu = krank
        ldvadj = krank
c
        call zgesdd(jobz,krank,n,r(io+1),ldr,s,r(io+krank*n+1),ldu,
     1              v,ldvadj,r(io+krank*n+krank*krank+1),lwork,
     2              r(io+krank*n+krank*krank+lwork+1),r,info)
c
        if(info .ne. 0) then
          ier = info
          return
        endif
c
c
c       Multiply the U from R from the left by Q to obtain the U
c       for A.
c
        do k = 1,krank
c
          do j = 1,krank
            u(j,k) = r(io+krank*n+j+krank*(k-1))
          enddo ! j
c
          do j = krank+1,m
            u(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        ifadjoint = 0
        call idz_qmatmat(ifadjoint,m,n,a,krank,krank,u,r)
c
c
c       Take the adjoint of v to obtain r.
c
        call idz_adjer(krank,n,v,r)
c
c
c       Copy r into v.
c
        do k = 1,n*krank
          v(k) = r(k)
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idzp_svd(lw,eps,m,n,a,krank,iu,iv,is,w,ier)
c
c       constructs a rank-krank SVD  U Sigma V^*  approximating a
c       to precision eps, where U is an m x krank matrix whose
c       columns are orthonormal, V is an n x krank matrix whose
c       columns are orthonormal, and Sigma is a diagonal krank x krank
c       matrix whose entries are all nonnegative.
c       The entries of U are stored in w, starting at w(iu);
c       the entries of V are stored in w, starting at w(iv).
c       The diagonal entries of Sigma are stored in w,
c       starting at w(is). This routine combines a QR code
c       (which is based on plane/Householder reflections)
c       with the LAPACK routine zgesdd.
c
c       input:
c       lw -- maximum usable length of w (in complex*16 elements)
c       eps -- precision to which the SVD approximates a
c       m -- first dimension of a and u
c       n -- second dimension of a, and first dimension of v
c       a -- matrix to be SVD'd
c
c       output:
c       krank -- rank of the approximation to a
c       iu -- index in w of the first entry of the matrix
c             of orthonormal left singular vectors of a
c       iv -- index in w of the first entry of the matrix
c             of orthonormal right singular vectors of a
c       is -- index in w of the first entry of the array
c             of singular values of a; the singular values are stored
c             as complex*16 numbers whose imaginary parts are zeros
c       w -- array containing the singular values and singular vectors
c            of a; w doubles as a work array, and so must be at least
c            (krank+1)*(m+2*n+9)+8*min(m,n)+6*krank**2
c            complex*16 elements long, where krank is the rank
c            output by the present routine
c       ier -- 0 when the routine terminates successfully;
c              -1000 when lw is too small;
c              other nonzero values when zgesdd bombs
c
c       _N.B._: This routine destroys a. Also, please beware that
c               the source code for this routine could be clearer.
c               w must be at least
c               (krank+1)*(m+2*n+9)+8*min(m,n)+6*krank**2
c               complex*16 elements long, where krank is the rank
c               output by the present routine.
c
        implicit none
        character*1 jobz
        integer m,n,k,krank,ifadjoint,ldr,ldu,ldvadj,lwork,
     1          info,j,ier,io,iu,iv,is,ivi,isi,lu,lv,ls,lw
        real*8 eps
        complex*16 a(m,n),w(*)
c
c
        io = 8*min(m,n)
c
c
        ier = 0
c
c
c       Compute a pivoted QR decomposition of a.
c
        call idzp_qrpiv(eps,m,n,a,krank,w,w(io+1))
c
c
        if(krank .gt. 0) then
c
c
c         Extract R from the QR decomposition.
c
          call idz_retriever(m,n,a,krank,w(io+1))
c
c
c         Rearrange R according to ind.
c
          call idz_permuter(krank,w,krank,n,w(io+1))
c
c
c         Use LAPACK to SVD R,
c         storing the krank (krank x 1) left singular vectors
c         in w(io+krank*n+1 : io+krank*n+krank*krank).
c
          jobz = 'S'
          ldr = krank
          lwork = 2*(krank**2+2*krank+n)
          ldu = krank
          ldvadj = krank
c
          ivi = io+krank*n+krank*krank+lwork+3*krank**2+4*krank+1
          lv = n*krank
c
          isi = ivi+lv
          ls = krank
c
          if(lw .lt. isi+ls+m*krank-1) then
            ier = -1000
            return
          endif
c
          call zgesdd(jobz,krank,n,w(io+1),ldr,w(isi),w(io+krank*n+1),
     1                ldu,w(ivi),ldvadj,w(io+krank*n+krank*krank+1),
     2                lwork,w(io+krank*n+krank*krank+lwork+1),w,info)
c
          if(info .ne. 0) then
            ier = info
            return
          endif
c
c
c         Take the adjoint of w(ivi:ivi+lv-1) to obtain V.
c
          iv = 1
          call idz_adjer(krank,n,w(ivi),w(iv))
c
c
c         Copy w(isi:isi+ls/2) into w(is:is+ls-1).
c
          is = iv+lv
c
          call idz_realcomp(ls,w(isi),w(is))
c
c
c         Multiply the U from R from the left by Q to obtain the U
c         for A.
c
          iu = is+ls
          lu = m*krank
c
          do k = 1,krank
c
            do j = 1,krank
              w(iu-1+j+krank*(k-1)) = w(io+krank*n+j+krank*(k-1))
            enddo ! j
c
          enddo ! k
c
          do k = krank,1,-1
c
            do j = m,krank+1,-1
              w(iu-1+j+m*(k-1)) = 0
            enddo ! j
c
            do j = krank,1,-1
              w(iu-1+j+m*(k-1)) = w(iu-1+j+krank*(k-1))
            enddo ! j
c
          enddo ! k
c
          ifadjoint = 0
          call idz_qmatmat(ifadjoint,m,n,a,krank,krank,w(iu),
     1                     w(iu+lu+1))
c
c
        endif ! krank .gt. 0
c
c
        return
        end
c
c
c
c
        subroutine idz_realcomp(n,a,b)
c
c       copies the real*8 array a into the complex*16 array b.
c
c       input:
c       n -- length of a and b
c       a -- real*8 array to be copied into b
c
c       output:
c       b -- complex*16 copy of a
c
        integer n,k
        real*8 a(n)
        complex*16 b(n)
c
c
        do k = 1,n
          b(k) = a(k)
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_permuter(krank,ind,m,n,a)
c
c       permutes the columns of a according to ind obtained
c       from routine idzr_qrpiv or idzp_qrpiv, assuming that
c       a = q r from idzr_qrpiv or idzp_qrpiv.
c
c       input:
c       krank -- rank specified to routine idzr_qrpiv
c                or obtained from routine idzp_qrpiv
c       ind -- indexing array obtained from routine idzr_qrpiv
c              or idzp_qrpiv
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix to be rearranged
c
c       output:
c       a -- rearranged matrix
c
        implicit none
        integer k,krank,m,n,j,ind(krank)
        complex*16 cswap,a(m,n)
c
c
        do k = krank,1,-1
          do j = 1,m
c
            cswap = a(j,k)
            a(j,k) = a(j,ind(k))
            a(j,ind(k)) = cswap
c
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_retriever(m,n,a,krank,r)
c
c       extracts R in the QR decomposition specified by the output a
c       of the routine idzr_qrpiv or idzp_qrpiv
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a and r
c       a -- output of routine idzr_qrpiv or idzp_qrpiv
c       krank -- rank specified to routine idzr_qrpiv,
c                or output by routine idzp_qrpiv
c
c       output:
c       r -- triangular factor in the QR decomposition specified
c            by the output a of the routine idzr_qrpiv or idzp_qrpiv
c
        implicit none
        integer m,n,j,k,krank
        complex*16 a(m,n),r(krank,n)
c
c
c       Copy a into r and zero out the appropriate
c       Householder vectors that are stored in one triangle of a.
c
        do k = 1,n
          do j = 1,krank
            r(j,k) = a(j,k)
          enddo ! j
        enddo ! k
c
        do k = 1,n
          if(k .lt. krank) then
            do j = k+1,krank
              r(j,k) = 0
            enddo ! j
          endif
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_adjer(m,n,a,aa)
c
c       forms the adjoint aa of a.
c
c       input:
c       m -- first dimension of a and second dimension of aa
c       n -- second dimension of a and first dimension of aa
c       a -- matrix whose adjoint is to be taken
c
c       output:
c       aa -- adjoint of a
c
        implicit none
        integer m,n,j,k
        complex*16 a(m,n),aa(n,m)
c
c
        do k = 1,n
          do j = 1,m
            aa(k,j) = conjg(a(j,k))
          enddo ! j
        enddo ! k
c
c
        return
        end


subroutine MakeGrid2D(grid, cilm, lmax, interval, nlat, nlong, norm, csphase, f, a, north, south, east, west)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given the Spherical Harmonic coefficients cilm, this subroutine
!	will compute a 2D grid with equal latitude and longitude spacings.
!	Note that since this is NOT done using FFTs, this routine is therefore
!	relatively SLOW! You might want to instead use MakeGridDH.
!
!	The value at grid(1,1) correspons to 90 degrees latitude
!	and 0 degrees longitude, and the longitude spacing goes from 0 to 360,
!	with both points being calculated. If the optional
!	parameters NORTH, SOUTH, EAST and WEST are specified, the upper-left and lower right coordinates
!	of the output grid are (NORTH, WEST) and (SOUTH, EAST), respectively.
!
!	Calling Parameters:
!		IN
!			cilm:		Spherical harmonic coefficients.
!			lmax:		Maximum degree of expansions to be performed.
!			interval:	Spacing of output grid in DEGREES.
!		OUT
!			grid:		Gridded expansion of spherical harmonic coefficients.
!			nlat:		Number of latitude points for the grid.
!			nlong:		Number of longitude points for the grid.
!		OPTIONAL (IN)
!			norm		Spherical harmonic normalization:
!						(1) "geodesy" (default)
!						(2) Schmidt
!						(3) unnormalized
!						(4) orthonormalized
!			csphase:	1: Do not include the phase factor of (-1)^m
!					-1: Apply the phase factor of (-1)^m.
!			f, a:		Flattening and semimajor axis of the function. If included,
!					an ellipsoid with these parameters will be subtracted from the
!					data.
!			north		Maximum latitude to compute, in degrees.
!			south		Minimum latitude to compute, in degrees.
!			east		Maximum longitude to compute, in degrees.
!			west		Minimum latitude to compute, in degrees.
!
!
!	Notes:
!		1.	If lmax is greater than the the maximum spherical harmonic
!			degree of the input file, then this file will be ZERO PADDED!
!			(i.e., those degrees after lmax are assumed to be zero).
!
!	Dependencies:		PlmBar, PlBar, PlmSchmidt, PlSchmidt, PLegendreA, PLegendre,
!				PlmON, CSPHASE_DEFAULT
!
!	Written by Mark Wieczorek (2003)
!
!	August 2005 - 	sines and cosines are now precomputed, leading to a savings in time
!			by a factor of up to 15 (if the code is compiled with normal
!			optimizations.
!	April 12, 2007	Added option to allow calculation of function referenced to a flattened ellipsoid.
!	July 21, 2007 	Reference ellipsoid is now calculated exactly using the flattening and semi-major
!			axis instead of just the second degree Legendre expansion coefficient.
!	August 19, 2007	Added option to calculate subdomains of a raster grid.
!
!	Copyright (c) 2005-2007, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PlmBar, PlBar, PlmSchmidt, PlSchmidt, PLegendreA, PLegendre, &
				PlmON, PlON, CSPHASE_DEFAULT

	implicit none

	real*8, intent(in) :: 	cilm(:,:,:), interval
	real*8, intent(out) :: 	grid(:,:)
	integer, intent(in) :: 	lmax
	integer, intent(out) :: nlat, nlong
	integer, intent(in), optional :: norm, csphase
	real*8, intent(in), optional :: f, a, north, south, east, west
	integer :: 		l, m, j, k, index, l1, m1, lmax_comp, phase, lnorm, temp, astat(4)
	real*8 :: 		pi, latmax, latmin, longmin, longmax, lat, longitude, &
				x, intervalrad,  r_ref
	real*8, allocatable ::	pl(:), cosm(:, :), sinm(:, :), cilm2(:,:, :)

	temp = 0
	if (present(north)) temp = temp + 1
	if (present(south)) temp = temp + 1
	if (present(east)) temp = temp + 1
	if (present(west)) temp = temp + 1

	if (temp /=0 .and. temp /=4) then
		print*, "Error --- MakeGrid2d"
		print*, "The optional parameters NORTH, SOUTH, EAST, and WEST must all be specified", &
			present(north), present(south), present(east), present(west)
		stop
	endif

	if (temp == 4) then
		latmax = north
		latmin = south
		longmin = west
		longmax = east

		if (latmax < latmin) then
			print*, "Error --- MakeGrid2d"
			print*, "NORTH must be larger than SOUTH."
			print*, "NORTH = ", latmax
			print*, "SOUTH = ", latmin
			stop
		endif

		if (latmax > 90.0d0 .or. latmin < -90.0d0) then
			print*, "Error --- MakeGrid2d"
			print*, "NORTH and SOUTH must lie between 90 and -90."
			print*, "NORTH = ", latmax
			print*, "SOUTH = ", latmin
			stop
		endif

		if (longmin > longmax) longmax = longmax + 360.0d0

	else
		latmax = 90.0d0
		latmin = -90.0d0
		longmin = 0.0d0
		longmax = 360.d0
	endif

	nlat = (latmax - latmin) / interval + 1
	nlong = (longmax - longmin) / interval + 1

	if (present(norm)) then
		if (norm > 4 .or. norm < 1) then
			print*, "Error - MakeGrid2d"
			print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), 3 (unnormalized), or 4 (orthonormalized)."
			print*, "Input value is ", norm
			stop
		endif

		lnorm = norm

	else
		lnorm = 1
	endif

 	if (present(csphase)) then
     		if (csphase /= -1 .and. csphase /= 1) then
     			print*, "MakeGrid2D --- Error"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)"
     			print*, "Input valuse is ", csphase
     			stop
     		else
     			phase = csphase
     		endif
     	else
     		phase = CSPHASE_DEFAULT
     	endif

 	if (size(grid(:,1)) < nlat .or. size(grid(1,:)) < nlong ) then
		print*, "Error --- MakeGrid2D"
		print*, "GRID must be dimensioned ( (LATMAX-LATMIN)/INTERVAL+1, (LONGMAX-LONGMIN)/INTERVAL+1 ) where"
		print*, "INTERVAL = ", interval
		print*, "LATMAX = ", latmax
		print*, "LATMIN = ", latmin
		print*, "LONGMIN = ", longmin
		print*, "LONGMAX = ", longmax
		print*, "Input array is dimensioned ", size(grid(:,1)), size(grid(1,:))
		stop
	elseif (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 .or. size(cilm(1,1,:)) < lmax+1) then
		print*, "Error --- MakeGrid2D"
		print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	if ((present(f) .and. .not. present(a)) .or. (present(a) .and. .not. present(f)) ) then
		print*, "Error --- MakeGrid2D"
		print*, "Both F and A must be present"
		print*, "F ", present(f)
		print*, "A ", present(a)
		stop
	endif

	allocate(pl((lmax+1)*(lmax+2)/2), stat = astat(1))
	allocate(cosm(int(360./interval + 1), lmax+1), stat = astat(2))
	allocate(sinm(int(360./interval + 1), lmax+1), stat = astat(3))
	allocate(cilm2(2,lmax+1,lmax+1), stat = astat(4))
	if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /=0 .or. astat(4) /= 0) then
		print*, "Error --- MakeGrid2D"
		print*, "Problem allocating arrays PL, COSM, SINM, and CILM2", astat(1), astat(2), astat(3), astat(4)
		stop
	endif

	pi = acos(-1.0d0)
	grid = 0.0d0

	lmax_comp = min(lmax, size(cilm(1,1,:))-1)

	intervalrad = interval*pi/180.0d0

	cilm2(1:2,1:lmax+1,1:lmax+1) = cilm(1:2,1:lmax+1,1:lmax+1)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Precomputing sines and cosines leads to an increase in speed by a factor
	!	of almost 4 with no optimization, and by a factor of about 15 with normal
	!	optimizations.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do k=1, nlong

		longitude = longmin*pi/180.0d0 + dble(k-1)*intervalrad
		do m=0, lmax
			cosm(k, m+1) = cos(m*longitude)
			sinm(k, m+1) = sin(m*longitude)
		enddo

	enddo

	do j=1, nlat

		lat = latmax - dble(j-1)*interval
		x = sin(lat*pi/180.0d0)

		if (lat == 90.0d0 .or. lat == -90.0d0) then

			select case(lnorm)
				case(1); call PlBar(pl, lmax_comp, x)
				case(2); call PlSchmidt(pl, lmax_comp, x)
				case(3); call PLegendre(pl, lmax_comp, x)
				case(4); call PlON(pl, lmax_comp, x)
			end select

			do l = lmax_comp, 0, -1
				l1 = l+1
				grid(j,1) = grid(j,1) + cilm2(1,l1,1) * pl(l1)
			enddo

			grid(j, 2:nlong) = grid(j,1)

			if (present(f)) grid(j,1:nlong) = grid(j,1:nlong) - a*(1.0d0-f)

		else

			select case(lnorm)
				case(1); call PlmBar(pl, lmax_comp, x, csphase = phase)
				case(2); call PlmSchmidt(pl, lmax_comp, x, csphase = phase)
				case(3); call PLegendreA(pl, lmax_comp, x, csphase = phase)
				case(4); call PlmON(pl, lmax_comp, x, csphase = phase)
			end select

			do k = 1, nlong

				do l = lmax_comp, 0, -1

					l1 = l+1
					index = (l+1)*l/2 + 1
					grid(j,k) = grid(j,k) + cilm2(1,l1,1) * pl(index)

					do m = 1, l, 1
						m1 = m+1
						index = (l+1)*l/2 + m + 1
						grid(j,k) = grid(j,k) + ( cilm2(1,l1,m1)*cosm(k,m+1) + &
							cilm2(2,l1,m1)*sinm(k,m+1) ) * pl(index)
					enddo
				enddo

			enddo

			if (present(f)) then
				r_ref = a**2 * (1.0d0 + tan(lat*pi/180.0d0)**2) / &
					(1.0d0  + tan(lat*pi/180.0d0)**2 / (1.0d0 - f)**2 )
				r_ref = sqrt(r_ref)
				grid(j,1:nlong) = grid(j,1:nlong) - r_ref
			endif

		endif

	enddo

	! deallocate memory
	select case(lnorm)
		case(1); call PlmBar(pl, -1, x, csphase = phase)
		case(2); call PlmSchmidt(pl, -1, x, csphase = phase)
		case(4); call PlmON(pl, -1, x, csphase = phase)
	end select
	deallocate(pl)
	deallocate(cosm)
	deallocate(sinm)
	deallocate(cilm2)

end subroutine MakeGrid2D


   !        Generated by TAPENADE     (INRIA, Ecuador team)
   !  Tapenade 3.16 (master) -  9 Oct 2020 17:47
   !
   !  Differentiation of getelementprops in forward (tangent) mode (with options noISIZE i4 dr8 r8):
   !   variations   of useful results: area normal
   !   with respect to varying inputs: points
   SUBROUTINE GETELEMENTPROPS_D(points, pointsb, npts, area, areab, normal&
   & , normalb)
   USE CONSTANTS
   IMPLICIT NONE
   ! Subroutine Variables
   INTEGER(kind=inttype), INTENT(IN) :: npts
   REAL(kind=realtype), DIMENSION(3, npts), INTENT(IN) :: points
   REAL(kind=realtype), DIMENSION(3, npts), INTENT(IN) :: pointsb
   REAL(kind=realtype), DIMENSION(3), INTENT(OUT) :: normal
   REAL(kind=realtype), DIMENSION(3), INTENT(OUT) :: normalb
   REAL(kind=realtype), INTENT(OUT) :: area
   REAL(kind=realtype), INTENT(OUT) :: areab
   ! Local variables
   INTEGER(kind=inttype) :: i
   REAL(kind=realtype), DIMENSION(3, npts) :: radialvec
   REAL(kind=realtype), DIMENSION(3, npts) :: radialvecb
   REAL(kind=realtype), DIMENSION(3) :: center, cross
   REAL(kind=realtype), DIMENSION(3) :: centerb, crossb
   REAL(kind=realtype), DIMENSION(1) :: crossnorm
   REAL(kind=realtype), DIMENSION(1) :: crossnormb
   INTRINSIC SQRT
   REAL(kind=realtype) :: arg1
   REAL(kind=realtype) :: arg1b
   REAL(kind=realtype) :: result1
   REAL(kind=realtype) :: result1b
   REAL(kind=realtype) :: temp
   ! Compute the element center:
   center(:) = zero
   centerb = 0.0_8
   DO i=1,npts
   centerb(:) = centerb(:) + pointsb(:, i)
   center(:) = center(:) + points(:, i)
   END DO
   centerb = centerb/npts
   center = center/npts
   radialvecb = 0.0_8
   ! compute the vector from the center to each point defining the element
   DO i=1,npts
   radialvecb(:, i) = pointsb(:, i) - centerb
   radialvec(:, i) = points(:, i) - center
   END DO
   ! Now loop around element doing cross products to get directional area
   normal = zero
   area = zero
   areab = 0.0_8
   normalb = 0.0_8
   crossb = 0.0_8
   crossnormb = 0.0_8
   DO i=1,npts
   IF (i .LT. npts) THEN
   CALL CROSS_PRODUCT_3D_D(radialvec(:, i), radialvecb(:, i), &
   &                       radialvec(:, i+1), radialvecb(:, i+1), cross, &
   &                       crossb)
   ELSE
   CALL CROSS_PRODUCT_3D_D(radialvec(:, i), radialvecb(:, i), &
   &                       radialvec(:, 1), radialvecb(:, 1), cross, crossb&
   &                      )
   END IF
   arg1b = 2*cross(1)*crossb(1) + 2*cross(2)*crossb(2) + 2*cross(3)*&
   &     crossb(3)
   arg1 = cross(1)**2 + cross(2)**2 + cross(3)**2 + 1e-15
   temp = SQRT(arg1)
   IF (arg1 .EQ. 0.0_8) THEN
   crossnormb(1) = 0.0_8
   ELSE
   crossnormb(1) = arg1b/(2.0*temp)
   END IF
   crossnorm(1) = temp
   areab = areab + half*crossnormb(1)
   area = area + half*crossnorm(1)
   normalb = normalb + (crossb-cross*crossnormb(1)/crossnorm(1))/&
   &     crossnorm(1)
   normal = normal + cross/crossnorm(1)
   END DO
   ! Also make the normal a unit lenth
   arg1b = 2*normal(1)*normalb(1) + 2*normal(2)*normalb(2) + 2*normal(3)*&
   &   normalb(3)
   arg1 = normal(1)**2 + normal(2)**2 + normal(3)**2
   temp = SQRT(arg1)
   IF (arg1 .EQ. 0.0_8) THEN
   result1b = 0.0_8
   ELSE
   result1b = arg1b/(2.0*temp)
   END IF
   result1 = temp
   normalb = (normalb-normal*result1b/result1)/result1
   normal = normal/result1
   END SUBROUTINE GETELEMENTPROPS_D


       program karp
c
c This simple program approximates pi by computing pi = integral
c from 0 to 1 of 4/(1+x*x)dx which is approximated by sum from
c k=1 to N of 4 / (1+((k-.5)/N)**2).  The only input data required is N.
c
c NOTE: Comments that begin with "cspmd" are hints for part b of the
c       lab exercise, where you convert this into an MPI program.
c
cspmd  Each process could be given a chunk of the interval to do.
c
c RLF 3/21/97  Change floats to real*8
c SHM 8/29/97  Change input to read from a file to accommodate
c              VW Companion
c SHM 8/29/97  Replaced goto with do while
c
       real*8 err, f, pi, sum, w, x
       integer i, N
       f(x) = 4.0/(1.0+x*x)
       pi = 4.0*atan(1.0)
       open(unit=20, file='values')

cspmd  call startup routine that returns the number of tasks and the
cspmd  taskid of the current instance.

c Now read in a new value for N.  When it is 0, then you should depart.

       read(20,*) N
       print*, 'Number of approximation intervals = ',N

       do 20 while (N .GT. 0)
       w = 1.0/N
       sum = 0.0
       do i = 1,N
	  sum = sum + f((i-0.5)*w)
       enddo
       sum = sum * w
       err = sum - pi
       print *, 'sum = ',sum,' err =', err

       read(20,*) N
       print*, 'Number of approximation intervals = ',N

20     continue

       close(unit=20)
       end


	PROGRAM CUBICSOLV
C
C	SMALL EPSILON APPROX TO DISERSION RELATION, STERO-CASSINI NB P.84
C
	COMPLEX ROOT(3)
C
	DATA TPAR /.15E-4/
	DATA WRSAVE,XKSAVE /1.0014,7.13/
	DATA VGP0 /-1./
	DATA WCYCL /.0062/
	DATA ANG /11.1/
c	DATA ANG /0./
c
	XK = 7.
	RATIO = 1.1
	DO I = 1,60
	  XK =XK/RATIO
C	  USE CUBIC, COLD PLASMA
	  A = -XK**2
	  B = (XK**4 - WCYCL**2)/4.
	  C = ((WCYCL*XK*SIND(ANG))**2)/8.
	  CALL CUBIC(A,B,C,ROOT)
C	  PRINT*,'ROOTS',ROOT
	  PRINT*,'XK,A,B,C',XK,A,B,C
	  WRITE(26,1026) XK,ROOT
 1026	FORMAT(F6.3,6E12.3)
	ENDDO
	XK = 0.
	A = -XK**2
	B = (XK**4 - WCYCL**2)/4.
	C = ((WCYCL*XK*SIND(ANG))**2)/8.
	  CALL CUBIC(A,B,C,ROOT)
C	  PRINT*,'ROOTS',ROOT
	PRINT*,'XK,A,B,C',XK,A,B,C
	WRITE(26,1026) XK,ROOT
	STOP
	END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Transforms from (line,sample) to (latitude,longitude) for a
C perspective projection camera system.  An oblate spheroid model of the
C planet (RE,RP) is used.  All angles are in radians.  Planetocentric
C latitudes and east-longitudes are used.
C
C Inputs:
C     RLINE,RSAMP   :  input image coordinates
C     OM	    :  camera to planet transformation matrix
C     PSC3          :  spacecraft vector in (x3,y3,z3) coordinates, where
C		    :     PSC3(1) = RSC*DCOS(SCLAT)*DCOS(SCLON-RLORA)
C		    :     PSC3(2) = RSC*DCOS(SCLAT)*DSIN(SCLON-RLORA)
C		    :     PSC3(3) = RSC*DSIN(SCLAT)
C     A2B2,B2C2,etc :  constants derived from planet radii & s/c vector
C     RLORA         :  longitude of planet's major equatorial radius
C     OAL,OAS       :  image coordinates of optical axis intercept point
C     ZSCALE        :  camera constant = FL*PSCALE
C
C Outputs:
C     IND           :	IND=1 if resulting (RLAT,RLON) are valid
C		    :	IND=0 if point is off the planet
C     RLAT,RLON     :  computed planet coordinates.
C
      SUBROUTINE PLANET(IND,RLINE,RSAMP,RLAT,RLON,OM,PSC3,RLORA,
     &                OAL,OAS,ZSCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/PCONST/AI2,BI2,CI2,AI2XS,BI2YS,CI2ZS,CTERM
      COMMON/PCONST/A0,B0,B1,C0,C1,C2
      REAL*8 OM(3,3),PSC3(3)
      REAL*8 PI/3.141592653589793D0/
C
C         Vector from spacecraft to point on planet in camera coordinate system
      x0 = RSAMP - OAS
      y0 = RLINE - OAL
      z0 = ZSCALE
C         Convert vector to planet coordinate system (x3,y3,z3)
      xc = OM(1,1)*x0 + OM(1,2)*y0 + OM(1,3)*z0
      yc = OM(2,1)*x0 + OM(2,2)*y0 + OM(2,3)*z0
      zc = OM(3,1)*x0 + OM(3,2)*y0 + OM(3,3)*z0
C          Find where vector intersects planet
      A = AI2*xc**2 + BI2*yc**2 + CI2*zc**2
      B = AI2XS*xc  + BI2YS*yc  + CI2ZS*zc
      D = B*B - A*CTERM
      IF(D.LT.0.) THEN
          IND = 0		!Point off the planet
          RETURN
      ENDIF
      r = (-B-DSQRT(D))/A	!Choose smaller root for point in front
C
      x3 = r*xc + PSC3(1)
      y3 = r*yc + PSC3(2)
      z3 = r*zc + PSC3(3)
      D = DSQRT(x3**2+y3**2)
      RLAT = DATAN2(z3,D)
      RLON = DMOD(DATAN2(y3,x3)+RLORA+2.D0*PI,2.D0*PI)
      IND = 1
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Transforms from (latitude,longitude) to (line,sample) in a
C perspective projection camera system.  An oblate spheroid model of the
C planet (RE,RP) is used.  All angles are in radians.  Planetocentric
C latitudes and east-longitudes are used.
C
C Inputs:
C     RLAT,RLON     :  input planet coordinates.
C     OM	    :  camera to planet transformation matrix
C     PSC3          :  spacecraft vector in (x3,y3,z3) coordinates, where
C		    :     PSC3(1) = RSC*DCOS(SCLAT)DCOS(SCLAT-RLORA)
C		    :     PSC3(2) = RSC*DCOS(SCLAT)DSIN(SCLAT-RLORA)
C		    :     PSC3(3) = RSC*DSIN(SCLAT)
C     RLORA         :  longitude of planet's major equatorial radius
C     ABC,A2B2,etc  :  constants derived from planet radii & s/c vector
C     OAL,OAS       :  image coordinates of optical axis intercept point
C     ZSCALE        :  camera constant = FL*PSCALE
C
C Outputs:
C     IND           :  IND=1 if resulting (RLINE,RSAMP) are valid
C                   :  IND=0 if point is behind the planet
C     RLINE,RSAMP   :  computed image coordinates
C
      SUBROUTINE PLAINV(IND,RLAT,RLON,RLINE,RSAMP,OM,PSC3,RLORA,
     &                    OAL,OAS,ZSCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/PCONST/AI2,BI2,CI2,AI2XS,BI2YS,CI2ZS,CTERM
      COMMON/PCONST/A0,B0,B1,C0,C1,C2
      REAL*8 OM(3,3),PSC3(3)
C
      CLAT = DCOS(RLAT)
      SLAT = DSIN(RLAT)
      CLON = DCOS(RLON-RLORA)
      SLON = DSIN(RLON-RLORA)
C     ...Compute planetocentric radius
      R = 1.D0/DSQRT(AI2*(CLAT*CLON)**2+BI2*(CLAT*SLON)**2+CI2*SLAT**2)
C     ...Convert (lat,lon) point on planet to rectangular coordinates
      xp = R*CLAT*CLON
      yp = R*CLAT*SLON
      zp = R*SLAT
C          Compute vector from camera to point on planet
      xc =  xp - PSC3(1)
      yc =  yp - PSC3(2)
      zc =  zp - PSC3(3)
C          Vance Haemmerle's back-of-planet test
      DOTPROD = xc*xp + yc*yp + zc*zp
      IF (DOTPROD.GT.0) THEN	!If the angle between the two vectors
           IND = 0		!is less than 90 degrees, then point
           RETURN		!is behind the planet.
      ENDIF
C          Rotate vector into camera coordinates
      x0 = OM(1,1)*xc + OM(2,1)*yc + OM(3,1)*zc
      y0 = OM(1,2)*xc + OM(2,2)*yc + OM(3,2)*zc
      z0 = OM(1,3)*xc + OM(2,3)*yc + OM(3,3)*zc
C          Scale vector into pixels
      S = ZSCALE/z0
      RLINE = S*y0 + OAL
      RSAMP = S*x0 + OAS
      IND = 1
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Transform from camera coordinates (line,sample) to ring plane
C coordinates (radius,longitude) for a perspective projection camera system.
C All angles are in radians.  Planetocentric latitudes and east-longitudes
C are used.
C
C Inputs:
C     RLINE,RSAMP   :  input image coordinates
C     OM	    :  camera to planet transformation matrix
C     PSC3          :  spacecraft vector in (x3,y3,z3) coordinates, where
C		    :     PSC3(1) = RSC*DCOS(SCLAT)DCOS(SCLON-RLORA)
C		    :     PSC3(2) = RSC*DCOS(SCLAT)DSIN(SCLON-RLORA)
C		    :     PSC3(3) = RSC*DSIN(SCLAT)
C     SCLON         :  spacecraft longitude
C     OAL,OAS       :  image coordinates of optical axis intercept point
C     ZSCALE        :  camera constant = FL*PSCALE
C
C Outputs:
C     IND           :  return indicator.  Upon return,
C		    :	    IND=1 if resulting (RADIUS,RLON) are valid
C                   : 	    IND=0 if the ring plane is not visible
C     RADIUS,RLON   :  computed ring coordinates.
C
      SUBROUTINE RING(IND,RLINE,RSAMP,RADIUS,RLON,OM,PSC3,RLORA,
     &       OAL,OAS,ZSCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 OM(3,3),PSC3(3)
      REAL*8 PI/3.141592653589793D0/
C
C         Vector from spacecraft to point on ring in camera coordinate system
      x0 = RSAMP - OAS
      y0 = RLINE - OAL
      z0 = ZSCALE
C         Convert vector to planet centered coordinates
      xc = OM(1,1)*x0 + OM(1,2)*y0 + OM(1,3)*z0
      yc = OM(2,1)*x0 + OM(2,2)*y0 + OM(2,3)*z0
      zc = OM(3,1)*x0 + OM(3,2)*y0 + OM(3,3)*z0
C
      S = -PSC3(3)/zc
      IF (S.LT.0.) THEN
	IND = 0
        RETURN
      ENDIF
C
      X = S*xc + PSC3(1)
      Y = S*yc + PSC3(2)
      RADIUS = DSQRT(X**2+Y**2)
      RLON = DMOD(DATAN2(Y,X)+RLORA+2.D0*PI,2.D0*PI)
      IND = 1
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Transforms from ring plane coordinates (radius,longitude) to
C camera coordinates (line,sample) in a perspective projection camera system.
C All angles are in radians.  Planetocentric latitudes and east-longitudes
C are used.
C
C Inputs:
C     RADIUS,RLON   :  input ring coordinates.
C     OM	    :  camera to planet transformation matrix
C     PSC3          :  spacecraft vector in (x3,y3,z3) coordinates, where
C		    :     PSC3(1) = RSC*DCOS(SCLAT)DCOS(SCLON-RLORA)
C		    :     PSC3(2) = RSC*DCOS(SCLAT)DSIN(SCLON-RLORA)
C		    :     PSC3(3) = RSC*DSIN(SCLAT)
C     SCLON         :  spacecraft longitude.
C     OAL,OAS       :  image coordinates of optical axis intercept point
C     ZSCALE        :  camera constant = FL*PSCALE
C
C Outputs:
C     IND           :  IND=1 always.  Output (line,sample) are always valid.
C     RLINE,RSAMP   :  computed image coordinates
C
      SUBROUTINE RINV(IND,RADIUS,RLON,RLINE,RSAMP,
     &      OM,PSC3,RLORA,OAL,OAS,ZSCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 OM(3,3),PSC3(3)
C          Compute vector from camera to point on ring
      xc =  RADIUS*DCOS(RLON-RLORA) - PSC3(1)
      yc =  RADIUS*DSIN(RLON-RLORA) - PSC3(2)
      zc =                          - PSC3(3)
C          Rotate vector into camera coordinates
      x0 = OM(1,1)*xc + OM(2,1)*yc + OM(3,1)*zc
      y0 = OM(1,2)*xc + OM(2,2)*yc + OM(3,2)*zc
      z0 = OM(1,3)*xc + OM(2,3)*yc + OM(3,3)*zc
C          Scale vector into pixels
      S = ZSCALE/z0
      RLINE = S*y0 + OAL
      RSAMP = S*x0 + OAS
      IND = 1
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given the line-sample image coordinates of a star, calculate
C its right-ascension and declination.
C
C Outputs: RA,DEC
C
      SUBROUTINE STAR(RLINE,RSAMP,ra,dec,CM,OAL,OAS,ZSCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 CM(3,3)
      REAL*8 PI/3.141592653589793D0/

C     ....Compute vector in camera coordinates
      x0 = RSAMP - OAS
      y0 = RLINE - OAL
      z0 = ZSCALE
C     ....Rotate vector into EME50 coordinate system using C-matrix
      x = CM(1,1)*x0 + CM(1,2)*y0 + CM(1,3)*z0
      y = CM(2,1)*x0 + CM(2,2)*y0 + CM(2,3)*z0
      z = CM(3,1)*x0 + CM(3,2)*y0 + CM(3,3)*z0
C     ....Convert from rectangular to polar coordinates
      D = DSQRT(x**2 + y**2)
      DEC = DATAN2(z,D)
      RA = DMOD(DATAN2(y,x)+2.D0*PI,2.D0*PI)
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Given the right-ascension and declination of a star, calculate
C its line-sample coordinates in the image.
C
C Outputs: RLINE,RSAMP
C
      SUBROUTINE STARINV(RA,DEC,rline,rsamp,CM,OAL,OAS,ZSCALE)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 CM(3,3)

C     ....Convert RA,DEC to unit vector (x,y,z) in EME50 coordinates.
      CD = DCOS(DEC)
      x = DCOS(RA)*CD
      y = DSIN(RA)*CD
      z = DSIN(DEC)
C     ....Rotate vector into camera coordinates using inverse C-matrix
      x0 = CM(1,1)*x + CM(2,1)*y + CM(3,1)*z
      y0 = CM(1,2)*x + CM(2,2)*y + CM(3,2)*z
      z0 = CM(1,3)*x + CM(2,3)*y + CM(3,3)*z
C     ....Project onto focal-plane and scale vector into pixels
      S = ZSCALE/z0		!ZSCALE=FL*PICSCALE
      RLINE = S*y0 + OAL
      RSAMP = S*x0 + OAS
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C convert from (line,sample) to (lat,lon) or (radius,lon)
C
      SUBROUTINE LATLON(IND,RLINE,RSAMP,rlat,rlon)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/DISTOR/CONV(2216),OAL_IS,OAS_IS,CTOS,PROJECT
      COMMON/DISTORI/ITYPE,NPH,NPV
      REAL*4 CONV
      CHARACTER*5 PROJECT

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL
      real*4 rl4,rs4

      IF (ITYPE.EQ.7) THEN  !If image-space, convert to object=space.
	CALL CONVISOS(PROJECT,ICAM,sngl(RLINE),sngl(RSAMP),rl4,rs4,1,
     &   CONV,NPH,NPV,ind)
	rl=rl4
	rs=rs4
      ELSE		    !Else, no conversion necessary.
	RL = RLINE
	RS = RSAMP
      ENDIF

      IF (MODEL.LE.3) THEN	!Convert from (line,samp) to (lat,lon)
          CALL PLANET(IND,RL,RS,rlat,rlon,
     &            OM,PSC3,RLORA,OAL,OAS,ZSCALE)
          IF (IND.EQ.0) CALL XVMESSAGE('***Point off planet',' ')
          RETURN
      ENDIF

      IF (MODEL.EQ.4) THEN	!Convert from (line,samp) to (radius,lon)
        CALL RING(IND,RL,RS,radius,rlon,
     &   OM,PSC3,RLORA,OAL,OAS,ZSCALE)
        RLAT = RADIUS
        IF (IND.EQ.0) CALL XVMESSAGE('***Ring plane is not visible',
     &   ' ')
        RETURN
      ENDIF

      IF (MODEL.LE.5) THEN	!Convert from (line,samp) to (RA,DEC)
          CALL STAR(RL,RS,ras,dec,CM,OAL,OAS,ZSCALE)
          RLAT = RAS
          RLON = DEC
          IND = 1
          RETURN
      ENDIF

      CALL PRNT(4,1,MODEL,' ***Invalid target model=.')
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C convert from (lat,lon) or (radius,lon) to (line,sample)
C
      SUBROUTINE LINSAM(IND,RLAT,RLON,rline,rsamp)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/DISTOR/CONV(2216),OAL_IS,OAS_IS,CTOS,PROJECT
      COMMON/DISTORI/ITYPE,NPH,NPV
      REAL*4 CONV
      CHARACTER*5 PROJECT

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL
      real*4 rl4,rs4

      IF (MODEL.LT.3.OR.MODEL.GT.5) THEN
          CALL PRNT(4,1,MODEL,' ***Invalid target model=.')
          IND = 0
          RETURN
      ENDIF

      IF (MODEL.LE.3) THEN	!Convert from (lat,lon) to (line,samp)
          CALL PLAINV(IND,RLAT,RLON,rline,rsamp,
     &           OM,PSC3,RLORA,OAL,OAS,ZSCALE)
          IF (IND.EQ.0) THEN
             CALL XVMESSAGE('***Point behind the planet',' ')
             RETURN
          ENDIF
      ENDIF

      IF (MODEL.EQ.4) THEN	!Convert from (radius,lon) to (line,samp)
          RADIUS = RLAT
          CALL RINV(IND,RADIUS,RLON,rline,rsamp,
     &            OM,PSC3,RLORA,OAL,OAS,ZSCALE)
      ENDIF

      IF (MODEL.EQ.5) THEN	!Convert from (RA,DEC) to (line,samp)
          RAS = RLAT
          DEC = RLON
          CALL STARINV(RAS,DEC,rline,rsamp,CM,OAL,OAS,ZSCALE)
      ENDIF

      IF (ITYPE.EQ.7) then
	CALL CONVISOS(PROJECT,ICAM,rl4,rs4,sngl(RLINE),sngl(RSAMP),
     &		0,CONV,NPH,NPV,ind)
	rline=rl4
	rsamp=rs4
      endif
      IND = 1
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to calculate the phase angle at a particular point (radius,longitude)
C for the ring and (latitude,longitude) for the planet or satellite
C
      SUBROUTINE PHASE(RADIUS,RLON,PHA,RANGE,SCALE,RSCALE) !VRH 3/1/94 add arg
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/PCONST/AI2,BI2,CI2,AI2XS,BI2YS,CI2ZS,CTERM
      COMMON/PCONST/A0,B0,B1,C0,C1,C2
C
C  All vectors are planet centered co-ordinates.  Convert (radius,longitude)
C  or (latitude,longitude) of intercept point to X,Y,Z
      IF (MODEL.EQ.3) THEN
        CLAT = DCOS(RADIUS)			!RLAT = RADIUS
        SLAT = DSIN(RADIUS)
        CLON = DCOS(RLON-RLORA) ! Fixed by VRH 5/26/89 (RLORA replaces
        SLON = DSIN(RLON-RLORA) ! Fixed by VRH 5/26/89      SCLON)
CCC        EPSLN = (RA/RC)**2
CCC        R = RE/DSQRT((1-EPSLN)*CLAT**2+EPSLN)	!geocentric radius
        R = 1.D0/DSQRT(AI2*(CLAT*CLON)**2	!Planetocentric radius
     &		 + BI2*(CLAT*SLON)**2 + CI2*SLAT**2)
        XP3 = R*CLAT*CLON
        YP3 = R*CLAT*SLON
        ZP3 = R*SLAT
      ELSE IF (MODEL.EQ.4) THEN
        XP3 = RADIUS*DCOS(RLON-RLORA) !Fixed VRH 5/26/89  (RLORA replaces
        YP3 = RADIUS*DSIN(RLON-RLORA) !Fixed VRH 5/26/89       SCLON)
        ZP3 = 0.D0
      ENDIF
C  Get components of Spacecraft from intercept point, vector DX,DY,DZ
      DX = PSC3(1) - XP3
      DY = PSC3(2) - YP3
      DZ = PSC3(3) - ZP3
      RANGE = DSQRT(DX*DX + DY*DY + DZ*DZ)
c
c VRH added code to calculate particular info (one time deal) 3/94
c      sin_delta = DZ/RANGE
c      delta = dasind(sin_delta)
c      print*,'S/C is',delta,' deg above ring plane as seen from pt'
c
C  Get components of Sun from intercept point, vector DXSUN,DYSUN,DZSUN
      DXSUN = PSUN3(1) - XP3
      DYSUN = PSUN3(2) - YP3
      DZSUN = PSUN3(3) - ZP3
      SUNRAD = DSQRT(DXSUN*DXSUN + DYSUN*DYSUN + DZSUN*DZSUN)
C  Calculate Cos(phase)
      COSPHA = (DX*DXSUN + DY*DYSUN + DZ*DZSUN)/RANGE/SUNRAD
      PHA = DACOS(COSPHA)
C  Calculate Image scale (km/pixel)  ! VRH 3/1/94 add
      SCALE = RANGE/ZSCALE
C  Calculate Radial image scale (km/pixel) !VRH 3/1/94 add
      IF(MODEL.EQ.4) THEN
        COSPHI = -(DX*XP3 + DY*YP3)/RADIUS/RANGE
        PHI = DACOS(COSPHI)
        RSCALE = SCALE/DSIN(PHI)
      ENDIF
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to convert input latitude (RLAT) from planetodetic to planetocentric
C if IGEO=1.  If IGEO=0, the latitude is returned unchanged.
C
      FUNCTION GEOCEN(RLAT,RLON)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/CONST/PI,DTR,RTD

      IF (DABS(RLAT).GE.PI/2.D0) THEN
           GEOCEN = DSIGN(PI/2.D0,RLAT)
           RETURN
      ENDIF

      IF (IGEO.NE.1) THEN
           GEOCEN = RLAT
      ELSE
           EPS = (RC/(RA*RB))**2*
     &              DSQRT(RA**4 + (RB**4-RA**4)*DCOS(RLON-RLORA)**2)
           GEOCEN = DATAN(DTAN(RLAT)*EPS)
      ENDIF
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to convert input latitude (RLAT) from planetocentric to
C planetodetic if IGEO=1.  If IGEO=0, the latitude is returned
C unchanged. ! VRH changed description from GEOFLAG to IGEO 9/6/91
C
      FUNCTION GEODET(RLAT,RLON)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/CONST/PI,DTR,RTD

      IF (DABS(RLAT).GE.PI/2.D0) THEN
         GEODET = DSIGN(PI/2.D0,RLAT)
         RETURN
      ENDIF

      IF (IGEO.NE.1) THEN
         GEODET = RLAT
      ELSE
         EPS = ((RA*RB)/RC)**2/
     &              DSQRT(RA**4 + (RB**4-RA**4)*DCOS(RLON-RLORA)**2)
         GEODET = DATAN(DTAN(RLAT)*EPS)
      ENDIF
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert (line,sample) to camera unit vector
C
      SUBROUTINE IMG2OBJ(RLINE,RSAMP,vout)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/DISTOR/CONV(2216),OAL_IS,OAS_IS,CTOS,PROJECT
      COMMON/DISTORI/ITYPE,NPH,NPV
      REAL*4 CONV
      CHARACTER*5 PROJECT

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      DOUBLEPRECISION VIN(3),VOUT(3),VLCL(3)
      REAL*4 RL,RS

      IF (ITYPE.EQ.7) THEN  !If image space, convert to object space.
         CALL CONVISOS(PROJECT,ICAM,SNGL(RLINE),SNGL(RSAMP),rl,rs,1,
     &                CONV,NPH,NPV,ind)
      ELSE		    !Else, no conversion necessary.
         RL = RLINE
         RS = RSAMP
      ENDIF

      VOUT(1) = RS - OAS
      VOUT(2) = RL - OAL
      VOUT(3) = ZSCALE
      CALL VHAT(VOUT,vout)	!Make it a unit vector
      RETURN

C********************************************************************
C Convert camera vector to (line,sample)
C
      ENTRY OBJ2IMG(VIN,rline,rsamp)

C     ....Test for vector pointing along or behind image plane
      IF (VIN(3).LE.0D0) THEN
        RLINE = -999D0
        RSAMP = RLINE
        RETURN
      ENDIF
C
C     ....Convert to vector with Z = ZSCALE
      CALL VSCL(ZSCALE/VIN(3),VIN,VLCL)
      RSAMP = VLCL(1) + OAS
      RLINE = VLCL(2) + OAL

      IF (ITYPE.EQ.7) THEN  !Convert object-space to image-space,
         CALL CONVISOS(PROJECT,ICAM,rl,rs,SNGL(RLINE),SNGL(RSAMP),0,
     &                CONV,NPH,NPV,ind)
	RLINE=RL
	RSAMP=RS
      ENDIF
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert (line,sample) <=> object l,s <=> camera unit vec
C rotate one vector around another
C
      SUBROUTINE ROTVEC(ROT,VECIN,AXIVEC,VECOUT)
      IMPLICIT NONE
      DOUBLEPRECISION ROT,VECIN(3),AXIVEC(3),VECOUT(3)
      DOUBLEPRECISION QUART(0:3),QMTX(3,3),OLDROT,SINROT2,ROT2
      DATA QUART(0) / 1D0 /
      DATA OLDROT / 0D0 /
      DATA SINROT2 / 0D0 /
      SAVE

      IF (ROT .EQ. -OLDROT) THEN
         SINROT2 = -SINROT2
         OLDROT = ROT
      ELSE IF (ROT .NE. OLDROT) THEN
         ROT2 = ROT / 2D0
         QUART(0) = DCOS(ROT2)
         SINROT2 = DSIN(ROT2)
         OLDROT = ROT
      ENDIF
      IF (QUART(0) .EQ. 1D0) THEN
        CALL VEQU(VECIN,VECOUT)
      ELSE
        CALL VSCL(SINROT2,AXIVEC,QUART(1))
        CALL Q2M(QUART,QMTX)
        CALL MXV(QMTX,VECIN,VECOUT)
      ENDIF
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CBTC
CBTC END - rotvec
CBTC START + & - rotate vector around axis,convert to image space,update
CBTC       array of image space line,samp,count how many are within
CBTC       image space limits
CBTC SUBROUTINE ROTVECS2IMG
CBTC Inputs:
CBTC   VECIN(3)    DP   Vector to rotate
CBTC   AXIVEC(3)   DP   Axis of rotation
CBTC   ROT         DP   Rotation,radians
CBTC   SL,SS,EL,ES DP   Image space limits - determines which results cause
CBTC                      NPTS to be updated
CBTC Outputs:
CBTC   NPTS        INT  Counter to be incremented for each line,samp
CBTC                      within limits
CBTC   PTS(2,2)    R4   Array of line,samp pairs for positive & negative rot
CBTC
      subroutine rotvecs2img(vecin,axivec,rot,sl,ss,el,es
     &                      ,npts,pts)
      implicitnone
      doubleprecision vecin(3),axivec(3),rot,sl,ss,el,es
      real*4 pts(2,2)
      integer npts
CBTC
      doubleprecision vec1(3),rline,rsamp
      integer i
CBTC********************************************************************
CBTC rotate negative
      call rotvec(-rot,vecin,axivec,vec1)
      call obj2img(vec1,rline,rsamp)
CBTC
CBTC copy rline,rsamp to pts(,1) if both are not outside limits & update npts,
CBTC otherwise copy to pts(,2)
      if (.not. (rline.lt.sl .or. rline.gt.el
     &        .or. rsamp.lt.ss .or. rsamp.gt.es)) then
        pts(1,1) = rline
        pts(2,1) = rsamp
        i = 2
        npts = npts + 1
      else
        pts(1,2) = rline
        pts(2,2) = rsamp
        i = 1
      endif
CBTC
CBTC rotate positive
      call rotvec(rot,vecin,axivec,vec1)
      call obj2img(vec1,rline,rsamp)
CBTC
CBTC copy rline,rsamp to pts(,i) & update npts if necessary
      pts(1,i) = rline
      pts(2,i) = rsamp
      if (.not. (rline.lt.sl .or. rline.gt.el
     &        .or. rsamp.lt.ss .or. rsamp.gt.es)) npts = npts + 1
      return
      end


!!# MODULE <<FUN_FactorialLn>>
MODULE FUN_FactorialLn
!!## PURPOSE
!! Defines function FactorialLn(k) which returns the real natural log of
!! the factorial of integer k, in double precision.

!!## MODULES
USE FUN_Sequence                                !!((03-A-FUN_Sequence.f90))
USE SUB_Reallocate                              !!((04-B-SUB_Reallocate.f90))
USE FUN_FactorialInt                            !!((05-B-FUN_FactorialInt.f90))
USE FUN_GammaLn                                 !!((05-B-FUN_GammaLn.f90))

!!## PARAMETERS
!! * kind of the real function return value [KIND_R]
!! * kinds of the allowed integer arguments
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp,& !!((01-A-KND_IntrinsicTypes.f90))
              KIND_I1,KIND_I2,KIND_I4,KIND_I8

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE !! PUBLIC

!!## FUNCTION OVERLOADING
INTERFACE FactorialLn
 MODULE PROCEDURE FactorialLn_A1I1
 MODULE PROCEDURE FactorialLn_A1I2
 MODULE PROCEDURE FactorialLn_A1I4
 MODULE PROCEDURE FactorialLn_A1I8
 MODULE PROCEDURE FactorialLn_A2I1
 MODULE PROCEDURE FactorialLn_A2I2
 MODULE PROCEDURE FactorialLn_A2I4
 MODULE PROCEDURE FactorialLn_A2I8
ENDINTERFACE
PUBLIC :: FactorialLn

!!## GLOBAL VARIABLES
!! * a list of saved values of the natural log of the factorial [a]
REAL(KIND_R),POINTER :: a(:) => NULL()

CONTAINS

FUNCTION FactorialLn_A2I1( x , Initialize ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-FUN_FactorialLn_A2.f90.hdr"
!!--begin--
INCLUDE "08-B-FUN_FactorialLn_A2.f90.bdy"
!!--end--
ENDFUNCTION

FUNCTION FactorialLn_A2I2( x , Initialize ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-FUN_FactorialLn_A2.f90.hdr"
!!--begin--
INCLUDE "08-B-FUN_FactorialLn_A2.f90.bdy"
!!--end--
ENDFUNCTION

FUNCTION FactorialLn_A2I4( x , Initialize ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-FUN_FactorialLn_A2.f90.hdr"
!!--begin--
INCLUDE "08-B-FUN_FactorialLn_A2.f90.bdy"
!!--end--
ENDFUNCTION

FUNCTION FactorialLn_A2I8( x , Initialize ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-FUN_FactorialLn_A2.f90.hdr"
!!--begin--
INCLUDE "08-B-FUN_FactorialLn_A2.f90.bdy"
!!--end--
ENDFUNCTION

PURE ELEMENTAL FUNCTION FactorialLn_A1I1( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-FUN_FactorialLn_A1.f90.hdr"
!!--begin--
INCLUDE "08-B-FUN_FactorialLn_A1.f90.bdy"
!!--end--
ENDFUNCTION

PURE ELEMENTAL FUNCTION FactorialLn_A1I2( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-FUN_FactorialLn_A1.f90.hdr"
!!--begin--
INCLUDE "08-B-FUN_FactorialLn_A1.f90.bdy"
!!--end--
ENDFUNCTION

PURE ELEMENTAL FUNCTION FactorialLn_A1I4( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-FUN_FactorialLn_A1.f90.hdr"
!!--begin--
INCLUDE "08-B-FUN_FactorialLn_A1.f90.bdy"
!!--end--
ENDFUNCTION

PURE ELEMENTAL FUNCTION FactorialLn_A1I8( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-FUN_FactorialLn_A1.f90.hdr"
!!--begin--
INCLUDE "08-B-FUN_FactorialLn_A1.f90.bdy"
!!--end--
ENDFUNCTION

ENDMODULE


! RUN: %S/test_modfile.sh %s %t %flang_fc1
! REQUIRES: shell
! Tests folding of array constructors

module m
  real, parameter :: a0 = 1.0_8
  real, parameter :: a1(2) = [real::2.0, 3.0]
  real, parameter :: a2(2) = [4.0, 5.0]
  real, parameter :: a3(0) = [real::]
  real, parameter :: a4(55) = [real::((1.0*k,k=1,j),j=1,10)]
  real, parameter :: a5(*) = [6.0, 7.0, 8.0]
  real, parameter :: a6(2) = [9, 10]
  real, parameter :: a7(6) = [([(1.0*k,k=1,j)],j=1,3)]
  real, parameter :: a8(13) = [real::1,2_1,3_2,4_4,5_8,6_16,7._2,8._3,9._4,10._8,11._16,(12.,12.5),(13._8,13.5)]
end module m

!Expect: m.mod
!module m
!real(4),parameter::a0=1._4
!real(4),parameter::a1(1_8:2_8)=[REAL(4)::2._4,3._4]
!real(4),parameter::a2(1_8:2_8)=[REAL(4)::4._4,5._4]
!real(4),parameter::a3(1_8:0_8)=[REAL(4)::]
!real(4),parameter::a4(1_8:55_8)=[REAL(4)::1._4,1._4,2._4,1._4,2._4,3._4,1._4,2._4,3._4,4._4,1._4,2._4,3._4,4._4,5._4,1._4,2._4,3._4,4._4,5._4,6._4,1._4,2._4,3._4,4._4,5._4,6._4,7._4,1._4,2._4,3._4,4._4,5._4,6._4,7._4,8._4,1._4,2._4,3._4,4._4,5._4,6._4,7._4,8._4,9._4,1._4,2._4,3._4,4._4,5._4,6._4,7._4,8._4,9._4,1.e1_4]
!real(4),parameter::a5(1_8:*)=[REAL(4)::6._4,7._4,8._4]
!real(4),parameter::a6(1_8:2_8)=[REAL(4)::9._4,1.e1_4]
!real(4),parameter::a7(1_8:6_8)=[REAL(4)::1._4,1._4,2._4,1._4,2._4,3._4]
!real(4),parameter::a8(1_8:13_8)=[REAL(4)::1._4,2._4,3._4,4._4,5._4,6._4,7._4,8._4,9._4,1.e1_4,1.1e1_4,1.2e1_4,1.3e1_4]
!end


!> 计算人工粘度的子程序。详见 Monaghan (1992), Hernquist 和 Katz (1989) 或第 4 章中的论述。
!>     subroutine to calculate the artificial viscosity (monaghan, 1992)
subroutine art_visc(ntotal, hsml, mass, x, vx, niac, rho, c, pair_i, pair_j, w, dwdx, dvxdt, dedt)

    use sph_kind, only: rk
    use parameter
    implicit none

    !> 在模拟中所使用的粒子总数
    !> number of particles in simulation
    integer, intent(in) :: ntotal
    !> 光滑长度
    !> smoothing length
    real(rk), intent(in) :: hsml(maxn)
    !> 粒子的质量
    !> particle masses
    real(rk), intent(in) :: mass(maxn)
    !> 粒子的坐标
    !> particle coordinates
    real(rk), intent(in) :: x(dim, maxn)
    !> 粒子的速度
    !> particle velocities
    real(rk), intent(in) :: vx(dim, maxn)
    !> 相互作用对的数目
    !> number of interaction pairs
    integer, intent(in) :: niac
    !> 密度
    !> density
    real(rk), intent(in) :: rho(maxn)
    !> 温度
    !> temperature
    real(rk), intent(in) :: c(maxn)
    !> 相互作用对的第一个粒子
    !> first partner of interaction pair
    integer, intent(in) :: pair_i(max_interaction)
    !> 相互作用对的第二个粒子
    !> second partner of interaction pair
    integer, intent(in) :: pair_j(max_interaction)
    !> 相互作用对的核函数
    !> kernel for all interaction pairs
    real(rk), intent(in) :: w(max_interaction)
    !> 相互作用对的核函数的导数
    !> derivative of kernel with respect to x, y and z
    real(rk), intent(in) :: dwdx(dim, max_interaction)
    !> 相互作用对的加速度
    !> acceleration with respect to x, y and z
    real(rk), intent(out) :: dvxdt(dim, maxn)
    !> 改变特定内部能量
    !> change of specific internal energy
    real(rk), intent(out) :: dedt(maxn)

    integer :: i, j, k, d
    real(rk) :: dx, dvx(dim), alpha, beta, etq, piv, muv, vr, rr, h, mc, mrho, mhsml

    !     parameter for the artificial viscosity:
    !     shear viscosity
    parameter(alpha=1._rk)

    !     bulk viscosity
    parameter(beta=1._rk)

    !     parameter to avoid singularities
    parameter(etq=0.1_rk)

    do i = 1, ntotal
        do d = 1, dim
            dvxdt(d, i) = 0._rk
        end do
        dedt(i) = 0._rk
    end do

    !     calculate sph sum for artificial viscosity

    do k = 1, niac
        i = pair_i(k)
        j = pair_j(k)
        mhsml = (hsml(i) + hsml(j))/2._rk
        vr = 0._rk
        rr = 0._rk
        do d = 1, dim
            dvx(d) = vx(d, i) - vx(d, j)
            dx = x(d, i) - x(d, j)
            vr = vr + dvx(d)*dx
            rr = rr + dx*dx
        end do

        !     artificial viscous force only if v_ij * r_ij < 0

        if (vr < 0._rk) then

            !     calculate muv_ij = hsml v_ij * r_ij / ( r_ij^2 + hsml^2 etq^2 )

            muv = mhsml*vr/(rr + mhsml*mhsml*etq*etq)

            !     calculate piv_ij = (-alpha muv_ij c_ij + beta muv_ij^2) / rho_ij

            mc = 0.5_rk*(c(i) + c(j))
            mrho = 0.5_rk*(rho(i) + rho(j))
            piv = (beta*muv - alpha*mc)*muv/mrho

            !     calculate sph sum for artificial viscous force

            do d = 1, dim
                h = -piv*dwdx(d, k)
                dvxdt(d, i) = dvxdt(d, i) + mass(j)*h
                dvxdt(d, j) = dvxdt(d, j) - mass(i)*h
                dedt(i) = dedt(i) - mass(j)*dvx(d)*h
                dedt(j) = dedt(j) - mass(i)*dvx(d)*h
            end do
        end if
    end do

    !     change of specific internal energy:

    do i = 1, ntotal
        dedt(i) = 0.5_rk*dedt(i)
    end do

end subroutine art_visc


c find the centroid of a minimum in chisq given its
c approx location.  indx is the index of the minimum
c we found with findmultmin or whatever

      function centroidmin(n,x,y,indx)

      integer indx
      real x(n),y(n)
c      real centroidmin

c look in a window this size around the min
      nwtmin = 5
c buffer
      nbuff = 3
c window for "continuum"
      ncontwin = 10

      csum=0.0
      ncont=0
      i1 = max(1,indx-nwtmin-nbuff-ncontwin)
      i2 = max(1,indx-nwtmin-nbuff-1)
      do i=i1,i2
         csum=csum+y(i)
         ncont=ncont+1
      end do
      i1= min(n,indx+nwtmin+nbuff+1)
      i2= min(n,indx+nwtmin+nbuff+ncontwin)
      do i=i1,i2
         csum = csum+y(i)
         ncont=ncont+1
      end do
      cont=csum/ncont

c this is like finding a center of mass:
c take the y-weighted mean of the x_i
c (but make the weights y minus continuum)

      xysum = 0.0
      wtsum = 0.0
      i1 = min(n,indx-nwtmin)
      i2 = min(n,indx+nwtmin)
      do i=i1,i2
         wt = y(i)-cont
         xysum = xysum+wt*x(i)
         wtsum = wtsum+wt
      end do

      centroidmin = xysum/wtsum
      return
      end


C$Procedure      XF2RAV ( Transform to rotation and angular velocity)

      SUBROUTINE XF2RAV ( XFORM, ROT, AV )

C$ Abstract
C
C     This routine determines from a state transformation matrix
C     the associated rotation matrix and angular velocity of the
C     rotation.
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     None.
C
C$ Keywords
C
C     FRAMES
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      XFORM  ( 6, 6 )
      DOUBLE PRECISION      ROT    ( 3, 3 )
      DOUBLE PRECISION      AV     ( 3    )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     XFORM      I   is a state transformation matrix
C     ROT        O   is the rotation associated with XFORM
C     AV         O   is the angular velocity associated with XFORM
C
C$ Detailed_Input
C
C     XFORM       is a state transformation matrix from one frame
C                 FRAME1 to some other frame FRAME2.
C
C$ Detailed_Output
C
C     ROT         is a rotation that gives the transformation from
C                 some frame FRAME1 to another frame FRAME2.
C
C     AV          is the angular velocity of the transformation.
C                 In other words, if P is the position of a fixed
C                 point in FRAME2, then from the point of view of
C                 FRAME1,  P rotates (in a right handed sense) about
C                 an axis parallel to AV.  Moreover the rate of rotation
C                 in radians per unit time is given by the length of
C                 AV.
C
C                 More formally, the velocity V of P in FRAME1 is
C                 given by
C                                    t
C                     V  = AV x ( ROT * P )
C
C                 The components of AV are given relative to FRAME1.
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) No checks are performed on XFORM to ensure that it is indeed
C        a state transformation matrix.
C
C$ Particulars
C
C     This routine is essentially a macro routine for converting
C     state transformation matrices into the equivalent representation
C     in terms of a rotation and angular velocity.
C
C     This routine is an inverse of the routine RAV2XF.
C
C$ Examples
C
C     Suppose that you wanted to determine the angular velocity
C     of the earth with respect to J2000 at a particular epoch ET.
C     The following code fragment illustrates a procedure for
C     computing the angular velocity.
C
C        CALL TISBOD ( 'J2000', 399, ET, TSIPM )
C
C
C        Now get the angular velocity by calling XF2RAV
C
C        CALL XF2RAV ( TSPMI, TPMI, AV )
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-   SPICELIB Version 1.1.0, 28-JUL-1997 (WLT)
C
C       The example in version 1.0.0 was incorrect.  The example
C       in version 1.1.0 fixes the previous problem.
C
C-    SPICELIB Version 1.0.0, 19-SEP-1995 (WLT)
C
C
C-&

C$ Index_Entries
C
C     State transformation to rotation and angular velocity
C
C-&

      INTEGER               I
      INTEGER               J

      DOUBLE PRECISION      DRDT  ( 3, 3 )
      DOUBLE PRECISION      OMEGA ( 3, 3 )

C
C     A state transformation matrix XFORM has the following form
C
C
C         [      |     ]
C         |  R   |  0  |
C         |      |     |
C         | -----+-----|
C         |  dR  |     |
C         |  --  |  R  |
C         [  dt  |     ]
C
C
C     where R is a rotation and dR/dt is the time derivative of that
C     rotation.  From this we can immediately read the rotation and
C     its derivative.
C
      DO I = 1, 3
         DO J = 1,3
            ROT (I,J) = XFORM(I,  J)
            DRDT(I,J) = XFORM(I+3,J)
         END DO
      END DO

C
C     Recall that ROT is a transformation that converts positions
C     in some frame FRAME1 to positions in a second frame FRAME2.
C
C     The angular velocity matrix OMEGA (the cross product matrix
C     corresponding to AV) has the following property.
C
C     If P is the position of an object that is stationary with
C     respect to FRAME2 then the velocity V of that object in FRAME1
C     is given by:
C                          t
C         V  =  OMEGA * ROT  *  P
C
C     But V is also given by
C
C                    t
C               d ROT
C         V =   -----  * P
C                 dt
C
C     So that
C                                  t
C                    t        d ROT
C         OMEGA * ROT    =   -------
C                               dt
C
C     Hence
C                             t
C                       d ROT
C         OMEGA    =   -------  *  ROT
C                         dt
C
C
C
      CALL MTXM ( DRDT, ROT, OMEGA )

C
C     Recall that OMEGA has the form
C
C         _                     _
C        |                       |
C        |   0    -AV(3)  AV(2)  |
C        |                       |
C        |  AV(3)    0   -AV(1)  |
C        |                       |
C        | -AV(2)   AV(1)   0    |
C        |_                     _|
C
      AV(1) = OMEGA(3,2)
      AV(2) = OMEGA(1,3)
      AV(3) = OMEGA(2,1)

      RETURN
      END