C==============================================================================
C
C     LIBRARY ROUTINES FOR SPECTRAL METHODS
C
C     March 1989
C
C     For questions, comments or suggestions, please contact:
C
C     Einar Malvin Ronquist
C     Room 3-243
C     Department of Mechanical Engineering
C     Massachusetts Institute of Technology
C     77 Massachusetts Avenue
C     Cambridge, MA 0299
C     U.S.A.
C
C------------------------------------------------------------------------------
C
C     ABBRIVIATIONS:
C
C     M   - Set of mesh points
C     Z   - Set of collocation/quadrature points
C     W   - Set of quadrature weights
C     H   - Lagrangian interpolant
C     D   - Derivative operator
C     I   - Interpolation operator
C     GL  - Gauss Legendre
C     GLL - Gauss-Lobatto Legendre
C     GJ  - Gauss Jacobi
C     GLJ - Gauss-Lobatto Jacobi
C
C
C     MAIN ROUTINES:
C
C     Points and weights:
C
C     ZWGL      Compute Gauss Legendre points and weights
C     ZWGLL     Compute Gauss-Lobatto Legendre points and weights
C     ZWGJ      Compute Gauss Jacobi points and weights (general)
C     ZWGLJ     Compute Gauss-Lobatto Jacobi points and weights (general)
C
C     Lagrangian interpolants:
C
C     HGL       Compute Gauss Legendre Lagrangian interpolant
C     HGLL      Compute Gauss-Lobatto Legendre Lagrangian interpolant
C     HGJ       Compute Gauss Jacobi Lagrangian interpolant (general)
C     HGLJ      Compute Gauss-Lobatto Jacobi Lagrangian interpolant (general)
C
C     Derivative operators:
C
C     DGLL      Compute Gauss-Lobatto Legendre derivative matrix
C     DGLLGL    Compute derivative matrix for a staggered mesh (GLL->GL)
C     DGJ       Compute Gauss Jacobi derivative matrix (general)
C     DGLJ      Compute Gauss-Lobatto Jacobi derivative matrix (general)
C     DGLJGJ    Compute derivative matrix for a staggered mesh (GLJ->GJ) (general)
C
C     Interpolation operators:
C
C     IGLM      Compute interpolation operator GL  -> M
C     IGLLM     Compute interpolation operator GLL -> M
C     IGJM      Compute interpolation operator GJ  -> M  (general)
C     IGLJM     Compute interpolation operator GLJ -> M  (general)
C
C     Other:
C
C     PNLEG     Compute Legendre polynomial of degree N
C     PNDLEG    Compute derivative of Legendre polynomial of degree N
C
C     Comments:
C
C     Note that many of the above routines exist in both single and
C     double precision. If the name of the single precision routine is
C     SUB, the double precision version is called SUBD. In most cases
C     all the "low-level" arithmetic is done in double precision, even
C     for the single precsion versions.
C
C     Useful references:
C
C [1] Gabor Szego: Orthogonal Polynomials, American Mathematical Society,
C     Providence, Rhode Island, 1939.
C [2] Abramowitz & Stegun: Handbook of Mathematical Functions,
C     Dover, New York, 1972.
C [3] Canuto, Hussaini, Quarteroni & Zang: Spectral Methods in Fluid
C     Dynamics, Springer-Verlag, 1988.
C
C
C==============================================================================
C
C--------------------------------------------------------------------
      SUBROUTINE ZWGL (Z,W,NP)
C--------------------------------------------------------------------
C
C     Generate NP Gauss Legendre points (Z) and weights (W)
C     associated with Jacobi polynomial P(N)(alpha=0,beta=0).
C     The polynomial degree N=NP-1.
C     Z and W are in single precision, but all the arithmetic
C     operations are done in double precision.
C
C--------------------------------------------------------------------
      REAL Z(1),W(1)
      ALPHA = 0.
      BETA  = 0.
      CALL ZWGJ (Z,W,NP,ALPHA,BETA)
      RETURN
      END
C
      SUBROUTINE ZWGLL (Z,W,NP)
C--------------------------------------------------------------------
C
C     Generate NP Gauss-Lobatto Legendre points (Z) and weights (W)
C     associated with Jacobi polynomial P(N)(alpha=0,beta=0).
C     The polynomial degree N=NP-1.
C     Z and W are in single precision, but all the arithmetic
C     operations are done in double precision.
C
C--------------------------------------------------------------------
      REAL Z(1),W(1)
      ALPHA = 0.
      BETA  = 0.
      CALL ZWGLJ (Z,W,NP,ALPHA,BETA)
      RETURN
      END
C
      SUBROUTINE ZWGJ (Z,W,NP,ALPHA,BETA)
C--------------------------------------------------------------------
C
C     Generate NP GAUSS JACOBI points (Z) and weights (W)
C     associated with Jacobi polynomial P(N)(alpha>-1,beta>-1).
C     The polynomial degree N=NP-1.
C     Single precision version.
C
C--------------------------------------------------------------------
      PARAMETER (NMAX=84)
      PARAMETER (NZD = NMAX)
      REAL*8  ZD(NZD),WD(NZD)
      REAL Z(1),W(1),ALPHA,BETA
C
      NPMAX = NZD
      IF (NP.GT.NPMAX) THEN
         WRITE (6,*) 'Too large polynomial degree in ZWGJ'
         WRITE (6,*) 'Maximum polynomial degree is',NMAX
         WRITE (6,*) 'Here NP=',NP
         call exitt(1)
      ENDIF
      ALPHAD = ALPHA
      BETAD  = BETA
      CALL ZWGJD (ZD,WD,NP,ALPHAD,BETAD)
      DO 100 I=1,NP
         Z(I) = ZD(I)
         W(I) = WD(I)
 100  CONTINUE
      RETURN
      END
C
      SUBROUTINE ZWGJD (Z,W,NP,ALPHA,BETA)
C--------------------------------------------------------------------
C
C     Generate NP GAUSS JACOBI points (Z) and weights (W)
C     associated with Jacobi polynomial P(N)(alpha>-1,beta>-1).
C     The polynomial degree N=NP-1.
C     Double precision version.
C
C--------------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  Z(1),W(1),ALPHA,BETA
C
      N     = NP-1
      DN    = ((N))
      ONE   = 1.
      TWO   = 2.
      APB   = ALPHA+BETA
C
      IF (NP.LE.0) THEN
         WRITE (6,*) 'ZWGJD: Minimum number of Gauss points is 1',np
         call exitt(1)
      ENDIF
      IF ((ALPHA.LE.-ONE).OR.(BETA.LE.-ONE)) THEN
         WRITE (6,*) 'ZWGJD: Alpha and Beta must be greater than -1'
         call exitt(1)
      ENDIF
C
      IF (NP.EQ.1) THEN
         Z(1) = (BETA-ALPHA)/(APB+TWO)
         W(1) = GAMMAF(ALPHA+ONE)*GAMMAF(BETA+ONE)/GAMMAF(APB+TWO)
     $          * TWO**(APB+ONE)
         RETURN
      ENDIF
C
      CALL JACG (Z,NP,ALPHA,BETA)
C
      NP1   = N+1
      NP2   = N+2
      DNP1  = ((NP1))
      DNP2  = ((NP2))
      FAC1  = DNP1+ALPHA+BETA+ONE
      FAC2  = FAC1+DNP1
      FAC3  = FAC2+ONE
      FNORM = PNORMJ(NP1,ALPHA,BETA)
      RCOEF = (FNORM*FAC2*FAC3)/(TWO*FAC1*DNP2)
      DO 100 I=1,NP
         CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,NP2,ALPHA,BETA,Z(I))
         W(I) = -RCOEF/(P*PDM1)
 100  CONTINUE
      RETURN
      END
C
      SUBROUTINE ZWGLJ (Z,W,NP,ALPHA,BETA)
C--------------------------------------------------------------------
C
C     Generate NP GAUSS LOBATTO JACOBI points (Z) and weights (W)
C     associated with Jacobi polynomial P(N)(alpha>-1,beta>-1).
C     The polynomial degree N=NP-1.
C     Single precision version.
C
C--------------------------------------------------------------------
      PARAMETER (NMAX=84)
      PARAMETER (NZD = NMAX)
      REAL*8  ZD(NZD),WD(NZD)
      REAL Z(1),W(1),ALPHA,BETA
C
      NPMAX = NZD
      IF (NP.GT.NPMAX) THEN
         WRITE (6,*) 'Too large polynomial degree in ZWGLJ'
         WRITE (6,*) 'Maximum polynomial degree is',NMAX
         WRITE (6,*) 'Here NP=',NP
         call exitt(1)
      ENDIF
      ALPHAD = ALPHA
      BETAD  = BETA
      CALL ZWGLJD (ZD,WD,NP,ALPHAD,BETAD)
      DO 100 I=1,NP
         Z(I) = ZD(I)
         W(I) = WD(I)
 100  CONTINUE
      RETURN
      END
C
      SUBROUTINE ZWGLJD (Z,W,NP,ALPHA,BETA)
C--------------------------------------------------------------------
C
C     Generate NP GAUSS LOBATTO JACOBI points (Z) and weights (W)
C     associated with Jacobi polynomial P(N)(alpha>-1,beta>-1).
C     The polynomial degree N=NP-1.
C     Double precision version.
C
C--------------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  Z(NP),W(NP),ALPHA,BETA
C
      N     = NP-1
      NM1   = N-1
      ONE   = 1.
      TWO   = 2.
C
      IF (NP.LE.1) THEN
       WRITE (6,*) 'ZWGLJD: Minimum number of Gauss-Lobatto points is 2'
       WRITE (6,*) 'ZWGLJD: alpha,beta:',alpha,beta,np
       call exitt(1)
      ENDIF
      IF ((ALPHA.LE.-ONE).OR.(BETA.LE.-ONE)) THEN
         WRITE (6,*) 'ZWGLJD: Alpha and Beta must be greater than -1'
         call exitt(1)
      ENDIF
C
      IF (NM1.GT.0) THEN
         ALPG  = ALPHA+ONE
         BETG  = BETA+ONE
         CALL ZWGJD (Z(2),W(2),NM1,ALPG,BETG)
      ENDIF
      Z(1)  = -ONE
      Z(NP) =  ONE
      DO 100  I=2,NP-1
         W(I) = W(I)/(ONE-Z(I)**2)
 100  CONTINUE
      CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,N,ALPHA,BETA,Z(1))
      W(1)  = ENDW1 (N,ALPHA,BETA)/(TWO*PD)
      CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,N,ALPHA,BETA,Z(NP))
      W(NP) = ENDW2 (N,ALPHA,BETA)/(TWO*PD)
C
      RETURN
      END
C
      REAL*8  FUNCTION ENDW1 (N,ALPHA,BETA)
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  ALPHA,BETA
      ZERO  = 0.
      ONE   = 1.
      TWO   = 2.
      THREE = 3.
      FOUR  = 4.
      APB   = ALPHA+BETA
      IF (N.EQ.0) THEN
         ENDW1 = ZERO
         RETURN
      ENDIF
      F1   = GAMMAF(ALPHA+TWO)*GAMMAF(BETA+ONE)/GAMMAF(APB+THREE)
      F1   = F1*(APB+TWO)*TWO**(APB+TWO)/TWO
      IF (N.EQ.1) THEN
         ENDW1 = F1
         RETURN
      ENDIF
      FINT1 = GAMMAF(ALPHA+TWO)*GAMMAF(BETA+ONE)/GAMMAF(APB+THREE)
      FINT1 = FINT1*TWO**(APB+TWO)
      FINT2 = GAMMAF(ALPHA+TWO)*GAMMAF(BETA+TWO)/GAMMAF(APB+FOUR)
      FINT2 = FINT2*TWO**(APB+THREE)
      F2    = (-TWO*(BETA+TWO)*FINT1 + (APB+FOUR)*FINT2)
     $        * (APB+THREE)/FOUR
      IF (N.EQ.2) THEN
         ENDW1 = F2
         RETURN
      ENDIF
      DO 100 I=3,N
         DI   = ((I-1))
         ABN  = ALPHA+BETA+DI
         ABNN = ABN+DI
         A1   = -(TWO*(DI+ALPHA)*(DI+BETA))/(ABN*ABNN*(ABNN+ONE))
         A2   =  (TWO*(ALPHA-BETA))/(ABNN*(ABNN+TWO))
         A3   =  (TWO*(ABN+ONE))/((ABNN+TWO)*(ABNN+ONE))
         F3   =  -(A2*F2+A1*F1)/A3
         F1   = F2
         F2   = F3
 100  CONTINUE
      ENDW1  = F3
      RETURN
      END
C
      REAL*8  FUNCTION ENDW2 (N,ALPHA,BETA)
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  ALPHA,BETA
      ZERO  = 0.
      ONE   = 1.
      TWO   = 2.
      THREE = 3.
      FOUR  = 4.
      APB   = ALPHA+BETA
      IF (N.EQ.0) THEN
         ENDW2 = ZERO
         RETURN
      ENDIF
      F1   = GAMMAF(ALPHA+ONE)*GAMMAF(BETA+TWO)/GAMMAF(APB+THREE)
      F1   = F1*(APB+TWO)*TWO**(APB+TWO)/TWO
      IF (N.EQ.1) THEN
         ENDW2 = F1
         RETURN
      ENDIF
      FINT1 = GAMMAF(ALPHA+ONE)*GAMMAF(BETA+TWO)/GAMMAF(APB+THREE)
      FINT1 = FINT1*TWO**(APB+TWO)
      FINT2 = GAMMAF(ALPHA+TWO)*GAMMAF(BETA+TWO)/GAMMAF(APB+FOUR)
      FINT2 = FINT2*TWO**(APB+THREE)
      F2    = (TWO*(ALPHA+TWO)*FINT1 - (APB+FOUR)*FINT2)
     $        * (APB+THREE)/FOUR
      IF (N.EQ.2) THEN
         ENDW2 = F2
         RETURN
      ENDIF
      DO 100 I=3,N
         DI   = ((I-1))
         ABN  = ALPHA+BETA+DI
         ABNN = ABN+DI
         A1   =  -(TWO*(DI+ALPHA)*(DI+BETA))/(ABN*ABNN*(ABNN+ONE))
         A2   =  (TWO*(ALPHA-BETA))/(ABNN*(ABNN+TWO))
         A3   =  (TWO*(ABN+ONE))/((ABNN+TWO)*(ABNN+ONE))
         F3   =  -(A2*F2+A1*F1)/A3
         F1   = F2
         F2   = F3
 100  CONTINUE
      ENDW2  = F3
      RETURN
      END
C
      REAL*8  FUNCTION GAMMAF (X)
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  X
      ZERO = 0.0
      HALF = 0.5
      ONE  = 1.0
      TWO  = 2.0
      FOUR = 4.0
      PI   = FOUR*ATAN(ONE)
      GAMMAF = ONE
      IF (X.EQ.-HALF) GAMMAF = -TWO*SQRT(PI)
      IF (X.EQ. HALF) GAMMAF =  SQRT(PI)
      IF (X.EQ. ONE ) GAMMAF =  ONE
      IF (X.EQ. TWO ) GAMMAF =  ONE
      IF (X.EQ. 1.5  ) GAMMAF =  SQRT(PI)/2.
      IF (X.EQ. 2.5) GAMMAF =  1.5*SQRT(PI)/2.
      IF (X.EQ. 3.5) GAMMAF =  0.5*(2.5*(1.5*SQRT(PI)))
      IF (X.EQ. 3. ) GAMMAF =  2.
      IF (X.EQ. 4. ) GAMMAF = 6.
      IF (X.EQ. 5. ) GAMMAF = 24.
      IF (X.EQ. 6. ) GAMMAF = 120.
      RETURN
      END
C
      REAL*8  FUNCTION PNORMJ (N,ALPHA,BETA)
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  ALPHA,BETA
      ONE   = 1.
      TWO   = 2.
      DN    = ((N))
      CONST = ALPHA+BETA+ONE
      IF (N.LE.1) THEN
         PROD   = GAMMAF(DN+ALPHA)*GAMMAF(DN+BETA)
         PROD   = PROD/(GAMMAF(DN)*GAMMAF(DN+ALPHA+BETA))
         PNORMJ = PROD * TWO**CONST/(TWO*DN+CONST)
         RETURN
      ENDIF
      PROD  = GAMMAF(ALPHA+ONE)*GAMMAF(BETA+ONE)
      PROD  = PROD/(TWO*(ONE+CONST)*GAMMAF(CONST+ONE))
      PROD  = PROD*(ONE+ALPHA)*(TWO+ALPHA)
      PROD  = PROD*(ONE+BETA)*(TWO+BETA)
      DO 100 I=3,N
         DINDX = ((I))
         FRAC  = (DINDX+ALPHA)*(DINDX+BETA)/(DINDX*(DINDX+ALPHA+BETA))
         PROD  = PROD*FRAC
 100  CONTINUE
      PNORMJ = PROD * TWO**CONST/(TWO*DN+CONST)
      RETURN
      END
C
      SUBROUTINE JACG (XJAC,NP,ALPHA,BETA)
C--------------------------------------------------------------------
C
C     Compute NP Gauss points XJAC, which are the zeros of the
C     Jacobi polynomial J(NP) with parameters ALPHA and BETA.
C     ALPHA and BETA determines the specific type of Gauss points.
C     Examples:
C     ALPHA = BETA =  0.0  ->  Legendre points
C     ALPHA = BETA = -0.5  ->  Chebyshev points
C
C--------------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  XJAC(1)
      DATA KSTOP /10/
      DATA EPS/1.0e-12/
      N   = NP-1
      one = 1.
      DTH = 4.*ATAN(one)/(2.*((N))+2.)
      DO 40 J=1,NP
         IF (J.EQ.1) THEN
            X = COS((2.*(((J))-1.)+1.)*DTH)
         ELSE
            X1 = COS((2.*(((J))-1.)+1.)*DTH)
            X2 = XLAST
            X  = (X1+X2)/2.
         ENDIF
         DO 30 K=1,KSTOP
            CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,NP,ALPHA,BETA,X)
            RECSUM = 0.
            JM = J-1
            DO 29 I=1,JM
               RECSUM = RECSUM+1./(X-XJAC(NP-I+1))
 29         CONTINUE
            DELX = -P/(PD-RECSUM*P)
            X    = X+DELX
            IF (ABS(DELX) .LT. EPS) GOTO 31
 30      CONTINUE
 31      CONTINUE
         XJAC(NP-J+1) = X
         XLAST        = X
 40   CONTINUE
      DO 200 I=1,NP
         XMIN = 2.
         DO 100 J=I,NP
            IF (XJAC(J).LT.XMIN) THEN
               XMIN = XJAC(J)
               JMIN = J
            ENDIF
 100     CONTINUE
         IF (JMIN.NE.I) THEN
            SWAP = XJAC(I)
            XJAC(I) = XJAC(JMIN)
            XJAC(JMIN) = SWAP
         ENDIF
 200  CONTINUE
      RETURN
      END
C
      SUBROUTINE JACOBF (POLY,PDER,POLYM1,PDERM1,POLYM2,PDERM2,
     $                   N,ALP,BET,X)
C--------------------------------------------------------------------
C
C     Computes the Jacobi polynomial (POLY) and its derivative (PDER)
C     of degree N at X.
C
C--------------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      APB  = ALP+BET
      POLY = 1.
      PDER = 0.
      IF (N .EQ. 0) RETURN
      POLYL = POLY
      PDERL = PDER
      POLY  = (ALP-BET+(APB+2.)*X)/2.
      PDER  = (APB+2.)/2.
      IF (N .EQ. 1) RETURN
      DO 20 K=2,N
         DK = ((K))
         A1 = 2.*DK*(DK+APB)*(2.*DK+APB-2.)
         A2 = (2.*DK+APB-1.)*(ALP**2-BET**2)
         B3 = (2.*DK+APB-2.)
         A3 = B3*(B3+1.)*(B3+2.)
         A4 = 2.*(DK+ALP-1.)*(DK+BET-1.)*(2.*DK+APB)
         POLYN  = ((A2+A3*X)*POLY-A4*POLYL)/A1
         PDERN  = ((A2+A3*X)*PDER-A4*PDERL+A3*POLY)/A1
         PSAVE  = POLYL
         PDSAVE = PDERL
         POLYL  = POLY
         POLY   = POLYN
         PDERL  = PDER
         PDER   = PDERN
 20   CONTINUE
      POLYM1 = POLYL
      PDERM1 = PDERL
      POLYM2 = PSAVE
      PDERM2 = PDSAVE
      RETURN
      END
C
      REAL FUNCTION HGJ (II,Z,ZGJ,NP,ALPHA,BETA)
C---------------------------------------------------------------------
C
C     Compute the value of the Lagrangian interpolant HGJ through
C     the NP Gauss Jacobi points ZGJ at the point Z.
C     Single precision version.
C
C---------------------------------------------------------------------
      PARAMETER (NMAX=84)
      PARAMETER (NZD = NMAX)
      REAL*8  ZD,ZGJD(NZD)
      REAL Z,ZGJ(1),ALPHA,BETA
      NPMAX = NZD
      IF (NP.GT.NPMAX) THEN
         WRITE (6,*) 'Too large polynomial degree in HGJ'
         WRITE (6,*) 'Maximum polynomial degree is',NMAX
         WRITE (6,*) 'Here NP=',NP
         call exitt(1)
      ENDIF
      ZD = Z
      DO 100 I=1,NP
         ZGJD(I) = ZGJ(I)
 100  CONTINUE
      ALPHAD = ALPHA
      BETAD  = BETA
      HGJ    = HGJD (II,ZD,ZGJD,NP,ALPHAD,BETAD)
      RETURN
      END
C
      REAL*8  FUNCTION HGJD (II,Z,ZGJ,NP,ALPHA,BETA)
C---------------------------------------------------------------------
C
C     Compute the value of the Lagrangian interpolant HGJD through
C     the NZ Gauss-Lobatto Jacobi points ZGJ at the point Z.
C     Double precision version.
C
C---------------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  Z,ZGJ(1),ALPHA,BETA
      EPS = 1.e-5
      ONE = 1.
      ZI  = ZGJ(II)
      DZ  = Z-ZI
      IF (ABS(DZ).LT.EPS) THEN
         HGJD = ONE
         RETURN
      ENDIF
      CALL JACOBF (PZI,PDZI,PM1,PDM1,PM2,PDM2,NP,ALPHA,BETA,ZI)
      CALL JACOBF (PZ,PDZ,PM1,PDM1,PM2,PDM2,NP,ALPHA,BETA,Z)
      HGJD  = PZ/(PDZI*(Z-ZI))
      RETURN
      END
C
      REAL FUNCTION HGLJ (II,Z,ZGLJ,NP,ALPHA,BETA)
C---------------------------------------------------------------------
C
C     Compute the value of the Lagrangian interpolant HGLJ through
C     the NZ Gauss-Lobatto Jacobi points ZGLJ at the point Z.
C     Single precision version.
C
C---------------------------------------------------------------------
      PARAMETER (NMAX=84)
      PARAMETER (NZD = NMAX)
      REAL*8  ZD,ZGLJD(NZD)
      REAL Z,ZGLJ(1),ALPHA,BETA
      NPMAX = NZD
      IF (NP.GT.NPMAX) THEN
         WRITE (6,*) 'Too large polynomial degree in HGLJ'
         WRITE (6,*) 'Maximum polynomial degree is',NMAX
         WRITE (6,*) 'Here NP=',NP
         call exitt(1)
      ENDIF
      ZD = Z
      DO 100 I=1,NP
         ZGLJD(I) = ZGLJ(I)
 100  CONTINUE
      ALPHAD = ALPHA
      BETAD  = BETA
      HGLJ   = HGLJD (II,ZD,ZGLJD,NP,ALPHAD,BETAD)
      RETURN
      END
C
      REAL*8  FUNCTION HGLJD (I,Z,ZGLJ,NP,ALPHA,BETA)
C---------------------------------------------------------------------
C
C     Compute the value of the Lagrangian interpolant HGLJD through
C     the NZ Gauss-Lobatto Jacobi points ZJACL at the point Z.
C     Double precision version.
C
C---------------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  Z,ZGLJ(1),ALPHA,BETA
      EPS = 1.e-5
      ONE = 1.
      ZI  = ZGLJ(I)
      DZ  = Z-ZI
      IF (ABS(DZ).LT.EPS) THEN
         HGLJD = ONE
         RETURN
      ENDIF
      N      = NP-1
      DN     = ((N))
      EIGVAL = -DN*(DN+ALPHA+BETA+ONE)
      CALL JACOBF (PI,PDI,PM1,PDM1,PM2,PDM2,N,ALPHA,BETA,ZI)
      CONST  = EIGVAL*PI+ALPHA*(ONE+ZI)*PDI-BETA*(ONE-ZI)*PDI
      CALL JACOBF (P,PD,PM1,PDM1,PM2,PDM2,N,ALPHA,BETA,Z)
      HGLJD  = (ONE-Z**2)*PD/(CONST*(Z-ZI))
      RETURN
      END
C
      SUBROUTINE DGJ (D,DT,Z,NZ,NZD,ALPHA,BETA)
C-----------------------------------------------------------------
C
C     Compute the derivative matrix D and its transpose DT
C     associated with the Nth order Lagrangian interpolants
C     through the NZ Gauss Jacobi points Z.
C     Note: D and DT are square matrices.
C     Single precision version.
C
C-----------------------------------------------------------------
      PARAMETER (NMAX=84)
      PARAMETER (NZDD = NMAX)
      REAL*8  DD(NZDD,NZDD),DTD(NZDD,NZDD),ZD(NZDD)
      REAL D(NZD,NZD),DT(NZD,NZD),Z(1),ALPHA,BETA
C
      IF (NZ.LE.0) THEN
         WRITE (6,*) 'DGJ: Minimum number of Gauss points is 1'
         call exitt(1)
      ENDIF
      IF (NZ .GT. NMAX) THEN
         WRITE (6,*) 'Too large polynomial degree in DGJ'
         WRITE (6,*) 'Maximum polynomial degree is',NMAX
         WRITE (6,*) 'Here Nz=',Nz
         call exitt(1)
      ENDIF
      IF ((ALPHA.LE.-1.).OR.(BETA.LE.-1.)) THEN
         WRITE (6,*) 'DGJ: Alpha and Beta must be greater than -1'
         call exitt(1)
      ENDIF
      ALPHAD = ALPHA
      BETAD  = BETA
      DO 100 I=1,NZ
         ZD(I) = Z(I)
 100  CONTINUE
      CALL DGJD (DD,DTD,ZD,NZ,NZDD,ALPHAD,BETAD)
      DO 200 I=1,NZ
      DO 200 J=1,NZ
         D(I,J)  = DD(I,J)
         DT(I,J) = DTD(I,J)
 200  CONTINUE
      RETURN
      END
C
      SUBROUTINE DGJD (D,DT,Z,NZ,NZD,ALPHA,BETA)
C-----------------------------------------------------------------
C
C     Compute the derivative matrix D and its transpose DT
C     associated with the Nth order Lagrangian interpolants
C     through the NZ Gauss Jacobi points Z.
C     Note: D and DT are square matrices.
C     Double precision version.
C
C-----------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  D(NZD,NZD),DT(NZD,NZD),Z(1),ALPHA,BETA
      N    = NZ-1
      DN   = ((N))
      ONE  = 1.
      TWO  = 2.
C
      IF (NZ.LE.1) THEN
       WRITE (6,*) 'DGJD: Minimum number of Gauss-Lobatto points is 2'
       call exitt(1)
      ENDIF
      IF ((ALPHA.LE.-ONE).OR.(BETA.LE.-ONE)) THEN
         WRITE (6,*) 'DGJD: Alpha and Beta must be greater than -1'
         call exitt(1)
      ENDIF
C
      DO 200 I=1,NZ
      DO 200 J=1,NZ
         CALL JACOBF (PI,PDI,PM1,PDM1,PM2,PDM2,NZ,ALPHA,BETA,Z(I))
         CALL JACOBF (PJ,PDJ,PM1,PDM1,PM2,PDM2,NZ,ALPHA,BETA,Z(J))
         IF (I.NE.J) D(I,J) = PDI/(PDJ*(Z(I)-Z(J)))
         IF (I.EQ.J) D(I,J) = ((ALPHA+BETA+TWO)*Z(I)+ALPHA-BETA)/
     $                        (TWO*(ONE-Z(I)**2))
         DT(J,I) = D(I,J)
 200  CONTINUE
      RETURN
      END
C
      SUBROUTINE DGLJ (D,DT,Z,NZ,NZD,ALPHA,BETA)
C-----------------------------------------------------------------
C
C     Compute the derivative matrix D and its transpose DT
C     associated with the Nth order Lagrangian interpolants
C     through the NZ Gauss-Lobatto Jacobi points Z.
C     Note: D and DT are square matrices.
C     Single precision version.
C
C-----------------------------------------------------------------
      PARAMETER (NMAX=84)
      PARAMETER (NZDD = NMAX)
      REAL*8  DD(NZDD,NZDD),DTD(NZDD,NZDD),ZD(NZDD)
      REAL D(NZD,NZD),DT(NZD,NZD),Z(1),ALPHA,BETA
C
      IF (NZ.LE.1) THEN
       WRITE (6,*) 'DGLJ: Minimum number of Gauss-Lobatto points is 2'
       call exitt(1)
      ENDIF
      IF (NZ .GT. NMAX) THEN
         WRITE (6,*) 'Too large polynomial degree in DGLJ'
         WRITE (6,*) 'Maximum polynomial degree is',NMAX
         WRITE (6,*) 'Here NZ=',NZ
         call exitt(1)
      ENDIF
      IF ((ALPHA.LE.-1.).OR.(BETA.LE.-1.)) THEN
         WRITE (6,*) 'DGLJ: Alpha and Beta must be greater than -1'
         call exitt(1)
      ENDIF
      ALPHAD = ALPHA
      BETAD  = BETA
      DO 100 I=1,NZ
         ZD(I) = Z(I)
 100  CONTINUE
      CALL DGLJD (DD,DTD,ZD,NZ,NZDD,ALPHAD,BETAD)
      DO 200 I=1,NZ
      DO 200 J=1,NZ
         D(I,J)  = DD(I,J)
         DT(I,J) = DTD(I,J)
 200  CONTINUE
      RETURN
      END
C
      SUBROUTINE DGLJD (D,DT,Z,NZ,NZD,ALPHA,BETA)
C-----------------------------------------------------------------
C
C     Compute the derivative matrix D and its transpose DT
C     associated with the Nth order Lagrangian interpolants
C     through the NZ Gauss-Lobatto Jacobi points Z.
C     Note: D and DT are square matrices.
C     Double precision version.
C
C-----------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  D(NZD,NZD),DT(NZD,NZD),Z(1),ALPHA,BETA
      N    = NZ-1
      DN   = ((N))
      ONE  = 1.
      TWO  = 2.
      EIGVAL = -DN*(DN+ALPHA+BETA+ONE)
C
      IF (NZ.LE.1) THEN
       WRITE (6,*) 'DGLJD: Minimum number of Gauss-Lobatto points is 2'
       call exitt(1)
      ENDIF
      IF ((ALPHA.LE.-ONE).OR.(BETA.LE.-ONE)) THEN
         WRITE (6,*) 'DGLJD: Alpha and Beta must be greater than -1'
         call exitt(1)
      ENDIF
C
      DO 200 I=1,NZ
      DO 200 J=1,NZ
         CALL JACOBF (PI,PDI,PM1,PDM1,PM2,PDM2,N,ALPHA,BETA,Z(I))
         CALL JACOBF (PJ,PDJ,PM1,PDM1,PM2,PDM2,N,ALPHA,BETA,Z(J))
         CI = EIGVAL*PI-(BETA*(ONE-Z(I))-ALPHA*(ONE+Z(I)))*PDI
         CJ = EIGVAL*PJ-(BETA*(ONE-Z(J))-ALPHA*(ONE+Z(J)))*PDJ
         IF (I.NE.J) D(I,J) = CI/(CJ*(Z(I)-Z(J)))
         IF ((I.EQ.J).AND.(I.NE.1).AND.(I.NE.NZ))
     $   D(I,J) = (ALPHA*(ONE+Z(I))-BETA*(ONE-Z(I)))/
     $            (TWO*(ONE-Z(I)**2))
         IF ((I.EQ.J).AND.(I.EQ.1))
     $   D(I,J) =  (EIGVAL+ALPHA)/(TWO*(BETA+TWO))
         IF ((I.EQ.J).AND.(I.EQ.NZ))
     $   D(I,J) = -(EIGVAL+BETA)/(TWO*(ALPHA+TWO))
         DT(J,I) = D(I,J)
 200  CONTINUE
      RETURN
      END
C
      SUBROUTINE DGLL (D,DT,Z,NZ,NZD)
C-----------------------------------------------------------------
C
C     Compute the derivative matrix D and its transpose DT
C     associated with the Nth order Lagrangian interpolants
C     through the NZ Gauss-Lobatto Legendre points Z.
C     Note: D and DT are square matrices.
C
C-----------------------------------------------------------------
      PARAMETER (NMAX=84)
      REAL D(NZD,NZD),DT(NZD,NZD),Z(1)
      N  = NZ-1
      IF (NZ .GT. NMAX) THEN
         WRITE (6,*) 'Subroutine DGLL'
         WRITE (6,*) 'Maximum polynomial degree =',NMAX
         WRITE (6,*) 'Polynomial degree         =',NZ
      ENDIF
      IF (NZ .EQ. 1) THEN
         D(1,1) = 0.
         RETURN
      ENDIF
      FN = (N)
      d0 = FN*(FN+1.)/4.
      DO 200 I=1,NZ
      DO 200 J=1,NZ
         D(I,J) = 0.
         IF  (I.NE.J) D(I,J) = PNLEG(Z(I),N)/
     $                        (PNLEG(Z(J),N)*(Z(I)-Z(J)))
         IF ((I.EQ.J).AND.(I.EQ.1))  D(I,J) = -d0
         IF ((I.EQ.J).AND.(I.EQ.NZ)) D(I,J) =  d0
         DT(J,I) = D(I,J)
 200  CONTINUE
      RETURN
      END
C
      REAL FUNCTION HGLL (I,Z,ZGLL,NZ)
C---------------------------------------------------------------------
C
C     Compute the value of the Lagrangian interpolant L through
C     the NZ Gauss-Lobatto Legendre points ZGLL at the point Z.
C
C---------------------------------------------------------------------
      REAL ZGLL(1)
      EPS = 1.E-5
      DZ = Z - ZGLL(I)
      IF (ABS(DZ) .LT. EPS) THEN
         HGLL = 1.
         RETURN
      ENDIF
      N = NZ - 1
      ALFAN = (N)*((N)+1.)
      HGLL = - (1.-Z*Z)*PNDLEG(Z,N)/
     $         (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))
      RETURN
      END
C
      REAL FUNCTION HGL (I,Z,ZGL,NZ)
C---------------------------------------------------------------------
C
C     Compute the value of the Lagrangian interpolant HGL through
C     the NZ Gauss Legendre points ZGL at the point Z.
C
C---------------------------------------------------------------------
      REAL ZGL(1)
      EPS = 1.E-5
      DZ = Z - ZGL(I)
      IF (ABS(DZ) .LT. EPS) THEN
         HGL = 1.
         RETURN
      ENDIF
      N = NZ-1
      HGL = PNLEG(Z,NZ)/(PNDLEG(ZGL(I),NZ)*(Z-ZGL(I)))
      RETURN
      END
C
      REAL FUNCTION PNLEG (Z,N)
C---------------------------------------------------------------------
C
C     Compute the value of the Nth order Legendre polynomial at Z.
C     (Simpler than JACOBF)
C     Based on the recursion formula for the Legendre polynomials.
C
C---------------------------------------------------------------------
C
C     This next statement is to overcome the underflow bug in the i860.
C     It can be removed at a later date.  11 Aug 1990   pff.
C
      IF(ABS(Z) .LT. 1.0E-25) Z = 0.0
C
      P1   = 1.
      IF (N.EQ.0) THEN
         PNLEG = P1
         RETURN
      ENDIF
      P2   = Z
      P3   = P2
      DO 10 K = 1, N-1
         FK  = (K)
         P3  = ((2.*FK+1.)*Z*P2 - FK*P1)/(FK+1.)
         P1  = P2
         P2  = P3
 10   CONTINUE
      PNLEG = P3
      if (n.eq.0) pnleg = 1.
      RETURN
      END
C
      REAL FUNCTION PNDLEG (Z,N)
C----------------------------------------------------------------------
C
C     Compute the derivative of the Nth order Legendre polynomial at Z.
C     (Simpler than JACOBF)
C     Based on the recursion formula for the Legendre polynomials.
C
C----------------------------------------------------------------------
      P1   = 1.
      P2   = Z
      P1D  = 0.
      P2D  = 1.
      P3D  = 1.
      DO 10 K = 1, N-1
         FK  = (K)
         P3  = ((2.*FK+1.)*Z*P2 - FK*P1)/(FK+1.)
         P3D = ((2.*FK+1.)*P2 + (2.*FK+1.)*Z*P2D - FK*P1D)/(FK+1.)
         P1  = P2
         P2  = P3
         P1D = P2D
         P2D = P3D
 10   CONTINUE
      PNDLEG = P3D
      IF (N.eq.0) pndleg = 0.
      RETURN
      END
C
      SUBROUTINE DGLLGL (D,DT,ZM1,ZM2,IM12,NZM1,NZM2,ND1,ND2)
C-----------------------------------------------------------------------
C
C     Compute the (one-dimensional) derivative matrix D and its
C     transpose DT associated with taking the derivative of a variable
C     expanded on a Gauss-Lobatto Legendre mesh (M1), and evaluate its
C     derivative on a Guass Legendre mesh (M2).
C     Need the one-dimensional interpolation operator IM12
C     (see subroutine IGLLGL).
C     Note: D and DT are rectangular matrices.
C
C-----------------------------------------------------------------------
      REAL D(ND2,ND1), DT(ND1,ND2), ZM1(ND1), ZM2(ND2), IM12(ND2,ND1)
      IF (NZM1.EQ.1) THEN
        D (1,1) = 0.
        DT(1,1) = 0.
        RETURN
      ENDIF
      EPS = 1.E-6
      NM1 = NZM1-1
      DO 10 IP = 1, NZM2
         DO 10 JQ = 1, NZM1
            ZP = ZM2(IP)
            ZQ = ZM1(JQ)
            IF ((ABS(ZP) .LT. EPS).AND.(ABS(ZQ) .LT. EPS)) THEN
                D(IP,JQ) = 0.
            ELSE
                D(IP,JQ) = (PNLEG(ZP,NM1)/PNLEG(ZQ,NM1)
     $                     -IM12(IP,JQ))/(ZP-ZQ)
            ENDIF
            DT(JQ,IP) = D(IP,JQ)
 10   CONTINUE
      RETURN
      END
C
      SUBROUTINE DGLJGJ (D,DT,ZGL,ZG,IGLG,NPGL,NPG,ND1,ND2,ALPHA,BETA)
C-----------------------------------------------------------------------
C
C     Compute the (one-dimensional) derivative matrix D and its
C     transpose DT associated with taking the derivative of a variable
C     expanded on a Gauss-Lobatto Jacobi mesh (M1), and evaluate its
C     derivative on a Guass Jacobi mesh (M2).
C     Need the one-dimensional interpolation operator IM12
C     (see subroutine IGLJGJ).
C     Note: D and DT are rectangular matrices.
C     Single precision version.
C
C-----------------------------------------------------------------------
      REAL D(ND2,ND1), DT(ND1,ND2), ZGL(ND1), ZG(ND2), IGLG(ND2,ND1)
      PARAMETER (NMAX=84)
      PARAMETER (NDD = NMAX)
      REAL*8  DD(NDD,NDD), DTD(NDD,NDD)
      REAL*8  ZGD(NDD), ZGLD(NDD), IGLGD(NDD,NDD)
      REAL*8  ALPHAD, BETAD
C
      IF (NPGL.LE.1) THEN
       WRITE(6,*) 'DGLJGJ: Minimum number of Gauss-Lobatto points is 2'
       call exitt(1)
      ENDIF
      IF (NPGL.GT.NMAX) THEN
         WRITE(6,*) 'Polynomial degree too high in DGLJGJ'
         WRITE(6,*) 'Maximum polynomial degree is',NMAX
         WRITE(6,*) 'Here NPGL=',NPGL
         call exitt(1)
      ENDIF
      IF ((ALPHA.LE.-1.).OR.(BETA.LE.-1.)) THEN
         WRITE(6,*) 'DGLJGJ: Alpha and Beta must be greater than -1'
         call exitt(1)
      ENDIF
C
      ALPHAD = ALPHA
      BETAD  = BETA
      DO 100 I=1,NPG
         ZGD(I) = ZG(I)
         DO 100 J=1,NPGL
            IGLGD(I,J) = IGLG(I,J)
 100  CONTINUE
      DO 200 I=1,NPGL
         ZGLD(I) = ZGL(I)
 200  CONTINUE
      CALL DGLJGJD (DD,DTD,ZGLD,ZGD,IGLGD,NPGL,NPG,NDD,NDD,ALPHAD,BETAD)
      DO 300 I=1,NPG
      DO 300 J=1,NPGL
         D(I,J)  = DD(I,J)
         DT(J,I) = DTD(J,I)
 300  CONTINUE
      RETURN
      END
C
      SUBROUTINE DGLJGJD (D,DT,ZGL,ZG,IGLG,NPGL,NPG,ND1,ND2,ALPHA,BETA)
C-----------------------------------------------------------------------
C
C     Compute the (one-dimensional) derivative matrix D and its
C     transpose DT associated with taking the derivative of a variable
C     expanded on a Gauss-Lobatto Jacobi mesh (M1), and evaluate its
C     derivative on a Guass Jacobi mesh (M2).
C     Need the one-dimensional interpolation operator IM12
C     (see subroutine IGLJGJ).
C     Note: D and DT are rectangular matrices.
C     Double precision version.
C
C-----------------------------------------------------------------------
      IMPLICIT REAL*8  (A-H,O-Z)
      REAL*8  D(ND2,ND1), DT(ND1,ND2), ZGL(ND1), ZG(ND2)
      REAL*8  IGLG(ND2,ND1), ALPHA, BETA
C
      IF (NPGL.LE.1) THEN
       WRITE(6,*) 'DGLJGJD: Minimum number of Gauss-Lobatto points is 2'
       call exitt(1)
      ENDIF
      IF ((ALPHA.LE.-1.).OR.(BETA.LE.-1.)) THEN
         WRITE(6,*) 'DGLJGJD: Alpha and Beta must be greater than -1'
         call exitt(1)
      ENDIF
C
      EPS    = 1.e-6
      ONE    = 1.
      TWO    = 2.
      NGL    = NPGL-1
      DN     = ((NGL))
      EIGVAL = -DN*(DN+ALPHA+BETA+ONE)
C
      DO 100 I=1,NPG
      DO 100 J=1,NPGL
         DZ = ABS(ZG(I)-ZGL(J))
         IF (DZ.LT.EPS) THEN
            D(I,J) = (ALPHA*(ONE+ZG(I))-BETA*(ONE-ZG(I)))/
     $               (TWO*(ONE-ZG(I)**2))
         ELSE
            CALL JACOBF (PI,PDI,PM1,PDM1,PM2,PDM2,NGL,ALPHA,BETA,ZG(I))
            CALL JACOBF (PJ,PDJ,PM1,PDM1,PM2,PDM2,NGL,ALPHA,BETA,ZGL(J))
            FACI   = ALPHA*(ONE+ZG(I))-BETA*(ONE-ZG(I))
            FACJ   = ALPHA*(ONE+ZGL(J))-BETA*(ONE-ZGL(J))
            CONST  = EIGVAL*PJ+FACJ*PDJ
            D(I,J) = ((EIGVAL*PI+FACI*PDI)*(ZG(I)-ZGL(J))
     $               -(ONE-ZG(I)**2)*PDI)/(CONST*(ZG(I)-ZGL(J))**2)
         ENDIF
         DT(J,I) = D(I,J)
 100  CONTINUE
      RETURN
      END
C
      SUBROUTINE IGLM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2)
C----------------------------------------------------------------------
C
C     Compute the one-dimensional interpolation operator (matrix) I12
C     ands its transpose IT12 for interpolating a variable from a
C     Gauss Legendre mesh (1) to a another mesh M (2).
C     Z1 : NZ1 Gauss Legendre points.
C     Z2 : NZ2 points on mesh M.
C
C--------------------------------------------------------------------
      REAL I12(ND2,ND1),IT12(ND1,ND2),Z1(ND1),Z2(ND2)
      IF (NZ1 .EQ. 1) THEN
         I12 (1,1) = 1.
         IT12(1,1) = 1.
         RETURN
      ENDIF
      DO 10 I=1,NZ2
         ZI = Z2(I)
         DO 10 J=1,NZ1
            I12 (I,J) = HGL(J,ZI,Z1,NZ1)
            IT12(J,I) = I12(I,J)
 10   CONTINUE
      RETURN
      END
c
      SUBROUTINE IGLLM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2)
C----------------------------------------------------------------------
C
C     Compute the one-dimensional interpolation operator (matrix) I12
C     ands its transpose IT12 for interpolating a variable from a
C     Gauss-Lobatto Legendre mesh (1) to a another mesh M (2).
C     Z1 : NZ1 Gauss-Lobatto Legendre points.
C     Z2 : NZ2 points on mesh M.
C
C--------------------------------------------------------------------
      REAL I12(ND2,ND1),IT12(ND1,ND2),Z1(ND1),Z2(ND2)
      IF (NZ1 .EQ. 1) THEN
         I12 (1,1) = 1.
         IT12(1,1) = 1.
         RETURN
      ENDIF
      DO 10 I=1,NZ2
         ZI = Z2(I)
         DO 10 J=1,NZ1
            I12 (I,J) = HGLL(J,ZI,Z1,NZ1)
            IT12(J,I) = I12(I,J)
 10   CONTINUE
      RETURN
      END
C
      SUBROUTINE IGJM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2,ALPHA,BETA)
C----------------------------------------------------------------------
C
C     Compute the one-dimensional interpolation operator (matrix) I12
C     ands its transpose IT12 for interpolating a variable from a
C     Gauss Jacobi mesh (1) to a another mesh M (2).
C     Z1 : NZ1 Gauss Jacobi points.
C     Z2 : NZ2 points on mesh M.
C     Single precision version.
C
C--------------------------------------------------------------------
      REAL I12(ND2,ND1),IT12(ND1,ND2),Z1(ND1),Z2(ND2)
      IF (NZ1 .EQ. 1) THEN
         I12 (1,1) = 1.
         IT12(1,1) = 1.
         RETURN
      ENDIF
      DO 10 I=1,NZ2
         ZI = Z2(I)
         DO 10 J=1,NZ1
            I12 (I,J) = HGJ(J,ZI,Z1,NZ1,ALPHA,BETA)
            IT12(J,I) = I12(I,J)
 10   CONTINUE
      RETURN
      END
c
      SUBROUTINE IGLJM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2,ALPHA,BETA)
C----------------------------------------------------------------------
C
C     Compute the one-dimensional interpolation operator (matrix) I12
C     ands its transpose IT12 for interpolating a variable from a
C     Gauss-Lobatto Jacobi mesh (1) to a another mesh M (2).
C     Z1 : NZ1 Gauss-Lobatto Jacobi points.
C     Z2 : NZ2 points on mesh M.
C     Single precision version.
C
C--------------------------------------------------------------------
      REAL I12(ND2,ND1),IT12(ND1,ND2),Z1(ND1),Z2(ND2)
      IF (NZ1 .EQ. 1) THEN
         I12 (1,1) = 1.
         IT12(1,1) = 1.
         RETURN
      ENDIF
      DO 10 I=1,NZ2
         ZI = Z2(I)
         DO 10 J=1,NZ1
            I12 (I,J) = HGLJ(J,ZI,Z1,NZ1,ALPHA,BETA)
            IT12(J,I) = I12(I,J)
 10   CONTINUE
      RETURN
      END


 subroutine chobk1(kb,loads)
!Choleski back-substitution
 implicit none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in)::kb(:,:)
 REAL(iwp),intent(in out)::loads(0:)
 integer::iw,n,i,j,k
 REAL(iwp)::x
 n=size(kb,1)
 iw=size(kb,2)-1
 loads(1)=loads(1)/kb(1,iw+1)
 do i=2,n
   x=.0
   k=1
   if(i<=iw+1)k=iw-i+2
   do j=k,iw
     x=x+kb(i,j)*loads(i+j-iw-1)
   end do
   loads(i)=(loads(i)-x)/kb(i,iw+1)
 end do
return
end subroutine chobk1


      SUBROUTINE kendl1(data1,data2,n,tau,z,prob)
      INTEGER n
      REAL prob,tau,z,data1(n),data2(n)
CU    USES erfcc
      INTEGER is,j,k,n1,n2
      REAL a1,a2,aa,var,erfcc
      n1=0
      n2=0
      is=0
      do 12 j=1,n-1
        do 11 k=j+1,n
          a1=data1(j)-data1(k)
          a2=data2(j)-data2(k)
          aa=a1*a2
          if(aa.ne.0.)then
            n1=n1+1
            n2=n2+1
            if(aa.gt.0.)then
              is=is+1
            else
              is=is-1
            endif
          else
            if(a1.ne.0.)n1=n1+1
            if(a2.ne.0.)n2=n2+1
          endif
11      continue
12    continue
      tau=float(is)/sqrt(float(n1)*float(n2))
      var=(4.*n+10.)/(9.*n*(n-1.))
      z=tau/sqrt(var)
      prob=erfcc(abs(z)/1.4142136)
      return
      END

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


      SUBROUTINE NF01BY( CJTE, NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z,
     $                   LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Jacobian of the error function for a neural network
C     of the structure
C
C             - tanh(w1*z+b1) -
C           /      :            \
C         z ---    :          --- sum(ws(i)*...)+ b(n+1)  --- y,
C           \      :            /
C             - tanh(wn*z+bn) -
C
C     for the single-output case. The Jacobian has the form
C
C                d e(1)  / d WB(1)   ...    d e(1)  / d WB(NWB)
C         J =            :                          :           ,
C              d e(NSMP) / d WB(1)   ...  d e(NSMP) / d WB(NWB)
C
C     where e(z) is the error function, WB is the set of weights and
C     biases of the network (for the considered output), and NWB is
C     the number of elements of this set, NWB = IPAR(1)*(NZ+2)+1
C     (see below).
C
C     In the multi-output case, this routine should be called for each
C     output.
C
C     NOTE: this routine must have the same arguments as SLICOT Library
C     routine NF01BD.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     CJTE    CHARACTER*1
C             Specifies whether the matrix-vector product J'*e should be
C             computed or not, as follows:
C             = 'C' :  compute J'*e;
C             = 'N' :  do not compute J'*e.
C
C     Input/Output Parameters
C
C     NSMP    (input) INTEGER
C             The number of training samples.  NSMP >= 0.
C
C     NZ      (input) INTEGER
C             The length of each input sample.  NZ >= 0.
C
C     L       (input) INTEGER
C             The length of each output sample.
C             Currently, L must be 1.
C
C     IPAR    (input/output) INTEGER array, dimension (LIPAR)
C             The integer parameters needed.
C             On entry, the first element of this array must contain
C             a value related to the number of neurons, n; specifically,
C             n = abs(IPAR(1)), since setting IPAR(1) < 0 has a special
C             meaning (see below).
C             On exit, if IPAR(1) < 0 on entry, then no computations are
C             performed, except the needed tests on input parameters,
C             but the following values are returned:
C             IPAR(1) contains the length of the array J, LJ;
C             LDJ     contains the leading dimension of array J.
C             Otherwise, IPAR(1) and LDJ are unchanged on exit.
C
C     LIPAR   (input) INTEGER
C             The length of the vector IPAR.  LIPAR >= 1.
C
C     WB      (input) DOUBLE PRECISION array, dimension (LWB)
C             The leading NWB = IPAR(1)*(NZ+2)+1 part of this array
C             must contain the weights and biases of the network,
C             WB = ( w(1,1), ..., w(1,NZ), ..., w(n,1), ...,  w(n,NZ),
C                    ws(1), ..., ws(n), b(1), ..., b(n+1) ),
C             where w(i,j) are the weights of the hidden layer,
C             ws(i) are the weights of the linear output layer and
C             b(i) are the biases.
C
C     LWB     (input) INTEGER
C             The length of array WB.  LWB >= NWB.
C
C     Z       (input) DOUBLE PRECISION array, dimension (LDZ, NZ)
C             The leading NSMP-by-NZ part of this array must contain the
C             set of input samples,
C             Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ).
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= MAX(1,NSMP).
C
C     E       (input) DOUBLE PRECISION array, dimension (NSMP)
C             If CJTE = 'C', this array must contain the error vector e.
C             If CJTE = 'N', this array is not referenced.
C
C     J       (output) DOUBLE PRECISION array, dimension (LDJ, NWB)
C             The leading NSMP-by-NWB part of this array contains the
C             Jacobian of the error function.
C
C     LDJ     INTEGER
C             The leading dimension of array J.  LDJ >= MAX(1,NSMP).
C             Note that LDJ is an input parameter, except for
C             IPAR(1) < 0 on entry, when it is an output parameter.
C
C     JTE     (output) DOUBLE PRECISION array, dimension (NWB)
C             If CJTE = 'C', this array contains the matrix-vector
C             product J'*e.
C             If CJTE = 'N', this array is not referenced.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             This argument is included for combatibility with SLICOT
C             Library routine NF01BD.
C
C     LDWORK  INTEGER
C             Normally, the length of the array DWORK.  LDWORK >= 0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The Jacobian is computed analytically.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Oct. 2000, during a stay at University of Twente, NL.
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Input output description, neural network, nonlinear system,
C     optimization, system response.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         CJTE
      INTEGER           INFO, L, LDJ, LDWORK, LDZ, LIPAR, LWB, NSMP, NZ
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), E(*), J(LDJ,*), JTE(*), WB(*),
     $                  Z(LDZ,*)
      INTEGER           IPAR(*)
C     .. Local Scalars ..
      LOGICAL           WJTE
      INTEGER           BP1, DI, I, IB, K, M, NN, NWB, WS
      DOUBLE PRECISION  BIGNUM, SMLNUM, TMP
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      LOGICAL           LSAME
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DLABAD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, EXP, LOG, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      WJTE = LSAME( CJTE, 'C' )
      INFO = 0
      NN   = IPAR(1)
      NWB  = NN*( NZ + 2 ) + 1
      IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN
         INFO = -1
      ELSEIF ( NSMP.LT.0 ) THEN
         INFO = -2
      ELSEIF ( NZ.LT.0 ) THEN
         INFO = -3
      ELSEIF ( L.NE.1 ) THEN
         INFO = -4
      ELSEIF ( LIPAR.LT.1 ) THEN
         INFO = -6
      ELSEIF ( IPAR(1).LT.0 ) THEN
         IF( INFO.NE.0 ) THEN
            CALL XERBLA( 'NF01BY', -INFO )
         ELSE
            IPAR(1) = NSMP*( ABS( NN )*( NZ + 2 ) + 1 )
            LDJ     = NSMP
         ENDIF
         RETURN
      ELSEIF ( LWB.LT.NWB ) THEN
         INFO = -8
      ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN
         INFO = -10
      ELSEIF ( LDJ.LT.MAX( 1, NSMP ) ) THEN
         INFO = -13
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01BY', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( MIN( NSMP, NZ ).EQ.0 )
     $   RETURN
C
C     Set parameters to avoid overflows and increase accuracy for
C     extreme values.
C
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = LOG( SMLNUM )
      BIGNUM = LOG( BIGNUM )
C
      WS  = NZ*NN + 1
      IB  = WS + NN
      BP1 = IB + NN
C
      J(1, BP1) = ONE
      CALL DCOPY( NSMP, J(1, BP1), 0, J(1, BP1), 1 )
C
      DO 10 I = 0, NN - 1
         CALL DCOPY( NSMP, WB(IB+I), 0, J(1, WS+I), 1 )
   10 CONTINUE
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', NSMP, NN, NZ, -TWO, Z,
     $            LDZ, WB, NZ, -TWO, J(1, WS), LDJ )
      DI = 1
C
      DO 50 I = 0, NN - 1
C
         DO 20 K = 1, NSMP
            TMP = J(K, WS+I)
            IF ( ABS( TMP ).GE.BIGNUM ) THEN
               IF ( TMP.GT.ZERO ) THEN
                  J(K, WS+I) = -ONE
               ELSE
                  J(K, WS+I) = ONE
               END IF
            ELSE IF ( ABS( TMP ).LE.SMLNUM ) THEN
               J(K, WS+I) = ZERO
            ELSE
               J(K, WS+I) = TWO/( ONE + EXP( TMP ) ) - ONE
            END IF
            J(K, IB+I) = WB(WS+I)*( ONE - J(K, WS+I)**2 )
   20    CONTINUE
C
         DO 40 K = 0, NZ - 1
C
             DO 30 M = 1, NSMP
                J(M, DI+K) = J(M, IB+I)*Z(M, K+1)
   30       CONTINUE
C
   40    CONTINUE
C
         DI = DI + NZ
   50 CONTINUE
C
      IF ( WJTE ) THEN
C
C        Compute J'e.
C
         CALL DGEMV( 'Transpose', NSMP, NWB, ONE, J, LDJ, E, 1, ZERO,
     $               JTE, 1 )
      END IF
C
      RETURN
C
C *** Last line of NF01BY ***
      END


C
C $Id: idgtcp.f,v 1.4 2008-07-27 00:17:30 haley 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 IDGTCP (X1,Y1,X2,Y2,X3,Y3,XC,YC)
C
C This subroutine, given the coordinates of three points in the plane -
C (X1,Y1), (X2,Y2), and (X3,Y3) - returns the coordinates of the center
C of the circle passing through those three points: (XC,YC).
C
        A=2.*(X1-X2)
        B=2.*(Y1-Y2)
        C=X1*X1-X2*X2+Y1*Y1-Y2*Y2
        D=2.*(X1-X3)
        E=2.*(Y1-Y3)
        F=X1*X1-X3*X3+Y1*Y1-Y3*Y3
        XC=(C*E-B*F)/(A*E-B*D)
        YC=(C*D-A*F)/(B*D-A*E)
C
        RETURN
C
      END


      SUBROUTINE slDJCL (DJM, IY, IM, ID, FD, J)
*+
*     - - - - -
*      D J C L
*     - - - - -
*
*  Modified Julian Date to Gregorian year, month, day,
*  and fraction of a day.
*
*  Given:
*     DJM      dp     modified Julian Date (JD-2400000.5)
*
*  Returned:
*     IY       int    year
*     IM       int    month
*     ID       int    day
*     FD       dp     fraction of day
*     J        int    status:
*                       0 = OK
*                      -1 = unacceptable date (before 4701BC March 1)
*
*  The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55).
*
*  Last revision:   22 July 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DJM
      INTEGER IY,IM,ID
      DOUBLE PRECISION FD
      INTEGER J

      DOUBLE PRECISION F,D
      INTEGER JD,N4,ND10

*  Check if date is acceptable.
      IF ( DJM.LE.-2395520D0 .OR. DJM.GE.1D9 ) THEN
         J = -1
      ELSE
         J = 0

*     Separate day and fraction.
         F = MOD(DJM,1D0)
         IF (F.LT.0D0) F = F+1D0
         D = ANINT(DJM-F)

*     Express day in Gregorian calendar.
         JD = NINT(D)+2400001

         N4 = 4*(JD+((6*((4*JD-17918)/146097))/4+1)/2-37)
         ND10 = 10*(MOD(N4-237,1461)/4)+5

         IY = N4/1461-4712
         IM = MOD(ND10/306+2,12)+1
         ID = MOD(ND10,306)/10+1
         FD = F

         J=0

      END IF

      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c
c ... file slapec.f
c
c     this file includes documentation and code for
c     subroutine slapec          i
c
c ... files which must be loaded with slapec.f
c
c     sphcom.f, hrfft.f, shaec.f, shsec.f
c
c
c
c     subroutine slapec(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,
c    +                  wshsec,lshsec,work,lwork,ierror)
c
c
c     given the scalar spherical harmonic coefficients a and b, precomputed
c     by subroutine shaec for a scalar field sf, subroutine slapec computes
c     the laplacian of sf in the scalar array slap.  slap(i,j) is the
c     laplacian of sf at the colatitude
c
c         theta(i) = (i-1)*pi/(nlat-1)
c
c     and east longitude
c
c         lambda(j) = (j-1)*2*pi/nlon
c
c     on the sphere.  i.e.
c
c         slap(i,j) =
c
c                  2                2
c         [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint
c
c
c     where sint = sin(theta(i)).  the scalar laplacian in slap has the
c     same symmetry or absence of symmetry about the equator as the scalar
c     field sf.  the input parameters isym,nt,mdab,ndab must have the
c     same values used by shaec to compute a and b for sf. the associated
c     legendre functions are recomputed rather than stored as they are
c     in subroutine slapes.

c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct longitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     isym   this parameter should have the same value input to subroutine
c            shaec to compute the coefficients a and b for the scalar field
c            sf.  isym is set as follows:
c
c            = 0  no symmetries exist in sf about the equator. scalar
c                 synthesis is used to compute slap on the entire sphere.
c                 i.e., in the array slap(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c           = 1  sf and slap are antisymmetric about the equator. the
c                synthesis used to compute slap is performed on the
c                northern hemisphere only.  if nlat is odd, slap(i,j) is
c                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
c                nlat is even, slap(i,j) is computed for i=1,...,nlat/2
c                and j=1,...,nlon.
c
c
c           = 2  sf and slap are symmetric about the equator. the
c                synthesis used to compute slap is performed on the
c                northern hemisphere only.  if nlat is odd, slap(i,j) is
c                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
c                nlat is even, slap(i,j) is computed for i=1,...,nlat/2
c                and j=1,...,nlon.
c
c
c     nt     the number of analyses.  in the program that calls slapec
c            the arrays slap,a, and b can be three dimensional in which
c            case multiple synthesis will be performed.  the third index
c            is the synthesis index which assumes the values k=1,...,nt.
c            for a single analysis set nt=1. the description of the
c            remaining parameters is simplified by assuming that nt=1
c            or that all the arrays are two dimensional.
c
c   ids      the first dimension of the array slap as it appears in the
c            program that calls slapec.  if isym = 0 then ids must be at
c            least nlat.  if isym > 0 and nlat is even then ids must be
c            at least nlat/2. if isym > 0 and nlat is odd then ids must
c            be at least (nlat+1)/2.
c
c   jds      the second dimension of the array slap as it appears in the
c            program that calls slapec. jds must be at least nlon.
c
c
c   a,b      two or three dimensional arrays (see input parameter nt)
c            that contain scalar spherical harmonic coefficients
c            of the scalar field sf as computed by subroutine shaec.
c     ***    a,b must be computed by shaec prior to calling slapec.
c
c
c    mdab    the first dimension of the arrays a and b as it appears
c            in the program that calls slapec.  mdab must be at
c            least min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    ndab    the second dimension of the arrays a and b as it appears
c            in the program that calls slapec. ndbc must be at least
c            least nlat.
c
c            mdab,ndab should have the same values input to shaec to
c            compute the coefficients a and b.
c
c
c    wshsec  an array which must be initialized by subroutine shseci
c            before calling slapec.  once initialized, wshsec
c            can be used repeatedly by slapec as long as nlat and nlon
c            remain unchanged.  wshsec must not be altered between calls
c            of slapec.
c
c    lshsec  the dimension of the array wshsec as it appears in the
c            program that calls slapec.  let
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsec must be greater than or equal to
c
c               2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls slapec. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            if isym = 0 let
c
c               lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1.
c
c            if isym > 0 let
c
c               lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1)
c
c
c     then lwork must be greater than or equal to lwkmin (see ierror=10)
c
c     **************************************************************
c
c     output parameters
c
c
c    slap    a two or three dimensional arrays (see input parameter nt) that
c            contain the scalar laplacian of the scalar field sf.  slap(i,j)
c            is the scalar laplacian at the colatitude
c
c                 theta(i) = (i-1)*pi/(nlat-1)
c
c            and longitude
c
c                 lambda(j) = (j-1)*2*pi/nlon
c
c            for i=1,...,nlat and j=1,...,nlon.
c
c
c  ierror    a parameter which flags errors in input parameters as follows:
c
c            = 0  no errors detected
c
c            = 1  error in the specification of nlat
c
c            = 2  error in the specification of nlon
c
c            = 3  error in the specification of ityp
c
c            = 4  error in the specification of nt
c
c            = 5  error in the specification of ids
c
c            = 6  error in the specification of jds
c
c            = 7  error in the specification of mdbc
c
c            = 8  error in the specification of ndbc
c
c            = 9  error in the specification of lshsec
c
c            = 10 error in the specification of lwork
c
c
c **********************************************************************
c
c     end of documentation for slapec
c
c **********************************************************************
c
c
      subroutine slapec(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,
     +                  wshsec,lshsec,work,lwork,ierror)
      dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt)
      dimension wshsec(lshsec),work(lwork)
c
c     check input parameters
c
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 4) return
      ierror = 3
      if (isym.lt.0 .or. isym.gt.2) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((isym.eq.0 .and. ids.lt.nlat) .or.
     1   (isym.gt.0 .and. ids.lt.imid)) return
      ierror = 6
      if(jds .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,nlon/2+1)
      if(mdab .lt. mmax) return
      ierror = 8
      if(ndab .lt. nlat) return
      ierror = 9
c
c     set and verify saved work space length
c
c
      l1 = min0(nlat,(nlon+2)/2)
      l2 = (nlat+1)/2
      lwmin = 2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
      if(lshsec .lt. lwmin) return
      ierror = 10
c
c     set and verify unsaved work space length
c
      ls = nlat
      if(isym .gt. 0) ls = imid
      nln = nt*ls*nlon
      mn = mmax*nlat*nt
c     lwmin = nln+ls*nlon+2*mn+nlat
c     if (lwork .lt. lwmin) return
      l2 = (nlat+1)/2
      l1 = min0(nlat,nlon/2+1)
      if (isym .eq. 0) then
	lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1)
      else
	lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1)
      end if
      if (lwork .lt. lwkmin) return

      ierror = 0
c
c     set work space pointers
c
      ia = 1
      ib = ia+mn
      ifn = ib+mn
      iwk = ifn+nlat
      lwk = lwork-2*mn-nlat
      call slapec1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,
     +work(ia),work(ib),mmax,work(ifn),wshsec,lshsec,work(iwk),lwk,
     +ierror)
      return
      end

      subroutine slapec1(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,
     +                  alap,blap,mmax,fnn,wshsec,lshsec,wk,lwk,ierror)
      dimension slap(ids,jds,nt),a(mdab,ndab,nt),b(mdab,ndab,nt)
      dimension alap(mmax,nlat,nt),blap(mmax,nlat,nt),fnn(nlat)
      dimension wshsec(lshsec),wk(lwk)
c
c     set coefficient multiplyers
c
      do 1 n=2,nlat
      fn = float(n-1)
      fnn(n) = fn*(fn+1.)
    1 continue
c
c     compute scalar laplacian coefficients for each vector field
c
      do 2 k=1,nt
      do 3 n=1,nlat
      do 4 m=1,mmax
      alap(m,n,k) = 0.0
      blap(m,n,k) = 0.0
    4 continue
    3 continue
c
c     compute m=0 coefficients
c
      do 5 n=2,nlat
      alap(1,n,k) = -fnn(n)*a(1,n,k)
      blap(1,n,k) = -fnn(n)*b(1,n,k)
    5 continue
c
c     compute m>0 coefficients
c
      do 6 m=2,mmax
      do 7 n=m,nlat
      alap(m,n,k) = -fnn(n)*a(m,n,k)
      blap(m,n,k) = -fnn(n)*b(m,n,k)
    7 continue
    6 continue
    2 continue
c
c     synthesize alap,blap into slap
c
      call shsec(nlat,nlon,isym,nt,slap,ids,jds,alap,blap,
     +           mmax,nlat,wshsec,lshsec,wk,lwk,ierror)
      return
      end


*DECK HFTI
      SUBROUTINE HFTI (A, MDA, M, N, B, MDB, NB, TAU, KRANK, RNORM, H,
     +   G, IP)
C***BEGIN PROLOGUE  HFTI
C***PURPOSE  Solve a linear least squares problems by performing a QR
C            factorization of the matrix using Householder
C            transformations.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      SINGLE PRECISION (HFTI-S, DHFTI-D)
C***KEYWORDS  CURVE FITTING, LINEAR LEAST SQUARES, QR FACTORIZATION
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     DIMENSION A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N)
C
C     This subroutine solves a linear least squares problem or a set of
C     linear least squares problems having the same matrix but different
C     right-side vectors.  The problem data consists of an M by N matrix
C     A, an M by NB matrix B, and an absolute tolerance parameter TAU
C     whose usage is described below.  The NB column vectors of B
C     represent right-side vectors for NB distinct linear least squares
C     problems.
C
C     This set of problems can also be written as the matrix least
C     squares problem
C
C                       AX = B,
C
C     where X is the N by NB solution matrix.
C
C     Note that if B is the M by M identity matrix, then X will be the
C     pseudo-inverse of A.
C
C     This subroutine first transforms the augmented matrix (A B) to a
C     matrix (R C) using premultiplying Householder transformations with
C     column interchanges.  All subdiagonal elements in the matrix R are
C     zero and its diagonal elements satisfy
C
C                       ABS(R(I,I)).GE.ABS(R(I+1,I+1)),
C
C                       I = 1,...,L-1, where
C
C                       L = MIN(M,N).
C
C     The subroutine will compute an integer, KRANK, equal to the number
C     of diagonal terms of R that exceed TAU in magnitude. Then a
C     solution of minimum Euclidean length is computed using the first
C     KRANK rows of (R C).
C
C     To be specific we suggest that the user consider an easily
C     computable matrix norm, such as, the maximum of all column sums of
C     magnitudes.
C
C     Now if the relative uncertainty of B is EPS, (norm of uncertainty/
C     norm of B), it is suggested that TAU be set approximately equal to
C     EPS*(norm of A).
C
C     The user must dimension all arrays appearing in the call list..
C     A(MDA,N),(B(MDB,NB) or B(M)),RNORM(NB),H(N),G(N),IP(N).  This
C     permits the solution of a range of problems in the same array
C     space.
C
C     The entire set of parameters for HFTI are
C
C     INPUT..
C
C     A(*,*),MDA,M,N    The array A(*,*) initially contains the M by N
C                       matrix A of the least squares problem AX = B.
C                       The first dimensioning parameter of the array
C                       A(*,*) is MDA, which must satisfy MDA.GE.M
C                       Either M.GE.N or M.LT.N is permitted.  There
C                       is no restriction on the rank of A.  The
C                       condition MDA.LT.M is considered an error.
C
C     B(*),MDB,NB       If NB = 0 the subroutine will perform the
C                       orthogonal decomposition but will make no
C                       references to the array B(*).  If NB.GT.0
C                       the array B(*) must initially contain the M by
C                       NB matrix B of the least squares problem AX =
C                       B.  If NB.GE.2 the array B(*) must be doubly
C                       subscripted with first dimensioning parameter
C                       MDB.GE.MAX(M,N).  If NB = 1 the array B(*) may
C                       be either doubly or singly subscripted.  In
C                       the latter case the value of MDB is arbitrary
C                       but it should be set to some valid integer
C                       value such as MDB = M.
C
C                       The condition of NB.GT.1.AND.MDB.LT. MAX(M,N)
C                       is considered an error.
C
C     TAU               Absolute tolerance parameter provided by user
C                       for pseudorank determination.
C
C     H(*),G(*),IP(*)   Arrays of working space used by HFTI.
C
C     OUTPUT..
C
C     A(*,*)            The contents of the array A(*,*) will be
C                       modified by the subroutine. These contents
C                       are not generally required by the user.
C
C     B(*)              On return the array B(*) will contain the N by
C                       NB solution matrix X.
C
C     KRANK             Set by the subroutine to indicate the
C                       pseudorank of A.
C
C     RNORM(*)          On return, RNORM(J) will contain the Euclidean
C                       norm of the residual vector for the problem
C                       defined by the J-th column vector of the array
C                       B(*,*) for J = 1,...,NB.
C
C     H(*),G(*)         On return these arrays respectively contain
C                       elements of the pre- and post-multiplying
C                       Householder transformations used to compute
C                       the minimum Euclidean length solution.
C
C     IP(*)             Array in which the subroutine records indices
C                       describing the permutation of column vectors.
C                       The contents of arrays H(*),G(*) and IP(*)
C                       are not generally required by the user.
C
C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
C                 Problems, Prentice-Hall, Inc., 1974, Chapter 14.
C***ROUTINES CALLED  H12, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   901005  Replace usage of DIFF with usage of R1MACH.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HFTI
      DIMENSION A(MDA,*),B(MDB,*),H(*),G(*),RNORM(*)
      INTEGER IP(*)
      DOUBLE PRECISION SM,DZERO
      SAVE RELEPS
      DATA RELEPS /0.E0/
C***FIRST EXECUTABLE STATEMENT  HFTI
      IF (RELEPS.EQ.0) RELEPS = R1MACH(4)
      SZERO=0.
      DZERO=0.D0
      FACTOR=0.001
C
      K=0
      LDIAG=MIN(M,N)
      IF (LDIAG.LE.0) GO TO 270
      IF (.NOT.MDA.LT.M) GO TO 5
      NERR=1
      IOPT=2
      CALL XERMSG ('SLATEC', 'HFTI', 'MDA.LT.M, PROBABLE ERROR.',
     +   NERR, IOPT)
      RETURN
    5 CONTINUE
C
      IF (.NOT.(NB.GT.1.AND.MAX(M,N).GT.MDB)) GO TO 6
      NERR=2
      IOPT=2
      CALL XERMSG ('SLATEC', 'HFTI',
     +   'MDB.LT.MAX(M,N).AND.NB.GT.1. PROBABLE ERROR.', NERR, IOPT)
      RETURN
    6 CONTINUE
C
          DO 80 J=1,LDIAG
          IF (J.EQ.1) GO TO 20
C
C     UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
          LMAX=J
              DO 10 L=J,N
              H(L)=H(L)-A(J-1,L)**2
              IF (H(L).GT.H(LMAX)) LMAX=L
   10         CONTINUE
          IF (FACTOR*H(LMAX) .GT. HMAX*RELEPS) GO TO 50
C
C     COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
   20     LMAX=J
              DO 40 L=J,N
              H(L)=0.
                  DO 30 I=J,M
   30             H(L)=H(L)+A(I,L)**2
              IF (H(L).GT.H(LMAX)) LMAX=L
   40         CONTINUE
          HMAX=H(LMAX)
C    ..
C     LMAX HAS BEEN DETERMINED
C
C     DO COLUMN INTERCHANGES IF NEEDED.
C    ..
   50     CONTINUE
          IP(J)=LMAX
          IF (IP(J).EQ.J) GO TO 70
              DO 60 I=1,M
              TMP=A(I,J)
              A(I,J)=A(I,LMAX)
   60         A(I,LMAX)=TMP
          H(LMAX)=H(J)
C
C     COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B.
C    ..
   70     CALL H12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J)
   80     CALL H12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)
C
C     DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU.
C    ..
          DO 90 J=1,LDIAG
          IF (ABS(A(J,J)).LE.TAU) GO TO 100
   90     CONTINUE
      K=LDIAG
      GO TO 110
  100 K=J-1
  110 KP1=K+1
C
C     COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
      IF (NB.LE.0) GO TO 140
          DO 130 JB=1,NB
          TMP=SZERO
          IF (KP1.GT.M) GO TO 130
              DO 120 I=KP1,M
  120         TMP=TMP+B(I,JB)**2
  130     RNORM(JB)=SQRT(TMP)
  140 CONTINUE
C                                           SPECIAL FOR PSEUDORANK = 0
      IF (K.GT.0) GO TO 160
      IF (NB.LE.0) GO TO 270
          DO 150 JB=1,NB
              DO 150 I=1,N
  150         B(I,JB)=SZERO
      GO TO 270
C
C     IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C     DECOMPOSITION OF FIRST K ROWS.
C    ..
  160 IF (K.EQ.N) GO TO 180
          DO 170 II=1,K
          I=KP1-II
  170     CALL H12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  180 CONTINUE
C
C
      IF (NB.LE.0) GO TO 270
          DO 260 JB=1,NB
C
C     SOLVE THE K BY K TRIANGULAR SYSTEM.
C    ..
              DO 210 L=1,K
              SM=DZERO
              I=KP1-L
              IF (I.EQ.K) GO TO 200
              IP1=I+1
                  DO 190 J=IP1,K
  190             SM=SM+A(I,J)*DBLE(B(J,JB))
  200         SM1=SM
  210         B(I,JB)=(B(I,JB)-SM1)/A(I,I)
C
C     COMPLETE COMPUTATION OF SOLUTION VECTOR.
C    ..
          IF (K.EQ.N) GO TO 240
              DO 220 J=KP1,N
  220         B(J,JB)=SZERO
              DO 230 I=1,K
  230         CALL H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1)
C
C      RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C      COLUMN INTERCHANGES.
C    ..
  240         DO 250 JJ=1,LDIAG
              J=LDIAG+1-JJ
              IF (IP(J).EQ.J) GO TO 250
              L=IP(J)
              TMP=B(L,JB)
              B(L,JB)=B(J,JB)
              B(J,JB)=TMP
  250         CONTINUE
  260     CONTINUE
C    ..
C     THE SOLUTION VECTORS, X, ARE NOW
C     IN THE FIRST  N  ROWS OF THE ARRAY B(,).
C
  270 KRANK=K
      RETURN
      END


      subroutine resid_hs3(ctfm,ctfmp,n_A,n_B,n_C1s,n_C5psi,n_psi,octfmp
     &,Nx,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_B(Nx)
      real*8 n_C1s(Nx)
      real*8 n_C5psi(Nx)
      real*8 n_psi(Nx)
      real*8 octfmp(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = -0.5000000000000000D0 * (0.3D1 * n_psi(i) - 0.4D1 * n_psi(i +
     # 1) + n_psi(i + 2)) / hx
      res = res + qb**2
      end do
      endif
      do i=2, Nx-1, 1
      qb = n_C1s(i) * n_psi(i) + n_C5psi(i) + (-0.5000000000000000D0 / n
     #_A(i) / ctfmp(i) * (-0.1D1 * n_psi(i - 1) + n_psi(i + 1)) * octfmp
     #(i) + 0.1D1 / ctfm(i) / n_A(i) / ctfmp(i) * (-0.1D1 * n_psi(i - 1)
     # + n_psi(i + 1))) / hx + (0.1D1 / n_A(i) * (n_psi(i - 1) - 0.2D1 *
     # n_psi(i) + n_psi(i + 1)) - 0.1250000000000000D0 / n_A(i) ** 2 * (
     #-0.1D1 * n_A(i - 1) + n_A(i + 1)) * (-0.1D1 * n_psi(i - 1) + n_psi
     #(i + 1)) + 0.2500000000000000D0 / n_B(i) / n_A(i) * (-0.1D1 * n_B(
     #i - 1) + n_B(i + 1)) * (-0.1D1 * n_psi(i - 1) + n_psi(i + 1))) / c
     #tfmp(i) ** 2 / hx ** 2
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = n_psi(i) - 0.1D1 + myzero * ctfm(i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


SUBROUTINE rsolv_sp(a,d,b)
   use mo_kind
   use mo_nrutil, ONLY : assert_eq
   IMPLICIT NONE
   REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
   REAL(SP), DIMENSION(:), INTENT(IN) :: d
   REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
   INTEGER(I4) :: i,n
   n=assert_eq(size(a,1),size(a,2),size(b),size(d),'rsolv')
   b(n)=b(n)/d(n)
   do i=n-1,1,-1
      b(i)=(b(i)-dot_product(a(i,i+1:n),b(i+1:n)))/d(i)
   end do
 END SUBROUTINE rsolv_sp
SUBROUTINE rsolv_dp(a,d,b)
   use mo_kind
   use mo_nrutil, ONLY : assert_eq
   IMPLICIT NONE
   REAL(DP), DIMENSION(:,:), INTENT(IN) :: a
   REAL(DP), DIMENSION(:), INTENT(IN) :: d
   REAL(DP), DIMENSION(:), INTENT(INOUT) :: b
   INTEGER(I8) :: i,n
   n=assert_eq(size(a,1),size(a,2),size(b),size(d),'rsolv')
   b(n)=b(n)/d(n)
   do i=n-1,1,-1
      b(i)=(b(i)-dot_product(a(i,i+1:n),b(i+1:n)))/d(i)
   end do
 END SUBROUTINE rsolv_dp


! Fortran code for computing response spectra.
! Originial version is writting by: Leonardo Ramirez-Guzman
! The code base is tailored for F2py.
!

subroutine max_osc_response(acc, npts, dt, period, csi, max_disp, &
    max_vel, max_acc)

    implicit none
    integer, intent(in) :: npts
    real, intent(in) :: acc(npts)
    real :: a(npts), v(npts), d(npts)
    real, intent(in) :: dt, period, csi
    real, intent(out) :: max_disp, max_vel, max_acc
    integer :: i=1
    real, parameter :: PI = 3.14159265359
    real :: w, ww, csicsi, dcsiw, rcsi, csircs, wd, ueskdt, dcsiew, um2csi, e, &
     s, c0, ca, cb, cc, cd, cap, cbp, ccp, cdp

    d(1) = 0.
    v(1) = 0.

    w = (2*PI)/period
    ww = w ** 2
    csicsi = csi ** 2
    dcsiw = 2. * csi * w

    rcsi = sqrt(1-csicsi)
    csircs = csi/rcsi
    wd = w * rcsi
    ueskdt = -1/(ww*dt)
    dcsiew = 2 * csi / w
    um2csi = (1.-2*csicsi)/wd
    e=exp(-w*dt*csi)
    s=sin(wd*dt)
    c0=cos(wd*dt)

    a(1) = -ww*d(1)-dcsiw*v(1)

    ca = e * (csircs*s+c0)
    cb = e * s/wd
    cc = (e*((um2csi-csircs*dt)*s -(dcsiew+dt)*c0)+dcsiew)*ueskdt
    cd = (e*(-um2csi*s+dcsiew*c0)+dt-dcsiew)*ueskdt
    cap = -cb * ww
    cbp = e * (c0-csircs*s)
    ccp = (e*((w*dt/rcsi+csircs)*s+c0)-1.)*ueskdt
    cdp = (1.-ca)*ueskdt

    do i=2,npts
        d(i) = ca*d(i-1)+cb*v(i-1)+cc*acc(i-1)+cd*acc(i)
        v(i) = cap*d(i-1)+cbp*v(i-1)+ccp*acc(i-1)+cdp*acc(i)
        a(i) = -ww*d(i)-dcsiw*v(i)
    end do

    max_disp = 0
    max_vel = 0
    max_acc = 0

    do i=1,npts
        if (abs(a(i)) .gt. max_acc) then
            max_acc = abs(a(i))
        end if
    end do

    do i=1,npts
        if (abs(v(i)) .gt. max_vel) then
            max_vel = abs(v(i))
        end if
    end do

    do i=1,npts
        if (abs(d(i)) .gt. max_disp) then
            max_disp = abs(d(i))
        end if
    end do

end subroutine max_osc_response

subroutine calc_response(acc, npts, dt, periods, n_prds,csi, max_disps, &
     max_vels, max_accs)
    implicit none
    integer, intent(in) :: npts, n_prds
    real, intent(in) :: acc(npts)
    real, intent(in) :: dt, csi
    real, intent(in) :: periods(n_prds)
    real, intent(out) :: max_disps(n_prds), max_vels(n_prds), max_accs(n_prds)
    integer :: i=1

    do i=1,n_prds
        call max_osc_response(acc, npts, dt, periods(i), csi, max_disps(i),&
         max_vels(i), max_accs(i))
    end do

end subroutine calc_response


      SUBROUTINE TILING(A,B,SZ)

      INTEGER T,SZ
      INTEGER A(1:SZ,1:SZ)
      INTEGER B(0:SZ+1,0:SZ+1)
      INTEGER kernel(0:2,0:2)
      PARAMETER (T=10)

      if ( MOD(SZ,T) .NE. 0 ) RETURN

      DO i=1,SZ,T
        DO j=1,SZ,T
          DO k=i,i+T-1
            DO l=j,j+T-1
              A(k,l)=0
              DO m=-1,1
                DO n=-1,1
                  A(k,l) = A(k,l) + B(k+m,l+n)*kernel(m+1,n+1)
                ENDDO
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDDO

      DO i=1,SZ
        DO j=1,SZ
          print *,A(i,j)
        ENDDO
      ENDDO
      END


    Program zgetrs_example

!     ZGETRS 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_complex_gen_comp
      Use lapack_interfaces, Only: zgetrf, zgetrs
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: trans = 'N'
!     .. Local Scalars ..
      Integer :: i, ifail, info, lda, ldb, n, nrhs
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :)
      Integer, Allocatable :: ipiv(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZGETRS Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, nrhs
      lda = n
      ldb = n
      Allocate (a(lda,n), b(ldb,nrhs), ipiv(n))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:nrhs), i=1, n)

!     Factorize A

      Call zgetrf(n, n, a, lda, ipiv, info)

      Write (nout, *)
      Flush (nout)
      If (info==0) Then

!       Compute solution

        Call zgetrs(trans, n, nrhs, a, lda, ipiv, b, ldb, info)

!       Print solution

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, nrhs, &
          b, ldb, 'Bracketed', 'F7.4', 'Solution(s)', 'Integer', rlabs, &
          'Integer', clabs, 80, 0, ifail)

      Else
        Write (nout, *) 'The factor U is singular'
      End If

    End Program


!----------------------------------------------------------------------
! Program: handy
!> Purpose: Human and Nature Dynamics (from Motesharrei et al., 2014)
!>

!> Author: Benjamin Menetrier
!>

!> Licensing: this code is distributed under Apache License 2.0
!----------------------------------------------------------------------
program handy

use handy_mod
implicit none

! Local variables
integer :: it,jt
real :: eta,deltastar,deltastar2,chimax
type(statetype) :: k1,k2,k3,k4
type(statetype),allocatable :: state(:)
type(partype) :: par
character(1024) :: filename
character(1024) :: subr = 'handy'

!----------------------------------------------------------------------
! Header
!----------------------------------------------------------------------

write(*,'(a)') '-------------------------------------------------------------------'
write(*,'(a)') '--- You are running HANDY  (from Motesharrei et al., 2014) --------'
write(*,'(a)') '--- Author : Benjamin Ménétrier -----------------------------------'

!----------------------------------------------------------------------
! Initialization
!----------------------------------------------------------------------

write(*,'(a)') '-------------------------------------------------------------------'
write(*,'(a)') '-1- Initialization'

!----------------------------------------------------------------------
! Read namelist
!----------------------------------------------------------------------

write(*,'(a)') '-------------------------------------------------------------------'
write(*,'(a)') '    Read namelist'
read(*,nml=handy_param)

!----------------------------------------------------------------------
! Memory allocation
!----------------------------------------------------------------------

write(*,'(a)') '-------------------------------------------------------------------'
write(*,'(a)') '    Memory allocation'
allocate(state(0:nt*dtrat))

!----------------------------------------------------------------------
! Initialization
!----------------------------------------------------------------------

write(*,'(a)') '-------------------------------------------------------------------'
write(*,'(a)') '    Initialization'

! Fixed parameters
par%alpham = 1.0e-2
par%alphamax = 7.0e-2
par%s = 5.0e-4
par%rho = 5.0e-3
par%gamma = 1.0e-2
par%lambda = 1.0e2

! Fixed initial variables
state(0)%y = par%lambda
state(0)%w = 0.0

select case(trim(society))
case('egalitarian')
   ! Fixed parameters
   par%betac = 3.0e-2
   par%betae = 0.0
   par%kappa = 0.0
   state(0)%xc = 1.0e2
   state(0)%xe = 0.0

   ! Eta parameter
   eta = (par%alphamax - par%betac)/(par%alphamax - par%alpham)
   write(*,'(a,f6.2)') '    Eta parameter: ',eta

   ! Egalitarian optimal delta
   deltastar = 2.0*eta*par%s/par%lambda

   ! Select depletion factor
   select case(trim(config))
   case('optimal_soft_landing')
      par%delta = deltastar
   case('suboptimal_soft_landing')
      par%delta = 0.75*deltastar
   case('oscillatory_landing')
      par%delta = 2.5*deltastar
   case('cycles')
      par%delta = 4.0*deltastar
   case('collapse')
      par%delta = 5.5*deltastar
   case default
      write(*,'(a)') '    Not a valid config for an '//trim(society)//' society'
      stop
   end select

   ! Maximum carrying capacity
   chimax = par%gamma/(eta*par%s)*(par%lambda/2)**2
case('equitable')
   select case(trim(config))
   case('decreased_depletion')
      par%betac = 3.0e-2
      par%betae = 3.0e-2
      par%kappa = 1.0
      state(0)%xc = 1.0e2
      state(0)%xe = 6.0e2
   case default
      par%betac = 3.0e-2
      par%betae = 3.0e-2
      par%kappa = 1.0
      state(0)%xc = 1.0e2
      state(0)%xe = 2.5e1
   end select

   ! Eta parameter
   eta = (par%alphamax - par%betac)/(par%alphamax - par%alpham)
   write(*,'(a,f6.2)') '    Eta parameter: ',eta

   ! Egalitarian optimal delta
   deltastar2 = 2.0*eta*par%s/par%lambda*(1.0 + state(0)%xe/state(0)%xc)

   ! Select depletion factor
   select case(trim(config))
   case('optimal_soft_landing')
      par%delta = deltastar2
   case('suboptimal_soft_landing')
      par%delta = 0.75*deltastar2
   case('oscillatory_landing')
      par%delta = 2.64*deltastar2
   case('cycles')
      par%delta = 3.46*deltastar2
   case('collapse')
      par%delta = 5.0*deltastar2
   case('decreased_depletion')
      par%delta = 5.0*deltastar2
   case default
      write(*,'(a)') '    Not a valid config for an '//trim(society)//' society'
      stop
   end select

   ! Maximum carrying capacity
   chimax = par%gamma/(eta*par%s)*(par%lambda/2)**2

case('unequal')
   ! Predatory elite
   select case(trim(config))
   case('type-L_collapse')
      par%betac = 3.0e-2
      par%betae = 3.0e-2
      par%kappa = 100.0
      state(0)%xc = 1.0e2
      state(0)%xe = 1.0e-2
   case('type-N_collapse')
      par%betac = 3.0e-2
      par%betae = 3.0e-2
      par%kappa = 100.0
      state(0)%xc = 1.0e2
      state(0)%xe = 0.2
   case('optimal_soft_landing')
      par%betac = 6.5e-2
      par%betae = 2.0e-2
      par%kappa = 10.0
      state(0)%xc = 1.0e4
      state(0)%xe = 3.0e3
   case('oscillatory_landing')
      par%betac = 6.5e-2
      par%betae = 2.0e-2
      par%kappa = 10.0
      state(0)%xc = 1.0e4
      state(0)%xe = 3.0e3
   end select

   ! Eta parameter
   eta = (par%alphamax - par%betac)/(par%alphamax - par%alpham)
   write(*,'(a,f6.2)') '    Eta parameter: ',eta

   ! Egalitarian optimal delta
   deltastar = 2.0*eta*par%s/par%lambda

   ! Select depletion factor
   select case(trim(config))
   case('type-L_collapse')
      par%delta = deltastar
   case('type-N_collapse')
      par%delta = 1.0e-4
   case('optimal_soft_landing')
      par%delta = 6.35e-6
   case('oscillatory_landing')
      par%delta = 1.3e-5
   case default
      write(*,'(a)') '    Not a valid config for an '//trim(society)//' society'
      stop
   end select

   ! Maximum carrying capacity
   chimax = par%gamma/(eta*par%s)*(par%lambda/2)**2
case default
   write(*,'(a)') '    Not a valid society'
   stop
end select
par%nature_switch = .true.

!----------------------------------------------------------------------
! Integration
!----------------------------------------------------------------------

write(*,'(a)') '-------------------------------------------------------------------'
write(*,'(a)') '-2- Integration'

do it=0,nt*dtrat-1
   ! Initialization
   state(it+1) = state(it)

   ! Check nature value
   if (lpos==3) par%nature_switch = par%nature_switch.and.(state(it+1)%y>1.0e-6*par%lambda)

   ! Integration
   if (trim(scheme)=='rk') then
      ! Fourth-order Runge-Kutta scheme
      call handy_step(state(it+1),par,k1)
      call handy_step(state(it+1) + k1/(2.0*float(dtrat)),par,k2)
      call handy_step(state(it+1) + k2/(2.0*float(dtrat)),par,k3)
      call handy_step(state(it+1) + k3/float(dtrat),par,k4)
      state(it+1) = state(it+1) + (k1 + 2.0*k2 + 2.0*k3 + k4)/(6.0*float(dtrat))
   elseif (trim(scheme)=='fe') then
      ! Forward Euler scheme
      call handy_step(state(it+1),par,k1)
      state(it+1) = state(it+1) + k1/float(dtrat)
   else
      write(*,'(a)') '    Not a valid integration scheme'
      stop
   end if

   if (it==0) write(*,'(a7,a6,a12,a12,a12,a12)') '','Year','Commoners','Elite','Nature','Accumulated wealth'
   write(*,'(a7,i6,e12.3,e12.3,e12.3,e12.3)') '',it,state(it+1)%xc,state(it+1)%xe,state(it+1)%y,state(it+1)%w

   if ((lpos>0).and.((state(it+1)%xc<0.0).or.(state(it+1)%xe<0.0).or.(state(it+1)%y<0.0).or.(state(it+1)%w<0.0))) then
      if (lpos==1) then
         ! Stop when negative values
         do jt=it+2,nt*dtrat
            state(jt)%xc = -999.0
            state(jt)%xe = -999.0
            state(jt)%y = -999.0
            state(jt)%w = -999.0
         end do
         exit
      elseif (lpos==2) then
         ! Force positivity
         state(it+1)%xc = max(0.0,state(it+1)%xc)
         state(it+1)%xe = max(0.0,state(it+1)%xe)
         state(it+1)%y = max(0.0,state(it+1)%y)
         state(it+1)%w = max(0.0,state(it+1)%w)
      elseif (lpos==3) then
         ! Threshold on nature regeneration (see handy_step)
      else
         write(*,'(a)') '    Not a valid positivity option'
         stop
      end if
   end if
end do

!----------------------------------------------------------------------
! Write data
!----------------------------------------------------------------------

write(*,'(a)') '-------------------------------------------------------------------'
write(*,'(a)') '-3- Write data'

if (kind(1.0)==4) then
   write(filename,'(a,a,a,a,a,a,a,i2.2,a,i1,a)') '../data/',trim(society),'-',trim(config),'-',trim(scheme),'-',dtrat, &
 & '-lpos',lpos,'-sp.dat'
elseif (kind(1.0)==8) then
   write(filename,'(a,a,a,a,a,a,a,i2.2,a,i1,a)') '../data/',trim(society),'-',trim(config),'-',trim(scheme),'-',dtrat, &
 & '-lpos',lpos,'-dp.dat'
end if
open(unit=20,file=trim(filename),action='write',status='replace')
do it=0,nt*dtrat
   if (state(it)%xc>-999.0) then
      write(20,*) it,float(it)/float(dtrat),state(it)%xc/chimax,state(it)%xe/chimax,state(it)%y/par%lambda,state(it)%w/par%lambda
   else
      write(20,*) it,float(it)/float(dtrat),state(it)%xc,state(it)%xe,state(it)%y,state(it)%w
   end if
end do
close(unit=20)

end program handy


SUBROUTINE RMINVE (A , AI , NSIZE , ERROR)
IMPLICIT NONE
!PARAMETER DECLARATION
INTEGER, PARAMETER:: MSIZE=500
!DATA DECLARATION
REAL(8) R0    /0.0D0/
REAL(8) R1    /1.0D0/
CHARACTER*6 NAME
DATA NAME/'RMINVE'/
!SCALAR VARIABLES FROM ARGUMENTS
INTEGER NSIZE
LOGICAL ERROR
!ARRAYS FROM ARGUMENTS
REAL(8), DIMENSION(NSIZE,NSIZE):: A
REAL(8), DIMENSION(NSIZE,NSIZE):: AI
!LOCAL SCALAR VARIABLES
INTEGER ISIZE, JSIZE
REAL(8) DUMMY, DETA
!LOCAL ARRAYS
INTEGER, DIMENSION(NSIZE):: INDX
!INITIALIZE LOCAL VARIABLES
ISIZE=0  ; JSIZE=0
DUMMY=R0 ; DETA=R0
INDX=0
!***********************************************************************
! Evaluate inverse matrix without determinant
!*Arrays
! A     - A matrix
!=AI    - inversed A matrix
!*Variables
! NSIZE - Size of the matrix
!=ERROR - Error flag
!***********************************************************************
! Set up identity matrix
! ----------------------
ERROR=.FALSE.
DO 20 ISIZE=1,NSIZE
	DO 10 JSIZE=1,NSIZE
        	AI(ISIZE,JSIZE)=R0
   	10   CONTINUE
        AI(ISIZE,ISIZE)=R1
20 CONTINUE
! LU decompose the matrix
CALL LUDCMPX(A    ,INDX  ,DUMMY,NSIZE ,NSIZE ,ERROR )
DETA=DUMMY
! Find inverse by columns
DO 30 ISIZE=1,NSIZE
	CALL LUBKSBX(A     ,AI(1,ISIZE),INDX  ,NSIZE ,NSIZE )
! Obtain determinant
        DETA=DETA*A(ISIZE,ISIZE)
30 CONTINUE
999 CONTINUE
RETURN
END


SUBROUTINE tide_pole_se (mjd,xp,yp , dC21,dS21)

! ----------------------------------------------------------------------
! SUBROUTINE: tide_pole_se.f90
! ----------------------------------------------------------------------
! Purpose:
!  Solid Earth pole tide effect to C21 and S21 spherical harmonic coefficients
!  of the geopotential harmonics expansion
! ----------------------------------------------------------------------
! Input arguments:
! - mjd   :			Modified Julian Day number in Terrestrial Time (TT)
!                  	including the fraction of the day
! Output arguments:
! - dC21  :  		C21 coefficient correction due to Solid Earth Pole Tide
! - dS21  :  		S21 coefficient correction due to Solid Earth Pole Tide
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	November 2015
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 30 October 2017:
!   The subroutine has been slightly modified in order to call the subroutine iau_JD2CAL.for from the IAU SOFA package
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: mjd, xp, yp
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: dC21,dS21
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: m1,m2
! ----------------------------------------------------------------------
! Remark:
!  Variables "epoch, xp_mean, yp_mean" enter F77 code and thus, these are declared as DP.
      REAL (KIND = prec_d) :: epoch, xp_mean, yp_mean
      !REAL*8 epoch, xp_mean,yp_mean
      INTEGER error,version
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: jd0
      INTEGER IY, IM, ID, J_flag
      DOUBLE PRECISION FD
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
jd0 = 2400000.5D0
CALL iau_JD2CAL ( jd0, mjd, IY, IM, ID, FD, J_flag )

epoch = IY*1.D0 + IM/12.D0 + ID/365.25D0 + FD/365.25D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Conventional Mean Pole

!      epoch_int = INT (epoch)
!      IF (epoch_int >= 2010) THEN
!         version = 2015
!      ELSE IF (epoch_int < 2010 .AND. epoch_int >= 2003) THEN
!	     version = 2010
!      ELSE IF (epoch_int < 2003 .AND. epoch_int >= 2010)

	  version = 2015
      CALL IERS_CMP_2015   (version,epoch , xp_mean,yp_mean,error)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Wobble variables m1, m2 (in seconds of arc)
      m1 = xp - xp_mean
      m2 = -1.0D0 * (yp - yp_mean)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      dC21 = -1.333D-9 * (m1 + 0.0115D0 * m2)
      dS21 = -1.333D-9 * (m2 - 0.0115D0 * m1)
! ----------------------------------------------------------------------

END


!	Get multinomial probabilities for latent vector.  Place in densitym.
!	Input involves linear component linth, quadrature points quadpoint, quadratic components quadth, and quadrature weights quadweight.
function densitym(linth,quadpoint,quadth,quadweight)
implicit none
real(kind=8),intent(in)::linth(:),quadpoint(:,:),quadth(:,:),quadweight(:)
real(kind=8)::densitym(size(quadweight))
!	quad counts quadrature points.
integer::quad
!	rescale density with rescale.
real(kind=8)::rescale

do quad=1,size(quadweight)
	densitym(quad)=quadweight(quad)*exp(dot_product(quadpoint(:,quad),linth+matmul(quadth,quadpoint(:,quad))))
end do
rescale=1.0_8/sum(densitym)
densitym=rescale*densitym
return
end function densitym


      subroutine gaus3(x,p,y,dydp,mp)
      implicit none
      real*8 x,p,y,dydp
      integer mp
      dimension p(mp),dydp(mp)

      dydp(1)=exp(-0.5*(x-p(3))**2/p(2)**2)
      y=p(1)*dydp(1)
      dydp(2)=p(1)*(x-p(3))**2/p(2)**3 *dydp(1)
      dydp(3)=p(1)*(x-p(3))/p(2)**2 *dydp(1)
      return
      end


FUNCTION GET_LUMDIST(z)

  !compute luminosity distance to redshift z
  !assumes flat universe w/ only matter and lambda
  !assumes om0,ol0,H0 set in sps_vars.f90

  USE sps_vars; USE sps_utils, ONLY : tsum
  IMPLICIT NONE
  INTEGER :: i
  INTEGER, PARAMETER :: ii=10000
  REAL(SP), INTENT(in) :: z
  REAL(SP) :: get_lumdist, dhub
  REAL(SP), DIMENSION(ii) :: zz, hub

  !---------------------------------------------------------------!
  !---------------------------------------------------------------!

  get_lumdist = 0.0

  !Hubble distance in pc
  dhub = clight/1E13/H0*1E6

  DO i=1,ii
     zz(i) = REAL(i)/ii*z
  ENDDO

  hub = SQRT( om0*(1+zz)**3 + ol0 )

  get_lumdist = TSUM(zz,1/hub) * (1+z) * dhub

END FUNCTION GET_LUMDIST


      function dpolardiskdens(r,ctheta)
      z=r*ctheta
      s=r*sqrt(1.0 - ctheta*ctheta)
      dpolardiskdens=diskdensestimate(s,z)
      return
      end

      function diskdensestimate(s,z)

      include 'commonblocks'
c
      r=sqrt(s*s+z*z)
      t=sqrt(0.5d0)*(r-outdisk)/drtrunc
      t2=t*t
      if (t.lt.-5.0) then
         eerfc=1.
      elseif (t.lt.5.0) then
         eerfc=0.5*erfc(t)
      else
         eerfc=0
      endif
      if (r.gt.0.) then
         f=diskconst*eerfc*exp(-r/rdisk)
      else
         f=diskconst*eerfc
      endif
      zz=abs(z/zdisk)
      ezz=exp(-zz)
      e2zz=ezz*ezz
      tsech2=(2*ezz/(1+e2zz))**2
      diskdensestimate=f*tsech2

      return
      end

      function halodensity(r)

      include 'commonblocks'
      real nfwdens

      halodensity = nfwdens(r)*eerfc(r)

      return
      end

      function halodensprime(r)

      include 'commonblocks'
      real nfwdens, nfwdensprime

      halodensprime = nfwdens(r)*eerfcprime(r)+nfwdensprime(r)*eerfc(r)

      return
      end

      function halodens2prime(r)

      include 'commonblocks'
      real nfwdens, nfwdensprime, nfwdens2prime

      t1 = nfwdens2prime(r)*eerfc(r)
      t2 = 2.*nfwdensprime(r)*eerfcprime(r)
      t3 = nfwdens(r)*eerfc2prime(r)
      halodens2prime = t1 + t2 + t3
      return
      end

      function eerfc(r)

      include 'commonblocks'

      t=sqrt(0.5)*(r-chalo)/drtrunchalo
      t2=t*t
      if (t.lt.-4.) then
         eerfc=1.
      elseif (t.lt.4.) then
         eerfc=0.5*erfc(t)
      else
         eerfc=0
      endif

      return
      end

      function eerfcprime(r)

      include 'commonblocks'

      t=sqrt(0.5)*(r-chalo)/drtrunchalo
      t2=t*t

      if(t2.gt.16.) then
         eerfcprime = 0.
      else
         eerfcprime = -0.5*sqrt(2./pi)/drtrunchalo*exp(-t2)
      endif
      return
      end

      function eerfc2prime(r)

      include 'commonblocks'

      t=sqrt(0.5)*(r-chalo)/drtrunchalo
      t2=t*t

      if(t2.gt.16.) then
         eerfc2prime = 0.
      else
         eerfc2prime = 1./sqrt(pi)/drtrunchalo/drtrunchalo*t*exp(-t2)
      endif
C      write(77,*) r,eerfc2prime
      return
      end