******************************************************************
      SUBROUTINE GAUSSL(X,W,M)
c   a slightly modified version of a program in Numerical Recipes
c       (Cambridge Univ. Press, 1989)
c   input:
c      m    = number of gaussian latitudes between pole and equator
c   output:
c      x(m) = sin(gaussian latitude)
c      w(m) = weights in gaussian quadrature (sum should equal 1.0)
      DOUBLE PRECISION Z,Z1,P1,P2,P3,PP,EPS
      DIMENSION X(M),W(M)
      PARAMETER (EPS=3.D-14)
      N=2*M
      DO 12 I=1,M
        Z=COS(3.141592654D0*(I-.25D0)/(N+.5D0))
    1   CONTINUE
        P1=1.D0
        P2=0.D0
        DO 11 J=1,N
          P3=P2
          P2=P1
          P1=((2.D0*J-1.D0)*Z*P2-(J-1.D0)*P3)/J
   11   CONTINUE
        PP=N*(Z*P1-P2)/(Z*Z-1.D0)
        Z1=Z
        Z=Z1-P1/PP
        IF(ABS(Z-Z1).GT.EPS) GO TO 1
        X(I)=Z
        W(I)=2.D0/((1.D0-Z*Z)*PP*PP)
   12 CONTINUE
      RETURN
      END
****************************************************************
      SUBROUTINE PARMTR(A)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

c   initializes Legendre transforms and constants used for other
c   subroutines that manipulate spherical harmonics
c
c   input:  A = radius of the sphere
c   first compute Gaussian latitudes and weights at the IY points from
c       pole to equator
c   SIA(IY) is sin of latitude, WT(IY) are Gaussian weights for quadratures,
c     saved in COMMON/GAUSS (com_spectral.h)
      CALL GAUSSL(SIA,WT,IY)
      AM1 = 1./A
      AM2=  1./(A*A)
c   COA(IY) = cos(lat); WGHT needed for transforms,
c             saved in COMMON/GAUSS (com_spectral.h)
      DO 1 J=1,IY
        COSQR = 1.0-SIA(J)**2
        COA(J)=SQRT(COSQR)
        WGHT(J)=WT(J)/(A*COSQR)
    1 CONTINUE
c   expand cosine and its reciprocal to cover both hemispheres,
c      saved in COMMON/GAUSS (com_spectral.h)
      DO 11 J=1,IY
        JJ=IL+1-J
        COSG(J)=COA(J)
        COSG(JJ)=COA(J)
        COSGR(J)=1./COA(J)
        COSGR(JJ)=1./COA(J)
        COSGR2(J)=1./(COA(J)*coa(j))
        COSGR2(JJ)=1./(COA(J)*coa(j))
   11 CONTINUE
c  MM = zonal wavenumber = m
c     ISC=3 implies that only wavenumber 0,3,6,9,etc are included in model
c  LL = total wavenumber of spherical harmonic = l
c  L2 = l*(l+1)
c  EL2 = l*(l+1)/(a**2)
c  EL4 = EL2*EL2 ; for biharmonic diffusion
c  ELM2 = 1./EL2
c  TRFILT used to filter out "non-triangular" part of rhomboidal truncation
c   saved in COMMON/CSPEC (com_spectral.h)

      DO 2 N=1,NX
      nsh2(n)=0
       DO 2 M=1,MX
         MM(M)=ISC*(M-1)
         LL(M,N)=MM(M)+N-1
         L2(M,N)=LL(M,N)*(LL(M,N)+1)
         EL2(M,N)=FLOAT(L2(M,N))*AM2
         EL4(M,N)=EL2(M,N)*EL2(M,N)
         if (ll(m,n).le.ntrun1.or.ix.ne.4*iy) nsh2(n)=nsh2(n)+2
         if (ll(m,n).le.ntrun) then
           trfilt(m,n)=1.
         else
           trfilt(m,n)=0.
         endif
    2 CONTINUE
      ELM2(1,1)=0.
      DO 3 M=2,MX
      DO 3 N=1,NX
        ELM2(M,N)=1./EL2(M,N)
    3 CONTINUE
      DO 4 N=2,NX
        ELM2(1,N)=1./EL2(1,N)
    4 CONTINUE

c    quantities needed to generate and differentiate Legendre polynomials
c    all m values up to MXP = ISC*MTRUN+1 are needed by recursion relation
c    saved in COMMON/LGND (com_spectral.h)
      DO 10 M=1,MXP
      DO 10 N=1,NXP
        EMM(M)=FLOAT(M-1)
        ELL(M,N)=FLOAT(N+M-2)
        EMM2=EMM(M)**2
        ELL2=ELL(M,N)**2
        IF(N.EQ.NXP) THEN
          EPSI(M,N)=0.0
        ELSE IF(N.EQ.1.AND.M.EQ.1) THEN
          EPSI(M,N)=0.0
        ELSE
          EPSI(M,N)=SQRT((ELL2-EMM2)/(4.*ELL2-1.))
        ENDIF
        REPSI(M,N)=0.0
        IF(EPSI(M,N).GT.0.) REPSI(M,N)=1./EPSI(M,N)
   10 CONTINUE
      SQRHLF=SQRT(.5)
      DO 20 M=2,MXP
        CONSQ(M) = SQRT(.5*(2.*EMM(M)+1.)/EMM(M))
   20 CONTINUE
c  quantities required by subroutines GRAD, UVSPEC, and VDS
c  saved in COMMON/UV, COMMON/GRADC, and COMMON/VDS (com_spectral.h)
      DO 15 M=1,MX
      DO 15 N=1,NX
        M1=MM(M)
        M2=M1+1
        EL1=FLOAT(LL(M,N))
        IF(N.EQ.1) THEN
          GRADX(M)=FLOAT(M1)/A
          UVDX(M,1)=-A/FLOAT(M1+1)
          UVDYM(M,1)=0.0
          VDDYM(M,1)=0.0
        ELSE
          UVDX(M,N)=-A*FLOAT(M1)/(EL1*(EL1+1))
          GRADYM(M,N)=(EL1-1.)*EPSI(M2,N)/A
          UVDYM(M,N)=-A*EPSI(M2,N)/EL1
          VDDYM(M,N)=(EL1+1)*EPSI(M2,N)/A
        ENDIF
        GRADYP(M,N)=(EL1+2.)*EPSI(M2,N+1)/A
        UVDYP(M,N)=-A*EPSI(M2,N+1)/(EL1+1.)
        VDDYP(M,N)=EL1*EPSI(M2,N+1)/A
   15 CONTINUE
c  generate associated Legendre polynomial
c  LGNDRE computes the polynomials at a particular latitiude, POLY(MX,NX), and stores
c  them in COMMON/POL (com_spectral.h)
c  polynomials and 'clones' stored in COMMON/POL1 (com_spectral.h)
      DO 30 J=1,IY
        CALL LGNDRE(J)
        DO 51 N=1,NX
        DO 51 M=1,MX
          M1=2*M-1
          M2=2*M
          CPOL(M1,N,J)=POLY(M,N)
          CPOL(M2,N,J)=POLY(M,N)
   51   CONTINUE
   30 CONTINUE
      RETURN
      END
****************************************************************
      SUBROUTINE LGNDRE(J)
c  follows Leith Holloways code

      include "atparam.h"
c      include "param1spec.h"
      PARAMETER (SMALL = 1.E-30)
      include "com_spectral.h"

      DIMENSION ALP(MXP,NX)
        Y = COA(J)
        X = SIA(J)
c  start recursion with N=1 (M=L) diagonal
        ALP(1,1) = SQRHLF
        DO 31 M=2,MXP
          ALP(M,1) = CONSQ(M)*Y*ALP(M-1,1)
   31   CONTINUE
c  continue with other elements
        DO 32 M=1,MXP
          ALP(M,2)=(X*ALP(M,1))*REPSI(M,2)
   32   CONTINUE
        DO 33 N=3,NX
        DO 33 M=1,MXP
          ALP(M,N)=(X*ALP(M,N-1)-EPSI(M,N-1)*ALP(M,N-2))*REPSI(M,N)
   33   CONTINUE
c  zero polynomials with absolute values smaller than 10**(-30)
        DO 34 N=1,NX
        DO 34 M=1,MXP
          IF(ABS(ALP(M,N)) .LE. SMALL) ALP(M,N)=0.0
   34   CONTINUE
c   pick off the required polynomials
        DO 35 N=1,NX
        DO 35 M=1,MX
          MM2=ISC*(M-1)+1
          POLY(M,N)=ALP(MM2,N)
   35   CONTINUE
      RETURN
      END
***************************************************************
      SUBROUTINE LAP(STRM,VORM)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      COMPLEX VORM(MX,NX),STRM(MX,NX)
      DO 1 N=1,NX
      DO 1 M=1,MX
        VORM(M,N)=-STRM(M,N)*EL2(M,N)
    1 CONTINUE

      RETURN
      END
*******************************************************************
      SUBROUTINE INVLAP(VORM,STRM)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      COMPLEX VORM(MX,NX),STRM(MX,NX)
      DO 1 N=1,NX
      DO 1 M=1,MX
        STRM(M,N)=-VORM(M,N)*ELM2(M,N)
    1 CONTINUE
c     DO 1 M=1,MXNX
c       STRM(M,1)=-VORM(M,1)*ELM2(M,1)
c   1 CONTINUE
      RETURN
      END
*********************************************************************
      SUBROUTINE GRAD(PSI,PSDX,PSDY)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      DIMENSION PSI(2,MX,NX),PSDX(2,MX,NX),PSDY(2,MX,NX)
      DO 1 N=1,NX
      DO 1 M=1,MX
        PSDX(2,M,N)=GRADX(M)*PSI(1,M,N)
        PSDX(1,M,N)=-GRADX(M)*PSI(2,M,N)
    1 CONTINUE
      DO 2 K=1,2
      DO 2 M=1,MX
        PSDY(K,M,1)=GRADYP(M,1)*PSI(K,M,2)
        PSDY(K,M,NX)=-GRADYM(M,NX)*PSI(K,M,NTRUN1)
    2 CONTINUE
      DO 3 K=1,2
      DO 3 N=2,NTRUN1
      DO 3 M=1,MX
        PSDY(K,M,N)=-GRADYM(M,N)*PSI(K,M,N-1)+GRADYP(M,N)*PSI(K,M,N+1)
    3 CONTINUE
      RETURN
      END
******************************************************************
      SUBROUTINE VDS(UCOSM,VCOSM,VORM,DIVM)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      DIMENSION VORM(2,MX,NX),DIVM(2,MX,NX),UCOSM(2,MX,NX),
     * VCOSM(2,MX,NX),ZC(2,MX,NX),ZP(2,MX,NX)
      do 1 n=1,nx
      DO 1 M=1,MX
        ZP(2,M,n)=GRADX(M)*UCOSM(1,M,n)
        ZP(1,M,n)=-GRADX(M)*UCOSM(2,M,n)
        ZC(2,M,n)=GRADX(M)*VCOSM(1,M,n)
        ZC(1,M,n)=-GRADX(M)*VCOSM(2,M,n)
    1 CONTINUE
      DO 3 K=1,2
      DO 3 M=1,MX
        VORM(K,M,1)=ZC(K,M,1)-VDDYP(M,1)*UCOSM(K,M,2)
        VORM(K,M,NX)=VDDYM(M,NX)*UCOSM(K,M,NTRUN1)
        DIVM(K,M,1)=ZP(K,M,1)+VDDYP(M,1)*VCOSM(K,M,2)
        DIVM(K,M,NX)=-VDDYM(M,NX)*VCOSM(K,M,NTRUN1)
    3 CONTINUE
      DO 4 K=1,2
      DO 4 N=2,NTRUN1
      DO 4 M=1,MX
        VORM(K,M,N)=VDDYM(M,N)*UCOSM(K,M,N-1)-VDDYP(M,N)*
     *   UCOSM(K,M,N+1)+ZC(K,M,N)
        DIVM(K,M,N)=-VDDYM(M,N)*VCOSM(K,M,N-1)+VDDYP(M,N)*
     *   VCOSM(K,M,N+1)+ZP(K,M,N)
    4 CONTINUE
      RETURN
      END
******************************************************************
      SUBROUTINE UVSPEC(VORM,DIVM,UCOSM,VCOSM)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      DIMENSION VORM(2,MX,NX),DIVM(2,MX,NX),UCOSM(2,MX,NX),
     * VCOSM(2,MX,NX),ZC(2,MX,NX),ZP(2,MX,NX)
c     DO 1 M=1,MXNX
      DO 1 M=1,MX
      DO 1 n=1,NX
        ZP(2,M,n)=UVDX(M,n)*VORM(1,M,n)
        ZP(1,M,n)=-UVDX(M,n)*VORM(2,M,n)
        ZC(2,M,n)=UVDX(M,n)*DIVM(1,M,n)
        ZC(1,M,n)=-UVDX(M,n)*DIVM(2,M,n)
    1 CONTINUE
      DO 3 K=1,2
      DO 3 M=1,MX
        UCOSM(K,M,1)=ZC(K,M,1)-UVDYP(M,1)*VORM(K,M,2)
        UCOSM(K,M,NX)=UVDYM(M,NX)*VORM(K,M,NTRUN1)
        VCOSM(K,M,1)=ZP(K,M,1)+UVDYP(M,1)*DIVM(K,M,2)
        VCOSM(K,M,NX)=-UVDYM(M,NX)*DIVM(K,M,NTRUN1)
    3 CONTINUE
      DO 4 K=1,2
      DO 4 N=2,NTRUN1
      DO 4 M=1,MX
        VCOSM(K,M,N)=-UVDYM(M,N)*DIVM(K,M,N-1)+UVDYP(M,N)*
     *   DIVM(K,M,N+1)+ZP(K,M,N)
        UCOSM(K,M,N)= UVDYM(M,N)*VORM(K,M,N-1)-UVDYP(M,N)*
     *   VORM(K,M,N+1)+ZC(K,M,N)
    4 CONTINUE
      RETURN
      END
*******************************************************************
      SUBROUTINE GRID(VORM,VORG,KCOS)

      include "atparam.h"
c      include "param1spec.h"

      DIMENSION VORG(IX,IL)
      DIMENSION VORM(MX2,NX),VARM(MX2,IL)
      CALL GRIDY(VORM,VARM)
      CALL GRIDX(VARM,VORG,KCOS)
      RETURN
      END
*********************************************************************
      SUBROUTINE SPEC(VORG,VORM)

      include "atparam.h"
c      include "param1spec.h"

      DIMENSION VORG(IX,IL)
      DIMENSION VORM(MX2,NX),VARM(MX2,IL)
      CALL SPECX(VORG,VARM)
      CALL SPECY(VARM,VORM)
      RETURN
      END
*********************************************************************
      SUBROUTINE VDSPEC(UG,VG,VORM,DIVM,KCOS)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      DIMENSION UG(IX,IL),VG(IX,IL)
      DIMENSION VORM(MX2,NX),DIVM(MX2,NX),UM(MX2,IL),VM(MX2,IL)
      DIMENSION UG1(IX,IL),VG1(IX,IL)
      DIMENSION DUMC1(MX2,NX),DUMC2(MX2,NX)
      IF (KCOS.EQ.2) THEN
        DO 7 J=1,IL
          DO 8 I=1,IX
            UG1(I,J)=UG(I,J)*COSGR(J)
            VG1(I,J)=VG(I,J)*COSGR(J)
    8     CONTINUE
    7   CONTINUE
      ELSE
        DO 77 J=1,IL
          DO 88 I=1,IX
            UG1(I,J)=UG(I,J)*COSGR2(J)
            VG1(I,J)=VG(I,J)*COSGR2(J)
   88     CONTINUE
   77   CONTINUE
      ENDIF
      CALL SPECX(UG1,UM)
      CALL SPECX(VG1,VM)
      CALL SPECY(UM,DUMC1)
      CALL SPECY(VM,DUMC2)
      CALL VDS(DUMC1,DUMC2,VORM,DIVM)
      RETURN
      END
*********************************************************************
      SUBROUTINE GRIDY(V,VARM)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      DIMENSION VARM(MX2,IL),V(MX2,NX)
      DIMENSION VM1(MX2),VM2(MX2)

      DO 100 J=1,IY
        J1=IL+1-J

        DO M=1,MX2
          VM1(M)=0.
          VM2(M)=0.
        ENDDO

        DO N=1,NX,2
C        DO M=1,MX2
         DO M=1,nsh2(n)
           VM1(M)=VM1(M)+V(M,N)*CPOL(M,N,J)
         ENDDO
        ENDDO

        DO N=2,NX,2
C        DO M=1,MX2
         DO M=1,nsh2(n)
           VM2(M)=VM2(M)+V(M,N)*CPOL(M,N,J)
         ENDDO
        ENDDO

        DO M=1,MX2
          VARM(M,J1)=VM1(M)+VM2(M)
          VARM(M,J) =VM1(M)-VM2(M)
        ENDDO

  100 CONTINUE

      RETURN
      END
******************************************************************
      SUBROUTINE SPECY(VARM,VORM)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      DIMENSION VARM(MX2,IL), VORM(MX2,NX)
      dimension svarm(mx2,iy), dvarm(mx2,iy)

      DO N=1,NX
       DO M=1,MX2
         VORM(M,N)=0.
       ENDDO
      ENDDO

      do j=1,iy
        j1=il+1-j
        do m=1,mx2
          svarm(m,j)=(varm(m,j1)+varm(m,j))*wt(j)
          dvarm(m,j)=(varm(m,j1)-varm(m,j))*wt(j)
        ENDDO
      ENDDO

      DO 100 J=1,IY
        J1=IL+1-J

        DO N=1,NTRUN1,2
C        DO M=1,MX2
         DO M=1,nsh2(n)
           VORM(M,N) = VORM(M,N)+CPOL(M,N,J)*svarm(m,j)
         ENDDO
        ENDDO

        DO N=2,NTRUN1,2
C        DO M=1,MX2
         DO M=1,nsh2(n)
           VORM(M,N) = VORM(M,N)+CPOL(M,N,J)*dvarm(m,j)
         ENDDO
        ENDDO

  100 CONTINUE

      RETURN
      END
******************************************************************
      SUBROUTINE TRUNCT(VOR)

      include "atparam.h"
c      include "param1spec.h"
      include "com_spectral.h"

      COMPLEX VOR(MX,NX)

c       DO 20 M=1,MXNX
        DO 20 N=1,NX
        DO 20 M=1,MX
          VOR(M,N)=VOR(M,N)*TRFILT(M,N)
   20   CONTINUE

      RETURN
      END


C$Procedure QXQ (Quaternion times quaternion)

      SUBROUTINE QXQ ( Q1, Q2, QOUT )

C$ Abstract
C
C     Multiply two quaternions.
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     ROTATION
C
C$ Keywords
C
C     MATH
C     POINTING
C     ROTATION
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      Q1   ( 0 : 3 )
      DOUBLE PRECISION      Q2   ( 0 : 3 )
      DOUBLE PRECISION      QOUT ( 0 : 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     Q1         I   First SPICE quaternion factor.
C     Q2         I   Second SPICE quaternion factor.
C     QOUT       O   Product of Q1 and Q2.
C
C$ Detailed_Input
C
C     Q1             is a 4-vector representing a SPICE-style
C                    quaternion. See the discussion of quaternion
C                    styles in Particulars below.
C
C                    Note that multiple styles of quaternions
C                    are in use.  This routine will not work properly
C                    if the input quaternions do not conform to
C                    the SPICE convention.  See the Particulars
C                    section for details.
C
C     Q2             is a second SPICE-style quaternion.
C
C$ Detailed_Output
C
C     QOUT           is 4-vector representing the quaternion product
C
C                       Q1 * Q2
C
C                    Representing Q(i) as the sums of scalar (real)
C                    part s(i) and vector (imaginary) part v(i)
C                    respectively,
C
C                       Q1 = s1 + v1
C                       Q2 = s2 + v2
C
C                    QOUT has scalar part s3 defined by
C
C                       s3 = s1 * s2 - <v1, v2>
C
C                    and vector part v3 defined by
C
C                       v3 = s1 * v2  +  s2 * v1  +  v1 x v2
C
C                    where the notation < , > denotes the inner
C                    product operator and x indicates the cross
C                    product operator.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C
C     Quaternion Styles
C     -----------------
C
C     There are different "styles" of quaternions used in
C     science and engineering applications. Quaternion styles
C     are characterized by
C
C        - The order of quaternion elements
C
C        - The quaternion multiplication formula
C
C        - The convention for associating quaternions
C          with rotation matrices
C
C     Two of the commonly used styles are
C
C        - "SPICE"
C
C           > Invented by Sir William Rowan Hamilton
C           > Frequently used in mathematics and physics textbooks
C
C        - "Engineering"
C
C           > Widely used in aerospace engineering applications
C
C
C     SPICELIB subroutine interfaces ALWAYS use SPICE quaternions.
C     Quaternions of any other style must be converted to SPICE
C     quaternions before they are passed to SPICELIB routines.
C
C
C     Relationship between SPICE and Engineering Quaternions
C     ------------------------------------------------------
C
C     Let M be a rotation matrix such that for any vector V,
C
C        M*V
C
C     is the result of rotating V by theta radians in the
C     counterclockwise direction about unit rotation axis vector A.
C     Then the SPICE quaternions representing M are
C
C        (+/-) (  cos(theta/2),
C                 sin(theta/2) A(1),
C                 sin(theta/2) A(2),
C                 sin(theta/2) A(3)  )
C
C     while the engineering quaternions representing M are
C
C        (+/-) ( -sin(theta/2) A(1),
C                -sin(theta/2) A(2),
C                -sin(theta/2) A(3),
C                 cos(theta/2)       )
C
C     For both styles of quaternions, if a quaternion q represents
C     a rotation matrix M, then -q represents M as well.
C
C     Given an engineering quaternion
C
C        QENG   = ( q0,  q1,  q2,  q3 )
C
C     the equivalent SPICE quaternion is
C
C        QSPICE = ( q3, -q0, -q1, -q2 )
C
C
C     Associating SPICE Quaternions with Rotation Matrices
C     ----------------------------------------------------
C
C     Let FROM and TO be two right-handed reference frames, for
C     example, an inertial frame and a spacecraft-fixed frame. Let the
C     symbols
C
C        V    ,   V
C         FROM     TO
C
C     denote, respectively, an arbitrary vector expressed relative to
C     the FROM and TO frames. Let M denote the transformation matrix
C     that transforms vectors from frame FROM to frame TO; then
C
C        V   =  M * V
C         TO         FROM
C
C     where the expression on the right hand side represents left
C     multiplication of the vector by the matrix.
C
C     Then if the unit-length SPICE quaternion q represents M, where
C
C        q = (q0, q1, q2, q3)
C
C     the elements of M are derived from the elements of q as follows:
C
C          +-                                                         -+
C          |           2    2                                          |
C          | 1 - 2*( q2 + q3 )   2*(q1*q2 - q0*q3)   2*(q1*q3 + q0*q2) |
C          |                                                           |
C          |                                                           |
C          |                               2    2                      |
C      M = | 2*(q1*q2 + q0*q3)   1 - 2*( q1 + q3 )   2*(q2*q3 - q0*q1) |
C          |                                                           |
C          |                                                           |
C          |                                                   2    2  |
C          | 2*(q1*q3 - q0*q2)   2*(q2*q3 + q0*q1)   1 - 2*( q1 + q2 ) |
C          |                                                           |
C          +-                                                         -+
C
C     Note that substituting the elements of -q for those of q in the
C     right hand side leaves each element of M unchanged; this shows
C     that if a quaternion q represents a matrix M, then so does the
C     quaternion -q.
C
C     To map the rotation matrix M to a unit quaternion, we start by
C     decomposing the rotation matrix as a sum of symmetric
C     and skew-symmetric parts:
C
C                                        2
C        M = [ I  +  (1-cos(theta)) OMEGA  ] + [ sin(theta) OMEGA ]
C
C                     symmetric                   skew-symmetric
C
C
C     OMEGA is a skew-symmetric matrix of the form
C
C                   +-             -+
C                   |  0   -n3   n2 |
C                   |               |
C         OMEGA  =  |  n3   0   -n1 |
C                   |               |
C                   | -n2   n1   0  |
C                   +-             -+
C
C     The vector N of matrix entries (n1, n2, n3) is the rotation axis
C     of M and theta is M's rotation angle.  Note that N and theta
C     are not unique.
C
C     Let
C
C        C = cos(theta/2)
C        S = sin(theta/2)
C
C     Then the unit quaternions Q corresponding to M are
C
C        Q = +/- ( C, S*n1, S*n2, S*n3 )
C
C     The mappings between quaternions and the corresponding rotations
C     are carried out by the SPICELIB routines
C
C        Q2M {quaternion to matrix}
C        M2Q {matrix to quaternion}
C
C     M2Q always returns a quaternion with scalar part greater than
C     or equal to zero.
C
C
C     SPICE Quaternion Multiplication Formula
C     ---------------------------------------
C
C     Given a SPICE quaternion
C
C        Q = ( q0, q1, q2, q3 )
C
C     corresponding to rotation axis A and angle theta as above, we can
C     represent Q using "scalar + vector" notation as follows:
C
C        s =   q0           = cos(theta/2)
C
C        v = ( q1, q2, q3 ) = sin(theta/2) * A
C
C        Q = s + v
C
C     Let Q1 and Q2 be SPICE quaternions with respective scalar
C     and vector parts s1, s2 and v1, v2:
C
C        Q1 = s1 + v1
C        Q2 = s2 + v2
C
C     We represent the dot product of v1 and v2 by
C
C        <v1, v2>
C
C     and the cross product of v1 and v2 by
C
C        v1 x v2
C
C     Then the SPICE quaternion product is
C
C        Q1*Q2 = s1*s2 - <v1,v2>  + s1*v2 + s2*v1 + (v1 x v2)
C
C     If Q1 and Q2 represent the rotation matrices M1 and M2
C     respectively, then the quaternion product
C
C        Q1*Q2
C
C     represents the matrix product
C
C        M1*M2
C
C
C$ Examples
C
C     1)  Let QID, QI, QJ, QK be the "basis" quaternions
C
C            QID  =  ( 1, 0, 0, 0 )
C            QI   =  ( 0, 1, 0, 0 )
C            QJ   =  ( 0, 0, 1, 0 )
C            QK   =  ( 0, 0, 0, 1 )
C
C         respectively.  Then the calls
C
C            CALL QXQ ( QI, QJ, IXJ )
C            CALL QXQ ( QJ, QK, JXK )
C            CALL QXQ ( QK, QI, KXI )
C
C         produce the results
C
C            IXJ = QK
C            JXK = QI
C            KXI = QJ
C
C         All of the calls
C
C            CALL QXQ ( QI, QI, QOUT )
C            CALL QXQ ( QJ, QJ, QOUT )
C            CALL QXQ ( QK, QK, QOUT )
C
C         produce the result
C
C            QOUT  =  -QID
C
C         For any quaternion Q, the calls
C
C            CALL QXQ ( QID, Q,   QOUT )
C            CALL QXQ ( Q,   QID, QOUT )
C
C         produce the result
C
C            QOUT  =  Q
C
C
C
C     2)  Composition of rotations:  let CMAT1 and CMAT2 be two
C         C-matrices (which are rotation matrices).  Then the
C         following code fragment computes the product CMAT1 * CMAT2:
C
C
C            C
C            C     Convert the C-matrices to quaternions.
C            C
C                  CALL M2Q ( CMAT1, Q1 )
C                  CALL M2Q ( CMAT2, Q2 )
C
C            C
C            C     Find the product.
C            C
C                  CALL QXQ ( Q1, Q2, QOUT )
C
C            C
C            C     Convert the result to a C-matrix.
C            C
C                  CALL Q2M ( QOUT, CMAT3 )
C
C            C
C            C     Multiply CMAT1 and CMAT2 directly.
C            C
C                  CALL MXM ( CMAT1, CMAT2, CMAT4 )
C
C            C
C            C     Compare the results.  The difference DIFF of
C            C     CMAT3 and CMAT4 should be close to the zero
C            C     matrix.
C            C
C                  CALL VSUBG ( 9, CMAT3, CMAT4, DIFF )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 26-FEB-2008 (NJB)
C
C        Updated header; added information about SPICE
C        quaternion conventions.
C
C-    SPICELIB Version 1.0.0, 18-AUG-2002 (NJB)
C
C-&

C$ Index_Entries
C
C     quaternion times quaternion
C     multiply quaternion by quaternion
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDOT

C
C     Local variables
C
      DOUBLE PRECISION      CROSS ( 3 )

C
C     Compute the scalar part of the product.
C
      QOUT(0)  =  Q1(0) * Q2(0)  -  VDOT( Q1(1), Q2(1) )

C
C     And now the vector part.  The SPICELIB routine VLCOM3 computes
C     a linear combination of three 3-vectors.
C
      CALL VCRSS  ( Q1(1),  Q2(1),  CROSS )

      CALL VLCOM3 ( Q1(0),  Q2(1),
     .              Q2(0),  Q1(1),
     .              1.D0,   CROSS,  QOUT(1) )

      RETURN
      END


      SUBROUTINE MA01AD( XR, XI, YR, YI )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the complex square root YR + i*YI of a complex number
C     XR + i*XI  in real arithmetic.  The returned result is so that
C     YR >= 0.0  and  SIGN(YI) = SIGN(XI).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     XR      (input) DOUBLE PRECISION
C     XI      (input) DOUBLE PRECISION
C             These scalars define the real and imaginary part of the
C             complex number of which the square root is sought.
C
C     YR      (output) DOUBLE PRECISION
C     YI      (output) DOUBLE PRECISION
C             These scalars define the real and imaginary part of the
C             complex square root.
C
C     METHOD
C
C     The complex square root YR + i*YI of the complex number XR + i*XI
C     is computed in real arithmetic, taking care to avoid overflow.
C
C     REFERENCES
C
C     Adapted from EISPACK subroutine CSROOT.
C
C     CONTRIBUTOR
C
C     P. Benner, Universitaet Bremen, Germany, and
C     R. Byers, University of Kansas, Lawrence, USA,
C     Aug. 1998, routine DCROOT.
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 1998, SLICOT Library version.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF
      PARAMETER         ( ZERO = 0.0D0, HALF = 1.0D0/2.0D0 )
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XR, XI, YR, YI
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION  S
C     ..
C     .. External Functions ..
      DOUBLE PRECISION  DLAPY2
      EXTERNAL          DLAPY2
C
C     .. Intrinsic functions ..
      INTRINSIC         ABS, SQRT
C     ..
C     .. Executable Statements ..
C
      S = SQRT( HALF*( DLAPY2( XR, XI ) + ABS( XR ) ) )
      IF ( XR.GE.ZERO ) YR =  S
      IF ( XI.LT.ZERO ) S  = -S
      IF ( XR.LE.ZERO ) THEN
         YI =  S
         IF ( XR.LT.ZERO ) YR =  HALF*( XI/S )
      ELSE
         YI =  HALF*( XI/YR )
      END IF
C
      RETURN
C     *** Last line of MA01AD ***
      END


      SUBROUTINE CCOEF(N, CROOT, CCOF)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1995-11-29 CCOEF  Krogh   Converted from SFTRAN to Fortran 77
C>> 1987-02-25 CCOEF  Lawson  Initial code.
c Conversion should only be done from "Z" to "C" for processing to C.
c--C replaces "?": ?COEF
C
c     Given N complex numbers, this subr computes the (complex)
c     coefficients of the Nth degree monic polynomial having these
c     numbers as its roots.
c     C. L. Lawson, JPL, 1987 Feb 13.
c
c     N     [In, Integer]  Number of given roots and degree of poly.
c     CROOT() [In, Complex]  The given ith complex root is CROOT(i).
c     CCOF()  [Out, Complex]  The (complex) coefficient of z**j will be
c           stored in CCOF(N+1-j) for j = 0, ...,N+1.  The high
c           order coeff will be one, i.e. CCOF(1) = (1.0, 0.0).
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      INTEGER N, I, J
      COMPLEX CROOT(N), CCOF(N+1), CROOTI
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      CCOF(1) = 1.E0
      CCOF(2) = -CROOT(1)
      DO 20 I = 2,N
        CROOTI = CROOT(I)
        CCOF(I+1) = -CCOF(I) * CROOTI
        DO 10 J = I,2,-1
           CCOF(J) = CCOF(J) - CCOF(J-1) * CROOTI
   10   continue
   20 continue
      RETURN
      END


SUBROUTINE DetermineGenericStencilsUniform(StencilsG,alpha)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: alpha, i, rank, order
REAL(KIND=long), DIMENSION(2*alpha+1,2*alpha+1,2) :: StencilsG
REAL(KIND=long) :: x0, grid(2*alpha+1)
REAL(KIND=long), DIMENSION(:,:), ALLOCATABLE :: c
rank = 2*alpha+1
ALLOCATE( c(rank,3) )
rank = 2*alpha+1
DO i = 1, rank
	grid(i) = REAL(i,long)
END DO
DO order = 1, 2
	DO i = 1, rank
		! Expansion point where the approximation is to be defined
		x0 = REAL(i,long)
		! Determine local finite difference stencil coefficients
		CALL weights(x0,grid,rank-1,rank-1,order,c)
		StencilsG(1:rank,i,order) = c(1:rank,order+1)
	END DO
END DO
DEALLOCATE(c)
END SUBROUTINE DetermineGenericStencilsUniform


!The preceding program implements recursion using arrays, since Fortran 77 does not allow recursive
!functions. The same algorithm is much easier to follow in Fortran 90, using the RECURSIVE keyword.
!Like previously, the program only counts solutions. It's pretty straightforward to adapt it to print
!them too: one has to replace the 'm = m + 1' instruction with a PRINT statement.

function numq(n)
    implicit none
    integer :: i, n, m, a(n), numq
    logical :: up(2*n - 1), down(2*n - 1)
    do i = 1, n
        a(i) = i
    end do
    up = .true.
    down = .true.
    m = 0
    call sub(1)
    numq = m
contains
    recursive subroutine sub(i)
        integer :: i, j, k, p, q, s
        do k = i, n
            j = a(k)
            p = i + j - 1
            q = i - j + n
            if(up(p) .and. down(q)) then
                if(i == n) then
                    m = m + 1
                else
                    up(p) = .false.
                    down(q) = .false.
                    s = a(i)
                    a(i) = a(k)
                    a(k) = s
                    call sub(i + 1)
                    up(p) = .true.
                    down(q) = .true.
                    s = a(i)
                    a(i) = a(k)
                    a(k) = s
                end if
            end if
        end do
    end subroutine
end function

program queens
    implicit none
    integer :: numq, n, m
    do n = 4, 16
        m = numq(n)
        print *, n, m
    end do
end program


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZEXROU (Zomplex EXample Roots Of Unity)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the Nth order roots of unity by solving a
! corresponding unitary eigenvalue problem two different ways.
!
! 1) Form upper hessenberg permutation matrix and compute its
!    eigenvalues using ZUHFQR
!
! 2) Construct the factorization directly and compute its
!    eigenvalues using ZUFFQR
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program ZEXROU

  implicit none

  ! compute variables
  integer, parameter :: N = 16
  integer :: ii, INFO
  real(8) :: WORK(5*N), Q(3*(N-1)), D(2*N)
  complex(8) :: H(N,N), Z
  integer :: ITS(N-1)

  ! print banner
  print*,""
  print*,"ZEXROU: Zomplex EXample Roots Of Unity"
  print*,""

  ! initialize H to be an upper hessenberg permutation matrix
  H = cmplx(0d0,0d0,kind=8)
  do ii=1,N-1
    H(ii+1,ii) = cmplx(1d0,0d0,kind=8)
  end do
  H(1,N) = cmplx(1d0,0d0,kind=8)

  ! call zuhfqr
  call ZUHFQR('N',N,H,Z,ITS,WORK,INFO)

  ! check INFO
  if (INFO.NE.0) then
    print*,"ZUHFQR failed."
    print*,"INFO:",INFO
  end if

  ! print diag of H
  print*,"Roots computed using ZUHFQR:"
  do ii=1,N
    print*,dble(H(ii,ii)),aimag(H(ii,ii))
  end do
  print*,""

  ! initialize Q and D to be an upper hessenberg permutation matrix
  do ii=1,N-1
    Q(3*ii-2) = 0d0
    Q(3*ii-1) = 0d0
    Q(3*ii) = 1d0
  end do
  do ii=1,N-1
    D(2*ii-1) = 1d0
    D(2*ii) = 0d0
  end do
  D(2*N-1) = (-1d0)**(N-1)
  D(2*N) = 0d0

  ! call zuffqr
  call ZUFFQR('N',N,Q,D,Z,ITS,INFO)

  ! check INFO
  if (INFO.NE.0) then
    print*,"ZUFFQR failed."
    print*,"INFO:",INFO
  end if

  ! print D
  print*,"Roots computed using ZUFFQR:"
  do ii=1,N
    print*,D(2*ii-1),D(2*ii)
  end do
  print*,""

end program ZEXROU


      SUBROUTINE dfpmin(p,n,gtol,iter,fret,func,dfunc)
      INTEGER iter,n,NMAX,ITMAX
      REAL fret,gtol,p(n),func,EPS,STPMX,TOLX
      PARAMETER (NMAX=50,ITMAX=200,STPMX=100.,EPS=3.e-8,TOLX=4.*EPS)
      EXTERNAL dfunc,func
CU    USES dfunc,func,lnsrch
      INTEGER i,its,j
      LOGICAL check
      REAL den,fac,fad,fae,fp,stpmax,sum,sumdg,sumxi,temp,test,dg(NMAX),
     *g(NMAX),hdg(NMAX),hessin(NMAX,NMAX),pnew(NMAX),xi(NMAX)
      fp=func(p)
      call dfunc(p,g)
      sum=0.
      do 12 i=1,n
        do 11 j=1,n
          hessin(i,j)=0.
11      continue
        hessin(i,i)=1.
        xi(i)=-g(i)
        sum=sum+p(i)**2
12    continue
      stpmax=STPMX*max(sqrt(sum),float(n))
      do 27 its=1,ITMAX
        iter=its
        call lnsrch(n,p,fp,g,xi,pnew,fret,stpmax,check,func)
        fp=fret
        do 13 i=1,n
          xi(i)=pnew(i)-p(i)
          p(i)=pnew(i)
13      continue
        test=0.
        do 14 i=1,n
          temp=abs(xi(i))/max(abs(p(i)),1.)
          if(temp.gt.test)test=temp
14      continue
        if(test.lt.TOLX)return
        do 15 i=1,n
          dg(i)=g(i)
15      continue
        call dfunc(p,g)
        test=0.
        den=max(fret,1.)
        do 16 i=1,n
          temp=abs(g(i))*max(abs(p(i)),1.)/den
          if(temp.gt.test)test=temp
16      continue
        if(test.lt.gtol)return
        do 17 i=1,n
          dg(i)=g(i)-dg(i)
17      continue
        do 19 i=1,n
          hdg(i)=0.
          do 18 j=1,n
            hdg(i)=hdg(i)+hessin(i,j)*dg(j)
18        continue
19      continue
        fac=0.
        fae=0.
        sumdg=0.
        sumxi=0.
        do 21 i=1,n
          fac=fac+dg(i)*xi(i)
          fae=fae+dg(i)*hdg(i)
          sumdg=sumdg+dg(i)**2
          sumxi=sumxi+xi(i)**2
21      continue
        if(fac**2.gt.EPS*sumdg*sumxi)then
          fac=1./fac
          fad=1./fae
          do 22 i=1,n
            dg(i)=fac*xi(i)-fad*hdg(i)
22        continue
          do 24 i=1,n
            do 23 j=1,n
              hessin(i,j)=hessin(i,j)+fac*xi(i)*xi(j)-fad*hdg(i)*hdg(j)+
     *fae*dg(i)*dg(j)
23          continue
24        continue
        endif
        do 26 i=1,n
          xi(i)=0.
          do 25 j=1,n
            xi(i)=xi(i)-hessin(i,j)*g(j)
25        continue
26      continue
27    continue
      pause 'too many iterations in dfpmin'
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/dfpmin.for


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  This module contains code for representing functions via piecewise Chebyshev
!  expansions.  More accurately, functions on an interval [a,b] can be represented either
!  via their values  at the Chebyshev grids on a collection of subintervals [a,b] or
!  via their Chebyshev expansion coefficients on said subintervals.
!
!  The following routines should be regarded as public:
!
!    chebexps - construct the n-point Clenshaw-Curtis quadrature on the interval [-1,1],
!      the matrix which takes the values of a function to the Chebyshev coefficients of the
!      polynomial interpolating the function at the nodes of the quadrature rule, as well
!      as the "left" and "right" spectral integration matrices.!
!
!    chebs - evaluate the Chebyshev polynomials of orders 0 through n at a specified
!      point in the interval [-1,1]
!
!    chebeval - evaluate a polynomial of degree n-1 whose values are given
!      on the n-point Chebyshev grid on an interval [a,b] using the well-known
!      barycentric interpolation formula
!
!    chebeval2 - use the Clenshaw algorithm in order to evaluate an n-term Chebyshev
!      expansion on the interval [a,b] at a specified point t in [a,b]
!
!    chebevalder - evaluate an n-term Chebyshev expansion on the interval [a,b]
!      and its derivative at a specified point x in [a,b]
!
!    chebpw_eval - evaluate a function specified by its values at k-point Chebyshev
!      grids on a collection of subintervals of [a,b] at an arbitrary point x in
!      [a,b]
!
!    chebpw_eval2 - evaluate a piecewise Chebyshev expansion given on a collection
!      of subintervals of [a,b] at a specified point x in [a,b]
!
!    chebpw_aint - apply the matrix interpolating a function from a piecewise
!      Chebyshev grid to a user-specified collection of points to a vector
!
!    chebpw_aintt - apply the transpose of the matrix interpolating a function from
!      a piecewise Chebyshev grid to a user-specified collection of points to a vector
!
!    chebpw_aint_c - apply the matrix interpolating a function from a piecewise
!      Chebyshev grid to a user-specified collection of points to a complex-valued
!      vector
!
!    chebpw_aintt_c - apply the transpose of the matrix interpolating a function from
!      a piecewise Chebyshev grid to a user-specified collection of points to a complex-
!      valued vector
!
!    write_chebexps - write a chebexps structure to a text file on the disk
!
!    read_chebexps - read a chebexps structure from a text file on the disk
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module chebyshev

use utils

!
!  The chebexps_data structure contains the following elements:
!
!    xs - an array containing the n quadrature nodes
!    whts - an array containing the n quadrature weights
!    u - the (n,n) matrix which takes the values of an n-term Chebyshev expansion
!      at the n quadrature nodes to the n expansion coefficients
!    v - the (n,n) matrix which takes the coefficients of an nterm-Chebyshev
!      expansion to its values at the n quadratue nodes
!    aintl - the "left" spectral integration matrix which takes the values
!      of a function f(t) on the Chebyshev nodes to the value of the function g(t)
!      defined via the formula
!
!                     t
!          g(t) = \int  f(u) du
!                     a
!
!    aintr - the "right" spectral integration matrix which takes the values
!      of a function f(t) on the Chebyshev nodes to the value of the function g(t)
!      defined via the formula
!
!                     t
!          g(t) = \int_ f(u) du
!                     b
!    aintr2, aintr3, aintl2, aintl3 - the higher order left and right spectral
!      integration matrices
!

type      chebexps_data
integer                       :: k
double precision, allocatable :: xs(:),whts(:),u(:,:),v(:,:)

! left and right spectral integration matrices
double precision, allocatable :: aintr(:,:),aintr2(:,:),aintr3(:,:)
double precision, allocatable :: aintl(:,:),aintl2(:,:),aintl3(:,:)

end type  chebexps_data

contains

subroutine chebpw_aint(chebdata,nints,ab,nts,ts,x,y)
implicit double precision (a-h,o-z)

type(chebexps_data)        :: chebdata
integer                    :: nints
double precision           :: ab(2,nints), x(chebdata%k,nints)
double precision           :: ts(nts)
double precision           :: y(nts)

!
!  Apply the matrix interpolating a function whose values are given at the
!  nodes of a piecewise Chebyshev discretization scheme to a set of user-specified
!  points.
!
!  IMPORTANT - the list of user-specified points must be sorted in ascending order.
!
!  Input parameters:
!    chebdata - chebyshev expansion and interpolation data
!    nints - the number of intervals in the discretization scheme
!    ab - a (2,nints) array giving the endpoints of the intervals in the discretization
!      scheme
!    nts - the number of user-specified nodes
!    ts - an array containing the user specified nodes SORTED IN ASCENDING ORDER
!    x - the vector to which the transpose of the matrix should be applied
!
!  Output parameters:
!    y - the output vector
!

double precision           :: whts(chebdata%k)

eps0 = epsilon(0.0d0)
int0 = 1
k    = chebdata%k

do i=1,nts
t = ts(i)

do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int

xx    = (2*t - (b+a) ) /(b-a)
dsign = 1.0d0
do l=1,k
diff    = chebdata%xs(l) - xx
if (abs(diff) .lt. eps0) then
val = x(l,int)
goto 1000
endif
whts(l) = dsign/diff
dsign   = -dsign
end do

whts(1) = whts(1)/2
whts(k) = whts(k)/2
val     = sum(whts*x(:,int))/sum(whts)

1000 continue

y(i) = val
end do

end subroutine

subroutine chebpw_aintt(chebdata,nints,ab,nts,ts,x,y)
implicit double precision (a-h,o-z)

type(chebexps_data)        :: chebdata
integer                    :: nints
double precision           :: ab(2,nints)
double precision           :: ts(nts)
double precision           :: x(nts),y(chebdata%k,nints)

!
!  Apply the transpose of the matrix interpolating a function whose values
!  are given at the nodes of a piecewise Chebyshev discretization scheme to
!  a set of user-specified points.
!
!  IMPORTANT - the list of user-specified points must be sorted in ascending order.
!
!  Input parameters:
!    chebdata - chebyshev expansion and interpolation data
!    nints - the number of intervals in the discretization scheme
!    ab - a (2,nints) array giving the endpoints of the intervals in the discretization
!      scheme
!    nts - the number of user-specified nodes
!    ts - an array containing the user specified nodes SORTED IN ASCENDING ORDER
!    x - the vector to which the transpose of the matrix should be applied
!
!  Output parameters:
!    y - the output vector
!

double precision           :: whts(chebdata%k)

eps0 = epsilon(0.0d0)
int0 = 1
k    = chebdata%k
y    = 0
call prin2("x = ",x)
stop

!
!  Traverse the list of ts
!

do i=1,nts
t = ts(i)

do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int

xx    = (2*t - (b+a) ) /(b-a)
dsign = 1.0d0
do l=1,k
diff    = chebdata%xs(l) - xx
if (abs(diff) .lt. eps0) then
y(l,int) = y(l,int) + x(i)
goto 1000
endif
whts(l) = dsign/diff
dsign   = -dsign
end do
whts(1) = whts(1)/2
whts(k) = whts(k)/2

y(:,int) = y(:,int) + x(i)*whts(:)/sum(whts)
1000 continue

end do

end subroutine

subroutine chebpw_aint_c(chebdata,nints,ab,nts,ts,x,y)
implicit double precision (a-h,o-z)

type(chebexps_data)        :: chebdata
integer                    :: nints
double precision           :: ab(2,nints)
double precision           :: ts(nts)
double complex             :: y(nts), x(chebdata%k,nints)

!
!  Apply the matrix interpolating a function whose values are given at the
!  nodes of a piecewise Chebyshev discretization scheme to a set of user-specified
!  points.
!
!  IMPORTANT - the list of user-specified points must be sorted in ascending order.
!
!  Input parameters:
!    chebdata - chebyshev expansion and interpolation data
!    nints - the number of intervals in the discretization scheme
!    ab - a (2,nints) array giving the endpoints of the intervals in the discretization
!      scheme
!    nts - the number of user-specified nodes
!    ts - an array containing the user specified nodes SORTED IN ASCENDING ORDER
!    x - the vector to which the transpose of the matrix should be applied
!
!  Output parameters:
!    y - the output vector
!

double precision           :: whts(chebdata%k)

eps0 = epsilon(0.0d0)
int0 = 1
k    = chebdata%k

do i=1,nts
t = ts(i)

do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int

xx    = (2*t - (b+a) ) /(b-a)
dsign = 1.0d0
do l=1,k
diff    = chebdata%xs(l) - xx
if (abs(diff) .lt. eps0) then
val = x(l,int)
goto 1000
endif
whts(l) = dsign/diff
dsign   = -dsign
end do

whts(1) = whts(1)/2
whts(k) = whts(k)/2
val     = sum(whts*x(:,int))/sum(whts)

1000 continue

y(i) = val
end do

end subroutine

subroutine chebpw_aintt_c(chebdata,nints,ab,nts,ts,x,y)
implicit double precision (a-h,o-z)

type(chebexps_data)        :: chebdata
integer                    :: nints
double precision           :: ab(2,nints)
double precision           :: ts(nts)
double complex             :: x(nts),y(chebdata%k,nints)

!
!  Apply the transpose of the matrix interpolating a function whose values
!  are given at the nodes of a piecewise Chebyshev discretization scheme to
!  a set of user-specified points.
!
!  IMPORTANT - the list of user-specified points must be sorted in ascending order.
!
!  Input parameters:
!    chebdata - chebyshev expansion and interpolation data
!    nints - the number of intervals in the discretization scheme
!    ab - a (2,nints) array giving the endpoints of the intervals in the discretization
!      scheme
!    nts - the number of user-specified nodes
!    ts - an array containing the user specified nodes SORTED IN ASCENDING ORDER
!    x - the vector to which the transpose of the matrix should be applied
!
!  Output parameters:
!    y - the output vector
!

double precision           :: whts(chebdata%k)

eps0 = epsilon(0.0d0)
int0 = 1
k    = chebdata%k
y    = 0

!
!  Traverse the list of ts
!

do i=1,nts
t = ts(i)

do int=int0,nints-1
if (t .lt. ab(2,int)) exit
end do
a    = ab(1,int)
b    = ab(2,int)
int0 = int

xx    = (2*t - (b+a) ) /(b-a)
dsign = 1.0d0
do l=1,k
diff    = chebdata%xs(l) - xx
if (abs(diff) .lt. eps0) then
y(l,int) = y(l,int) + x(i)
goto 1000
endif
whts(l) = dsign/diff
dsign   = -dsign
end do
whts(1) = whts(1)/2
whts(k) = whts(k)/2

y(:,int) = y(:,int) + x(i)*whts(:)/sum(whts)
1000 continue

end do

end subroutine

subroutine chebexps(n,chebdata)
implicit double precision (a-h,o-z)
integer                               :: n
type(chebexps_data), intent(out)      :: chebdata

!
!  Populate a chebexps structure.
!
!  Input parameters:
!    n - the number of points in the chebyshev grid
!
!  Output parameters:
!   chebdata - the chebexps_data structure containing the elements described
!    above
!
!

double precision, allocatable :: pols(:),c(:,:),d(:,:),xx(:,:)
data pi /3.14159265358979323846264338327950288d0/

allocate(chebdata%xs(n),chebdata%whts(n),chebdata%u(n,n),chebdata%v(n,n))
allocate(pols(n+1),c(1,n),d(1,n))

chebdata%k = n
!
!  Construct the nodes
!

h = pi/(n-1)
do i=1,n
chebdata%xs(n-i+1) = cos(h*(i-1))
end do

!
!  Construct the matrix u which takes values to coefficients
!

do i=1,n
x = chebdata%xs(i)
call chebs(x,n-1,pols)
do j=1,n
chebdata%u(j,i) = pols(j)
chebdata%v(i,j) = pols(j)
end do
end do

chebdata%u(1,:) = chebdata%u(1,:)/2
chebdata%u(n,:) = chebdata%u(n,:)/2
chebdata%u(:,1) = chebdata%u(:,1)/2
chebdata%u(:,n) = chebdata%u(:,n)/2
chebdata%u = chebdata%u*2.0d0/(n-1)

!
!  Construct the weights by multiplying u^t on the left by the
!  integrals of the Chebyshev polynomials.
!

c=0
c(1,1) = 2.0d0
do i=2,n-1,2
c(1,i+1) = 1.0d0/(i+1)-1.0d0/(i-1)
end do

d = matmul(c,chebdata%u)
chebdata%whts = d(1:n,1)

!
!  Form the matrix which takes the values of a function f(t) to the values of
!
!              t
!    g(t) =  \int     f(u) du
!              a
!

allocate(xx(n,n),chebdata%aintr(n,n),chebdata%aintl(n,n))

do i=1,n
call chebs(chebdata%xs(i),n,pols)
xx(i,1) = chebdata%xs(i)
xx(i,2) = chebdata%xs(i)**2/2.0d0
do j=3,n
xx(i,j) = 0.5d0 * (pols(j+1)/j-pols(j-1)/(j-2))
end do
end do

do i=2,n
xx(i,:) = xx(i,:) - xx(1,:)
end do
xx(1,:) = 0

chebdata%aintl = matmul(xx,chebdata%u)

!
!  Form the matrix which takes the values of a function f(t) to the values of
!
!              t
!    g(t) =  \int     f(u) du
!              b
!

xx = 0

do i=1,n
call chebs(chebdata%xs(i),n,pols)
xx(i,1) = chebdata%xs(i)
xx(i,2) = chebdata%xs(i)**2/2.0d0
do j=3,n
xx(i,j) = 0.5d0 * (pols(j+1)/j-pols(j-1)/(j-2))
end do
end do

do i=1,n-1
xx(i,:) = xx(i,:) - xx(n,:)
end do
xx(n,:) = 0

chebdata%aintr = matmul(xx,chebdata%u)

!
!  Form the higher order spectral integration matrices
!

allocate(chebdata%aintr2(n,n),chebdata%aintr3(n,n))
chebdata%aintr2 = matmul(chebdata%aintr,chebdata%aintr)
chebdata%aintr3 = matmul(chebdata%aintr,chebdata%aintr2)

allocate(chebdata%aintl2(n,n),chebdata%aintl3(n,n))
chebdata%aintl2 = matmul(chebdata%aintl,chebdata%aintl)
chebdata%aintl3 = matmul(chebdata%aintl,chebdata%aintl2)

end subroutine

subroutine chebs(x,n,pols)
implicit double precision (a-h,o-z)

integer          :: n
double precision :: pols(0:n),x

!
!  Evaluate the Chebyshev polynomials of degree 0 through n at a specified point
!  using the standard 3-term recurrence relation.
!
!  Input parameters:
!
!    x - point at which to evaluate the polynomials
!    n - the order of the polynomials to evaluate
!
!  Output parameters:
!
!    pols - this user-supplied and allocated array of length n+1 will
!      contain the values of the polynomials of order 0 through n upon
!      return
!

if (x .eq. 1.0d0) then
do i=0,n
pols(i) = 1.0d0
end do
return
endif

if (x .eq. -1.0d0) then
pols(0) = 1.0d0
do i=1,n
pols(i) = -pols(i-1)
end do
return
endif

pols(0) = 1.0d0
if (n .eq. 0) return

pols(1) = x
if (n .eq. 1) return

xx1 = 1.0d0
xx2 = x

do i=1,n-1
xx        = 2*x*xx2 - xx1
pols(i+1) = xx
xx1       = xx2
xx2       = xx
end do

end subroutine

subroutine chebeval(a,b,n,xs,vals,x,val)
implicit double precision (a-h,o-z)

integer :: n
double precision ::  xs(n),vals(n),x,val

!
!  Use the barycentric formula to evaluate a function given its values at the
!  n-point Chebyshev grid on an interval [a,b].
!
!  Input parameters:
!
!    (a,b) - the interval on which the function is given
!    n - the number of nodes in the Chebyshev grid
!    xs - an array specifying the n Chevyshev node on the interval [-1,1]
!    vals - the values of the function on the n Chebyshev nodes on the
!      interval [-1,1]
!    x - the point in the interval (a,b) at which the function is to be
!      evaluated
!
!  Output parameters:
!
!   val - the approximate value of the function at the point x
!

eps0 = epsilon(0.0d0)

xx   = (2*x - (b+a) ) /(b-a)

sum1=0
sum2=0

dd1 = 1.0d0

do i=1,n
dd=1.0d0
if (i .eq. 1 .OR. i .eq. n) dd = 0.5d0

diff = xx-xs(i)

!
!  Handle the case in which the target node coincide with one of
!  of the Chebyshev nodes.
!

if(abs(diff) .le. eps0) then
val = vals(i)
return
endif

!
!  Otherwise, construct the sums.
!

dd   = (dd1*dd)/diff
dd1  = - dd1
sum1 = sum1+dd*vals(i)
sum2 = sum2+dd
dd   = - dd
end do

val = sum1/sum2

end subroutine

subroutine chebeval2(a,b,n,coefs,x,val)
implicit double precision (a-h,o-z)

integer, intent(in)             :: n
double precision, intent(in)    :: a,b,x,coefs(n)
double precision, intent(out)   :: val

!
!  Use the Clenshaw algorithm in order to evaluate a Chebyshev expansion on the
!  interval [a,b].
!
!  Input parameters:
!    (a,b) - the interval on which the expansion is given
!    n - the number of terms in the Chebyshev expansion
!    coefs - an array of length n specifying the expansion coefficients
!    x - the point at which to evaluate the expansion
!
!  Output parameters:
!    val - the value of the expansion at the point x
!

xx = (x - (b+a)/2.0d0) * 2.0d0/(b-a)

b2 = coefs(n)
b1 = 2*xx*b2+coefs(n-1)

do i=n-2,2,-1
b0  = coefs(i)+2*xx*b1-b2
b2 = b1
b1 = b0
end do

val = b1 * xx + (coefs(1)-b2)

end subroutine

subroutine chebpw_eval(nints,ab,k,xscheb,vals,x,val)
implicit double precision (a-h,o-z)

integer, intent(in)           :: nints,k
double precision, intent(in)  :: xscheb(k),ab(2,nints),vals(k,nints)
double precision, intent(out) :: val

!
!  Evaluate a function represented via its values at the nodes of the k-point
!  Chebyshev grids on a collection of subintervals of [a,b].
!
!  Input parameters:
!
!    (nints,ab) - arrays specifying the collection of subintervals of [a,b]
!    k - the number of terms in the Chebyshev expansions
!    xscheb - the nodes of the k-point Clenshaw-Curtis quadrature on [-1,1]
!    vals - a (k,nints) array the jth column of which gives the values of the
!      function at the nodes of the k-point Chebyshev grid in the jth
!      subinterval
!    x - the point in [a,b] at which to evaluate the function
!
!  Output parameters:
!    val - the value of the function at the point x
!

!
!  Conduct several iterations of a binary search for the interval.
!

eps0 = epsilon(0.0d0)

niters = 7
intl   = 1
intr   = nints

do iter=1,niters
int   = (intl+intr)/2
c     = ab(1,int)
if (x .gt. c) then
intl = int
else
if (int .gt. 1) intr = int-1
endif
end do

!
!  Conduct a brute force check from here.
!

do int = intl,intr-1
b = ab(2,int)
if (x .le. b) exit
end do

!
!  Call chebeval to evaluate the expansion and the save the index
!  of the interval containing x.
!

a = ab(1,int)
b = ab(2,int)

! call chebeval(a,b,k,xscheb,vals(1,int),x,val)
! return
xx   = (2*x - (b+a) ) /(b-a)

sum1=0
sum2=0

dd1 = 1.0d0

do i=1,k
dd=1.0d0
if (i .eq. 1 .OR. i .eq. k) dd = 0.5d0

diff = xx-xscheb(i)

!
!  Handle the case in which the target node coincide with one of
!  of the Chebyshev nodes.
!

if(abs(diff) .le. eps0 ) then
val = vals(i,int)
return
endif

!
!  Otherwise, construct the sums.
!

dd   = (dd1*dd)/diff
dd1  = - dd1
sum1 = sum1+dd*vals(i,int)
sum2 = sum2+dd
dd   = - dd
end do

val = sum1/sum2

end subroutine

subroutine chebpw_eval2(nints,ab,k,coefs,x,val)
implicit double precision (a-h,o-z)

integer, intent(in)           :: nints,k
double precision, intent(in)  :: ab(2,nints),coefs(k,nints)
double precision, intent(out) :: val

!
!  Evaluate a function represented via piecewise chebyshev expansions on
!  a collection of subintervals.
!
!  Input parameters:
!    (nints,ab) - the
!    k - an integer specifying the order of the Chebyshev expansions; on
!
!    coefs - a (k,nints) array whose jth column specified the coefficients
!     of the function's Chebyshev expansion on the jth subinterval
!    x - the point at which to evaluate
!
!
!  Output parameters:
!    val - the value of the function at the point x
!

double precision :: pols(k)
!
!  Conduct several iterations of a binary search for the interval.
!

niters = 6
intl   = 1
intr   = nints

do iter=1,niters
int   = (intl+intr)/2
c     = ab(1,int)
if (x .gt. c) then
intl = int
else
if (int .gt. 1) intr = int-1
endif
end do

!
!  Conduct a brute force check from here.
!

do int = intl,intr-1
b = ab(2,int)
if (x .le. b) exit
end do

a = ab(1,int)
b = ab(2,int)

!
!  Evaluate the Chebyshev expansion
!

xx = (x - (b+a)/2.0d0) * 2.0d0/(b-a)
call chebs(xx,k-1,pols)

val = 0
do i=1,k
val = val + coefs(i,int)*pols(i)
end do

return

! call chebeval2(a,b,k,coefs(1,int),x,val)

xx = (x - (b+a)/2.0d0) * 2.0d0/(b-a)
xx2 = 2*xx

b2 = coefs(k,int)
b1 = xx2*b2+coefs(k-1,int)

do i=k-2,2,-1
b0  = coefs(i,int)+xx2*b1-b2
b2 = b1
b1 = b0
end do

val = b1 * xx + (coefs(1,int)-b2)

return
end subroutine

subroutine write_chebexps(iw,chebdata)
implicit double precision (a-h,o-z)
type(chebexps_data)  :: chebdata

write (iw,"(I8.8)")       chebdata%k
write (iw,"(D30.20)")     chebdata%xs
write (iw,"(D30.20)")     chebdata%whts
write (iw,"(D30.20)")     chebdata%u
write (iw,"(D30.20)")     chebdata%v
write (iw,"(D30.20)")     chebdata%aintl
write (iw,"(D30.20)")     chebdata%aintl2
write (iw,"(D30.20)")     chebdata%aintl3
write (iw,"(D30.20)")     chebdata%aintr
write (iw,"(D30.20)")     chebdata%aintr2
write (iw,"(D30.20)")     chebdata%aintr3

end subroutine

subroutine read_chebexps(iw,chebdata)
implicit double precision (a-h,o-z)
type(chebexps_data)  :: chebdata

read (iw,"(I8.8)")       chebdata%k
k = chebdata%k
allocate(chebdata%xs(k),chebdata%whts(k))
allocate(chebdata%u(k,k),chebdata%v(k,k))
allocate(chebdata%aintl(k,k),chebdata%aintl2(k,k),chebdata%aintl3(k,k))
allocate(chebdata%aintr(k,k),chebdata%aintr2(k,k),chebdata%aintr3(k,k))
read (iw,"(D30.20)")     chebdata%xs
read (iw,"(D30.20)")     chebdata%whts
read (iw,"(D30.20)")     chebdata%u
read (iw,"(D30.20)")     chebdata%v
read (iw,"(D30.20)")     chebdata%aintl
read (iw,"(D30.20)")     chebdata%aintl2
read (iw,"(D30.20)")     chebdata%aintl3
read (iw,"(D30.20)")     chebdata%aintr
read (iw,"(D30.20)")     chebdata%aintr2
read (iw,"(D30.20)")     chebdata%aintr3

end subroutine

end module


!program  new_astro
subroutine new_astro(dd,astro,ader)
!c	this subroutine calculates the following five ephermides
!c	of the sun and moon
!c	h = mean longitude of the sum
!c	pp = mean longitude of the solar perigee
!c	s = mean longitude of the moon
!c	p = mean longitude of the lunar perigee
!c	np = negative of the longitude of the mean ascending node
!c	and their rates of change.
!c	Units for the ephermides are cycles and for their derivatives
!c	are cycles/365 days
!c	The formulae for calculating this ephermides were taken from
!c	pages 98 and 107 of the Explanatory Supplement to the
!c	Astronomical Ephermeris and the American Ephermis and
!c	Nautical Almanac (1961)

  real :: d1, d,s,h,p,np,pp,dc,tau,dtau
  integer ::sc,hc,pc,npc,ppc
  real,dimension(4) :: args,dargs
  integer :: kd0
  real,dimension(6) :: astro,ader
  real*8  :: dd

!Compute number of days from epoch of 12:00 UT Dec 31, 1899.
  ! (January 0.5 1900 ET)
  call gday(31,12,99,18,kd0,ier)
  if (ier.lt.0) then
     ierr=-1
     return
  end if
  d1=dd-dfloat(kd0)-0.5d0  ! -0.5 skyldes tidpunktet i kommentaren over
  d=d1/10000.0

! Compute astronomical constants at time d1.
  args(1)=d1
  args(2)=d*d
  args(3)=d*d*d

! These are the coefficients of the formulas in the Explan. Suppl.
  s = (270.434164d0 + 13.1763965268d0*args(1) -                   &
       0.000085d0*args(2) + 0.000000039d0*args(3))/360.0d0
  h = (279.696678d0 + 0.9856473354d0*args(1) +                    &
       0.00002267d0*args(2))/360.0d0
  p = (334.329556d0 + 0.1114040803d0*args(1) -                    &
       0.0007739d0*args(2) - 0.00000026d0*args(3))/360.0d0
  np = (-259.183275d0 + 0.0529539222d0*args(1) -                  &
       0.0001557d0*args(2) - 0.00000005d0*args(3))/360.0d0
  pp = (281.220844d0 +  0.0000470684d0*args(1) +                  &
       0.0000339d0*args(2) + 0.000000070d0*args(3))/360.0d0

  sc=floor(s)
  hc=floor(h)
  pc=floor(p)
  npc=floor(np)
  ppc=floor(pp)
  ! Compute the parameters; we only need the factional part of the cycle.

  astro(2)=s-floor(s)
  astro(3)=h-floor(h)
  astro(4)=p-floor(p)
  astro(5)=np-floor(np)
  astro(6)=pp-floor(pp)

  ! Compute lunar time tau, based on fractional part of solar day.
  ! We add the hour angle to the longitude of the sun and subtract the
  ! longitude of the moon.
  dc=dd-floor(dd)
  tau=dc+astro(3)-astro(2)
  astro(1)=tau
  ! Compute rates of change.
  dargs(1)= 0.0
  dargs(2)= 1.0
  dargs(3)= 2.0E-4*d
  dargs(4)= 3.0E-4*d*d

  ader(2) = (270.434164d0*dargs(1) + 13.1763965268d0*dargs(2) -     &
       0.000085d0*dargs(3) + 0.000000039d0*dargs(4))/360.0d0
  ader(3) = (279.696678d0*dargs(1) + 0.9856473354d0*dargs(2) +      &
       0.00002267d0*dargs(3))/360.0d0
  ader(4) = (334.329556d0*dargs(1) + 0.1114040803d0*dargs(2) -      &
       0.0007739d0*dargs(3) - 0.00000026d0*dargs(4))/360.0d0
  ader(5) = (-259.183275d0*dargs(1) + 0.0529539222d0*dargs(2) -     &
       0.0001557d0*dargs(3) - 0.00000005d0*dargs(4))/360.0d0
  ader(6) = (281.220844d0*dargs(1) +  0.0000470684d0*dargs(2) +     &
       0.0000339d0*dargs(3) + 0.000000070d0*dargs(4))/360.0d0
  dtau=1.0+ader(3)-ader(1)
  ader(1)=dtau
end subroutine


      SUBROUTINE tridag(a,b,c,r,u,n)
      INTEGER n,NMAX
      REAL a(n),b(n),c(n),r(n),u(n)
      PARAMETER (NMAX=500)
      INTEGER j
      REAL bet,gam(NMAX)
      if(b(1).eq.0.)pause 'tridag: rewrite equations'
      bet=b(1)
      u(1)=r(1)/bet
      do 11 j=2,n
        gam(j)=c(j-1)/bet
        bet=b(j)-a(j)*gam(j)
        if(bet.eq.0.)pause 'tridag failed'
        u(j)=(r(j)-a(j)*u(j-1))/bet
11    continue
      do 12 j=n-1,1,-1
        u(j)=u(j)-gam(j+1)*u(j+1)
12    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/tridag.for


C
C $Id: moprin.f,v 1.4 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MOPRIN (UVAL,VVAL,DLAT,DLON)
C
        DOUBLE PRECISION UVAL,VVAL,DLAT,DLON
C
C The subroutine MOPRIN implements a closed form of the true Mollweide
C projection, using formulas given on "Wolfram MathWorld".
C
C UVAL and VVAL are input values of U and V, in the projection plane.
C DLAT and DLON are output values of latitude and longitude, in radians.
C
C The common block MAPCM0 contains mathematical constants.
C
        COMMON /MAPCM0/  COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        DOUBLE PRECISION COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        SAVE   /MAPCM0/
C
C Local variables.
C
        DOUBLE PRECISION THTA,TVAL
C
C First, we must check the point (UVAL,VVAL) to see if it lies in the
C ellipse occupied by the projection of the globe.  If not, we return
C the value "1.D12" to signal that fact.
C
        IF ((UVAL/TSRT)**2+(VVAL/SROT)**2-1.D0.GT.1.D-12) THEN
          DLAT=1.D12
          DLON=1.D12
          RETURN
        END IF
C
C Do the math.
C
        THTA=ASIN(MAX(-1.D0,MIN(+1.D0,VVAL/SROT)))
C
        DLAT=ASIN(MAX(-1.D0,MIN(+1.D0,(2.D0*THTA+SIN(2.D0*THTA))/PI)))
        DLON=PI*UVAL/(TSRT*COS(THTA))
C
        RETURN
C
      END


      SUBROUTINE trigfact(nu, nv, nvh, nuvh, mf, nf, cmunv, smunv,
     1   cu, su, cv, sv)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: nu, nv, nvh, nuvh, mf, nf
      REAL(rprec), DIMENSION(nuvh,0:mf,-nf:nf) :: cmunv, smunv
      REAL(rprec), DIMENSION(nu,0:mf) :: cu, su
      REAL(rprec), DIMENSION(nvh,0:nf) :: cv, sv
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1, zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: i, j, m, n, kv, ku
      REAL(rprec) :: pi2, du, dv, cc, ss, sc, cs
C-----------------------------------------------
c      Calculate SIN/COS(m*u+n*nfp*v) factors for USE in FSIN transform
c      efficiently, i.e., SIN and COS are ONLY called once.
c      Must have nuvh=nu*(1+nv/2) = nu*nvh
c      nfp is the number of field periods
c
c      Note: The m,n dimensions of SIN/COS are different here from
c      the version in fourfast.f
c      this version allows you to calculate all the sin/cos factors
c      at one time using the largest (m,n) and
c      then use them for all smaller (m,n) as long as nu,nv are same
c
      pi2 = 4*ASIN(one)

      cu(:,0) = one                             !at m=0, m*u=0 for ALL u
      cv(:,0) = one
      su(:,0) = zero
      sv(:,0) = zero

      cu(1,:mf) = one                           !at u=0, m*u=0 for ALL m
      cv(1,:nf) = one                           !remember, u(i)=du*(i-1), so u=0 at i=1
      su(1,:mf) = zero
      sv(1,:nf) = zero

      du = pi2/nu                               !basic steps in u and v
      dv = pi2/nv                               !nfp factors cancelled out...
      cu(2,1) = COS(du)                         !These are the ONLY calls to COS/sin
      su(2,1) = SIN(du)                         !remember, u(i)=du*(i-1)
      cv(2,1) = COS(dv)                         !so u=du and v=dv at i=2
      sv(2,1) = SIN(dv)

c....  Next, Calculate COS/SIN(m*u)=cos/SIN(u) for m=1
c      USE SIN/COS(du) to calculate SIN/COS(u) : u=i*du
      DO i = 3, nu
         j = i - 1
         cu(i,1) = cu(2,1)*cu(j,1) - su(2,1)*su(j,1)
         su(i,1) = su(2,1)*cu(j,1) + cu(2,1)*su(j,1)
      END DO

c      And calculate COS/SIN(n*v)=cos/SIN(v) for n=1
c      USE SIN/COS(dv) to calculate SIN/COS(v) : v=i*dv
      DO i = 3, nvh
         j = i - 1
         cv(i,1) = cv(2,1)*cv(j,1) - sv(2,1)*sv(j,1)
         sv(i,1) = sv(2,1)*cv(j,1) + cv(2,1)*sv(j,1)
      END DO

c....  Then USE SIN/COS(u) to calculate SIN/COS(m*u) for ALL u
      DO i = 2, mf
         j = i - 1
         cu(:,i) = cu(:,1)*cu(:,j) - su(:,1)*su(:,j)
         su(:,i) = su(:,1)*cu(:,j) + cu(:,1)*su(:,j)
      END DO

c      And USE SIN/COS(v) to calculate SIN/COS(n*v) for ALL v
      DO i = 2, nf
         j = i - 1
         cv(:,i) = cv(:,1)*cv(:,j) - sv(:,1)*sv(:,j)
         sv(:,i) = sv(:,1)*cv(:,j) + cv(:,1)*sv(:,j)
      END DO

c..... Now ALL the SIN/COS(m*u) and SIN/COS(n*v) are READy, so
c      Calculate SIN/COS(m*u+n*v) at ALL u,v for m=0,mf; n=-nf,nf
      DO m = 0, mf
         DO n = 0, nf
            i = 0                          !i is REAL space INDEX 1,nuvh
            DO kv = 1, nvh
               DO ku = 1, nu
                  i = i + 1                !i goes from 1 to nuvh=nu*(1+nv/2)
                  cc = cu(ku,m)*cv(kv,n)
                  ss = su(ku,m)*sv(kv,n)
                  sc = su(ku,m)*cv(kv,n)
                  cs = cu(ku,m)*sv(kv,n)
                  cmunv(i,m,n) = cc - ss
                  cmunv(i,m,(-n)) = cc + ss
                  smunv(i,m,n) = sc + cs
                  smunv(i,m,(-n)) = sc - cs
               END DO
            END DO
         END DO                                  !ku loop
      END DO                                     !kv loop

      END SUBROUTINE trigfact


        subroutine idz_houseapp(n,vn,u,ifrescal,scal,v)
c
c       applies the Householder matrix
c       identity_matrix - scal * vn * adjoint(vn)
c       to the vector u, yielding the vector v;
c
c       scal = 2/(1 + |vn(2)|^2 + ... + |vn(n)|^2)
c       when vn(2), ..., vn(n) don't all vanish;
c
c       scal = 0
c       when vn(2), ..., vn(n) do all vanish
c       (including when n = 1).
c
c       input:
c       n -- size of vn, u, and v, though the indexing on vn goes
c            from 2 to n
c       vn -- components 2 to n of the Householder vector vn;
c             vn(1) is assumed to be 1
c       u -- vector to be transformed
c       ifrescal -- set to 1 to recompute scal from vn(2), ..., vn(n);
c                   set to 0 to use scal as input
c       scal -- see the entry for ifrescal in the decription
c               of the input
c
c       output:
c       scal -- see the entry for ifrescal in the decription
c               of the input
c       v -- result of applying the Householder matrix to u;
c            it's O.K. to have v be the same as u
c            in order to apply the matrix to the vector in place
c
c       reference:
c       Golub and Van Loan, "Matrix Computations," 3rd edition,
c            Johns Hopkins University Press, 1996, Chapter 5.
c
        implicit none
        save
        integer n,k,ifrescal
        real*8 scal,sum
        complex*16 vn(2:*),u(n),v(n),fact
c
c
c       Get out of this routine if n = 1.
c
        if(n .eq. 1) then
          v(1) = u(1)
          return
        endif
c
c
        if(ifrescal .eq. 1) then
c
c
c         Calculate |vn(2)|^2 + ... + |vn(n)|^2.
c
          sum = 0
          do k = 2,n
            sum = sum+vn(k)*conjg(vn(k))
          enddo ! k
c
c
c         Calculate scal.
c
          if(sum .eq. 0) scal = 0
          if(sum .ne. 0) scal = 2/(1+sum)
c
c
        endif
c
c
c       Calculate fact = scal * adjoint(vn) * u.
c
        fact = u(1)
c
        do k = 2,n
          fact = fact+conjg(vn(k))*u(k)
        enddo ! k
c
        fact = fact*scal
c
c
c       Subtract fact*vn from u, yielding v.
c
        v(1) = u(1) - fact
c
        do k = 2,n
          v(k) = u(k) - fact*vn(k)
        enddo ! k
c
c
        return
        end
c
c
c
c


program bit_functions ! GitHub FortranTip bit_func.f90
implicit none
! use 1-byte integers for illustration
integer, parameter :: ikind = selected_int_kind(1)
integer (kind=ikind) :: i, j, nbits
integer (kind=ikind), allocatable :: ivec(:)
integer, parameter   :: ni = 4
logical, allocatable :: bits(:)
nbits = bit_size(i)
allocate (bits(nbits))
ivec = [(i,i=nbits-1,0,-1)]
print "('bit representation of ',i0,'-bit integers')",nbits
print "(14x,'bit position')"
print "(9x,'i',2x,*(i3))",ivec
do i=-2,ni
   print "(i10,2x,*(i3))",i,merge(1,0,btest(i,ivec))
end do
print "(/,a,*(1x,i0))", &
  "not(1), iand(2,3), ior(2,3), ieor(2,3) =", &
   not(1), iand(2,3), ior(2,3), ieor(2,3)
end program bit_functions
! output:
! bit representation of 8-bit integers
!               bit position
!          i    7  6  5  4  3  2  1  0
!         -2    1  1  1  1  1  1  1  0
!         -1    1  1  1  1  1  1  1  1
!          0    0  0  0  0  0  0  0  0
!          1    0  0  0  0  0  0  0  1
!          2    0  0  0  0  0  0  1  0
!          3    0  0  0  0  0  0  1  1
!          4    0  0  0  0  0  1  0  0
!
! not(1), iand(2,3), ior(2,3), ieor(2,3) = -2 2 3 1


program primeNo
    integer :: n;
    logical isPrime /.true./
    integer :: i, j;

    print *, "Enter value of n...";
    read *, n;

    print *, "Prime no upto n : ";
    do i = 2, n, 1
        isPrime = .true.;
        do j = 2, int(sqrt(real(i))), 1 ! loop must have integer upper limit and sqrt takes real agruments
            if(mod(i,j) .eq. 0) then
                isPrime = .false.;
                exit;
            end if;
        end do

        if(isPrime) then
            print *, i;
        end if;
    end do;
end program primeNo


module ranges

  use globals
  implicit none

contains

  pure subroutine linrange(x, xlo, xhi)
    real(r64), intent(out) :: x(:)
    real(r64), intent(in) :: xlo, xhi
    integer :: n, i
    real(r64) :: t

    n = size(x)

    do concurrent (i = 1:n)
      t = real(i - 1, r64) / real(n - 1, r64)
      x(i) = xlo * (1 - t) + xhi * t
    end do
  end subroutine

  pure subroutine logrange(x, xlo, xhi)
    real(r64), intent(out) :: x(:)
    real(r64), intent(in) :: xlo, xhi

    call linrange(x, log(xlo), log(xhi))
    x(:) = exp(x)
  end subroutine

end module


      subroutine dqc25f(f,a,b,omega,integr,nrmom,maxp1,ksave,result,
     *   abserr,neval,resabs,resasc,momcom,chebmo)
c***begin prologue  dqc25f
c***date written   810101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a2
c***keywords  integration rules for functions with cos or sin
c             factor, clenshaw-curtis, gauss-kronrod
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  to compute the integral i=integral of f(x) over (a,b)
c            where w(x) = cos(omega*x) or w(x)=sin(omega*x) and to
c            compute j = integral of abs(f) over (a,b). for small value
c            of omega or small intervals (a,b) the 15-point gauss-kronro
c            rule is used. otherwise a generalized clenshaw-curtis
c            method is used.
c***description
c
c        integration rules for functions with cos or sin factor
c        standard fortran subroutine
c        double precision version
c
c        parameters
c         on entry
c           f      - double precision
c                    function subprogram defining the integrand
c                    function f(x). the actual name for f needs to
c                    be declared e x t e r n a l in the calling program.
c
c           a      - double precision
c                    lower limit of integration
c
c           b      - double precision
c                    upper limit of integration
c
c           omega  - double precision
c                    parameter in the weight function
c
c           integr - integer
c                    indicates which weight function is to be used
c                       integr = 1   w(x) = cos(omega*x)
c                       integr = 2   w(x) = sin(omega*x)
c
c           nrmom  - integer
c                    the length of interval (a,b) is equal to the length
c                    of the original integration interval divided by
c                    2**nrmom (we suppose that the routine is used in an
c                    adaptive integration process, otherwise set
c                    nrmom = 0). nrmom must be zero at the first call.
c
c           maxp1  - integer
c                    gives an upper bound on the number of chebyshev
c                    moments which can be stored, i.e. for the
c                    intervals of lengths abs(bb-aa)*2**(-l),
c                    l = 0,1,2, ..., maxp1-2.
c
c           ksave  - integer
c                    key which is one when the moments for the
c                    current interval have been computed
c
c         on return
c           result - double precision
c                    approximation to the integral i
c
c           abserr - double precision
c                    estimate of the modulus of the absolute
c                    error, which should equal or exceed abs(i-result)
c
c           neval  - integer
c                    number of integrand evaluations
c
c           resabs - double precision
c                    approximation to the integral j
c
c           resasc - double precision
c                    approximation to the integral of abs(f-i/(b-a))
c
c         on entry and return
c           momcom - integer
c                    for each interval length we need to compute the
c                    chebyshev moments. momcom counts the number of
c                    intervals for which these moments have already been
c                    computed. if nrmom.lt.momcom or ksave = 1, the
c                    chebyshev moments for the interval (a,b) have
c                    already been computed and stored, otherwise we
c                    compute them and we increase momcom.
c
c           chebmo - double precision
c                    array of dimension at least (maxp1,25) containing
c                    the modified chebyshev moments for the first momcom
c                    momcom interval lengths
c
c ......................................................................
c***references  (none)
c***routines called  d1mach,dgtsl,dqcheb,dqk15w,dqwgtf
c***end prologue  dqc25f
c
      double precision a,abserr,ac,an,an2,as,asap,ass,b,centr,chebmo,
     *  cheb12,cheb24,conc,cons,cospar,d,dabs,dcos,dsin,dqwgtf,d1,
     *  d1mach,d2,estc,ests,f,fval,hlgth,oflow,omega,parint,par2,par22,
     *  p2,p3,p4,resabs,resasc,resc12,resc24,ress12,ress24,result,
     *  sinpar,v,x
      integer i,iers,integr,isym,j,k,ksave,m,momcom,neval,maxp1,
     *  noequ,noeq1,nrmom
c
      dimension chebmo(maxp1,25),cheb12(13),cheb24(25),d(25),d1(25),
     *  d2(25),fval(25),v(28),x(11)
c
      external f,dqwgtf
c
c           the vector x contains the values cos(k*pi/24)
c           k = 1, ...,11, to be used for the chebyshev expansion of f
c
      data x(1) / 0.9914448613 7381041114 4557526928 563d0 /
      data x(2) / 0.9659258262 8906828674 9743199728 897d0 /
      data x(3) / 0.9238795325 1128675612 8183189396 788d0 /
      data x(4) / 0.8660254037 8443864676 3723170752 936d0 /
      data x(5) / 0.7933533402 9123516457 9776961501 299d0 /
      data x(6) / 0.7071067811 8654752440 0844362104 849d0 /
      data x(7) / 0.6087614290 0872063941 6097542898 164d0 /
      data x(8) / 0.5000000000 0000000000 0000000000 000d0 /
      data x(9) / 0.3826834323 6508977172 8459984030 399d0 /
      data x(10) / 0.2588190451 0252076234 8898837624 048d0 /
      data x(11) / 0.1305261922 2005159154 8406227895 489d0 /
c
c           list of major variables
c           -----------------------
c
c           centr  - mid point of the integration interval
c           hlgth  - half-length of the integration interval
c           fval   - value of the function f at the points
c                    (b-a)*0.5*cos(k*pi/12) + (b+a)*0.5, k = 0, ..., 24
c           cheb12 - coefficients of the chebyshev series expansion
c                    of degree 12, for the function f, in the
c                    interval (a,b)
c           cheb24 - coefficients of the chebyshev series expansion
c                    of degree 24, for the function f, in the
c                    interval (a,b)
c           resc12 - approximation to the integral of
c                    cos(0.5*(b-a)*omega*x)*f(0.5*(b-a)*x+0.5*(b+a))
c                    over (-1,+1), using the chebyshev series
c                    expansion of degree 12
c           resc24 - approximation to the same integral, using the
c                    chebyshev series expansion of degree 24
c           ress12 - the analogue of resc12 for the sine
c           ress24 - the analogue of resc24 for the sine
c
c
c           machine dependent constant
c           --------------------------
c
c           oflow is the largest positive magnitude.
c
c***first executable statement  dqc25f
      oflow = d1mach(2)
c
      centr = 0.5d+00*(b+a)
      hlgth = 0.5d+00*(b-a)
      parint = omega*hlgth
c
c           compute the integral using the 15-point gauss-kronrod
c           formula if the value of the parameter in the integrand
c           is small.
c
      if(dabs(parint).gt.0.2d+01) go to 10
      call dqk15w(f,dqwgtf,omega,p2,p3,p4,integr,a,b,result,
     *  abserr,resabs,resasc)
      neval = 15
      go to 170
c
c           compute the integral using the generalized clenshaw-
c           curtis method.
c
   10 conc = hlgth*dcos(centr*omega)
      cons = hlgth*dsin(centr*omega)
      resasc = oflow
      neval = 25
c
c           check whether the chebyshev moments for this interval
c           have already been computed.
c
      if(nrmom.lt.momcom.or.ksave.eq.1) go to 120
c
c           compute a new set of chebyshev moments.
c
      m = momcom+1
      par2 = parint*parint
      par22 = par2+0.2d+01
      sinpar = dsin(parint)
      cospar = dcos(parint)
c
c           compute the chebyshev moments with respect to cosine.
c
      v(1) = 0.2d+01*sinpar/parint
      v(2) = (0.8d+01*cospar+(par2+par2-0.8d+01)*sinpar/parint)/par2
      v(3) = (0.32d+02*(par2-0.12d+02)*cospar+(0.2d+01*
     *  ((par2-0.80d+02)*par2+0.192d+03)*sinpar)/parint)/(par2*par2)
      ac = 0.8d+01*cospar
      as = 0.24d+02*parint*sinpar
      if(dabs(parint).gt.0.24d+02) go to 30
c
c           compute the chebyshev moments as the solutions of a
c           boundary value problem with 1 initial value (v(3)) and 1
c           end value (computed using an asymptotic formula).
c
      noequ = 25
      noeq1 = noequ-1
      an = 0.6d+01
      do 20 k = 1,noeq1
        an2 = an*an
        d(k) = -0.2d+01*(an2-0.4d+01)*(par22-an2-an2)
        d2(k) = (an-0.1d+01)*(an-0.2d+01)*par2
        d1(k+1) = (an+0.3d+01)*(an+0.4d+01)*par2
        v(k+3) = as-(an2-0.4d+01)*ac
        an = an+0.2d+01
   20 continue
      an2 = an*an
      d(noequ) = -0.2d+01*(an2-0.4d+01)*(par22-an2-an2)
      v(noequ+3) = as-(an2-0.4d+01)*ac
      v(4) = v(4)-0.56d+02*par2*v(3)
      ass = parint*sinpar
      asap = (((((0.210d+03*par2-0.1d+01)*cospar-(0.105d+03*par2
     *  -0.63d+02)*ass)/an2-(0.1d+01-0.15d+02*par2)*cospar
     *  +0.15d+02*ass)/an2-cospar+0.3d+01*ass)/an2-cospar)/an2
      v(noequ+3) = v(noequ+3)-0.2d+01*asap*par2*(an-0.1d+01)*
     *   (an-0.2d+01)
c
c           solve the tridiagonal system by means of gaussian
c           elimination with partial pivoting.
c
c***        call to dgtsl has been replaced by call to
c***        lapack routine dgtsv
c
c      call dgtsl(noequ,d1,d,d2,v(4),iers)
      call dgtsv(noequ,1,d1(2:),d,d2(:noequ-1),v(4),noequ,iers)
      go to 50
c
c           compute the chebyshev moments by means of forward
c           recursion.
c
   30 an = 0.4d+01
      do 40 i = 4,13
        an2 = an*an
        v(i) = ((an2-0.4d+01)*(0.2d+01*(par22-an2-an2)*v(i-1)-ac)
     *  +as-par2*(an+0.1d+01)*(an+0.2d+01)*v(i-2))/
     *  (par2*(an-0.1d+01)*(an-0.2d+01))
        an = an+0.2d+01
   40 continue
   50 do 60 j = 1,13
        chebmo(m,2*j-1) = v(j)
   60 continue
c
c           compute the chebyshev moments with respect to sine.
c
      v(1) = 0.2d+01*(sinpar-parint*cospar)/par2
      v(2) = (0.18d+02-0.48d+02/par2)*sinpar/par2
     *  +(-0.2d+01+0.48d+02/par2)*cospar/parint
      ac = -0.24d+02*parint*cospar
      as = -0.8d+01*sinpar
      if(dabs(parint).gt.0.24d+02) go to 80
c
c           compute the chebyshev moments as the solutions of a boundary
c           value problem with 1 initial value (v(2)) and 1 end value
c           (computed using an asymptotic formula).
c
      an = 0.5d+01
      do 70 k = 1,noeq1
        an2 = an*an
        d(k) = -0.2d+01*(an2-0.4d+01)*(par22-an2-an2)
        d2(k) = (an-0.1d+01)*(an-0.2d+01)*par2
        d1(k+1) = (an+0.3d+01)*(an+0.4d+01)*par2
        v(k+2) = ac+(an2-0.4d+01)*as
        an = an+0.2d+01
   70 continue
      an2 = an*an
      d(noequ) = -0.2d+01*(an2-0.4d+01)*(par22-an2-an2)
      v(noequ+2) = ac+(an2-0.4d+01)*as
      v(3) = v(3)-0.42d+02*par2*v(2)
      ass = parint*cospar
      asap = (((((0.105d+03*par2-0.63d+02)*ass+(0.210d+03*par2
     *  -0.1d+01)*sinpar)/an2+(0.15d+02*par2-0.1d+01)*sinpar-
     *  0.15d+02*ass)/an2-0.3d+01*ass-sinpar)/an2-sinpar)/an2
      v(noequ+2) = v(noequ+2)-0.2d+01*asap*par2*(an-0.1d+01)
     *  *(an-0.2d+01)
c
c           solve the tridiagonal system by means of gaussian
c           elimination with partial pivoting.
c
c***        call to dgtsl has been replaced by call to
c***        lapack routine dgtsv
c
c      call dgtsl(noequ,d1,d,d2,v(3),iers)
      call dgtsv(noequ,1,d1(2:),d,d2(:noequ-1),v(3),noequ,iers)
      go to 100
c
c           compute the chebyshev moments by means of forward recursion.
c
   80 an = 0.3d+01
      do 90 i = 3,12
        an2 = an*an
        v(i) = ((an2-0.4d+01)*(0.2d+01*(par22-an2-an2)*v(i-1)+as)
     *  +ac-par2*(an+0.1d+01)*(an+0.2d+01)*v(i-2))
     *  /(par2*(an-0.1d+01)*(an-0.2d+01))
        an = an+0.2d+01
   90 continue
  100 do 110 j = 1,12
        chebmo(m,2*j) = v(j)
  110 continue
  120 if (nrmom.lt.momcom) m = nrmom+1
       if (momcom.lt.(maxp1-1).and.nrmom.ge.momcom) momcom = momcom+1
c
c           compute the coefficients of the chebyshev expansions
c           of degrees 12 and 24 of the function f.
c
      fval(1) = 0.5d+00*f(centr+hlgth)
      fval(13) = f(centr)
      fval(25) = 0.5d+00*f(centr-hlgth)
      do 130 i = 2,12
        isym = 26-i
        fval(i) = f(hlgth*x(i-1)+centr)
        fval(isym) = f(centr-hlgth*x(i-1))
  130 continue
      call dqcheb(x,fval,cheb12,cheb24)
c
c           compute the integral and error estimates.
c
      resc12 = cheb12(13)*chebmo(m,13)
      ress12 = 0.0d+00
      k = 11
      do 140 j = 1,6
        resc12 = resc12+cheb12(k)*chebmo(m,k)
        ress12 = ress12+cheb12(k+1)*chebmo(m,k+1)
        k = k-2
  140 continue
      resc24 = cheb24(25)*chebmo(m,25)
      ress24 = 0.0d+00
      resabs = dabs(cheb24(25))
      k = 23
      do 150 j = 1,12
        resc24 = resc24+cheb24(k)*chebmo(m,k)
        ress24 = ress24+cheb24(k+1)*chebmo(m,k+1)
        resabs = dabs(cheb24(k))+dabs(cheb24(k+1))
        k = k-2
  150 continue
      estc = dabs(resc24-resc12)
      ests = dabs(ress24-ress12)
      resabs = resabs*dabs(hlgth)
      if(integr.eq.2) go to 160
      result = conc*resc24-cons*ress24
      abserr = dabs(conc*estc)+dabs(cons*ests)
      go to 170
  160 result = conc*ress24+cons*resc24
      abserr = dabs(conc*ests)+dabs(cons*estc)
  170 return
      end


      subroutine pmicad(a,b,x,nx0,m,n,mdim,norm,eps,svd,solv)
c --- solve A.x=b  using "Best Corrector Method" ----------
      implicit real*8 (a-h,o-z)
c     parameter (nmax=1000,prec=1d-2)
      parameter (nmax=1000,prec=1d-6)
      dimension a(mdim,n),b(m),x(n),iw(nmax)
      logical norm,svd,solv
c     begin begin initialize for preventing compiler warning
      tm=0.d0
      small=0.d0
      k=0
      sk=0.d0
c     end   begin initialize for preventing compiler warning

c     call cputime(ctime0,irtc)
      nx=min(nx0,m,n)
      if(n.gt.nmax) then
        print *,' Too many variables:',n
        return
      endif
      do 5 i=1,n
        iw(i)=i
 5    continue
      if(norm) then
        tm=0d0
        do 7 j=1,n
          s=0d0
          do 6 i=1,m
            s=s+a(i,j)**2
 6        continue
          if(s.gt.tm) tm=s
 7      continue
      endif
      do 100 l=1,nx
        if(norm) small=tm*prec**2
        sm=0d0
        tm=0d0
        do 10 j=l,n
          s=0d0
          sd=0d0
          do 9 i=l,m
c09MAY94    t=a(i,j)**2
c09MAY94    s=s+t*b(i)**2
            s=s+a(i,j)*b(i)
            sd=sd+a(i,j)**2
    9     continue
          s=s**2
          if(sd.gt.tm) tm=sd
          if(norm) s=s/(sd+small)
c         ... normalize the inner product (aj,b) by norm of aj
          if(s.ge.sm)then
            sm=s
            k=j
            sk=sd
          endif
   10   continue
        i=iw(l)
        iw(l)=iw(k)
        iw(k)=i
        do 11 i=1,m
          t=a(i,l)
          a(i,l)=a(i,k)
          a(i,k)=t
   11   continue
        sk=sign(sqrt(sk),a(l,l))
c09MAY94h=sk*(sk+a(l,l))
        h=1d0/(sk*(sk+a(l,l)))
        a(l,l)=a(l,l)+sk
        do 13 j=l+1,n
          s=0d0
          do 12 i=l,m
            s=s+a(i,l)*a(i,j)
   12     continue
          s=s*h
          do i=l,m
            a(i,j)=a(i,j)-a(i,l)*s
          enddo
c09MAY94  x(j)=s/h
   13   continue
c09MAY94 --->
c       do 15 j=l+1,n
c         do 14 i=l,m
c           a(i,j)=a(i,j)-a(i,l)*x(j)
c  14     continue
c  15   continue
c09MAY94 <---
        s=0d0
        do 16 i=l,m
          s=s+a(i,l)*b(i)
   16   continue
c09MAY94s=s/h
        s=s*h
        do 17 i=l,m
          b(i)=b(i)-a(i,l)*s
   17   continue
c       s=0d0
c       do 18 i=l+1,m
c         s=s+b(i)**2
c  18   continue
c       s=sqrt(s/real(m))
c       print *,'l=',l,' iw=',iw(l),' Residual rms: ',sngl(s)
        a(l,l)=-sk
        do 19 i=l+1,m
          a(i,l)=0d0
   19   continue
  100 continue
c     call cputime(ctime1,irtc)
c     call tsolva(a,b,x,nx,nx,mdim,eps)
      if(solv)then
        call tsvd(a,b,x,nx,nx,mdim,eps,svd)
      endif
c     call cputime(ctime2,irtc)
c     print *,'ctime(Htrans)=',sngl(1d-6*(ctime1-ctime0))
c    1       ,'ctime(Tsolvg)=',sngl(1d-6*(ctime2-ctime1))
c
      if(svd .and. solv) then
        do i=1,nx
          err=0d0
          do j=1,nx
            err=err+(b(j)*a(j,i))**2
          enddo
          a(1,i)=sqrt(err)
        enddo
        do i=1,nx
          b(i)=a(1,i)
        enddo
        do i=nx+1,m
          b(i)=0d0
        enddo
      endif
      do 101 i=nx+1,n
        x(i)=0d0
  101 continue
      if(.not.solv)then
        do i=1,nx
          x(i)=1.d0
        enddo
      endif
c     call msort2(iw,x,nx)
      call msortn(iw,x,b,nx,1,nx)
      do 102 i=nx,1,-1
        if(iw(i).eq.i) return
        x(iw(i))=x(i)
        x(i)=0d0
        if(svd) then
          b(iw(i))=b(i)
          b(i)=0d0
        endif
  102 continue
      return
      end


*********************************************************
C
      DOUBLE PRECISION FUNCTION CONTR5(I,N,X,CONT,XSOL,HSOL)
C ----------------------------------------------------------
C     THIS FUNCTION CAN BE USED FOR CONINUOUS OUTPUT. IT PROVIDES AN
C     APPROXIMATION TO THE I-TH COMPONENT OF THE SOLUTION AT X.
C     IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR
C     THE LAST SUCCESSFULLY COMPUTED STEP (BY RADAR5).
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER, PARAMETER :: DP=kind(1D0)
      REAL(kind=DP), dimension(1), intent(in) ::  CONT
C --- REQUIRED CONSTANTS
      COMMON /CONSTN/C1,C2,C1M1,C2M1,C1MC2

      N2=2*N
      N3=3*N

      S=(X-XSOL)/HSOL

      CONTR5=CONT(I)+S*(CONT(I+N)+(S-C2M1)*(CONT(I+N2)
     &     +(S-C1M1)*CONT(I+N3)))

      RETURN
      END
C
C     END OF FUNCTION CONTR5
C
C ***********************************************************


      SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2)
      implicit double precision (a-h,o-z)
      PARAMETER (NMAX=100)
      DIMENSION X(N),Y(N),Y2(N),U(NMAX)
      IF (YP1.GT..99D30) THEN
        Y2(1)=0.
        U(1)=0.
      ELSE
        Y2(1)=-0.5d0
        U(1)=(3.d0/(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1)
      ENDIF
      DO 11 I=2,N-1
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
        P=SIG*Y2(I-1)+2.d0
        Y2(I)=(SIG-1.)/P
        U(I)=(6.d0*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1))
     *      /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P
11    CONTINUE
      IF (YPN.GT..99d30) THEN
        QN=0.d0
        UN=0.d0
      ELSE
        QN=0.5d0
        UN=(3.d0/(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1)))
      ENDIF
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.d0)
      DO 12 K=N-1,1,-1
        Y2(K)=Y2(K)*Y2(K+1)+U(K)
12    CONTINUE
      RETURN
      END


	SUBROUTINE IM_TTOB  ( nvals, tmpk, brit, iret )
C************************************************************************
C* IM_TTOB								*
C*									*
C* This image processing function converts a real temperature (degrees	*
C* Kelvin) to an 8-bit brightness pixel temperature count (in a 	*
C* 4-byte real value).  Brightness counts are also called mode-A 	*
C* counts or Ca.  							*
C*									*
C* The following equation is used:					*
C*									*
C*	If  (TMPK <= 242)  BRIT = 418 - TMPK				*
C*	If  (TMPK >  242)  BRIT = 2 * (330 - TMPK)			*
C*									*
C* SUBROUTINE IM_TTOB  ( NVALS, TMPK, BRIT, IRET )			*
C*									*
C* Input parameters:							*
C*	NVALS		INTEGER		Number of values to convert	*
C*	TMPK		REAL		Temperature in Kelvin		*
C*									*
C* Output parameters:							*
C*	BRIT		REAL		Brightness (0-255)		*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* J. Cowie/COMET	 4/96						*
C* D.W.Plummer/NCEP	 2/03	Convert from function to subroutine	*
C* T. Piper/SAIC	07/06	Set iret to zero			*
C************************************************************************
        INCLUDE		'GEMPRM.PRM'
	REAL		tmpk(*), brit(*)
C------------------------------------------------------------------------
	iret = 0
	DO  ii = 1, nvals
C
	    IF ( (tmpk(ii) .lt. 163.0) .or. (tmpk(ii) .gt. 330.0)) THEN
	        brit(ii) = RMISSD
	    ELSE IF ( tmpk(ii) .le. 242.0 ) THEN
	        brit(ii) = 418.0 - tmpk(ii)
	    ELSE
	        brit(ii) = 2 * (330.0 - tmpk(ii))
	    END IF
C
	END DO
C*
	RETURN
	END


      subroutine kscube (a1,a2,a3,a4,f1,f2,f3,f4,astar,fstar)
      implicit double precision (a-h,o-z)
c
c          routine to compute the minimum of a cubic
c          curve through points a1,f1 a2,f2 a3,f3 and a4,f4.
c
c          author   - Gregory A. Wrenn
c          location - Lockheed Engineering and Sciences Co.
c                     144 Research Drive
c                     Hampton, Va. 23666
c
c          last modification - 27 April 1989
c
      a1c = a1 * a1 * a1
      a2c = a2 * a2 * a2
      a3c = a3 * a3 * a3
      a4c = a4 * a4 * a4
c
      q1 = a3c * (a2 - a1) - a2c * (a3 - a1) + a1c * (a3 - a2)
      q2 = a4c * (a2 - a1) - a2c * (a4 - a1) + a1c * (a4 - a2)
      q3 = (a3 - a2) * (a2 - a1) * (a3 - a1)
      q4 = (a4 - a2) * (a2 - a1) * (a4 - a1)
      q5 = f3 * (a2 - a1) - f2 * (a3 - a1) + f1 * (a3 - a2)
      q6 = f4 * (a2 - a1) - f2 * (a4 - a1) + f1 * (a4 - a2)
c
      d1 = q2 * q3 - q1 * q4
      d2 = a2 - a1
      if (d1 .lt. 1.0e-12 .or. d2 .lt. 1.0e-12) go to 10
c
      b3 = (q3 * q6 - q4 * q5) / d1
      b2 = (q5 - b3 * q1) / q3
      b1 = (f2 - f1) / d2 - b3 * (a2c - a1c) / d2 - b2 * (a1 + a2)
      b0 = f1 - b1 * a1 - b2 * a1 * a1 - b3 * a1c
c
      bb = b2 * b2 - 3.0 * b1 * b3
      if (bb .lt. 0.0 .or. abs(b3) .lt. 1.0e-12) go to 10
      astar = (-b2 + sqrt(bb)) / (3.0 * b3)
      if (astar .lt. a1 .or. astar .gt. a4) go to 10
      as2 = astar * astar
      as3 = astar * as2
      fstar = b0 + b1 * astar + b2 * as2 + b3 * as3
      go to 40
c
   10 continue
      astar = a1
      fstar = f1
      if (f2 .ge. fstar) go to 20
      astar = a2
      fstar = f2
   20 continue
      if (f3 .ge. fstar) go to 30
      astar = a3
      fstar = f3
   30 continue
      if (f4 .ge. fstar) go to 40
      astar = a4
      fstar = f4
c
   40 continue
      return
      end


      PROGRAM TB0104

      IMPLICIT NONE

*----------- VARIABLE DECLARATION --------------------------------------

* IMPORTANT SUBROUTINE DESCRIPTION
*   DNTAP: DOUBLE PRECISION ANALYTICALLY NEWTON ROOT FINDER (PROCESS)
*   DSCP: DOUBLE PRECISION SECANT ROOT FINDER (PROCESS)
*   DSRP: DOUBLE PRECISION SEARCH ROOT FINDER (PROCESS)
*   (PROCESS MEANS THEY ONLY DO ONE ITERATION; WE SHOULD WRAP THEM BY
*   THE LOOPS)
*   THESE SUBROUTINES ARE EXPECTED TO RETURN ROOT VALUES AND UPDATED
*   METHOD SPECIFIC PARAMETERS.

* FUNCTION DECLARATION
*   DFUNC: THE FUNCTION WE ARE DISCUSSING
*   DDERV: THE 1ST ANALYTIC DERVIATIVE OF THE FUNCTION 'DFUNC'
      DOUBLE PRECISION  DFUNC, DDERV
      EXTERNAL          DFUNC, DDERV

* CALCULATION VARIABLES
*   ITR: ITERATION NUMBER
*   ITRMAX: MAXIMUN ITERATION NUMBER
*   ITRTHR: ITERATION THREAHOLD
*   DSRPR1: SEARCH METHOD PARAMETER 1 --- CURRENT GUESS
*   DSRPR2: SEARCH METHOD PARAMETER 2 --- CURRENT STEP
*   DNTPR: NEWTON METHOD PARAMETER --- CURRENT GUESS
*   DSCPR1: SECANT METHOD PARAMETER 1 --- CURRENT LOWER GUESS
*   DSCRP2: SECANT METHOD PARAMETER 2 --- CURRENT UPPER GUESS
      DOUBLE PRECISION  DSRPR1, DSRPR2, DNTPR, DSCPR1, DSCPR2, ITRTHR
      INTEGER           ITR, ITRMAX

*---------- MAIN PROGRAM -----------------------------------------------

* FILE OPERATION

      OPEN (11, FILE='Table-1-4.txt')
 1000 FORMAT ( 1X, I5, 4X, 3(F12.6) )
 1001 FORMAT ( A46 )
 1002 FORMAT ( 1X, A9, 3(A12) )

      WRITE(11,*) 'On the book, the deviation of 5th iteration for'
      WRITE(11,*) 'secant method is actually wrong'
      WRITE(11,*)
      WRITE(11,*) 'I do not know if different compliers behave diff-'
      WRITE(11,*) 'erently facing NaN. It is possible letting iteration'
      WRITE(11,*) 'numbers reach a very large number.'
      WRITE(11,*)

* CALCULATION

      WRITE(11,1001) '----------------------------------------------'
      WRITE(11,1002) 'Iteration', '      Search', '      Newton',
     $               '      Secant'
      WRITE(11,1002) '         ', '            ', '   Eq.(1.14)',
     $               '   Eq.(1.15)'
      WRITE(11,1001) '----------------------------------------------'

      ITR = 0
      ITRMAX = 100
      ITRTHR = 1.0D-6
      DSRPR1 = 1.0D0
      DSRPR2 = 0.5D0
      DNTPR = 1.0D0
      DSCPR1 = 0.5D0
      DSCPR2 = 1.0D0
      WRITE(11,1000) ITR, DSRPR1-DSQRT(5.0D0), DNTPR-DSQRT(5.0D0),
     $               DSCPR2-DSQRT(5.0D0)
  10  CONTINUE
        ITR = ITR + 1
        CALL DSRP(DFUNC, DSRPR1, DSRPR2)
        CALL DNTAP(DFUNC, DDERV, DNTPR)
        CALL DSCP(DFUNC, DSCPR1, DSCPR2)
        WRITE(11,1000) ITR, DSRPR1-DSQRT(5.0D0), DNTPR-DSQRT(5.0D0),
     $                 DSCPR2-DSQRT(5.0D0)
      IF (ITR.LT.ITRMAX.AND.MAX(DABS(DSRPR2),
     $    DABS(DNTPR-DSQRT(5.0D0)), DABS(DSCPR2-DSCPR1))
     $    .GT.ITRTHR) GOTO 10

      WRITE(11,1001) '----------------------------------------------'

      END PROGRAM TB0104

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

      SUBROUTINE DSRP(DFUNC, DSRPR1, DSRPR2)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  DFUNC, DSRPR1, DSRPR2
      EXTERNAL          DFUNC

      DSRPR1 = DSRPR1 + DSRPR2
      IF (DFUNC(DSRPR1) * DFUNC(DSRPR1-DSRPR2).LE.0.0D0) THEN
        DSRPR2 = - DSRPR2 / 2.0D0
      END IF

      END SUBROUTINE DSRP

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

      SUBROUTINE DNTAP(DFUNC, DDERV, DNTPR)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  DFUNC, DDERV, DNTPR
      EXTERNAL          DFUNC, DDERV

      DNTPR = DNTPR - DFUNC(DNTPR) / DDERV(DNTPR)

      END SUBROUTINE DNTAP

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

      SUBROUTINE DSCP(DFUNC, DSCPR1, DSCPR2)

      IMPLICIT NONE
* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  DFUNC, DSCPR1, DSCPR2
      EXTERNAL          DFUNC
* TEMPORARY VARIABLE STORAGE
      DOUBLE PRECISION  DTMP

      DTMP = DSCPR2 - DFUNC(DSCPR2) * (DSCPR2 - DSCPR1) / (DFUNC(DSCPR2)
     $       - DFUNC(DSCPR1))
      DSCPR1 = DSCPR2
      DSCPR2 = DTMP

      END SUBROUTINE

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

      FUNCTION DFUNC(DVAR)

      IMPLICIT NONE

      DOUBLE PRECISION  DVAR, DFUNC

      DFUNC = DVAR * DVAR - 5.0D0

      END FUNCTION DFUNC

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

      FUNCTION DDERV(DVAR)

      IMPLICIT NONE

      DOUBLE PRECISION  DVAR, DDERV

      DDERV = 2.0D0 * DVAR

      END FUNCTION DDERV