c =======fftpack.f subset==============================================
c     subroutine ezfftf(n,r,azero,a,b,wsave)
c
c     subroutine ezfftf computes the fourier coefficients of a real
c     perodic sequence (fourier analysis). the transform is defined
c     below at output parameters azero,a and b. ezfftf is a simplified
c     but slower version of rfftf.
c
c     input parameters
c
c     n       the length of the array r to be transformed.  the method
c             is must efficient when n is the product of small primes.
c
c     r       a real array of length n which contains the sequence
c             to be transformed. r is not destroyed.
c
c
c     wsave   a work array which must be dimensioned at least 3*n+15.
c             in the program that calls ezfftf. the wsave array must be
c             initialized by calling subroutine ezffti(n,wsave) and a
c             different wsave array must be used for each different
c             value of n. this initialization does not have to be
c             repeated so long as n remains unchanged thus subsequent
c             transforms can be obtained faster than the first.
c             the same wsave array can be used by ezfftf and ezfftb.
c
c     output parameters
c
c     azero   the sum from i=1 to i=n of r(i)/n
c
c     a,b     for n even b(n/2)=0. and a(n/2) is the sum from i=1 to
c             i=n of (-1)**(i-1)*r(i)/n
c
c             for n even define kmax=n/2-1
c             for n odd  define kmax=(n-1)/2
c
c             then for  k=1,...,kmax
c
c                  a(k) equals the sum from i=1 to i=n of
c
c                       2./n*r(i)*cos(k*(i-1)*2*pi/n)
c
c                  b(k) equals the sum from i=1 to i=n of
c
c                       2./n*r(i)*sin(k*(i-1)*2*pi/n)
c
c
      SUBROUTINE DEZFFTF(N,R,AZERO,A,B,WSAVE)
      DOUBLE PRECISION R
      DOUBLE PRECISION AZERO
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSAVE
      DOUBLE PRECISION CF
      DOUBLE PRECISION CFM
      DIMENSION R(*),A(*),B(*),WSAVE(*)
c
      IF (N-2.LE.0) THEN
          IF (N-2.NE.0) THEN
              AZERO = R(1)
              RETURN
          END IF
          AZERO = .5D0* (R(1)+R(2))
          A(1) = .5D0* (R(1)-R(2))
          RETURN
      END IF
      DO I = 1,N
          WSAVE(I) = R(I)
      END DO
      CALL DRFFTF(N,WSAVE,WSAVE(N+1))
      CF = 2.D0/DBLE(N)
      CFM = -CF
      AZERO = .5D0*CF*WSAVE(1)
      NS2 = (N+1)/2
      NS2M = NS2 - 1
      DO I = 1,NS2M
          A(I) = CF*WSAVE(2*I)
          B(I) = CFM*WSAVE(2*I+1)
      END DO
C      B(NS2) = 0.D0
      IF (MOD(N,2).EQ.1) RETURN
      A(NS2) = .5D0*CF*WSAVE(N)
      B(NS2) = 0.D0
      RETURN
      END
c
c =====================================================================
c     subroutine rfftf(n,r,wsave)
c
c     subroutine rfftf computes the fourier coefficients of a real
c     perodic sequence (fourier analysis). the transform is defined
c     below at output parameter r.
c
c     input parameters
c
c     n       the length of the array r to be transformed.  the method
c             is most efficient when n is a product of small primes.
c             n may change so long as different work arrays are provided
c
c     r       a real array of length n which contains the sequence
c             to be transformed
c
c     wsave   a work array which must be dimensioned at least 2*n+15.
c             in the program that calls rfftf. the wsave array must be
c             initialized by calling subroutine rffti(n,wsave) and a
c             different wsave array must be used for each different
c             value of n. this initialization does not have to be
c             repeated so long as n remains unchanged thus subsequent
c             transforms can be obtained faster than the first.
c             the same wsave array can be used by rfftf and rfftb.
c
c
c     output parameters
c
c     r       r(1) = the sum from i=1 to i=n of r(i)
c
c             if n is even set l =n/2   , if n is odd set l = (n+1)/2
c
c               then for k = 2,...,l
c
c                  r(2*k-2) = the sum from i = 1 to i = n of
c
c                       r(i)*cos((k-1)*(i-1)*2*pi/n)
c
c                  r(2*k-1) = the sum from i = 1 to i = n of
c
c                      -r(i)*sin((k-1)*(i-1)*2*pi/n)
c
c             if n is even
c
c                  r(n) = the sum from i = 1 to i = n of
c
c                       (-1)**(i-1)*r(i)
c
c      *****  note
c                  this transform is unnormalized since a call of rfftf
c                  followed by a call of rfftb will multiply the input
c                  sequence by n.
c
c     wsave   contains results which must not be destroyed between
c             calls of rfftf or rfftb.
c
      SUBROUTINE DRFFTF(N,R,WSAVE)
      DOUBLE PRECISION R
      DOUBLE PRECISION WSAVE
      DIMENSION R(*),WSAVE(*)
c
      IF (N.EQ.1) RETURN
      CALL DRFFTF1OLD(N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
c
      SUBROUTINE DRFFTF1OLD(N,C,CH,WA,IFAC)
      DOUBLE PRECISION C
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA
      DIMENSION CH(*),C(*),WA(*),IFAC(*)

      NF = IFAC(2)
      DO K1 = 1,NF
          KH = NF - K1
       END DO
      NA = 1
      L2 = N
      IW = N
      DO K1 = 1,NF
          KH = NF - K1
          IP = IFAC(KH+3)
          L1 = L2/IP
          IDO = N/L2
          IDL1 = IDO*L1
          IW = IW - (IP-1)*IDO
          NA = 1 - NA
          IF (IP.EQ.4) THEN
              IX2 = IW + IDO
              IX3 = IX2 + IDO
              IF (NA.EQ.0) THEN
                  CALL DRADF4(IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
                  GO TO 110
              END IF
              CALL DRADF4(IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
              GO TO 110
          END IF
          IF (IP.EQ.2) THEN
              IF (NA.EQ.0) THEN
                  CALL DRADF2(IDO,L1,C,CH,WA(IW))
                  GO TO 110
              END IF
              CALL DRADF2(IDO,L1,CH,C,WA(IW))
              GO TO 110
          END IF
  104     CONTINUE
          IF (IP.EQ.3) THEN
              IX2 = IW + IDO
              IF (NA.EQ.0) THEN
                  CALL DRADF3(IDO,L1,C,CH,WA(IW),WA(IX2))
                  GO TO 110
              END IF
              CALL DRADF3(IDO,L1,CH,C,WA(IW),WA(IX2))
              GO TO 110
          END IF
  106     CONTINUE
          IF (IP.EQ.5) THEN
              IX2 = IW + IDO
              IX3 = IX2 + IDO
              IX4 = IX3 + IDO
              IF (NA.EQ.0) THEN
                  CALL DRADF5(IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),
     +                WA(IX4))
                  GO TO 110
              END IF
              CALL DRADF5(IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
              GO TO 110
          END IF
  108     CONTINUE
          IF (IDO.EQ.1) NA = 1 - NA
          IF (NA.EQ.0) THEN
              CALL DRADFG(IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
              NA = 1
          ELSE
              CALL DRADFG(IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
              NA = 0
          END IF
  110     CONTINUE
          L2 = L1
      END DO
      IF (NA.EQ.1) RETURN
      DO I = 1,N
          C(I) = CH(I)
      END DO
      RETURN
      END
c ==============================================================
c     subroutine ezfftb(n,r,azero,a,b,wsave)
c
c     subroutine ezfftb computes a real perodic sequence from its
c     fourier coefficients (fourier synthesis). the transform is
c     defined below at output parameter r. ezfftb is a simplified
c     but slower version of rfftb.
c
c     input parameters
c
c     n       the length of the output array r.  the method is most
c             efficient when n is the product of small primes.
c
c     azero   the constant fourier coefficient
c
c     a,b     arrays which contain the remaining fourier coefficients
c             these arrays are not destroyed.
c
c             the length of these arrays depends on whether n is even or
c             odd.
c
c             if n is even n/2    locations are required
c             if n is odd (n-1)/2 locations are required
c
c     wsave   a work array which must be dimensioned at least 3*n+15.
c             in the program that calls ezfftb. the wsave array must be
c             initialized by calling subroutine ezffti(n,wsave) and a
c             different wsave array must be used for each different
c             value of n. this initialization does not have to be
c             repeated so long as n remains unchanged thus subsequent
c             transforms can be obtained faster than the first.
c             the same wsave array can be used by ezfftf and ezfftb.
c
c
c     output parameters
c
c     r       if n is even define kmax=n/2
c             if n is odd  define kmax=(n-1)/2
c
c             then for i=1,...,n
c
c                  r(i)=azero plus the sum from k=1 to k=kmax of
c
c                  a(k)*cos(k*(i-1)*2*pi/n)+b(k)*sin(k*(i-1)*2*pi/n)
c
c     ********************* complex notation **************************
c
c             for j=1,...,n
c
c             r(j) equals the sum from k=-kmax to k=kmax of
c
c                  c(k)*exp(i*k*(j-1)*2*pi/n)
c
c             where
c
c                  c(k) = .5*cmplx(a(k),-b(k))   for k=1,...,kmax
c
c                  c(-k) = conjg(c(k))
c
c                  c(0) = azero
c
c                       and i=sqrt(-1)
c
c     *************** amplitude - phase notation ***********************
c
c             for i=1,...,n
c
c             r(i) equals azero plus the sum from k=1 to k=kmax of
c
c                  alpha(k)*cos(k*(i-1)*2*pi/n+beta(k))
c
c             where
c
c                  alpha(k) = sqrt(a(k)*a(k)+b(k)*b(k))
c
c                  cos(beta(k))=a(k)/alpha(k)
c
c                  sin(beta(k))=-b(k)/alpha(k)
c
      SUBROUTINE DEZFFTB(N,R,AZERO,A,B,WSAVE)
      DOUBLE PRECISION R
      DOUBLE PRECISION AZERO
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSAVE
      DIMENSION R(*),A(*),B(*),WSAVE(*)
c
      IF (N-2.LE.0) THEN
          IF (N-2.NE.0) THEN
              R(1) = AZERO
              RETURN
          END IF
          R(1) = AZERO + A(1)
          R(2) = AZERO - A(1)
          RETURN
      END IF
      NS2 = (N-1)/2
      DO I = 1,NS2
          R(2*I) = .5D0*A(I)
          R(2*I+1) = -.5D0*B(I)
      END DO
      R(1) = AZERO
      IF (MOD(N,2).EQ.0) R(N) = A(NS2+1)
      CALL DRFFTB(N,R,WSAVE(N+1))
      RETURN
      END
c
c =====================================================================
c     subroutine rfftb(n,r,wsave)
c
c     subroutine rfftb computes the real perodic sequence from its
c     fourier coefficients (fourier synthesis). the transform is defined
c     below at output parameter r.
c
c     input parameters
c
c     n       the length of the array r to be transformed.  the method
c             is most efficient when n is a product of small primes.
c             n may change so long as different work arrays are provided
c
c     r       a real array of length n which contains the sequence
c             to be transformed
c
c     wsave   a work array which must be dimensioned at least 2*n+15.
c             in the program that calls rfftb. the wsave array must be
c             initialized by calling subroutine rffti(n,wsave) and a
c             different wsave array must be used for each different
c             value of n. this initialization does not have to be
c             repeated so long as n remains unchanged thus subsequent
c             transforms can be obtained faster than the first.
c             the same wsave array can be used by rfftf and rfftb.
c
c
c     output parameters
c
c     r       for n even and for i = 1,...,n
c
c                  r(i) = r(1)+(-1)**(i-1)*r(n)
c
c                       plus the sum from k=2 to k=n/2 of
c
c                        2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n)
c
c                       -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n)
c
c             for n odd and for i = 1,...,n
c
c                  r(i) = r(1) plus the sum from k=2 to k=(n+1)/2 of
c
c                       2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n)
c
c                      -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n)
c
c      *****  note
c                  this transform is unnormalized since a call of rfftf
c                  followed by a call of rfftb will multiply the input
c                  sequence by n.
c
c     wsave   contains results which must not be destroyed between
c             calls of rfftb or rfftf.
c
c
      SUBROUTINE DRFFTB(N,R,WSAVE)
      DOUBLE PRECISION R
      DOUBLE PRECISION WSAVE
      DIMENSION R(*),WSAVE(*)
c
      IF (N.EQ.1) RETURN
      CALL DRFFTB1OLD(N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
c
c =====================================================================
      SUBROUTINE DRFFTB1OLD(N,C,CH,WA,IFAC)
      DOUBLE PRECISION C
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA
      DIMENSION CH(*),C(*),WA(*),IFAC(*)

      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO K1 = 1,NF
          IP = IFAC(K1+2)
          L2 = IP*L1
          IDO = N/L2
          IDL1 = IDO*L1
          IF (IP.EQ.4) THEN
              IX2 = IW + IDO
              IX3 = IX2 + IDO
              IF (NA.EQ.0) THEN
                  CALL DRADB4(IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
              ELSE
                  CALL DRADB4(IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
              END IF
              NA = 1 - NA
          ELSE
              IF (IP.EQ.2) THEN
                  IF (NA.EQ.0) THEN
                      CALL DRADB2(IDO,L1,C,CH,WA(IW))
                  ELSE
                      CALL DRADB2(IDO,L1,CH,C,WA(IW))
                  END IF
                  NA = 1 - NA
              ELSE
                  IF (IP.EQ.3) THEN
                      IX2 = IW + IDO
                      IF (NA.EQ.0) THEN
                          CALL DRADB3(IDO,L1,C,CH,WA(IW),WA(IX2))
                      ELSE
                          CALL DRADB3(IDO,L1,CH,C,WA(IW),WA(IX2))
                      END IF
                      NA = 1 - NA
                  ELSE
                      IF (IP.EQ.5) THEN
                          IX2 = IW + IDO
                          IX3 = IX2 + IDO
                          IX4 = IX3 + IDO
                          IF (NA.EQ.0) THEN
                              CALL DRADB5(IDO,L1,C,CH,WA(IW),WA(IX2),
     +                                   WA(IX3),WA(IX4))
                          ELSE
                              CALL DRADB5(IDO,L1,CH,C,WA(IW),WA(IX2),
     +                                   WA(IX3),WA(IX4))
                          END IF
                          NA = 1 - NA
                      ELSE
                          IF (NA.EQ.0) THEN
                              CALL DRADBG(IDO,IP,L1,IDL1,C,C,C,CH,CH,
     +                                   WA(IW))
                          ELSE
                              CALL DRADBG(IDO,IP,L1,IDL1,CH,CH,CH,C,C,
     +                                   WA(IW))
                          END IF
                          IF (IDO.EQ.1) NA = 1 - NA
                      END IF
                  END IF
              END IF
          END IF
          L1 = L2
          IW = IW + (IP-1)*IDO
      END DO
      IF (NA.EQ.0) RETURN
      DO I = 1,N
          C(I) = CH(I)
      END DO
      RETURN
      END
c ==============================================================
c     subroutine ezffti(n,wsave)
c
c     subroutine ezffti initializes the array wsave which is used in
c     both ezfftf and ezfftb. the prime factorization of n together with
c     a tabulation of the trigonometric functions are computed and
c     stored in wsave.
c
c     input parameter
c
c     n       the length of the sequence to be transformed.
c
c     output parameter
c
c     wsave   a work array which must be dimensioned at least 3*n+15.
c             the same work array can be used for both ezfftf and ezfftb
c             as long as n remains unchanged. different wsave arrays
c             are required for different values of n.
c
      SUBROUTINE DEZFFTI(N,WSAVE)
      DOUBLE PRECISION WSAVE
      DIMENSION WSAVE(*)
c
      IF (N.EQ.1) RETURN
      CALL DEZFFT1(N,WSAVE(2*N+1),WSAVE(3*N+1))
      RETURN
      END
c
      SUBROUTINE DEZFFT1(N,WA,IFAC)
      DOUBLE PRECISION WA
      DOUBLE PRECISION TPI
      DOUBLE PRECISION ARGH
      DOUBLE PRECISION ARG1
      DOUBLE PRECISION CH1
      DOUBLE PRECISION SH1
      DOUBLE PRECISION DCH1
      DOUBLE PRECISION DSH1
      DOUBLE PRECISION CH1H
      DIMENSION WA(*),IFAC(*),NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/

      TPI = 8.0D0*ATAN(1.0D0)
      NL = N
      NF = 0
      J = 0
  101 CONTINUE
      J = J + 1
      IF (J-4.LE.0) THEN
          NTRY = NTRYH(J)
      ELSE
          NTRY = NTRY + 2
      END IF
  104 CONTINUE
      NQ = NL/NTRY
      NR = NL - NTRY*NQ
      IF (NR.NE.0) GO TO 101
      NF = NF + 1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY.EQ.2) THEN
          IF (NF.NE.1) THEN
              DO I = 2,NF
                  IB = NF - I + 2
                  IFAC(IB+2) = IFAC(IB+1)
              END DO
              IFAC(3) = 2
          END IF
      END IF
      IF (NL.NE.1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      ARGH = TPI/DBLE(N)
      IS = 0
      NFM1 = NF - 1
      L1 = 1
      IF (NFM1.EQ.0) RETURN
      DO K1 = 1,NFM1
          IP = IFAC(K1+2)
          L2 = L1*IP
          IDO = N/L2
          IPM = IP - 1
          ARG1 = DBLE(L1)*ARGH
          CH1 = 1.D0
          SH1 = 0.D0
          DCH1 = COS(ARG1)
          DSH1 = SIN(ARG1)
          DO J = 1,IPM
              CH1H = DCH1*CH1 - DSH1*SH1
              SH1 = DCH1*SH1 + DSH1*CH1
              CH1 = CH1H
              I = IS + 2
              WA(I-1) = CH1
              WA(I) = SH1
              IF (IDO.GE.5) THEN
                  DO II = 5,IDO,2
                      I = I + 2
                      WA(I-1) = CH1*WA(I-3) - SH1*WA(I-2)
                      WA(I) = CH1*WA(I-2) + SH1*WA(I-3)
                  END DO
              END IF
              IS = IS + IDO
          END DO
          L1 = L2
      END DO
      RETURN
      END
c ==========================================================
c     subroutine rffti(n,wsave)
c
c     subroutine rffti initializes the array wsave which is used in
c     both rfftf and rfftb. the prime factorization of n together with
c     a tabulation of the trigonometric functions are computed and
c     stored in wsave.
c
c     input parameter
c
c     n       the length of the sequence to be transformed.
c
c     output parameter
c
c     wsave   a work array which must be dimensioned at least 2*n+15.
c             the same work array can be used for both rfftf and rfftb
c             as long as n remains unchanged. different wsave arrays
c             are required for different values of n. the contents of
c             wsave must not be changed between calls of rfftf or rfftb.
c
      SUBROUTINE DRFFTI(N,WSAVE)
      DOUBLE PRECISION WSAVE
      DIMENSION WSAVE(*)
c
      IF (N.EQ.1) RETURN
      CALL DRFFTI1OLD(N,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
c
c ==========================================================
c      real function pimach (dum)
c     pi=3.1415926535897932384626433832795028841971693993751058209749446
c
c      pimach = 4.*atan(1.0)
c      return
c      end
c
      SUBROUTINE DRFFTI1OLD(N,WA,IFAC)
      DOUBLE PRECISION WA
      DOUBLE PRECISION TPI
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION DUM
      DOUBLE PRECISION ARGH
      DOUBLE PRECISION ARGLD
      DOUBLE PRECISION FI
      DOUBLE PRECISION ARG
      DIMENSION WA(*),IFAC(*),NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/

      NL = N
      NF = 0
      J = 0
  101 CONTINUE
      J = J + 1
      IF (J-4.LE.0) THEN
          NTRY = NTRYH(J)
      ELSE
          NTRY = NTRY + 2
      END IF
  104 CONTINUE
      NQ = NL/NTRY
      NR = NL - NTRY*NQ
      IF (NR.NE.0) GO TO 101
      NF = NF + 1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY.EQ.2) THEN
          IF (NF.NE.1) THEN
              DO I = 2,NF
                  IB = NF - I + 2
                  IFAC(IB+2) = IFAC(IB+1)
              END DO
              IFAC(3) = 2
          END IF
      END IF
      IF (NL.NE.1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 2.0D0*DPIMACH(DUM)
      ARGH = TPI/DBLE(N)
      IS = 0
      NFM1 = NF - 1
      L1 = 1
      IF (NFM1.EQ.0) RETURN
      DO K1 = 1,NFM1
          IP = IFAC(K1+2)
          LD = 0
          L2 = L1*IP
          IDO = N/L2
          IPM = IP - 1
          DO J = 1,IPM
              LD = LD + L1
              I = IS
              ARGLD = DBLE(LD)*ARGH
              FI = 0.D0
              DO II = 3,IDO,2
                  I = I + 2
                  FI = FI + 1.D0
                  ARG = FI*ARGLD
                  WA(I-1) = COS(ARG)
                  WA(I) = SIN(ARG)
              END DO
              IS = IS + IDO
          END DO
          L1 = L2
      END DO
      RETURN
      END
c
      SUBROUTINE DRADF2(IDO,L1,CC,CH,WA1)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION TR2
      DOUBLE PRECISION TI2
      DIMENSION CH(IDO,2,L1),CC(IDO,L1,2),WA1(*)

      DO K = 1,L1
          CH(1,1,K) = CC(1,K,1) + CC(1,K,2)
          CH(IDO,2,K) = CC(1,K,1) - CC(1,K,2)
      END DO
      IF (IDO-2.GE.0) THEN
          IF (IDO-2.NE.0) THEN
              IDP2 = IDO + 2
              DO K = 1,L1
                  DO I = 3,IDO,2
                      IC = IDP2 - I
                      TR2 = WA1(I-2)*CC(I-1,K,2) + WA1(I-1)*CC(I,K,2)
                      TI2 = WA1(I-2)*CC(I,K,2) - WA1(I-1)*CC(I-1,K,2)
                      CH(I,1,K) = CC(I,K,1) + TI2
                      CH(IC,2,K) = TI2 - CC(I,K,1)
                      CH(I-1,1,K) = CC(I-1,K,1) + TR2
                      CH(IC-1,2,K) = CC(I-1,K,1) - TR2
                  END DO
              END DO
              IF (MOD(IDO,2).EQ.1) RETURN
          END IF
          DO K = 1,L1
              CH(1,2,K) = -CC(IDO,K,2)
              CH(IDO,1,K) = CC(IDO,K,1)
          END DO
      END IF
      RETURN
      END
c
      SUBROUTINE DRADF3(IDO,L1,CC,CH,WA1,WA2)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION TAUR
      DOUBLE PRECISION TAUI
      DOUBLE PRECISION CR2
      DOUBLE PRECISION DR2
      DOUBLE PRECISION DI2
      DOUBLE PRECISION DR3
      DOUBLE PRECISION DI3
      DOUBLE PRECISION CI2
      DOUBLE PRECISION TR2
      DOUBLE PRECISION TI2
      DOUBLE PRECISION TR3
      DOUBLE PRECISION TI3
      DIMENSION CH(IDO,3,L1),CC(IDO,L1,3),WA1(*),WA2(*)
      DATA TAUR,TAUI/-.5D0,.866025403784439D0/

      DO K = 1,L1
          CR2 = CC(1,K,2) + CC(1,K,3)
          CH(1,1,K) = CC(1,K,1) + CR2
          CH(1,3,K) = TAUI* (CC(1,K,3)-CC(1,K,2))
          CH(IDO,2,K) = CC(1,K,1) + TAUR*CR2
      END DO
      IF (IDO.EQ.1) RETURN
      IDP2 = IDO + 2
      DO K = 1,L1
          DO I = 3,IDO,2
              IC = IDP2 - I
              DR2 = WA1(I-2)*CC(I-1,K,2) + WA1(I-1)*CC(I,K,2)
              DI2 = WA1(I-2)*CC(I,K,2) - WA1(I-1)*CC(I-1,K,2)
              DR3 = WA2(I-2)*CC(I-1,K,3) + WA2(I-1)*CC(I,K,3)
              DI3 = WA2(I-2)*CC(I,K,3) - WA2(I-1)*CC(I-1,K,3)
              CR2 = DR2 + DR3
              CI2 = DI2 + DI3
              CH(I-1,1,K) = CC(I-1,K,1) + CR2
              CH(I,1,K) = CC(I,K,1) + CI2
              TR2 = CC(I-1,K,1) + TAUR*CR2
              TI2 = CC(I,K,1) + TAUR*CI2
              TR3 = TAUI* (DI2-DI3)
              TI3 = TAUI* (DR3-DR2)
              CH(I-1,3,K) = TR2 + TR3
              CH(IC-1,2,K) = TR2 - TR3
              CH(I,3,K) = TI2 + TI3
              CH(IC,2,K) = TI3 - TI2
          END DO
      END DO
      RETURN
      END
c
      SUBROUTINE DRADF4(IDO,L1,CC,CH,WA1,WA2,WA3)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION WA3
      DOUBLE PRECISION HSQT2
      DOUBLE PRECISION TR1
      DOUBLE PRECISION TR2
      DOUBLE PRECISION CR2
      DOUBLE PRECISION CI2
      DOUBLE PRECISION CR3
      DOUBLE PRECISION CI3
      DOUBLE PRECISION CR4
      DOUBLE PRECISION CI4
      DOUBLE PRECISION TR4
      DOUBLE PRECISION TI1
      DOUBLE PRECISION TI4
      DOUBLE PRECISION TI2
      DOUBLE PRECISION TI3
      DOUBLE PRECISION TR3
      DIMENSION CC(IDO,L1,4),CH(IDO,4,L1),WA1(*),WA2(*),WA3(*)
      DATA HSQT2/.7071067811865475D0/

      DO K = 1,L1
          TR1 = CC(1,K,2) + CC(1,K,4)
          TR2 = CC(1,K,1) + CC(1,K,3)
          CH(1,1,K) = TR1 + TR2
          CH(IDO,4,K) = TR2 - TR1
          CH(IDO,2,K) = CC(1,K,1) - CC(1,K,3)
          CH(1,3,K) = CC(1,K,4) - CC(1,K,2)
      END DO
      IF (IDO-2.GE.0) THEN
          IF (IDO-2.NE.0) THEN
              IDP2 = IDO + 2
              DO K = 1,L1
                  DO I = 3,IDO,2
                      IC = IDP2 - I
                      CR2 = WA1(I-2)*CC(I-1,K,2) + WA1(I-1)*CC(I,K,2)
                      CI2 = WA1(I-2)*CC(I,K,2) - WA1(I-1)*CC(I-1,K,2)
                      CR3 = WA2(I-2)*CC(I-1,K,3) + WA2(I-1)*CC(I,K,3)
                      CI3 = WA2(I-2)*CC(I,K,3) - WA2(I-1)*CC(I-1,K,3)
                      CR4 = WA3(I-2)*CC(I-1,K,4) + WA3(I-1)*CC(I,K,4)
                      CI4 = WA3(I-2)*CC(I,K,4) - WA3(I-1)*CC(I-1,K,4)
                      TR1 = CR2 + CR4
                      TR4 = CR4 - CR2
                      TI1 = CI2 + CI4
                      TI4 = CI2 - CI4
                      TI2 = CC(I,K,1) + CI3
                      TI3 = CC(I,K,1) - CI3
                      TR2 = CC(I-1,K,1) + CR3
                      TR3 = CC(I-1,K,1) - CR3
                      CH(I-1,1,K) = TR1 + TR2
                      CH(IC-1,4,K) = TR2 - TR1
                      CH(I,1,K) = TI1 + TI2
                      CH(IC,4,K) = TI1 - TI2
                      CH(I-1,3,K) = TI4 + TR3
                      CH(IC-1,2,K) = TR3 - TI4
                      CH(I,3,K) = TR4 + TI3
                      CH(IC,2,K) = TR4 - TI3
                  END DO
              END DO
              IF (MOD(IDO,2).EQ.1) RETURN
          END IF
          DO K = 1,L1
              TI1 = -HSQT2* (CC(IDO,K,2)+CC(IDO,K,4))
              TR1 = HSQT2* (CC(IDO,K,2)-CC(IDO,K,4))
              CH(IDO,1,K) = TR1 + CC(IDO,K,1)
              CH(IDO,3,K) = CC(IDO,K,1) - TR1
              CH(1,2,K) = TI1 - CC(IDO,K,3)
              CH(1,4,K) = TI1 + CC(IDO,K,3)
          END DO
      END IF
      RETURN
      END
c
      SUBROUTINE DRADF5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION WA3
      DOUBLE PRECISION WA4
      DOUBLE PRECISION TR11
      DOUBLE PRECISION TI11
      DOUBLE PRECISION TR12
      DOUBLE PRECISION TI12
      DOUBLE PRECISION CR2
      DOUBLE PRECISION CI5
      DOUBLE PRECISION CR3
      DOUBLE PRECISION CI4
      DOUBLE PRECISION DR2
      DOUBLE PRECISION DI2
      DOUBLE PRECISION DR3
      DOUBLE PRECISION DI3
      DOUBLE PRECISION DR4
      DOUBLE PRECISION DI4
      DOUBLE PRECISION DR5
      DOUBLE PRECISION DI5
      DOUBLE PRECISION CR5
      DOUBLE PRECISION CI2
      DOUBLE PRECISION CR4
      DOUBLE PRECISION CI3
      DOUBLE PRECISION TR2
      DOUBLE PRECISION TI2
      DOUBLE PRECISION TR3
      DOUBLE PRECISION TI3
      DOUBLE PRECISION TR5
      DOUBLE PRECISION TI5
      DOUBLE PRECISION TR4
      DOUBLE PRECISION TI4
      DIMENSION CC(IDO,L1,5),CH(IDO,5,L1),WA1(*),WA2(*),WA3(*),WA4(*)
      DATA TR11,TI11,TR12,TI12/.309016994374947D0,.951056516295154D0,
     +     -.809016994374947D0,.587785252292473D0/

      DO K = 1,L1
          CR2 = CC(1,K,5) + CC(1,K,2)
          CI5 = CC(1,K,5) - CC(1,K,2)
          CR3 = CC(1,K,4) + CC(1,K,3)
          CI4 = CC(1,K,4) - CC(1,K,3)
          CH(1,1,K) = CC(1,K,1) + CR2 + CR3
          CH(IDO,2,K) = CC(1,K,1) + TR11*CR2 + TR12*CR3
          CH(1,3,K) = TI11*CI5 + TI12*CI4
          CH(IDO,4,K) = CC(1,K,1) + TR12*CR2 + TR11*CR3
          CH(1,5,K) = TI12*CI5 - TI11*CI4
      END DO
      IF (IDO.EQ.1) RETURN
      IDP2 = IDO + 2
      DO K = 1,L1
          DO I = 3,IDO,2
              IC = IDP2 - I
              DR2 = WA1(I-2)*CC(I-1,K,2) + WA1(I-1)*CC(I,K,2)
              DI2 = WA1(I-2)*CC(I,K,2) - WA1(I-1)*CC(I-1,K,2)
              DR3 = WA2(I-2)*CC(I-1,K,3) + WA2(I-1)*CC(I,K,3)
              DI3 = WA2(I-2)*CC(I,K,3) - WA2(I-1)*CC(I-1,K,3)
              DR4 = WA3(I-2)*CC(I-1,K,4) + WA3(I-1)*CC(I,K,4)
              DI4 = WA3(I-2)*CC(I,K,4) - WA3(I-1)*CC(I-1,K,4)
              DR5 = WA4(I-2)*CC(I-1,K,5) + WA4(I-1)*CC(I,K,5)
              DI5 = WA4(I-2)*CC(I,K,5) - WA4(I-1)*CC(I-1,K,5)
              CR2 = DR2 + DR5
              CI5 = DR5 - DR2
              CR5 = DI2 - DI5
              CI2 = DI2 + DI5
              CR3 = DR3 + DR4
              CI4 = DR4 - DR3
              CR4 = DI3 - DI4
              CI3 = DI3 + DI4
              CH(I-1,1,K) = CC(I-1,K,1) + CR2 + CR3
              CH(I,1,K) = CC(I,K,1) + CI2 + CI3
              TR2 = CC(I-1,K,1) + TR11*CR2 + TR12*CR3
              TI2 = CC(I,K,1) + TR11*CI2 + TR12*CI3
              TR3 = CC(I-1,K,1) + TR12*CR2 + TR11*CR3
              TI3 = CC(I,K,1) + TR12*CI2 + TR11*CI3
              TR5 = TI11*CR5 + TI12*CR4
              TI5 = TI11*CI5 + TI12*CI4
              TR4 = TI12*CR5 - TI11*CR4
              TI4 = TI12*CI5 - TI11*CI4
              CH(I-1,3,K) = TR2 + TR5
              CH(IC-1,2,K) = TR2 - TR5
              CH(I,3,K) = TI2 + TI5
              CH(IC,2,K) = TI5 - TI2
              CH(I-1,5,K) = TR3 + TR4
              CH(IC-1,4,K) = TR3 - TR4
              CH(I,5,K) = TI3 + TI4
              CH(IC,4,K) = TI4 - TI3
          END DO
      END DO
      RETURN
      END
c
      SUBROUTINE DRADFG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      DOUBLE PRECISION CC
      DOUBLE PRECISION C1
      DOUBLE PRECISION C2
      DOUBLE PRECISION CH
      DOUBLE PRECISION CH2
      DOUBLE PRECISION WA
      DOUBLE PRECISION TPI
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION DUM
      DOUBLE PRECISION ARG
      DOUBLE PRECISION DCP
      DOUBLE PRECISION DSP
      DOUBLE PRECISION AR1
      DOUBLE PRECISION AI1
      DOUBLE PRECISION AR1H
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION AR2
      DOUBLE PRECISION AI2
      DOUBLE PRECISION AR2H
      DIMENSION CH(IDO,L1,IP),CC(IDO,IP,L1),C1(IDO,L1,IP),C2(IDL1,IP),
     +          CH2(IDL1,IP),WA(*)

      TPI = 2.0D0*DPIMACH(DUM)
      ARG = TPI/DBLE(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP + 2
      IDP2 = IDO + 2
      NBD = (IDO-1)/2
      IF (IDO.NE.1) THEN
          DO IK = 1,IDL1
              CH2(IK,1) = C2(IK,1)
          END DO
          DO J = 2,IP
              DO K = 1,L1
                  CH(1,K,J) = C1(1,K,J)
              END DO
          END DO
          IF (NBD.LE.L1) THEN
              IS = -IDO
              DO J = 2,IP
                  IS = IS + IDO
                  IDIJ = IS
                  DO I = 3,IDO,2
                      IDIJ = IDIJ + 2
                      DO K = 1,L1
                          CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J) +
     +                                  WA(IDIJ)*C1(I,K,J)
                          CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J) -
     +                                WA(IDIJ)*C1(I-1,K,J)
                      END DO
                  END DO
              END DO
          ELSE
              IS = -IDO
              DO J = 2,IP
                  IS = IS + IDO
                  DO K = 1,L1
                      IDIJ = IS
                      DO I = 3,IDO,2
                          IDIJ = IDIJ + 2
                          CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J) +
     +                                  WA(IDIJ)*C1(I,K,J)
                          CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J) -
     +                                WA(IDIJ)*C1(I-1,K,J)
                      END DO
                  END DO
              END DO
          END IF
          IF (NBD.GE.L1) THEN
              DO J = 2,IPPH
                  JC = IPP2 - J
                  DO K = 1,L1
                      DO I = 3,IDO,2
                          C1(I-1,K,J) = CH(I-1,K,J) + CH(I-1,K,JC)
                          C1(I-1,K,JC) = CH(I,K,J) - CH(I,K,JC)
                          C1(I,K,J) = CH(I,K,J) + CH(I,K,JC)
                          C1(I,K,JC) = CH(I-1,K,JC) - CH(I-1,K,J)
                      END DO
                  END DO
              END DO
              GO TO 121
          END IF
          DO J = 2,IPPH
              JC = IPP2 - J
              DO I = 3,IDO,2
                  DO K = 1,L1
                      C1(I-1,K,J) = CH(I-1,K,J) + CH(I-1,K,JC)
                      C1(I-1,K,JC) = CH(I,K,J) - CH(I,K,JC)
                      C1(I,K,J) = CH(I,K,J) + CH(I,K,JC)
                      C1(I,K,JC) = CH(I-1,K,JC) - CH(I-1,K,J)
                  END DO
              END DO
          END DO
          GO TO 121
      END IF
      DO IK = 1,IDL1
          C2(IK,1) = CH2(IK,1)
      END DO
  121 CONTINUE
      DO J = 2,IPPH
          JC = IPP2 - J
          DO K = 1,L1
              C1(1,K,J) = CH(1,K,J) + CH(1,K,JC)
              C1(1,K,JC) = CH(1,K,JC) - CH(1,K,J)
          END DO
      END DO
c
      AR1 = 1.D0
      AI1 = 0.D0
      DO L = 2,IPPH
          LC = IPP2 - L
          AR1H = DCP*AR1 - DSP*AI1
          AI1 = DCP*AI1 + DSP*AR1
          AR1 = AR1H
          DO IK = 1,IDL1
              CH2(IK,L) = C2(IK,1) + AR1*C2(IK,2)
              CH2(IK,LC) = AI1*C2(IK,IP)
          END DO
          DC2 = AR1
          DS2 = AI1
          AR2 = AR1
          AI2 = AI1
          DO J = 3,IPPH
              JC = IPP2 - J
              AR2H = DC2*AR2 - DS2*AI2
              AI2 = DC2*AI2 + DS2*AR2
              AR2 = AR2H
              DO IK = 1,IDL1
                  CH2(IK,L) = CH2(IK,L) + AR2*C2(IK,J)
                  CH2(IK,LC) = CH2(IK,LC) + AI2*C2(IK,JC)
              END DO
          END DO
      END DO
      DO J = 2,IPPH
          DO IK = 1,IDL1
              CH2(IK,1) = CH2(IK,1) + C2(IK,J)
          END DO
      END DO
c
      IF (IDO.GE.L1) THEN
          DO K = 1,L1
              DO I = 1,IDO
                  CC(I,1,K) = CH(I,K,1)
              END DO
          END DO
      ELSE
          DO I = 1,IDO
              DO K = 1,L1
                  CC(I,1,K) = CH(I,K,1)
              END DO
          END DO
      END IF
      DO J = 2,IPPH
          JC = IPP2 - J
          J2 = J + J
          DO K = 1,L1
              CC(IDO,J2-2,K) = CH(1,K,J)
              CC(1,J2-1,K) = CH(1,K,JC)
          END DO
      END DO
      IF (IDO.EQ.1) RETURN
      IF (NBD.GE.L1) THEN
          DO J = 2,IPPH
              JC = IPP2 - J
              J2 = J + J
              DO K = 1,L1
                  DO I = 3,IDO,2
                      IC = IDP2 - I
                      CC(I-1,J2-1,K) = CH(I-1,K,J) + CH(I-1,K,JC)
                      CC(IC-1,J2-2,K) = CH(I-1,K,J) - CH(I-1,K,JC)
                      CC(I,J2-1,K) = CH(I,K,J) + CH(I,K,JC)
                      CC(IC,J2-2,K) = CH(I,K,JC) - CH(I,K,J)
                  END DO
              END DO
          END DO
          RETURN
      END IF
      DO J = 2,IPPH
          JC = IPP2 - J
          J2 = J + J
          DO I = 3,IDO,2
              IC = IDP2 - I
              DO K = 1,L1
                  CC(I-1,J2-1,K) = CH(I-1,K,J) + CH(I-1,K,JC)
                  CC(IC-1,J2-2,K) = CH(I-1,K,J) - CH(I-1,K,JC)
                  CC(I,J2-1,K) = CH(I,K,J) + CH(I,K,JC)
                  CC(IC,J2-2,K) = CH(I,K,JC) - CH(I,K,J)
              END DO
          END DO
      END DO
      RETURN
      END
c
      SUBROUTINE DRADB2(IDO,L1,CC,CH,WA1)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION TR2
      DOUBLE PRECISION TI2
      DIMENSION CC(IDO,2,L1),CH(IDO,L1,2),WA1(*)

      DO K = 1,L1
          CH(1,K,1) = CC(1,1,K) + CC(IDO,2,K)
          CH(1,K,2) = CC(1,1,K) - CC(IDO,2,K)
      END DO
      IF (IDO-2.GE.0) THEN
          IF (IDO-2.NE.0) THEN
              IDP2 = IDO + 2
              DO K = 1,L1
                  DO I = 3,IDO,2
                      IC = IDP2 - I
                      CH(I-1,K,1) = CC(I-1,1,K) + CC(IC-1,2,K)
                      TR2 = CC(I-1,1,K) - CC(IC-1,2,K)
                      CH(I,K,1) = CC(I,1,K) - CC(IC,2,K)
                      TI2 = CC(I,1,K) + CC(IC,2,K)
                      CH(I-1,K,2) = WA1(I-2)*TR2 - WA1(I-1)*TI2
                      CH(I,K,2) = WA1(I-2)*TI2 + WA1(I-1)*TR2
                  END DO
              END DO
              IF (MOD(IDO,2).EQ.1) RETURN
          END IF
          DO K = 1,L1
              CH(IDO,K,1) = CC(IDO,1,K) + CC(IDO,1,K)
              CH(IDO,K,2) = - (CC(1,2,K)+CC(1,2,K))
          END DO
      END IF
      RETURN
      END
c
      SUBROUTINE DRADB3(IDO,L1,CC,CH,WA1,WA2)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION TAUR
      DOUBLE PRECISION TAUI
      DOUBLE PRECISION TR2
      DOUBLE PRECISION CR2
      DOUBLE PRECISION CI3
      DOUBLE PRECISION TI2
      DOUBLE PRECISION CI2
      DOUBLE PRECISION CR3
      DOUBLE PRECISION DR2
      DOUBLE PRECISION DR3
      DOUBLE PRECISION DI2
      DOUBLE PRECISION DI3
      DIMENSION CC(IDO,3,L1),CH(IDO,L1,3),WA1(*),WA2(*)
      DATA TAUR,TAUI/-.5D0,.866025403784439D0/

      DO K = 1,L1
          TR2 = CC(IDO,2,K) + CC(IDO,2,K)
          CR2 = CC(1,1,K) + TAUR*TR2
          CH(1,K,1) = CC(1,1,K) + TR2
          CI3 = TAUI* (CC(1,3,K)+CC(1,3,K))
          CH(1,K,2) = CR2 - CI3
          CH(1,K,3) = CR2 + CI3
      END DO
      IF (IDO.EQ.1) RETURN
      IDP2 = IDO + 2
      DO K = 1,L1
          DO I = 3,IDO,2
              IC = IDP2 - I
              TR2 = CC(I-1,3,K) + CC(IC-1,2,K)
              CR2 = CC(I-1,1,K) + TAUR*TR2
              CH(I-1,K,1) = CC(I-1,1,K) + TR2
              TI2 = CC(I,3,K) - CC(IC,2,K)
              CI2 = CC(I,1,K) + TAUR*TI2
              CH(I,K,1) = CC(I,1,K) + TI2
              CR3 = TAUI* (CC(I-1,3,K)-CC(IC-1,2,K))
              CI3 = TAUI* (CC(I,3,K)+CC(IC,2,K))
              DR2 = CR2 - CI3
              DR3 = CR2 + CI3
              DI2 = CI2 + CR3
              DI3 = CI2 - CR3
              CH(I-1,K,2) = WA1(I-2)*DR2 - WA1(I-1)*DI2
              CH(I,K,2) = WA1(I-2)*DI2 + WA1(I-1)*DR2
              CH(I-1,K,3) = WA2(I-2)*DR3 - WA2(I-1)*DI3
              CH(I,K,3) = WA2(I-2)*DI3 + WA2(I-1)*DR3
          END DO
      END DO
      RETURN
      END
c
      SUBROUTINE DRADB4(IDO,L1,CC,CH,WA1,WA2,WA3)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION WA3
      DOUBLE PRECISION SQRT2
      DOUBLE PRECISION TR1
      DOUBLE PRECISION TR2
      DOUBLE PRECISION TR3
      DOUBLE PRECISION TR4
      DOUBLE PRECISION TI1
      DOUBLE PRECISION TI2
      DOUBLE PRECISION TI3
      DOUBLE PRECISION TI4
      DOUBLE PRECISION CR3
      DOUBLE PRECISION CI3
      DOUBLE PRECISION CR2
      DOUBLE PRECISION CR4
      DOUBLE PRECISION CI2
      DOUBLE PRECISION CI4
      DIMENSION CC(IDO,4,L1),CH(IDO,L1,4),WA1(*),WA2(*),WA3(*)
      DATA SQRT2/1.414213562373095D0/

      DO K = 1,L1
          TR1 = CC(1,1,K) - CC(IDO,4,K)
          TR2 = CC(1,1,K) + CC(IDO,4,K)
          TR3 = CC(IDO,2,K) + CC(IDO,2,K)
          TR4 = CC(1,3,K) + CC(1,3,K)
          CH(1,K,1) = TR2 + TR3
          CH(1,K,2) = TR1 - TR4
          CH(1,K,3) = TR2 - TR3
          CH(1,K,4) = TR1 + TR4
      END DO
      IF (IDO-2.GE.0) THEN
          IF (IDO-2.NE.0) THEN
              IDP2 = IDO + 2
              DO K = 1,L1
                  DO I = 3,IDO,2
                      IC = IDP2 - I
                      TI1 = CC(I,1,K) + CC(IC,4,K)
                      TI2 = CC(I,1,K) - CC(IC,4,K)
                      TI3 = CC(I,3,K) - CC(IC,2,K)
                      TR4 = CC(I,3,K) + CC(IC,2,K)
                      TR1 = CC(I-1,1,K) - CC(IC-1,4,K)
                      TR2 = CC(I-1,1,K) + CC(IC-1,4,K)
                      TI4 = CC(I-1,3,K) - CC(IC-1,2,K)
                      TR3 = CC(I-1,3,K) + CC(IC-1,2,K)
                      CH(I-1,K,1) = TR2 + TR3
                      CR3 = TR2 - TR3
                      CH(I,K,1) = TI2 + TI3
                      CI3 = TI2 - TI3
                      CR2 = TR1 - TR4
                      CR4 = TR1 + TR4
                      CI2 = TI1 + TI4
                      CI4 = TI1 - TI4
                      CH(I-1,K,2) = WA1(I-2)*CR2 - WA1(I-1)*CI2
                      CH(I,K,2) = WA1(I-2)*CI2 + WA1(I-1)*CR2
                      CH(I-1,K,3) = WA2(I-2)*CR3 - WA2(I-1)*CI3
                      CH(I,K,3) = WA2(I-2)*CI3 + WA2(I-1)*CR3
                      CH(I-1,K,4) = WA3(I-2)*CR4 - WA3(I-1)*CI4
                      CH(I,K,4) = WA3(I-2)*CI4 + WA3(I-1)*CR4
                  END DO
              END DO
              IF (MOD(IDO,2).EQ.1) RETURN
          END IF
          DO K = 1,L1
              TI1 = CC(1,2,K) + CC(1,4,K)
              TI2 = CC(1,4,K) - CC(1,2,K)
              TR1 = CC(IDO,1,K) - CC(IDO,3,K)
              TR2 = CC(IDO,1,K) + CC(IDO,3,K)
              CH(IDO,K,1) = TR2 + TR2
              CH(IDO,K,2) = SQRT2* (TR1-TI1)
              CH(IDO,K,3) = TI2 + TI2
              CH(IDO,K,4) = -SQRT2* (TR1+TI1)
          END DO
      END IF
      RETURN
      END
c
      SUBROUTINE DRADB5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      DOUBLE PRECISION CC
      DOUBLE PRECISION CH
      DOUBLE PRECISION WA1
      DOUBLE PRECISION WA2
      DOUBLE PRECISION WA3
      DOUBLE PRECISION WA4
      DOUBLE PRECISION TR11
      DOUBLE PRECISION TI11
      DOUBLE PRECISION TR12
      DOUBLE PRECISION TI12
      DOUBLE PRECISION TI5
      DOUBLE PRECISION TI4
      DOUBLE PRECISION TR2
      DOUBLE PRECISION TR3
      DOUBLE PRECISION CR2
      DOUBLE PRECISION CR3
      DOUBLE PRECISION CI5
      DOUBLE PRECISION CI4
      DOUBLE PRECISION TI2
      DOUBLE PRECISION TI3
      DOUBLE PRECISION TR5
      DOUBLE PRECISION TR4
      DOUBLE PRECISION CI2
      DOUBLE PRECISION CI3
      DOUBLE PRECISION CR5
      DOUBLE PRECISION CR4
      DOUBLE PRECISION DR3
      DOUBLE PRECISION DR4
      DOUBLE PRECISION DI3
      DOUBLE PRECISION DI4
      DOUBLE PRECISION DR5
      DOUBLE PRECISION DR2
      DOUBLE PRECISION DI5
      DOUBLE PRECISION DI2
      DIMENSION CC(IDO,5,L1),CH(IDO,L1,5),WA1(*),WA2(*),WA3(*),WA4(*)
      DATA TR11,TI11,TR12,TI12/.309016994374947D0,.951056516295154D0,
     +     -.809016994374947D0,.587785252292473D0/

      DO K = 1,L1
          TI5 = CC(1,3,K) + CC(1,3,K)
          TI4 = CC(1,5,K) + CC(1,5,K)
          TR2 = CC(IDO,2,K) + CC(IDO,2,K)
          TR3 = CC(IDO,4,K) + CC(IDO,4,K)
          CH(1,K,1) = CC(1,1,K) + TR2 + TR3
          CR2 = CC(1,1,K) + TR11*TR2 + TR12*TR3
          CR3 = CC(1,1,K) + TR12*TR2 + TR11*TR3
          CI5 = TI11*TI5 + TI12*TI4
          CI4 = TI12*TI5 - TI11*TI4
          CH(1,K,2) = CR2 - CI5
          CH(1,K,3) = CR3 - CI4
          CH(1,K,4) = CR3 + CI4
          CH(1,K,5) = CR2 + CI5
      END DO
      IF (IDO.EQ.1) RETURN
      IDP2 = IDO + 2
      DO K = 1,L1
          DO I = 3,IDO,2
              IC = IDP2 - I
              TI5 = CC(I,3,K) + CC(IC,2,K)
              TI2 = CC(I,3,K) - CC(IC,2,K)
              TI4 = CC(I,5,K) + CC(IC,4,K)
              TI3 = CC(I,5,K) - CC(IC,4,K)
              TR5 = CC(I-1,3,K) - CC(IC-1,2,K)
              TR2 = CC(I-1,3,K) + CC(IC-1,2,K)
              TR4 = CC(I-1,5,K) - CC(IC-1,4,K)
              TR3 = CC(I-1,5,K) + CC(IC-1,4,K)
              CH(I-1,K,1) = CC(I-1,1,K) + TR2 + TR3
              CH(I,K,1) = CC(I,1,K) + TI2 + TI3
              CR2 = CC(I-1,1,K) + TR11*TR2 + TR12*TR3
              CI2 = CC(I,1,K) + TR11*TI2 + TR12*TI3
              CR3 = CC(I-1,1,K) + TR12*TR2 + TR11*TR3
              CI3 = CC(I,1,K) + TR12*TI2 + TR11*TI3
              CR5 = TI11*TR5 + TI12*TR4
              CI5 = TI11*TI5 + TI12*TI4
              CR4 = TI12*TR5 - TI11*TR4
              CI4 = TI12*TI5 - TI11*TI4
              DR3 = CR3 - CI4
              DR4 = CR3 + CI4
              DI3 = CI3 + CR4
              DI4 = CI3 - CR4
              DR5 = CR2 + CI5
              DR2 = CR2 - CI5
              DI5 = CI2 - CR5
              DI2 = CI2 + CR5
              CH(I-1,K,2) = WA1(I-2)*DR2 - WA1(I-1)*DI2
              CH(I,K,2) = WA1(I-2)*DI2 + WA1(I-1)*DR2
              CH(I-1,K,3) = WA2(I-2)*DR3 - WA2(I-1)*DI3
              CH(I,K,3) = WA2(I-2)*DI3 + WA2(I-1)*DR3
              CH(I-1,K,4) = WA3(I-2)*DR4 - WA3(I-1)*DI4
              CH(I,K,4) = WA3(I-2)*DI4 + WA3(I-1)*DR4
              CH(I-1,K,5) = WA4(I-2)*DR5 - WA4(I-1)*DI5
              CH(I,K,5) = WA4(I-2)*DI5 + WA4(I-1)*DR5
          END DO
      END DO
      RETURN
      END
c
      SUBROUTINE DRADBG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      DOUBLE PRECISION CC
      DOUBLE PRECISION C1
      DOUBLE PRECISION C2
      DOUBLE PRECISION CH
      DOUBLE PRECISION CH2
      DOUBLE PRECISION WA
      DOUBLE PRECISION TPI
      DOUBLE PRECISION DPIMACH
      DOUBLE PRECISION DUM
      DOUBLE PRECISION ARG
      DOUBLE PRECISION DCP
      DOUBLE PRECISION DSP
      DOUBLE PRECISION AR1
      DOUBLE PRECISION AI1
      DOUBLE PRECISION AR1H
      DOUBLE PRECISION DC2
      DOUBLE PRECISION DS2
      DOUBLE PRECISION AR2
      DOUBLE PRECISION AI2
      DOUBLE PRECISION AR2H
      DIMENSION CH(IDO,L1,IP),CC(IDO,IP,L1),C1(IDO,L1,IP),C2(IDL1,IP),
     +          CH2(IDL1,IP),WA(*)

      TPI = 2.0D0*DPIMACH(DUM)
      ARG = TPI/DBLE(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IDP2 = IDO + 2
      NBD = (IDO-1)/2
      IPP2 = IP + 2
      IPPH = (IP+1)/2
      IF (IDO.GE.L1) THEN
          DO K = 1,L1
              DO I = 1,IDO
                  CH(I,K,1) = CC(I,1,K)
              END DO
          END DO
      ELSE
          DO I = 1,IDO
              DO K = 1,L1
                  CH(I,K,1) = CC(I,1,K)
              END DO
          END DO
      END IF
      DO J = 2,IPPH
          JC = IPP2 - J
          J2 = J + J
          DO K = 1,L1
              CH(1,K,J) = CC(IDO,J2-2,K) + CC(IDO,J2-2,K)
              CH(1,K,JC) = CC(1,J2-1,K) + CC(1,J2-1,K)
          END DO
      END DO
      IF (IDO.NE.1) THEN
          IF (NBD.GE.L1) THEN
              DO J = 2,IPPH
                  JC = IPP2 - J
                  DO K = 1,L1
                      DO I = 3,IDO,2
                          IC = IDP2 - I
                          CH(I-1,K,J) = CC(I-1,2*J-1,K) +
     +                                  CC(IC-1,2*J-2,K)
                          CH(I-1,K,JC) = CC(I-1,2*J-1,K) -
     +                                   CC(IC-1,2*J-2,K)
                          CH(I,K,J) = CC(I,2*J-1,K) - CC(IC,2*J-2,K)
                          CH(I,K,JC) = CC(I,2*J-1,K) + CC(IC,2*J-2,K)
                      END DO
                  END DO
              END DO
          ELSE
              DO J = 2,IPPH
                  JC = IPP2 - J
                  DO I = 3,IDO,2
                      IC = IDP2 - I
                      DO K = 1,L1
                          CH(I-1,K,J) = CC(I-1,2*J-1,K) +
     +                                  CC(IC-1,2*J-2,K)
                          CH(I-1,K,JC) = CC(I-1,2*J-1,K) -
     +                                   CC(IC-1,2*J-2,K)
                          CH(I,K,J) = CC(I,2*J-1,K) - CC(IC,2*J-2,K)
                          CH(I,K,JC) = CC(I,2*J-1,K) + CC(IC,2*J-2,K)
                      END DO
                  END DO
              END DO
          END IF
      END IF
      AR1 = 1.D0
      AI1 = 0.D0
      DO L = 2,IPPH
          LC = IPP2 - L
          AR1H = DCP*AR1 - DSP*AI1
          AI1 = DCP*AI1 + DSP*AR1
          AR1 = AR1H
          DO IK = 1,IDL1
              C2(IK,L) = CH2(IK,1) + AR1*CH2(IK,2)
              C2(IK,LC) = AI1*CH2(IK,IP)
          END DO
          DC2 = AR1
          DS2 = AI1
          AR2 = AR1
          AI2 = AI1
          DO J = 3,IPPH
              JC = IPP2 - J
              AR2H = DC2*AR2 - DS2*AI2
              AI2 = DC2*AI2 + DS2*AR2
              AR2 = AR2H
              DO IK = 1,IDL1
                  C2(IK,L) = C2(IK,L) + AR2*CH2(IK,J)
                  C2(IK,LC) = C2(IK,LC) + AI2*CH2(IK,JC)
              END DO
          END DO
      END DO
      DO J = 2,IPPH
          DO IK = 1,IDL1
              CH2(IK,1) = CH2(IK,1) + CH2(IK,J)
          END DO
      END DO
      DO J = 2,IPPH
          JC = IPP2 - J
          DO K = 1,L1
              CH(1,K,J) = C1(1,K,J) - C1(1,K,JC)
              CH(1,K,JC) = C1(1,K,J) + C1(1,K,JC)
          END DO
      END DO
      IF (IDO.NE.1) THEN
          IF (NBD.GE.L1) THEN
              DO J = 2,IPPH
                  JC = IPP2 - J
                  DO K = 1,L1
                      DO I = 3,IDO,2
                          CH(I-1,K,J) = C1(I-1,K,J) - C1(I,K,JC)
                          CH(I-1,K,JC) = C1(I-1,K,J) + C1(I,K,JC)
                          CH(I,K,J) = C1(I,K,J) + C1(I-1,K,JC)
                          CH(I,K,JC) = C1(I,K,J) - C1(I-1,K,JC)
                      END DO
                  END DO
              END DO
          ELSE
              DO J = 2,IPPH
                  JC = IPP2 - J
                  DO I = 3,IDO,2
                      DO K = 1,L1
                          CH(I-1,K,J) = C1(I-1,K,J) - C1(I,K,JC)
                          CH(I-1,K,JC) = C1(I-1,K,J) + C1(I,K,JC)
                          CH(I,K,J) = C1(I,K,J) + C1(I-1,K,JC)
                          CH(I,K,JC) = C1(I,K,J) - C1(I-1,K,JC)
                      END DO
                  END DO
              END DO
          END IF
      END IF
      IF (IDO.EQ.1) RETURN
      DO IK = 1,IDL1
          C2(IK,1) = CH2(IK,1)
      END DO
      DO J = 2,IP
          DO K = 1,L1
              C1(1,K,J) = CH(1,K,J)
          END DO
      END DO
      IF (NBD.LE.L1) THEN
          IS = -IDO
          DO J = 2,IP
              IS = IS + IDO
              IDIJ = IS
              DO I = 3,IDO,2
                  IDIJ = IDIJ + 2
                  DO K = 1,L1
                      C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J) -
     +                              WA(IDIJ)*CH(I,K,J)
                      C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J) +
     +                            WA(IDIJ)*CH(I-1,K,J)
                  END DO
              END DO
          END DO
      ELSE
          IS = -IDO
          DO J = 2,IP
              IS = IS + IDO
              DO K = 1,L1
                  IDIJ = IS
                  DO I = 3,IDO,2
                      IDIJ = IDIJ + 2
                      C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J) -
     +                              WA(IDIJ)*CH(I,K,J)
                      C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J) +
     +                            WA(IDIJ)*CH(I-1,K,J)
                  END DO
              END DO
          END DO
      END IF
      RETURN
      END


module modulo_utils
  use module_modint
  implicit none
  type(modint), allocatable :: f(:), invf(:)
contains
  subroutine init(n)
    integer, intent(in) :: n
    integer :: i
    if (allocated(f)) deallocate(f)
    if (allocated(invf)) deallocate(invf)
    allocate(f(0:n),invf(0:n))
    f(0) = 1
    do i = 1, n
      f(i) = f(i-1)*i
    end do
    invf(n) = f(n)%inv()
    do i = n, 1, -1
      invf(i-1) = invf(i)*i
    end do
  end
  pure elemental type(modint) function perm(n,k)
    integer, intent(in) :: n, k
    if (k > n .or. n < 0 .or. k < 0) return
    perm = f(n)*invf(n-k)
  end
  pure elemental type(modint) function comb(n,k)
    integer, intent(in) :: n, k
    comb = perm(n,k)*invf(k)
  end
  pure elemental type(modint) function homo(n,k)
    integer, intent(in) :: n, k
    homo = 1
    if (n == 0 .and. k == 0) return
    homo = comb(n+k-1,k)
  end
end module modulo_utils


      DOUBLE PRECISION FUNCTION CMOD(R,I)                               CMOD4700
C MODULUS OF A COMPLEX NUMBER AVOIDING OVERFLOW.
      DOUBLE PRECISION R,I,AR,AI,DABS,DSQURT
      AR = DABS(R)
      AI = DABS(I)
      IF (AR .GE. AI) GO TO 10
          CMOD = AI*DSQRT(1.0D0+(AR/AI)**2)
          RETURN
   10 IF (AR .LE. AI) GO TO 20
          CMOD = AR*DSQRT(1.0D0+(AI/AR)**2)
          RETURN
   20 CMOD = AR*DSQRT(2.0D0)
      RETURN
      END


! Test that NINT gives right results even in corner cases
!
! PR 31202
! http://gcc.gnu.org/ml/fortran/2005-04/msg00139.html
!
! { dg-do run }
! { dg-xfail-run-if "PR 33271, math library bug" { powerpc-ibm-aix powerpc*-*-linux* *-*-mingw* } { "-O0" } { "" } }
  real(kind=8) :: a
  integer(kind=8) :: i1, i2
  real :: b
  integer :: j1, j2

  a = nearest(0.5_8,-1.0_8)
  i2 = nint(nearest(0.5_8,-1.0_8))
  i1 = nint(a)
  if (i1 /= 0 .or. i2 /= 0) call abort

  a = 0.5_8
  i2 = nint(0.5_8)
  i1 = nint(a)
  if (i1 /= 1 .or. i2 /= 1) call abort

  a = nearest(0.5_8,1.0_8)
  i2 = nint(nearest(0.5_8,1.0_8))
  i1 = nint(a)
  if (i1 /= 1 .or. i2 /= 1) call abort

  b = nearest(0.5,-1.0)
  j2 = nint(nearest(0.5,-1.0))
  j1 = nint(b)
  if (j1 /= 0 .or. j2 /= 0) call abort

  b = 0.5
  j2 = nint(0.5)
  j1 = nint(b)
  if (j1 /= 1 .or. j2 /= 1) call abort

  b = nearest(0.5,1.0)
  j2 = nint(nearest(0.5,1.0))
  j1 = nint(b)
  if (j1 /= 1 .or. j2 /= 1) call abort

  a = 4503599627370497.0_8
  i1 = nint(a,kind=8)
  i2 = nint(4503599627370497.0_8,kind=8)
  if (i1 /= i2 .or. i1 /= 4503599627370497_8) call abort

  a = -4503599627370497.0_8
  i1 = nint(a,kind=8)
  i2 = nint(-4503599627370497.0_8,kind=8)
  if (i1 /= i2 .or. i1 /= -4503599627370497_8) call abort
  end


       SUBROUTINE svdfit(y,sig,ndata,a,ma,mp,np)
       IMPLICIT NONE
       INTEGER ma,mp,ndata,np,NMAX,MMAX,i,j
       DOUBLE PRECISION chisq,a(ma),sig(ndata),u(mp,np),v(np,np),w(np),
     * x(ndata),y(ndata),TOL
c       EXTERNAL funcs1
c       PARAMETER (NMAX=100000,MMAX=2000,TOL=1.e-14)
       include 'param.inc'
c         NMAX is the maximum expected value of ndata; MMAX the maximum expected for ma; the default TOL val

c USES svbksb,svdcmp
c Given a set of data points x(1:ndata),y(1:ndata) with individual standard deviations
c sig(1:ndata), use chi-2 minimization to determine the ma coefficients a of the fitting
c function xxxx. Here we solve the fitting equations using singular
c value decomposition of the ndata by ma matrix, as in §2.6.
c Arrays u(1:mp,1:np),v(1:np,1:np), w(1:np) provide workspace on input;
c on output they define the singular
c value decomposition, and can be used to obtain the covariance matrix.
c mp,np are the physical dimensions
c of the matrices u,v,w, as indicated above. It is necessary that
c mp≥ndata, np ≥ ma. The
c program returns values for the ma fit parameters a, and χ2, chisq. The
c user supplies a
c subroutine funcs(x,afunc,ma) that returns the ma basis functions
c evaluated at x = x
c in the array afunc.
       DOUBLE PRECISION sum,thresh,tmp,wmax,afunc(maxterm),b(maxdata)
       PARAMETER (TOL=1.e-14)
       do 12 i=1,ndata 					! Accumulate coefficients of the fitting ma
       call funcs1(i,afunc,ma)
c        if (i.eq.2) print *,i,y(i)
       tmp=1./sig(i)
       do 11 j=1,ma
       u(i,j)=afunc(j)*tmp
   11  enddo
       b(i)=y(i)*tmp
   12  enddo
       call svdcmp(u,ndata,ma,mp,np,w,v)                 ! Singular value decomposition.
       wmax=0.                                           ! Edit the singular values, given TOL from the
       do 13 j=1,ma                                      ! parameter statement, between here ...
       if(w(j).gt.wmax)wmax=w(j)
   13  enddo
       thresh=TOL*wmax
       do 14 j=1,ma
       if(w(j).lt.thresh)w(j)=0.
   14  enddo                                             ! ...and here.
       call svbksb(u,w,v,ndata,ma,mp,np,b,a)
       chisq=0.                                          ! Evaluate chi-square.
       do 16 i=1,ndata
       call funcs1(i,afunc,ma)
       sum=0.
       do 15 j=1,ma
       sum=sum+a(j)*afunc(j)
   15  enddo
       chisq=chisq+((y(i)-sum)/sig(i))**2
   16  enddo
       return
       END


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 4 node
!!    tetrahedron element (Langrange  interpolation)
module shape_tet4n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_tet4n(volcoord,func)
    real(kind=kreal), intent(in) :: volcoord(3)
    real(kind=kreal) :: func(4)
    func(2:4) = volcoord(1:3)
    func(1)   = 1.d0-volcoord(1)-volcoord(2)-volcoord(3)
  end subroutine

  subroutine ShapeDeriv_tet4n(func)
    real(kind=kreal), intent(out) :: func(4,3)
    func(1,1) = -1.d0
    func(2,1) = 1.d0
    func(3,1) = 0.d0
    func(4,1) = 0.d0

    func(1,2) = -1.d0
    func(2,2) = 0.d0
    func(3,2) = 1.d0
    func(4,2) = 0.d0

    func(1,3) = -1.d0
    func(2,3) = 0.d0
    func(3,3) = 0.d0
    func(4,3) = 1.d0
  end subroutine

end module


!=============================================================================!
        module diff
!
!  Finite Difference coefficients
!
!=============================================================================!
!.... First derivatives
!=============================================================================!

!.... second order central difference

        real, parameter :: gd1 = -5.000000000000000E-01
        real, parameter :: gd2 =  5.000000000000000E-01

!.... second order one-sided difference

        real, parameter :: ge1 = -1.500000000000000E+00
        real, parameter :: ge2 =  2.000000000000000E+00
        real, parameter :: ge3 = -5.000000000000000E-01

!.... first order one-sided difference

        real, parameter :: gf1 = -1.000000000000000E+00
        real, parameter :: gf2 =  1.000000000000000E+00

        end module diff

!=============================================================================!
        subroutine grad( ndof, nx, ny, v, g1v, g2v, dx, dy, optx, opty, &
                         xper, yper)
!
!  Take the gradient of a 2-D field.
!  updated to fourth order accurate differencing
!
!=============================================================================!
        use diff
        implicit none

        integer ndof, nx, ny, optx, opty
        logical :: xper, yper
        real v(ny,ndof,nx), g1v(ny,ndof,nx), g2v(ny,ndof,nx)
        real dx, dy

        real, parameter :: one = 1.0
        real dxinv, dyinv
!=============================================================================!

        dxinv  = one / dx
        dyinv  = one / dy

!=============================================================================!
!.... compute the gradient in x
!=============================================================================!

        if (xper) then

          g1v(:,:,1)        = ( gd1 * v(:,:,nx-1)       + &
                                gd2 * v(:,:,2   )       ) * dxinv

          g1v(:,:,nx) = g1v(:,:,1)

        else

          g1v(:,:,1)      = ( gf1 * v(:,:,1)  + &
                              gf2 * v(:,:,2)  ) * dxinv

          g1v(:,:,nx)    = -( gf1 * v(:,:,nx  )  + &
                              gf2 * v(:,:,nx-1)  ) * dxinv

        end if

!.... interior

        g1v(:,:,2:nx-1)  = ( gd1 * v(:,:,1:nx-2)        + &
                             gd2 * v(:,:,3:nx  )        ) * dxinv

!=============================================================================!
!.... compute the gradient in y
!=============================================================================!

        if (yper) then

          g2v(1,:,:)       = ( gd1 * v(ny-1,:,:)        + &
                               gd2 * v(2,:,:)           ) * dyinv

          g2v(ny,:,:) = g2v(1,:,:)

        else

          g2v(1,:,:)     = ( gf1 * v(1,:,:)  + &
                             gf2 * v(2,:,:)  ) * dyinv

          g2v(ny,:,:)   = -( gf1 * v(ny  ,:,:)  + &
                             gf2 * v(ny-1,:,:)  ) * dyinv

        end if

!.... interior

        g2v(2:ny-1,:,:) = ( gd1 * v(1:ny-2,:,:) + &
                            gd2 * v(3:ny  ,:,:) ) * dyinv

        return
        end


    Program dstegr_example

!     DSTEGR Example Program Text

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

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dstegr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: vl = 0.0E0_dp
      Real (Kind=dp), Parameter :: vu = 0.0E0_dp
      Integer, Parameter :: il = 0, iu = 0, nin = 5, nout = 6
      Character (1), Parameter :: range = 'A'
!     .. Local Scalars ..
      Real (Kind=dp) :: abstol
      Integer :: i, ifail, info, ldz, liwork, lwork, m, n
      Character (1) :: jobz
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:), w(:), work(:), z(:, :)
      Integer, Allocatable :: isuppz(:), iwork(:)
!     .. Executable Statements ..
      Write (nout, *) 'DSTEGR Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = n
      liwork = 10*n
      lwork = 18*n
      Allocate (d(n), e(n), w(n), work(lwork), z(ldz,n), isuppz(2*n), &
        iwork(liwork))

!     Read the symmetric tridiagonal matrix T from data file, first
!     the diagonal elements, then the off diagonal elements and then
!     JOBV ('N' - eigenvalues only, 'V' - vectors as well)

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)
      Read (nin, *) jobz

!     Calculate all the eigenvalues of T. Set ABSTOL to zero so that
!     the default value is used.

      abstol = 0.0E0_dp
      Call dstegr(jobz, range, n, d, e, vl, vu, il, iu, abstol, m, w, z, ldz, &
        isuppz, work, lwork, iwork, liwork, info)

      If (info==0) Then

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:m)

        Write (nout, *)
        Flush (nout)

!       Standardize the eigenvectors so that first elements are non-negative.
        Do i = 1, m
          If (z(1,i)<0.0_dp) Then
            z(1:n, i) = -z(1:n, i)
          End If
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, m, z, ldz, &
          'Eigenvectors', ifail)

      Else
        Write (nout, 110) 'Failure to compute an eigenvalue, INFO = ', info
      End If

100   Format ((3X,8F8.4))
110   Format (1X, A, I10)
    End Program


      REAL             FUNCTION SBESY1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SBESY1 Krogh  Added external statement.
C>> 1995-11-03 SBESY1 Krogh  Changes to simplify C conversion.
C>> 1994-11-11 SBESY1 Krogh  Declared all vars.
C>> 1994-10-20 SBESY1 Krogh  Changes to use M77CON
C>> 1991-01-14 SBESY1 CLL Changed to generic name SIN.
C>> 1990-11-29 CLL
C>> 1985-08-02 SBESY1 Lawson  Initial code.
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C C.L.LAWSON & S.CHAN, JPL, 1984 FEB ADAPTED TO JPL MATH77 LIBRARY.
c     ------------------------------------------------------------------
c--S replaces "?": ?BESY1, ?BESJ1, ?BMP1, ?INITS, ?CSEVL, ?ERM1
c     ------------------------------------------------------------------
      EXTERNAL R1MACH, SBESJ1, SCSEVL
      INTEGER NTY1
      REAL             X, BY1CS(20), AMPL, THETA, TWODPI, XMIN, XSML,
     1  Y, R1MACH, SCSEVL, SBESJ1
C
C SERIES FOR BY1        ON THE INTERVAL  0.          TO  1.60000E+01
C                                        WITH WEIGHTED ERROR   8.65E-33
C                                         LOG WEIGHTED ERROR  32.06
C                               SIGNIFICANT FIGURES REQUIRED  32.17
C                                    DECIMAL PLACES REQUIRED  32.71
C
      SAVE NTY1, XMIN, XSML
C
      DATA BY1CS / +.320804710061190862932352018628015E-1,
     *  +.126270789743350044953431725999727E+1,
     *  +.649996189992317500097490637314144E-2,
     *  -.893616452886050411653144160009712E-1,
     *  +.132508812217570954512375510370043E-1,
     *  -.897905911964835237753039508298105E-3,
     *  +.364736148795830678242287368165349E-4,
     *  -.100137438166600055549075523845295E-5,
     *  +.199453965739017397031159372421243E-7,
     *  -.302306560180338167284799332520743E-9,
     *  +.360987815694781196116252914242474E-11,
     *  -.348748829728758242414552947409066E-13,
     *  +.278387897155917665813507698517333E-15,
     *  -.186787096861948768766825352533333E-17,
     *  +.106853153391168259757070336000000E-19,
     *  -.527472195668448228943872000000000E-22,
     *  +.227019940315566414370133333333333E-24,
     *  -.859539035394523108693333333333333E-27,
     *  +.288540437983379456000000000000000E-29,
     *  -.864754113893717333333333333333333E-32 /
C
      DATA TWODPI / 0.636619772367581343075535053490057E0 /
      DATA NTY1, XMIN, XSML / 0, 2*0.E0 /
C     ------------------------------------------------------------------
      IF (NTY1 .EQ. 0) then
      call SINITS (BY1CS, 20, 0.1E0*R1MACH(3), NTY1)
C
      XMIN = 1.571E0 * EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) +
     1  0.01E0)
      XSML = SQRT (4.0E0*R1MACH(3))
      endif
C
      IF (X .LE. 0.E0) THEN
        SBESY1 = 0.E0
        CALL SERM1 ('SBESY1',1,0,'X IS ZERO OR NEGATIVE','X',X,'.')
      ELSE IF (X .LE. XMIN) THEN
        SBESY1 = 0.E0
        CALL SERM1 ('SBESY1',2,0,'X SO SMALL Y1 OVERFLOWS','X',X,'.')
      ELSE IF (X .LE. 4.E0) THEN
        IF (X .LE. XSML) THEN
          Y = 0.E0
        ELSE
          Y = X * X
        END IF
        SBESY1 = TWODPI * LOG(0.5E0*X)*SBESJ1(X) + (0.5E0 +
     *           SCSEVL (.125E0*Y-1.E0, BY1CS, NTY1))/X
      ELSE
        CALL SBMP1 (X, AMPL, THETA)
        SBESY1 = AMPL * SIN(THETA)
      END IF
      RETURN
      END


program invert_ppal

use datasissim_interface
use lu_interface
use sistu_interface
use sistl_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:,:), allocatable :: a_copia
real, dimension(:,:), allocatable :: a_inverse
real, dimension(:,:), allocatable :: jd
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: w

real :: deter

integer :: n, i

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), a_inverse(n,n), a_copia(n,n), jd(n,n), b(n), w(n))

call datasissim(a)

a_copia = a

call lu(a, deter)

do i = 1, n
  b = 0
  b(i) = 1

  call sistl(a,b,w)
  call sistu(a,w,a_inverse(:,i))

end do

print*, 'A inversa de A é: '

do i=1,n
  print*, a_inverse(i,:)
end do

jd = matmul(a_copia,a_inverse)

print*, 'Matriz identidade: '

do i=1,n
  print*, jd(i,:)
end do

if (allocated(a)) deallocate(a)

if(allocated(a_inverse)) deallocate(a_inverse)

if(allocated(jd)) deallocate(jd)

end program


MODULE myjunk
TYPE POINT
  REAL :: X, Y
CONTAINS
PROCEDURE, PASS :: LENGTH => POINT_LENGTH
END TYPE POINT

CONTAINS

REAL FUNCTION POINT_LENGTH(A,B)
CLASS(POINT), INTENT(IN) :: A, B
POINT_LENGTH = SQRT((A%X-B%X)**2+(A%Y-B%Y)**2)
END FUNCTION POINT_LENGTH
END MODULE


module spectra
   use constants
   implicit none
   private

   public :: fourier

contains

   subroutine fourier(wave, spectrum)
      real(dp), intent(in) :: wave(:)
      complex(dp), intent(out) :: spectrum(:)

      integer :: n, m
      real(dp) :: omega, phi
      complex(dp) :: transform(size(spectrum), size(wave))

      omega = 2 * pi / size(wave)

      do m = 1, size(wave)
         do n = 1, size(spectrum)
            phi = n * m * omega
            transform(n, m) = cmplx(cos(phi), sin(phi), dp)
         end do
      end do

      spectrum = matmul(transform, wave) / size(wave)
   end subroutine fourier
end module spectra


module stdlib_specialfunctions
    use stdlib_kinds, only: sp, dp, xdp, qp

    implicit none

    private

    public :: legendre
    public :: dlegendre

    interface legendre
        !! version: experimental
        !!
        !! Legendre polynomial
        pure elemental module function legendre_fp64(n,x) result(leg)
            integer, intent(in) :: n
            real(dp), intent(in) :: x
            real(dp) :: leg
        end function
    end interface

    interface dlegendre
        !! version: experimental
        !!
        !! First derivative Legendre polynomial
        pure elemental module function dlegendre_fp64(n,x) result(dleg)
            integer, intent(in) :: n
            real(dp), intent(in) :: x
            real(dp) :: dleg
        end function
    end interface

end module stdlib_specialfunctions


C     Example used by Khadija Immadoueddine, p. 7 in her report
C
C     It seems that she has unrolled the j loop by hand and the i loop
C     with PIPS; in fact, she's used an unroll-and-jam
C
C     Unlike unroll13 and 14, try tiling and unroll to emulate her
C     unroll-and-jam

      subroutine unroll15(n1, n2, a, b, c)
C
      real a(0:n1+1,0:n2+1)
      real b(0:n1+1,0:n2+1)
      real c(0:n1+1,0:n2+1)

      do 200 j = 1, n2
         do 300 i = 1, n1
            a(i,j)=a(i+1,j)*b(i,j)+a(i,j+1)*c(i,j)
 300     continue
 200  continue

      END

      program main
      parameter (n1=10, n2=11)
      real a(0:n1+1,0:n2+1)
      real b(0:n1+1,0:n2+1)
      real c(0:n1+1,0:n2+1)

      do i = 0, n1+1
         do j = 0, n2+1
            a(i,j) = 3*i*(n1+2)+j
            b(i,j) = 3*i*(n1+2)+j+1
            c(i,j) = 3*i*(n1+2)+j+2
         enddo
      enddo

      call unroll15(n1, n2, a, b, c)

      print *, a(0,0), a(0,n2+1),a(n1+1,0), a(n1+1,n2+1)

      end


program doloop_02
implicit none
integer :: i, j, a, b
j = 0
a = 1
b = 10
do i = a, b
    j = j + i
end do
if (j /= 55) error stop

a = 0
do i = 1, 10
    do j = 1, 10
        a = a + (i-1)*10+j
    end do
end do
if (a /= 100*101/2) error stop

a = 0
do i = 1, 10
    do j = 1, i
        a = a + j
    end do
end do
if (a /= 220) error stop
end


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test f2008 bessel_j1 intrinsic

program p
 use ISO_C_BINDING
 use check_mod

  interface
    subroutine get_expected_f( src1, expct, n ) bind(C)
     use ISO_C_BINDING
      type(C_PTR), value :: src1
      type(C_PTR), value :: expct
      integer(C_INT), value :: n
    end subroutine

    subroutine get_expected_d( src1, expct, n ) bind(C)
     use ISO_C_BINDING
      type(C_PTR), value :: src1
      type(C_PTR), value :: expct
      integer(C_INT), value :: n
    end subroutine
  end interface

  integer, parameter :: N=22
  real*4, target,  dimension(N) :: r_src1
  real*4, target,  dimension(N) :: r_rslt
  real*4, target,  dimension(N) :: r_expct
  real*8 :: valuer

  real*8, target,  dimension(N) :: d_src1
  real*8, target,  dimension(N) :: d_rslt
  real*8, target,  dimension(N) :: d_expct
  real*8 :: value8

  valuer = -.2
  valued = -.2_8
  do i =  0,N-1
    r_src1(i+1) = valuer + i
    d_src1(i+1) = valued + i
  enddo

  r_rslt = bessel_j1(r_src1)
  d_rslt = bessel_j1(d_src1)

  call get_expected_f(C_LOC(r_src1), C_LOC(r_expct), N)
  call get_expected_d(C_LOC(d_src1), C_LOC(d_expct), N)

  call checkr4( r_rslt, r_expct, N, rtoler=0.0000003)
  call checkr8( d_rslt, d_expct, N, rtoler=0.0000003_8)

!   print *, "r_expct:"
!   print *, r_expct
!   print *, "r_rslt:"
!   print *, r_rslt
!
!   print *, "d_expct:"
!   print *, d_expct
!   print *, "d_rslt:"
!   print *, d_rslt
end program


program pi

  use ISO_FORTRAN_ENV
  use mpi

  implicit none

  double precision              :: step, x, s, finalsum, mypi, start, stop
  integer(kind=int64)           :: num_steps, i, mymax, mymin
  character(len=:), allocatable :: a
  integer                       :: argl, rank, ierr, numprocs

  call MPI_INIT(ierr)
  call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
  call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)

  num_steps = 1000000000

! Get command line args (Fortran 2003 standard)
  if (command_argument_count() > 0) then
     call get_command_argument(1, length=argl)
     allocate(character(argl) :: a)
     call get_command_argument(1, a)
     read(a,*) num_steps
  end if

! Output start message

  if (rank == 0) then
    write(*,'(A)') "Calculating PI using:"
    write(*,'(A,1I16,A)') "                  ",num_steps, " slices"
    write(*,'(A,1I16,A)') "                  ",numprocs," process(es)"
  end if

! Initialise time counter and sum: set step size

  call MPI_BARRIER(MPI_COMM_WORLD, ierr)

  start = MPI_WTIME()
  s = 0d0
  step = 1.0d0 / num_steps

! Remember Fortran loops from 1
  mymin = ((rank * num_steps)/numprocs) + 1
  mymax = ((rank + 1) * num_steps)/numprocs

  do i = mymin, mymax
    x = (i - 0.5d0) * step
    s = s + 4.0d0 / (1.0d0 + x*x)
  end do

  call MPI_Reduce(s, finalsum, 1, MPI_DOUBLE, MPI_SUM, 0, MPI_COMM_WORLD, ierr)

! Evaluate PI from the final sum value, and stop the clock

  mypi = finalsum * step

  call MPI_BARRIER(MPI_COMM_WORLD, ierr)
  stop =  MPI_WTIME()

! output value of PI and time taken
! note cpu_time is only specified as being microsecond res

  if (rank == 0) then
    write(*,'(A,1F12.10,A)') "Obtained value of PI: ", mypi
    write(*,'(A,1F12.5,A)') "Time taken:           ",(stop-start), " seconds"
  end if

  call MPI_FINALIZE(ierr)

end program pi


module math_module

  public

contains

  ! Compute the standard cross-product of two three-vectors.

  function cross_product(A,B) result(C)

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    real(rt)         :: A(3), B(3)
    real(rt)         :: C(3)

    C(1) = A(2)*B(3) - A(3)*B(2)
    C(2) = A(3)*B(1) - A(1)*B(3)
    C(3) = A(1)*B(2) - A(2)*B(1)

  end function cross_product

end module math_module


      PROGRAM MAIN

      INTEGER N, NMAX, JMAX, IL, IU, M, LDA, LDZ, ZERO,
     $        SEED
      PARAMETER (NMAX=1000, JMAX=NMAX, LDA=NMAX, LDZ=NMAX, ZERO=0,
     $           SEED=12)

      DOUBLE PRECISION VL, VU, W(NMAX)
      COMPLEX*16 A(NMAX,NMAX), Z(NMAX,JMAX)

      INTEGER I, J, IERR

*     external functions
      EXTERNAL ZHEEIG

*     Intialize Hermitian matrix A of size N-by-N
      N = 100

      CALL SRAND(SEED)
      DO 100, J=1,N
         DO 200, I=1,J
            IF (I .EQ. J) THEN
               A(I,J) = COMPLEX(RAND(),ZERO)
            ELSE
               A(I,J) = COMPLEX(RAND(),RAND())
            ENDIF
 200     CONTINUE
 100  CONTINUE

      DO 300, J=1,N
         DO 400, I=J+1,N
            A(I,J) = CONJG(A(J,I))
 400     CONTINUE
 300  CONTINUE

*     Solve the eigenproblem
*     The number of threads for the LAPACK routines are set by
*     OMP_NUM_THREADS or GOTO_NUM_THREADS or MKL_NUM_THREADS ...
*     depending on the BLAS used. For the tridiagonal stage with
*     PMR_NUM_THREADS.
      CALL ZHEEIG('V', 'A', 'L', N, A, LDA, VL, VU, IL, IU,
     $            M, W, Z, LDZ, IERR)
      IF (IERR .NE. 0) THEN
         WRITE(*,*) 'Routine has failed with error', IERR
      ENDIF

      WRITE(*,*) 'Sucessfully computed eigenpairs!'

      END


      PROGRAM xddpoly
C     driver for routine ddpoly
      INTEGER NC,NCM1,NP
      PARAMETER(NC=6,NCM1=5,NP=20)
      INTEGER i,j
      REAL x,factrl,c(NC),pd(NCM1),d(NCM1,NP)
      CHARACTER a(NCM1)*15
      DATA a/'polynomial:','first deriv:','second deriv:',
     *     'third deriv:','fourth deriv:'/
      DATA c/-1.0,5.0,-10.0,10.0,-5.0,1.0/
      do 12 i=1,NP
        x=0.1*i
        call ddpoly(c,NC,x,pd,NC-1)
        do 11 j=1,NC-1
          d(j,i)=pd(j)
11      continue
12    continue
      do 14 i=1,NC-1
        write(*,'(1x,t7,a)') a(i)
        write(*,'(1x,t13,a,t25,a,t40,a)') 'X','DDPOLY','actual'
        do 13 j=1,NP
          x=0.1*j
          write(*,'(1x,3f15.6)') x,d(i,j),
     *         factrl(NC-1)/factrl(NC-i)*((x-1.0)**(NC-i))
13      continue
        write(*,*) 'press ENTER to continue...'
        read(*,*)
14    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xddpoly.for


subroutine knots_lms(X, N, Nctl, k, t)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract knots_lms generates knots suitable for b-splines
  !
  !     Description of Arguments
  !     Input
  !     X       - Real, size(N) The ordinates to use to make knot vector
  !     N       - Integer, the number of ordinates
  !     Nctl    - Integer, the desired number of control points
  !     k       - order of spline
  !
  !     Ouput
  !     t       - Real, size(Nctl+k) the resulting knots

  use precision
  implicit none

  ! Input
  integer, intent(in)     :: N
  integer, intent(in)     :: Nctl
  integer, intent(in)     :: K
  real(kind=realType), intent(in)  :: X(N)

  ! Output
  real(kind=realType), intent(out) :: T(Nctl+K)

  ! Working
  real(kind=realType) d, alpha
  integer  I, J

  ! ----------------------------
  !  PUT K KNOTS AT EACH ENDPOINT -- Knot a knot conditions
  !  ----------------------------
  !
  DO  J=1, K
     t(J) = X(1) ! Left
     t(Nctl+J) = X(N) ! right
  end do

  if (mod(N, 2) == 1) then ! Odd
     d = real(N/(Nctl-k+1.0))
     do j=1, Nctl-k
        i = floor(j*d)
        alpha = j*d-i
        t(k+j) = (1-alpha)*X(i) + alpha*X(i+2)
     end do
  else ! even
     d = real(N/(Nctl-k+1.0))
     do j=1, Nctl-k
        i = floor(j*d)
        alpha = j*d-i+0.5
        t(k+j) = (1-alpha)*X(i) + alpha*X(i+1)
     end do
  end if

end subroutine knots_lms

subroutine knots_interp(X, deriv_ptr, n, nd , k, t)
 !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract knots_lms generates knots suitable for b-spline
  !     interpolation
  !
  !     Description of Arguments
  !     Input
  !     X       - Real, size(N) The ordinates to use to make knot vector
  !     deriv_ptr - Real, size(nd) Flags to determine if a derivative
  !     is specified
  !     n       - Integer, the number of ordinates
  !     nd      - Integer, the number of derivatives specified
  !     k       - order of spline
  !
  !     Ouput
  !     t       - Real, size(nNctl+k) the resulting knots

  use precision
  implicit none

  ! Input
  integer, intent(in)              :: n, nd, k
  integer, intent(in)              :: deriv_ptr(nd)
  real(kind=realType), intent(in)  :: X(n)

  ! Output
  real(kind=realType), intent(out) :: t(n+nd+k)

  ! Working
  integer                          :: i, j, Nctl

  ! ----------------------------
  !  PUT K KNOTS AT EACH ENDPOINT -- Knot a knot conditions
  !  ----------------------------
  Nctl = n + nd

  DO  J=1, K
     t(J) = X(1) ! Left
     t(Nctl+J) = X(N) ! right
  end do

  if (nd == n) then ! Full Length nd so we can use formulas in NURBS book
     if (k == 3) then
        do i=1, n-2
           t(k+2*i-1) = 0.5*(X(i) + X(i+1))
           t(k+2*i) = X(i+1)
        end do
        t(Nctl) = 0.5*(X(n-1) + 1)
     else if (k ==4) then
        t(5) = X(2)/2
        t(Nctl) = 0.5*(X(n-1) + 1)
         do i=1, n-3
            t(k+2*i  ) = (1.0/3.0)*(2*X(i+1) + X(i+2))
            t(k+2*i+1) = (1.0/3.0)*(X(i+1) + 2*X(i+2))
         end do
     end if

  else if (nd == 0) then
     if (k ==2 ) then
        do j=1, N-k
           t(k+j) = X(j+1)
        end do
     else if (k == 3) then
        do j=1, N-k
           t(k+j) = 0.5*(X(j+1)+X(J+2))
        end do
     else if (k == 4) then
        do j=1, N-k
           t(K+j) = X(j+2)
        end do
     else
        print *, 'Error: Interpolation is only available for k=2, 3 or 4'
        stop
     end if
  else
     print *, 'Interp_knots with number of derivative != number of points is not yet supported'
     stop
  end if
end subroutine knots_interp


PROGRAM mairyzo

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:09

!       =========================================================
!       Purpose: This program computes the first NT zeros of Airy
!                functions Ai(x) and Ai'(x), and the associated
!                values of Ai(a') and Ai'(a), and the first NT
!                zeros of Airy functions Bi(x) and Bi'(x), and
!                the associated values of Bi(b') and Bi'(b) using
!                subroutine AIRYZO
!       Input :  NT    --- Total number of zeros
!                KF    --- Function code
!                          KF=1 for Ai(x) and Ai'(x)
!                          KF=2 for Bi(x) and Bi'(x)
!       Output:  XA(m) --- a, the m-th zero of Ai(x) or
!                          b, the m-th zero of Bi(x)
!                XB(m) --- a', the m-th zero of Ai'(x) or
!                          b', the m-th zero of Bi'(x)
!                XC(m) --- Ai(a') or Bi(b')
!                XD(m) --- Ai'(a) or Bi'(b)
!                          ( m --- Serial number of zeros )
!       Example: NT=5

!       m         a            Ai'(a)         a'          Ai(a')
!      -----------------------------------------------------------
!       1    -2.33810741     .70121082   -1.01879297    .53565666
!       2    -4.08794944    -.80311137   -3.24819758   -.41901548
!       3    -5.52055983     .86520403   -4.82009921    .38040647
!       4    -6.78670809    -.91085074   -6.16330736   -.35790794
!       5    -7.94413359     .94733571   -7.37217726    .34230124

!       m         b            Bi'(b)         b'          Bi(b')
!      -----------------------------------------------------------
!       1    -1.17371322     .60195789   -2.29443968   -.45494438
!       2    -3.27109330    -.76031014   -4.07315509    .39652284
!       3    -4.83073784     .83699101   -5.51239573   -.36796916
!       4    -6.16985213    -.88947990   -6.78129445    .34949912
!       5    -7.37676208     .92998364   -7.94017869   -.33602624
!       ==========================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION xa(50),xb(50),xc(50),xd(50)
WRITE(*,35)
WRITE(*,40)
WRITE(*,*)'Please enter KF,NT '
!        READ(*,*)KF,NT
kf=1
nt=5
WRITE(*,30)kf,nt
IF (kf == 1) THEN
  WRITE(*,*)'  m        a             Ai''(A)        A''',  &
      '           Ai(a'')'
ELSE IF (kf == 2) THEN
  WRITE(*,*)'  m        b             Bi''(B)        B''',  &
      '           Bi(b'')'
END IF
WRITE(*,*)'---------------------------------',   &
    '---------------------------'
CALL airyzo(nt,kf,xa,xb,xc,xd)
DO  k=1,nt
  WRITE(*,20)k,xa(k),xd(k),xb(k),xc(k)
END DO
20      FORMAT(1X,i3,1X,3F14.8,f13.8)
30      FORMAT(1X,3HKF=,i2,',     ',3HNT=,i3)
35      FORMAT(10X,'KF=1 for Ai(x) and Ai''(X); KF=2 FOR BI(X)',  &
    ' and Bi''(X)')
40      FORMAT(10X,'NT is the number of the zeros')
END PROGRAM mairyzo

SUBROUTINE airyzo(nt,kf,xa,xb,xc,xd)

!       ========================================================
!       Purpose: Compute the first NT zeros of Airy functions
!                Ai(x) and Ai'(x), a and a', and the associated
!                values of Ai(a') and Ai'(a); and the first NT
!                zeros of Airy functions Bi(x) and Bi'(x), b and
!                b', and the associated values of Bi(b') and
!                Bi'(b)
!       Input :  NT    --- Total number of zeros
!                KF    --- Function code
!                          KF=1 for Ai(x) and Ai'(x)
!                          KF=2 for Bi(x) and Bi'(x)
!       Output:  XA(m) --- a, the m-th zero of Ai(x) or
!                          b, the m-th zero of Bi(x)
!                XB(m) --- a', the m-th zero of Ai'(x) or
!                          b', the m-th zero of Bi'(x)
!                XC(m) --- Ai(a') or Bi(b')
!                XD(m) --- Ai'(a) or Bi'(b)
!                          ( m --- Serial number of zeros )
!       Routine called: AIRYB for computing Airy functions and
!                       their derivatives
!       =======================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
INTEGER, INTENT(IN)                      :: nt
INTEGER, INTENT(IN)                      :: kf
DOUBLE PRECISION, INTENT(OUT)            :: xa(nt)
DOUBLE PRECISION, INTENT(OUT)            :: xb(nt)
DOUBLE PRECISION, INTENT(OUT)            :: xc(nt)
DOUBLE PRECISION, INTENT(OUT)            :: xd(nt)

pi=3.141592653589793D0
DO  i=1,nt
  IF (kf == 1) THEN
    u=3.0*pi*(4.0*i-1)/8.0D0
    u1=1/(u*u)
    rt0=-(u*u)**(1.0/3.0)*((((-15.5902*u1+.929844)*u1  &
        -.138889)*u1+.10416667D0)*u1+1.0D0)
  ELSE IF (kf == 2) THEN
    IF (i == 1) THEN
      rt0=-1.17371
    ELSE
      u=3.0*pi*(4.0*i-3.0)/8.0
      u1=1.0D0/(u*u)
      rt0=-(u*u)**(1.0/3.0)*((((-15.5902*u1+.929844)*u1  &
          -.138889)*u1+.10416667)*u1+1.0)
    END IF
  END IF
  rt=1.0E300
  DO WHILE (DABS((rt-rt0)/rt) > 1.d-9)
    x=rt0
    CALL airyb(x,ai,bi,ad,bd)
    IF (kf == 1) rt=rt0-ai/ad
    IF (kf == 2) rt=rt0-bi/bd
    IF (DABS((rt-rt0)/rt) > 1.d-9) THEN
      rt0=rt
    END IF
  END DO
  xa(i)=rt
  IF (kf == 1) xd(i)=ad
  IF (kf == 2) xd(i)=bd
END DO
DO  i=1,nt
  IF (kf == 1) THEN
    IF (i == 1) THEN
      rt0=-1.01879
    ELSE
      u=3.0*pi*(4.0*i-3.0)/8.0
      u1=1/(u*u)
      rt0=-(u*u)**(1.0/3.0)*((((15.0168*u1-.873954)  &
          *u1+.121528)*u1-.145833D0)*u1+1.0D0)
    END IF
  ELSE IF (kf == 2) THEN
    IF (i == 1) THEN
      rt0=-2.29444
    ELSE
      u=3.0*pi*(4.0*i-1.0)/8.0
      u1=1.0/(u*u)
      rt0=-(u*u)**(1.0/3.0)*((((15.0168*u1-.873954)  &
          *u1+.121528)*u1-.145833)*u1+1.0)
    END IF
  END IF
  rt=1.0E300
  DO WHILE (DABS((rt-rt0)/rt) > 1.0D-9)
    x=rt0
    CALL airyb(x,ai,bi,ad,bd)
    IF (kf == 1) rt=rt0-ad/(ai*x)
    IF (kf == 2) rt=rt0-bd/(bi*x)
    IF (DABS((rt-rt0)/rt) > 1.0D-9) THEN
      rt0=rt
    END IF
  END DO
  xb(i)=rt
  IF (kf == 1) xc(i)=ai
  IF (kf == 2) xc(i)=bi
END DO
RETURN
END SUBROUTINE airyzo

SUBROUTINE airyb(x,ai,bi,ad,bd)

!       =======================================================
!       Purpose: Compute Airy functions and their derivatives
!       Input:   x  --- Argument of Airy function
!       Output:  AI --- Ai(x)
!                BI --- Bi(x)
!                AD --- Ai'(x)
!                BD --- Bi'(x)
!       =======================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: ai
DOUBLE PRECISION, INTENT(OUT)            :: bi
DOUBLE PRECISION, INTENT(OUT)            :: ad
DOUBLE PRECISION, INTENT(OUT)            :: bd
DIMENSION ck(41),dk(41)

eps=1.0D-15
pi=3.141592653589793D0
c1=0.355028053887817D0
c2=0.258819403792807D0
sr3=1.732050807568877D0
xa=DABS(x)
xq=DSQRT(xa)
IF (x > 0.0D0) xm=5.0
IF (x <= 0.0D0) xm=8.0
IF (x == 0.0D0) THEN
  ai=c1
  bi=sr3*c1
  ad=-c2
  bd=sr3*c2
  RETURN
END IF
IF (xa <= xm) THEN
  fx=1.0D0
  r=1.0D0
  DO  k=1,40
    r=r*x/(3.0D0*k)*x/(3.0D0*k-1.0D0)*x
    fx=fx+r
    IF (DABS(r/fx) < eps) EXIT
  END DO
  15         gx=x
  r=x
  DO  k=1,40
    r=r*x/(3.0D0*k)*x/(3.0D0*k+1.0D0)*x
    gx=gx+r
    IF (DABS(r/gx) < eps) EXIT
  END DO
  25         ai=c1*fx-c2*gx
  bi=sr3*(c1*fx+c2*gx)
  df=.5D0*x*x
  r=df
  DO  k=1,40
    r=r*x/(3.0D0*k)*x/(3.0D0*k+2.0D0)*x
    df=df+r
    IF (DABS(r/df) < eps) EXIT
  END DO
  35         dg=1.0D0
  r=1.0D0
  DO  k=1,40
    r=r*x/(3.0D0*k)*x/(3.0D0*k-2.0D0)*x
    dg=dg+r
    IF (DABS(r/dg) < eps) EXIT
  END DO
  45         ad=c1*df-c2*dg
  bd=sr3*(c1*df+c2*dg)
ELSE
  xe=xa*xq/1.5D0
  xr1=1.0D0/xe
  xar=1.0D0/xq
  xf=DSQRT(xar)
  rp=.5641895835477563D0
  r=1.0D0
  DO  k=1,40
    r=r*(6.0D0*k-1.0D0)/216.0D0*(6.0D0*k-3.0D0)  &
        /k*(6.0D0*k-5.0D0)/(2.0D0*k-1.0D0)
    ck(k)=r
    dk(k)=-(6.0D0*k+1.0D0)/(6.0D0*k-1.0D0)*ck(k)
  END DO
  km=INT(24.5-xa)
  IF (xa < 6.0) km=14
  IF (xa > 15.0) km=10
  IF (x > 0.0D0) THEN
    sai=1.0D0
    sad=1.0D0
    r=1.0D0
    DO  k=1,km
      r=-r*xr1
      sai=sai+ck(k)*r
      sad=sad+dk(k)*r
    END DO
    sbi=1.0D0
    sbd=1.0D0
    r=1.0D0
    DO  k=1,km
      r=r*xr1
      sbi=sbi+ck(k)*r
      sbd=sbd+dk(k)*r
    END DO
    xp1=DEXP(-xe)
    ai=.5D0*rp*xf*xp1*sai
    bi=rp*xf/xp1*sbi
    ad=-.5D0*rp/xf*xp1*sad
    bd=rp/xf/xp1*sbd
  ELSE
    xcs=DCOS(xe+pi/4.0D0)
    xss=DSIN(xe+pi/4.0D0)
    ssa=1.0D0
    sda=1.0D0
    r=1.0D0
    xr2=1.0D0/(xe*xe)
    DO  k=1,km
      r=-r*xr2
      ssa=ssa+ck(2*k)*r
      sda=sda+dk(2*k)*r
    END DO
    ssb=ck(1)*xr1
    sdb=dk(1)*xr1
    r=xr1
    DO  k=1,km
      r=-r*xr2
      ssb=ssb+ck(2*k+1)*r
      sdb=sdb+dk(2*k+1)*r
    END DO
    ai=rp*xf*(xss*ssa-xcs*ssb)
    bi=rp*xf*(xcs*ssa+xss*ssb)
    ad=-rp/xf*(xcs*sda+xss*sdb)
    bd=rp/xf*(xss*sda-xcs*sdb)
  END IF
END IF
RETURN
END SUBROUTINE airyb