cc      MODULE FEMUTIL
cc      CONTAINS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C         --G E N E R A L  F E M  S U B R O U T I N E S--              C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C STRAIN DISPLACEMENT INTERPOLATORS                                    C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM9:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 9-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE STDM9(NNE,NDOFEL,NTENS,XX,MCRD,B,DDET,R,S,XBAR)

      IMPLICIT REAL*8 (A-H,O-Z)

      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)

      DIMENSION XX(MCRD,NNE),B(NTENS,NDOFEL),P(2,NNE),AUX1(2,NNE),
     1          XJ(2,2),XJI(2,2)

C     Initialize arrays

      XBAR=ONE

C     Shape functions derivatives w.r.t natural coordinates

      CALL SFDER9(IELT,NDOFEL,NNE,R,S,P)

C     Computes the Jacobian operator and its determinant at point (r,s)

      CALL JACOPER(NNE,XJ,XX,P)
      DDET=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      AUX1=MATMUL(XJI,P)
C
C     Assembles B matrix.
C
      DO I=1,NNE
        II=2*(I-1)+1
        B(1,II)=AUX1(1,I)
        B(2,II+1)=AUX1(2,I)

        B(3,II)=AUX1(2,I)
        B(3,II+1)=AUX1(1,I)

        B(1,II+1)=0.0D0
        B(2,II  )=0.0D0

      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM8:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 8-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM8(NNE,NDOFEL,NTENS,XX,MCRD,B,DDET,R,S,XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(MCRD,NNE),B(NTENS,NDOFEL),P(2,NNE),AUX1(2,NNE),
     1          XJ(2,2),XJI(2,2)
C
C     Initialize arrays
C
      XBAR=ONE
C
C     Shape functions derivatives w.r.t natural coordinates
C
      CALL SFDER8(IELT,NDOFEL,NNE,R,S,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s)
C
      CALL JACOPER(NNE,XJ,XX,P)
      DDET=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
C
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      AUX1=MATMUL(XJI,P)
C
C     Assembles B matrix for a
C     Cosserat element.
C
      DO I=1,NNE
        II=2*(I-1)+1
        B(1,II)=AUX1(1,I)
        B(2,II+1)=AUX1(2,I)
        B(3,II)=AUX1(2,I)
        B(3,II+1)=AUX1(1,I)

        B(1,II+1)=0.0D0
        B(2,II  )=0.0D0

      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM4:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 4-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM4(NNE,NDOFEL,NTENS,XX,MCRD,B,DDET,R,S,XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(MCRD,NNE),B(NTENS,NDOFEL),P(2,NNE),AUX1(2,NNE),
     1          XJ(2,2),XJI(2,2)
C
C     Initialize arrays
C
      XBAR=ONE
C
C     Shape functions derivatives w.r.t natural coordinates
C
      CALL SFDER4(IELT,NDOFEL,NNE,R,S,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s)
C
      CALL JACOPER(NNE,XJ,XX,P)
      DDET=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
C
C     Computes the inverse of the Jacobian operator
C
      CALL JACINVE(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      AUX1=MATMUL(XJI,P)
C
C     Assembles B matrix.
C
      DO I=1,NNE
        II=2*(I-1)+1
        B(1,II)=AUX1(1,I)
        B(2,II+1)=AUX1(2,I)
        B(3,II)=AUX1(2,I)
        B(3,II+1)=AUX1(1,I)

        B(1,II+1)=0.0D0
        B(2,II  )=0.0D0
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM6:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 6-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM6(NNE,NDOFEL,NTENS,XX,MCRD,B,DDET,R,S,XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(MCRD,NNE),B(NTENS,NDOFEL),P(2,NNE),AUX1(2,NNE),
     1          XJ(2,2),XJI(2,2)
C
C     Initialize arrays
C
      XBAR=ONE
C
C     Shape functions derivatives w.r.t natural coordinates
C
      CALL SFDER6(IELT,NDOFEL,NNE,R,S,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s)
C
      CALL JACOPER(NNE,XJ,XX,P)
      DDET=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
C
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      AUX1=MATMUL(XJI,P)
C
C     Assembles B matrix.
C
      DO I=1,NNE
        II=2*(I-1)+1
        B(1,II)=AUX1(1,I)
        B(2,II+1)=AUX1(2,I)
        B(3,II)=AUX1(2,I)
        B(3,II+1)=AUX1(1,I)

        B(1,II+1)=0.0D0
        B(2,II  )=0.0D0

      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM8:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 8-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM3D8(NNE,NDOFEL,NTENS,XX,MCRD,B,DDET,R,S,T,
     1                   XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(MCRD,NNE),B(NTENS,NDOFEL),P(3,NNE),AUX1(3,NNE),
     1          XJ(3,3),XJI(3,3)
C
C     Initialize arrays
C
      XBAR=ONE
C
C     Shape functions derivatives w.r.t natural coordinates
C
ccccccccESTA RUTINA TAMBIÉN TIENE PROBLEMAS
C     CALL SFDER3D8(IELT,NDOFEL,NNE,R,S,T,P)
      CALL SFDER3D8(NDOFEL,NNE,R,S,T,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s,t)
C
      CALL JACOPER3D(NNE,XJ,XX,P)
      DD1= XJ(1,1)*(XJ(2,2)*XJ(3,3)-XJ(2,3)*XJ(3,2))
      DD2=-XJ(1,2)*(XJ(2,1)*XJ(3,3)-XJ(2,3)*XJ(3,1))
      DD3= XJ(1,3)*(XJ(2,1)*XJ(3,2)-XJ(2,2)*XJ(3,1))
      DDET= DD1+DD2+DD3
C
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE3D(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      AUX1=MATMUL(XJI,P)
C
C     Assembles B matrix for a
C     three dimensional element.
C
      DO I=1,NNE
        II=3*(I-1)+1
        B(1,II  )=AUX1(1,I)
        B(1,II+1)=0.0D0
        B(1,II+2)=0.0D0
C
        B(2,II  )=0.0D0
        B(2,II+1)=AUX1(2,I)
        B(2,II+2)=0.0D0
C
        B(3,II  )=0.0D0
        B(3,II+1)=0.0D0
        B(3,II+2)=AUX1(3,I)
C
        B(4,II  )=AUX1(2,I)
        B(4,II+1)=AUX1(1,I)
        B(4,II+2)=0.0D0
C
        B(5,II  )=AUX1(3,I)
        B(5,II+1)=0.0D0
        B(5,II+2)=AUX1(1,I)
C
        B(6,II  )=0.0D0
        B(6,II+1)=AUX1(3,I)
        B(6,II+2)=AUX1(2,I)
C
      END DO
C
      RETURN
C
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM8:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 8-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM3D10(NNE,NDOFEL,NTENS,XX,MCRD,B,DDET,R,S,T,
     1                   XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(MCRD,NNE),B(NTENS,NDOFEL),P(3,NNE),AUX1(3,NNE),
     1          XJ(3,3),XJI(3,3)
C
C     Initialize arrays
C
      XBAR=ONE
C
C     Shape functions derivatives w.r.t natural coordinates
C
      CALL SFDER3D10(NDOFEL,NNE,R,S,T,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s,t)
C
      CALL JACOPER3D(NNE,XJ,XX,P)
      DD1= XJ(1,1)*(XJ(2,2)*XJ(3,3)-XJ(2,3)*XJ(3,2))
      DD2=-XJ(1,2)*(XJ(2,1)*XJ(3,3)-XJ(2,3)*XJ(3,1))
      DD3= XJ(1,3)*(XJ(2,1)*XJ(3,2)-XJ(2,2)*XJ(3,1))
      DDET= DD1+DD2+DD3
C
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE3D(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      CALL MMULT(XJI,3,3,P,3,NNE,AUX1)
C
C     Assembles B matrix for a
C     three dimensional element.
C
      DO I=1,NNE
        II=3*(I-1)+1
        B(1,II  )=AUX1(1,I)
        B(1,II+1)=0.0D0
        B(1,II+2)=0.0D0
C
        B(2,II  )=0.0D0
        B(2,II+1)=AUX1(2,I)
        B(2,II+2)=0.0D0
C
        B(3,II  )=0.0D0
        B(3,II+1)=0.0D0
        B(3,II+2)=AUX1(3,I)
C
        B(4,II  )=AUX1(2,I)
        B(4,II+1)=AUX1(1,I)
        B(4,II+2)=0.0D0
C
        B(5,II  )=AUX1(3,I)
        B(5,II+1)=0.0D0
        B(5,II+2)=AUX1(1,I)
C
        B(6,II  )=0.0D0
        B(6,II+1)=AUX1(3,I)
        B(6,II+2)=AUX1(2,I)
C
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER3D8:GENERATES THE SHAPE FUNCTION DERIVATIVES     C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s , t                  C
C                                             i  j   k                 C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
C     SUBROUTINE SFDER3D8(IELT,NDOFEL,NNE,R,S,T,P)
      SUBROUTINE SFDER3D8(NDOFEL,NNE,R,S,T,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0 , QUARTER=0.25D0 , EIGTH =0.125D0)
C
      DIMENSION P(3,NNE)
C

      RP = ONE+R
      SP = ONE+S
      TP = ONE+T
      RM = ONE-R
      SM = ONE-S
      TM = ONE-T

C
C     3D LINEAR 8-NODED ELEMENT
C
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,1)= EIGTH*SP*TP
      P(1,2)=-EIGTH*SP*TP
      P(1,3)=-EIGTH*SM*TP
      P(1,4)= EIGTH*SM*TP
      P(1,5)= EIGTH*SP*TM
      P(1,6)=-EIGTH*SP*TM
      P(1,7)=-EIGTH*SM*TM
      P(1,8)= EIGTH*SM*TM
C
C     w.r.t.s
C
      P(2,1)= EIGTH*RP*TP
      P(2,2)= EIGTH*RM*TP
      P(2,3)=-EIGTH*RM*TP
      P(2,4)=-EIGTH*RP*TP
      P(2,5)= EIGTH*RP*TM
      P(2,6)= EIGTH*RM*TM
      P(2,7)=-EIGTH*RM*TM
      P(2,8)=-EIGTH*RP*TM
C
C     w.r.t.t
C
      P(3,1)= EIGTH*RP*SP
      P(3,2)= EIGTH*RM*SP
      P(3,3)= EIGTH*RM*SM
      P(3,4)= EIGTH*RP*SM
      P(3,5)=-EIGTH*RP*SP
      P(3,6)=-EIGTH*RM*SP
      P(3,7)=-EIGTH*RM*SM
      P(3,8)=-EIGTH*RP*SM

C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER3D8:GENERATES THE SHAPE FUNCTION DERIVATIVES     C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s , t                  C
C                                             i  j   k                 C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SFDER3D10(NDOFEL,NNE,R,S,T,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0 , QUARTER=0.25D0 , EIGTH =0.125D0)
C
      DIMENSION P(3,NNE)
C

      RP = ONE+R
      SP = ONE+S
      TP = ONE+T
      RM = ONE-R
      SM = ONE-S
      TM = ONE-T

C
C     3D LINEAR 8-NODED ELEMENT
C
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,1)= EIGTH*SP*TP
      P(1,2)=-EIGTH*SP*TP
      P(1,3)=-EIGTH*SM*TP
      P(1,4)= EIGTH*SM*TP
      P(1,5)= EIGTH*SP*TM
      P(1,6)=-EIGTH*SP*TM
      P(1,7)=-EIGTH*SM*TM
      P(1,8)= EIGTH*SM*TM
C
C     w.r.t.s
C
      P(2,1)= EIGTH*RP*TP
      P(2,2)= EIGTH*RM*TP
      P(2,3)=-EIGTH*RM*TP
      P(2,4)=-EIGTH*RP*TP
      P(2,5)= EIGTH*RP*TM
      P(2,6)= EIGTH*RM*TM
      P(2,7)=-EIGTH*RM*TM
      P(2,8)=-EIGTH*RP*TM
C
C     w.r.t.t
C
      P(3,1)= EIGTH*RP*SP
      P(3,2)= EIGTH*RM*SP
      P(3,3)= EIGTH*RM*SM
      P(3,4)= EIGTH*RP*SM
      P(3,5)=-EIGTH*RP*SP
      P(3,6)=-EIGTH*RM*SP
      P(3,7)=-EIGTH*RM*SM
      P(3,8)=-EIGTH*RP*SM

C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE KJACOPER                                                C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE JACOPER3D(NNE,XJA,XCORD,RDER)

      IMPLICIT REAL*8 (A-H,O-Z)

      PARAMETER(ZERO=0.0D0)

      DIMENSION XJA(3,3),XCORD(3,NNE),RDER(3,NNE)
C
      DUM=ZERO
      DO K=1,3
        DO J=1,3
          DO I=1,NNE
            DUM=DUM+RDER(K,I)*XCORD(J,I)
          END DO
          XJA(K,J)=DUM
          DUM=ZERO
        END DO
      END DO

      RETURN

      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      3X3 Jacobian inverse                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE JACINVE3D(XJA,DD,XJAI)

      IMPLICIT REAL*8 (A-H,O-Z)

      DIMENSION XJA(3,3),XJAI(3,3),XADJ(3,3),XADJT(3,3)
C
      XADJT(1 , 1) =  XJA(2,2)*XJA(3,3)-XJA(2,3)*XJA(3,2)
      XADJT(1 , 2) =  XJA(2,1)*XJA(3,3)-XJA(2,3)*XJA(3,1)
      XADJT(1 , 3) =  XJA(2,1)*XJA(3,2)-XJA(2,2)*XJA(3,1)
C
      XADJT(2 , 1) =  XJA(1,2)*XJA(3,3)-XJA(1,3)*XJA(3,2)
      XADJT(2 , 2) =  XJA(1,1)*XJA(3,3)-XJA(1,3)*XJA(3,1)
      XADJT(2 , 3) =  XJA(1,1)*XJA(3,2)-XJA(1,2)*XJA(3,1)
C
      XADJT(3 , 1) =  XJA(1,2)*XJA(2,3)-XJA(1,3)*XJA(2,2)
      XADJT(3 , 2) =  XJA(1,1)*XJA(2,3)-XJA(1,3)*XJA(2,1)
      XADJT(3 , 3) =  XJA(1,1)*XJA(2,2)-XJA(1,2)*XJA(2,1)
C
      CALL MTRAN(XADJT,3,3,XADJ)
C
      DO J=1,3
        DO K=1,3
          COFA=((-1)**(J+K))*XADJ(J,K)
          XJAI(J,K)=COFA/DD
        END DO
      END DO

      RETURN

      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE AMASS3D8(MASS,NDOFEL,RII,SII)                        C
C      Computes the mass matrix for an 8-noded element                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE AMASS3D8(AMASS,NDOFEL,RII,SII,TII)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (NTENS=3)

      DIMENSION SF(NTENS,NDOFEL),SFT(NDOFEL,NTENS),SN(8),
     1          AUX1(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL)

      CALL CLEAR(SF,NTENS,NDOFEL)
      CALL CLEAR(SFT,NDOFEL,NTENS)
      CALL SHAPEF3D8(SN,RII,SII,TII)
C
      DO I=1,8
        KK=3*(I-1)+1
        SF(1,  KK)=SN(I)
        SF(2,KK+1)=SN(I)
        SF(3,KK+2)=SN(I)
C
      END DO

      CALL MTRAN(SF,NTENS,NDOFEL,SFT)
      CALL MMULT(SFT,NDOFEL,NTENS,SF,NTENS,NDOFEL,AUX1)

      DO I=1,NDOFEL
        DO J=1,NDOFEL
          AMASS(I,J)=AUX1(I,J)
        END DO
      END DO
C
      RETURN

      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE AMASS3D8(MASS,NDOFEL,RII,SII)                        C
C      Computes the mass matrix for an 8-noded element                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE AMASS3D10(AMASS,NDOFEL,RII,SII,TII)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (NTENS=3)

      DIMENSION SF(NTENS,NDOFEL),SFT(NDOFEL,NTENS),SN(8),
     1          AUX1(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL)

      CALL CLEAR(SF,NTENS,NDOFEL)
      CALL CLEAR(SFT,NDOFEL,NTENS)
      CALL SHAPEF3D8(SN,RII,SII,TII)
C
      DO I=1,8
        KK=3*(I-1)+1
        SF(1,  KK)=SN(I)
        SF(2,KK+1)=SN(I)
        SF(3,KK+2)=SN(I)
C
      END DO

      CALL MTRAN(SF,NTENS,NDOFEL,SFT)
      CALL MMULT(SFT,NDOFEL,NTENS,SF,NTENS,NDOFEL,AUX1)

      DO I=1,NDOFEL
        DO J=1,NDOFEL
          AMASS(I,J)=AUX1(I,J)
        END DO
      END DO
C
      RETURN

      END

C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF8(SN,R,S)                                      C
C      8-noded element shape function at point R,S                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SHAPEF3D8(SN,R,S,T)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0,EIGTH =0.125D0)
C
      DIMENSION SN(8)
C
      CALL CLEARV(SN,8)
C
      RP =ONE+R
      RM =ONE-R
      SP =ONE+S
      SM =ONE-S
      TP =ONE+T
      TM =ONE-T
C
      SN(1)= EIGTH*RP*SP*TP
      SN(2)= EIGTH*RM*SP*TP
      SN(3)= EIGTH*RM*SM*TP
      SN(4)= EIGTH*RP*SM*TP
      SN(5)= EIGTH*RP*SP*TM
      SN(6)= EIGTH*RM*SP*TM
      SN(7)= EIGTH*RM*SM*TM
      SN(8)= EIGTH*RP*SM*TM
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF8(SN,R,S)                                      C
C      8-noded element shape function at point R,S                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SHAPEF3D10(SN,R,S,T)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0,EIGTH =0.125D0)
C
      DIMENSION SN(8)
C
      CALL CLEARV(SN,8)
C
      RP =ONE+R
      RM =ONE-R
      SP =ONE+S
      SM =ONE-S
      TP =ONE+T
      TM =ONE-T
C
      SN(1)= EIGTH*RP*SP*TP
      SN(2)= EIGTH*RM*SP*TP
      SN(3)= EIGTH*RM*SM*TP
      SN(4)= EIGTH*RP*SM*TP
      SN(5)= EIGTH*RP*SP*TM
      SN(6)= EIGTH*RM*SP*TM
      SN(7)= EIGTH*RM*SM*TM
      SN(8)= EIGTH*RP*SM*TM
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SHAPE FUNCTIONS AND THEIR DERIVATIVES                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER9:GENERATES THE SHAPE FUNCTION DERIVATIVES       C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s                      C
C                                             i  j                     C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SFDER9(IELT,NDOFEL,NNE,R,S,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0,TWO=2.D0, HALF=0.5D0,QUARTER=0.25D0,FOUR=4.D0)
C
      DIMENSION P(2,NNE)
C
      RP= ONE+R
      SP= ONE+S
      RM= ONE-R
      SM= ONE-S
      RMS=ONE-R**TWO
      SMS=ONE-S**TWO
C
C     9-NODED ELEMENT
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,9)=-TWO*R*SMS
      P(1,8)=-HALF*SMS-HALF*P(1,9)
      P(1,7)=-R*SP-HALF*P(1,9)
      P(1,6)= HALF*SMS-HALF*P(1,9)
      P(1,5)=-R*SM-HALF*P(1,9)
      P(1,4)=-QUARTER*SP-HALF*P(1,7)-HALF*P(1,8)-QUARTER*P(1,9)
      P(1,3)= QUARTER*SP-HALF*P(1,7)-HALF*P(1,6)-QUARTER*P(1,9)
      P(1,2)= QUARTER*SM-HALF*P(1,5)-HALF*P(1,6)-QUARTER*P(1,9)
      P(1,1)=-QUARTER*SM-HALF*P(1,8)-HALF*P(1,5)-QUARTER*P(1,9)
C
C        w.r.t.s
C
      P(2,9)=-TWO*S*RMS
      P(2,8)=-S*RM-HALF*P(2,9)
      P(2,7)= HALF*RMS-HALF*P(2,9)
      P(2,6)=-S*RP-HALF*P(2,9)
      P(2,5)=-HALF*RMS-HALF*P(2,9)
      P(2,4)= QUARTER*RM-HALF*P(2,7)-HALF*P(2,8)-QUARTER*P(2,9)
      P(2,3)= QUARTER*RP-HALF*P(2,7)-HALF*P(2,6)-QUARTER*P(2,9)
      P(2,2)=-QUARTER*RP-HALF*P(2,5)-HALF*P(2,6)-QUARTER*P(2,9)
      P(2,1)=-QUARTER*RM-HALF*P(2,8)-HALF*P(2,5)-QUARTER*P(2,9)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER8:GENERATES THE SHAPE FUNCTION DERIVATIVES       C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s                      C
C                                             i  j                     C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SFDER8(IELT,NDOFEL,NNE,R,S,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0,TWO=2.D0, HALF=0.5D0,QUARTER=0.25D0,FOUR=4.D0)
C
      DIMENSION P(2,NNE)
C
      RP= ONE+R
      SP= ONE+S
      RM= ONE-R
      SM= ONE-S
      RMS=ONE-R**TWO
      SMS=ONE-S**TWO
C
C     8-NODED ELEMENT
C
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,6)= HALF*SMS
      P(1,5)=-R*SM
      P(1,8)=-HALF*SMS
      P(1,7)=-R*SP
      P(1,2)= QUARTER*SM-HALF*P(1,5)-HALF*P(1,6)
      P(1,1)=-QUARTER*SM-HALF*P(1,8)-HALF*P(1,5)
      P(1,4)=-QUARTER*SP-HALF*P(1,7)-HALF*P(1,8)
      P(1,3)= QUARTER*SP-HALF*P(1,7)-HALF*P(1,6)
C
C     w.r.t.s
C
      P(2,6)=-S*RP
      P(2,5)=-HALF*RMS
      P(2,8)=-S*RM
      P(2,7)= HALF*RMS
      P(2,2)=-QUARTER*RP-HALF*P(2,5)-HALF*P(2,6)
      P(2,1)=-QUARTER*RM-HALF*P(2,8)-HALF*P(2,5)
      P(2,4)= QUARTER*RM-HALF*P(2,7)-HALF*P(2,8)
      P(2,3)= QUARTER*RP-HALF*P(2,7)-HALF*P(2,6)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER4:GENERATES THE SHAPE FUNCTION DERIVATIVES       C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s                      C
C                                             i  j                     C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SFDER4(IELT,NDOFEL,NNE,R,S,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0,TWO=2.D0,HALF=0.5D0,QUARTER=0.25D0,FOUR=4.D0)
C
      DIMENSION P(2,NNE)
C
      RP= ONE+R
      SP= ONE+S
      RM= ONE-R
      SM= ONE-S
      RMS=ONE-R**TWO
      SMS=ONE-S**TWO
C
C     4-NODED ELEMENT
C
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,2)= QUARTER*SM
      P(1,1)=-QUARTER*SM
      P(1,4)=-QUARTER*SP
      P(1,3)= QUARTER*SP
C
C     w.r.t.s
C
      P(2,2)=-QUARTER*RP
      P(2,1)=-QUARTER*RM
      P(2,4)= QUARTER*RM
      P(2,3)= QUARTER*RP
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER6:GENERATES THE SHAPE FUNCTION DERIVATIVES       C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s                      C
C                                             i  j                     C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SFDER6(IELT,NDOFEL,NNE,R,S,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0,TWO=2.D0,THREE=3.0D0, HALF=0.5D0,
     1          QUARTER=0.25D0,FOUR=4.D0,EIGHT=8.0D0, ZERO=0.0D0)
C
      DIMENSION P(2,NNE)
C
C     6-NODED ELEMENT
C
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,6)=-FOUR*S
      P(1,5)= FOUR*S
      P(1,4)= FOUR-EIGHT*R-FOUR*S
      P(1,3)= ZERO
      P(1,2)= FOUR*R-ONE
      P(1,1)=-THREE+FOUR*R+FOUR*S
C
C     w.r.t.s
C
      P(2,6)= FOUR-FOUR*R-EIGHT*S
      P(2,5)= FOUR*R
      P(2,4)=-FOUR*R
      P(2,3)= FOUR*S-ONE
      P(2,2)= ZERO
      P(2,1)=-THREE+FOUR*R+FOUR*S
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF9(SN,R,S)                                      C
C      9-noded element shape function at point R,S                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SHAPEF9(SN,R,S)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0,HALF=0.5D0,QUART=0.25D0)
C
      DIMENSION SN(9)
C
      CALL CLEARV(SN,9)
C
      RP =ONE+R
      RM =ONE-R
      RMS=ONE-R*R
      SP =ONE+S
      SM =ONE-S
      SMS=ONE-S*S
C
      SN(9)=RMS*SMS
      SN(8)=HALF*SMS*RM-HALF*SN(9)
      SN(7)=HALF*RMS*SP-HALF*SN(9)
      SN(6)=HALF*SMS*RP-HALF*SN(9)
      SN(5)=HALF*RMS*SM-HALF*SN(9)
      SN(1)=QUART*RM*SM-HALF*SN(8)-HALF*SN(5)-QUART*SN(9)
      SN(2)=QUART*RP*SM-HALF*SN(6)-HALF*SN(5)-QUART*SN(9)
      SN(3)=QUART*RP*SP-HALF*SN(6)-HALF*SN(7)-QUART*SN(9)
      SN(4)=QUART*RM*SP-HALF*SN(8)-HALF*SN(7)-QUART*SN(9)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF8(SN,R,S)                                      C
C      8-noded element shape function at point R,S                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SHAPEF8(SN,R,S)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0,HALF=0.5D0,QUART=0.25D0)
C
      DIMENSION SN(8)
C
      CALL CLEARV(SN,8)
C
      RP =ONE+R
      RM =ONE-R
      RMS=ONE-R*R
      SP =ONE+S
      SM =ONE-S
      SMS=ONE-S*S
C
      SN(8)=HALF*SMS*RM
      SN(7)=HALF*RMS*SP
      SN(6)=HALF*SMS*RP
      SN(5)=HALF*RMS*SM
      SN(1)=QUART*RM*SM-HALF*SN(8)-HALF*SN(5)
      SN(2)=QUART*RP*SM-HALF*SN(6)-HALF*SN(5)
      SN(3)=QUART*RP*SP-HALF*SN(6)-HALF*SN(7)
      SN(4)=QUART*RM*SP-HALF*SN(8)-HALF*SN(7)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF4(SN,R,S)                                      C
C      4-noded element shape function at point R,S                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SHAPEF4(SN,R,S)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0,HALF=0.5D0,QUART=0.25D0)
C
      DIMENSION SN(4)
C
      CALL CLEARV(SN,4)
C
      RP =ONE+R
      RM =ONE-R
      RMS=ONE-R*R
      SP =ONE+S
      SM =ONE-S
      SMS=ONE-S*S
C
      SN(1)=QUART*RM*SM
      SN(2)=QUART*RP*SM
      SN(3)=QUART*RP*SP
      SN(4)=QUART*RM*SP
C
      RETURN
C
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF4DASH(SN,R,S)                                  C
C      4-noded element shape function at point R,S                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SHAPEF4DASH(SMN,R,S, KINC)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0,HALF=0.5D0,QUART=0.25D0)
C
      DIMENSION SN(4), SMN(12,3)

      RP =ONE+R
      RM =ONE-R
      SP =ONE+S
      SM =ONE-S

      SN(1)=QUART*RP*SP
      SN(2)=QUART*RM*SP
      SN(3)=QUART*RM*SM
      SN(4)=QUART*RP*SM

	  SMN=0.0D0

	  SMN( 1,1)= SN(1)
	  SMN( 4,1)= SN(2)
	  SMN( 7,1)= SN(3)
	  SMN(10,1)= SN(4)

	  SMN( 2,2)= SN(1)
	  SMN( 5,2)= SN(2)
	  SMN( 8,2)= SN(3)
	  SMN(11,2)= SN(4)

	  SMN( 3,3)= SN(1)
	  SMN( 6,3)= SN(2)
	  SMN( 9,3)= SN(3)
	  SMN(12,3)= SN(4)

      RETURN
C
      END

C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE KJACOPER                                                C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE JACOPER(NNE,XJA,XCORD,RDER)

      IMPLICIT REAL*8 (A-H,O-Z)

      PARAMETER(ZERO=0.0D0)

      DIMENSION XJA(2,2),XCORD(2,NNE),RDER(2,NNE)

      DUM=ZERO
      DO K=1,2
        DO J=1,2
          DO I=1,NNE
            DUM=DUM+RDER(K,I)*XCORD(J,I)
          END DO
          XJA(K,J)=DUM
          DUM=ZERO
        END DO
      END DO

      RETURN

      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      2X2 Jacobian inverse                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE JACINVE(XJA,DD,XJAI)

      IMPLICIT REAL*8 (A-H,O-Z)

      DIMENSION XJA(2,2),XJAI(2,2),XADJ(2,2)

      XADJ(1,1)=XJA(2,2)
      XADJ(1,2)=XJA(1,2)
      XADJ(2,1)=XJA(2,1)
      XADJ(2,2)=XJA(1,1)

      DO J=1,2
        DO K=1,2
          COFA=((-1)**(J+K))*XADJ(J,K)
          XJAI(J,K)=COFA/DD
        END DO
      END DO

      RETURN

      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE AMASS9(MASS,NDOFEL,RII,SII)                          C
C      Computes the mass matrix for an 8-noded element                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE AMASS9(AMASS,NDOFEL,RII,SII)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (NTENS=2)

      DIMENSION SF(NTENS,NDOFEL),SFT(NDOFEL,NTENS),SN(9),
     1          AUX1(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL)

      CALL SHAPEF9(SN,RII,SII)

      DO I=1,9
        KK=2*I-1
        SF(1,  KK)=SN(I)
        SF(2,KK+1)=SN(I)
        SF(2,  KK)=0.0D0
        SF(1,KK+1)=0.0D0
      END DO

      SFT=TRANSPOSE(SF)
      AUX1=MATMUL(SFT,SF)

      DO I=1,NDOFEL
        DO J=1,NDOFEL
          AMASS(I,J)=AUX1(I,J)
        END DO
      END DO

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE CMASS8(MASS,NDOFEL,RII,SII)                          C
C      Computes the mass matrix for an 8-noded element                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE AMASS8(AMASS,NDOFEL,RII,SII)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (NTENS=2)

      DIMENSION SF(NTENS,NDOFEL),SFT(NDOFEL,NTENS),SN(8),
     1          AUX1(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL)

      CALL SHAPEF8(SN,RII,SII)

      DO I=1,8
        KK=2*I-1
        SF(1,  KK)=SN(I)
        SF(2,KK+1)=SN(I)
        SF(2,  KK)=0.0D0
        SF(1,KK+1)=0.0D0
      END DO

      SFT=TRANSPOSE(SF)
      AUX1=MATMUL(SFT,SF)

      DO I=1,NDOFEL
        DO J=1,NDOFEL
          AMASS(I,J)=AUX1(I,J)
        END DO
      END DO

      RETURN

      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE CMASS6(MASS,NDOFEL,RII,SII)                          C
C      Computes the mass matrix for an 6-noded triangular element      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE AMASS6(AMASS,NDOFEL,RII,SII)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (NTENS=2)

      DIMENSION SF(NTENS,NDOFEL),SFT(NDOFEL,NTENS),SN(6),
     1          AUX1(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL)

      CALL SHAPEF6(SN,RII,SII)

      DO I=1,6
        KK=2*I-1
        SF(1,  KK)=SN(I)
        SF(2,KK+1)=SN(I)
        SF(2,  KK)=0.0D0
        SF(1,KK+1)=0.0D0
      END DO

      SFT=TRANSPOSE(SF)
      AUX1=MATMUL(SFT,SF)

      DO I=1,NDOFEL
        DO J=1,NDOFEL
          AMASS(I,J)=DCMPLX(AUX1(I,J))
        END DO
      END DO

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE CMASSA(MASS,NDOFEL,RII,SII)                          C
C      Computes the mass matrix for an 4-noded element                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE AMASS4(AMASS,NDOFEL,RII,SII)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (NTENS=2)

      DIMENSION SF(NTENS,NDOFEL),SFT(NDOFEL,NTENS),SN(4),
     1          AUX1(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL)

      CALL SHAPEF4(SN,RII,SII)

      DO I=1,4
        KK=2*I-1
        SF(1,  KK)=SN(I)
        SF(2,KK+1)=SN(I)
        SF(2,  KK)=0.0D0
        SF(1,KK+1)=0.0D0
      END DO

      SFT=TRANSPOSE(SF)
      AUX1=MATMUL(SFT,SF)

      DO I=1,NDOFEL
        DO J=1,NDOFEL
          AMASS(I,J)=AUX1(I,J)
        END DO
      END DO

      RETURN

      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF6(SN,R,S)                                      C
C      6-noded triangular element shape function at point R,S          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE SHAPEF6(SN,R,S)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ONE=1.0D0,HALF=0.5D0,FOUR=4.0D0, TWO=2.0D0)

      DIMENSION SN(6)

C     CALL CLEARV(SN,6)

      OMRMS=ONE-R-S

      SN(6)=FOUR*S*OMRMS
      SN(5)=FOUR*R*S
      SN(4)=FOUR*R*OMRMS
      SN(3)=TWO*S*(S-HALF)
      SN(2)=TWO*R*(R-HALF)
      SN(1)=TWO*(HALF-R-S)*OMRMS

      RETURN

      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE SHAPE1D                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE SHAPE1D(SM,ETA)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ONE=1.0D0,HALF=0.5D0)

      DIMENSION SM(6,2)

      EP=ONE+ETA
      EM=ONE-ETA
      EMS=ONE-ETA**2

      S11=HALF*EM-HALF*EMS
      S51=HALF*EP-HALF*EMS
      S31=EMS

      SM(1,1)=S11
      SM(2,2)=SM(1,1)
      SM(3,1)=S31
      SM(4,2)=SM(3,1)
      SM(5,1)=S51
      SM(6,2)=SM(5,1)

      SM(1,2)=0.0D0
      SM(2,1)=0.0D0
      SM(3,2)=0.0D0
      SM(4,1)=0.0D0
      SM(5,2)=0.0D0
      SM(6,1)=0.0D0

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE SHAPE1DM                                                C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE SHAPE1DM(SM,ETA)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ONE=1.0D0,HALF=0.5D0)

      DIMENSION SM(6,2)

      EP=ONE+ETA
      EM=ONE-ETA
      EMS=ONE-ETA**2

      S1=HALF*EM-HALF*EMS
      S2=HALF*EP-HALF*EMS
      S3=EMS

      SM(1,1)=S1
      SM(2,2)=SM(1,1)
      SM(3,1)=S2
      SM(4,2)=SM(3,1)
      SM(5,1)=S3
      SM(6,2)=SM(5,1)

      SM(1,2)=0.0D0
      SM(2,1)=0.0D0
      SM(3,2)=0.0D0
      SM(4,1)=0.0D0
      SM(5,2)=0.0D0
      SM(6,1)=0.0D0

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE SHAPE1D                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE SHAPEF31D(SM,ETA)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ONE=1.0D0,HALF=0.5D0)

      DIMENSION SM(3)

      EP=ONE+ETA
      EM=ONE-ETA
      EMS=ONE-ETA**2

      SM(1)=HALF*EM-HALF*EMS
      SM(2)=HALF*EP-HALF*EMS
      SM(3)=EMS

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE SHAPEMAT8                                               C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE SHAPEMAT8(SNN,SN)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION SNN(2,16),SN(8)

      DO II=1,8
        SNN(1,2*II-1)=SN(II)
        SNN(1,2*II  )=0.0
        SNN(2,2*II-1)=0.0
        SNN(2,2*II  )=SN(II)
      END DO

      RETURN

      END

cc      END MODULE FEMUTIL


program test
   use spherical_geometry
   implicit none

   real(8) :: x1,x2,y1,y2,d

   ! Points
   x1 = 0.d0;  y1 = 0.d0
   x2 = 0.d0;  y2 = 10.d0

!  Calcuate distance with Haversie
   d = delta (x1,y1,x2,y2,degrees=.true.)
   write(*,*) 'Haversine distance: ',d

!  Calculate distance with vincenty
   call dist_vincenty(x1,y2,x2,y2,d,degrees=.true.)
   write(*,*) 'Vincenty distance:  ',d

end program


!----------------------------------------------------------------------
! Openpipeflow.org.  If used in your work, please cite
! Willis, A. (2017) SoftwareX 6, 124-127.
! https://doi.org/10.1016/j.softx.2017.05.003 (open access)
!                                      Thanks in advance! Ashley 2019.
!----------------------------------------------------------------------
! solve A x = b for x ;
! minimise |Ax-b| subject to constraint |x| < delta .
! requires lapack routines dgelsy, dgesvd.
!----------------------------------------------------------------------
! m	  gmres dimension
! n 	  dimension of x
! x	  on input:  guess for x, can be 0
!         on exit:  solution x, subject to constraint if del>0
! b	  input b
! matvec  performs y := A x, call matvec(x, y)
! dotprd  dot product, d = dotprd(a,b)
! h       Hessian matrix,  size (m+1)*m
! v       Krylov subspace, size n*(m+1)
! res	  on input: |Ax-b|/|b|<res;
!         on exit:  residual reached
! del     on input: if(del>0) then the x returned is the hookstep
!         on exit:  norm of next b predicted by hook
! its	  on input: max num its;
!         on exit:  number of its taken
! info	  on input: if(info==1) print* residuals
!                   if(info==2) recalc hookstep with new del
! 	  on exit:  0 sucessful, 1 method breakdown, 2 max its
!							A.P.Willis 2008
!----------------------------------------------------------------------

 subroutine gmresm(m,n,x,b,matvec,dotprd,h,v,res,del,its,info,out)

   integer(i4),          intent(in)    :: m
   integer(i4),          intent(in)    :: n
   real(dp), intent(inout) :: x(n)
   real(dp), intent(in)    :: b(n)
   external :: matvec
   real(dp), external      :: dotprd
   real(dp), intent(inout) :: h(m+1,m)
   real(dp), intent(inout) :: v(n,m+1)
   real(dp), intent(inout) :: res
   real(dp), intent(inout) :: del
   integer(i4),          intent(inout) :: its
   integer(i4),          intent(inout) :: info
   integer(i4), intent(in) :: out
   real(dp) :: tol,res_,stgn, w(n), z(n)
   real(dp) :: h_(m+1,m), y(m+1), p(m+1), work(4*m+1)
   integer(i4) :: imx, piv(m), rank, i
   real(dp), save :: beta
   integer(i4), save :: j
   logical :: done

   if(info==2) then
      call hookstep(j,h,m,beta,del,y,out)
      z = matmul(v(:,1:j),y(1:j))
      x = z
      info = 0
      return
   end if

   tol = res
   imx = its
   its = 0
   v   = 0

 1 continue
   res_ = 1.0e99_dp
   stgn = 1.0_dp - 1.0e-14_dp

   beta = sqrt(dotprd(x,x))
   if(abs(beta)<small)  w = 0
   if(abs(beta)>=small) call matvec(x, w)
   w = b - w
   beta = sqrt(dotprd(w,w))
   v(:,1) = w / beta

   h = 0
   do j = 1, m
      its = its + 1
      z = v(:,j)
      call matvec(z, w)
      do i = 1, j
        ! Fixed a possible bug here, size of v(1,i) and w do not match
        ! And the Gram-Schmidt doesn't make sense otherwise
         h(i,j) = dotprd(w,v(:,i))
         w = w - h(i,j)*v(:,i)
      end do
      h(j+1,j) = sqrt(dotprd(w,w))
      v(:,j+1) = w / h(j+1,j)

      p(1) = beta
      p(2:j+1) = 0
      h_(1:j+1,1:j) = h(1:j+1,1:j)
      call dgelsy(j+1,j,1,h_,m+1,p,m+1,piv,m,rank,work,4*m+1,i)
      if(i/=0) then
        write(out, *) 'gmresm: dgelsy'
        flush(out)
        stop
      end if
      y = p

      p(1:j+1) = - matmul(h(1:j+1,1:j),y(1:j))
      p(1) = p(1) + beta
      res = sqrt(dot_product(p(1:j+1),p(1:j+1)))
      if(info==1) write(out, *)  'gmresm: it=', its,' res=', res

      done = (res<=tol .or. its==imx .or. res>res_)
      if(done .or. j==m) then
         if(del>0.0_dp)  call hookstep(j,h,m,beta,del,y,out)
         z = matmul(v(:,1:j),y(1:j))
         x = x + z
         if(its==imx) info = 2
         if(res>res_) info = 1
         if(res<=tol) info = 0
         if(done)     return
         if(del>0.0_dp)  write(out, *)  'gmres: warning! restart affects hookstep'
         goto 1       ! (j==m) restart
      end if
      res_ = res*stgn

   end do

 end subroutine gmresm

!-----------------------------------------------------------------
! replace y with a vector that generates a hookstep
! c.f. Viswanath (2008) arXiv:0809.1498
!-----------------------------------------------------------------
 subroutine hookstep(j,h,m,beta,del,y,out)

   integer(i4),          intent(in)    :: j, m
   real(dp), intent(in)    :: h(m+1,j), beta
   real(dp), intent(inout) :: del
   real(dp), intent(out)   :: y(j)
   integer(i4), intent(in) :: out
   real(dp) :: a(j+1,j), s(j), u(j+1,j+1), vt(j,j), work(5*(j+1))
   real(dp) :: p(j+1), q(j), mu, qn
   integer(i4) :: info

   a = h(1:j+1,1:j)

   call dgesvd('A','A',j+1,j,a,j+1,s,u,j+1,vt,j,work,5*(j+1),info)
   if(info/=0) then
        write(out,*) 'hookstep: dgesvd'
        flush(out)
        stop
   end if

   p(1:j) = beta * u(1,1:j)

   mu = max(s(j)*s(j)*1.0e-6_dp,1.0e-99_dp)
   qn = 1.0e99_dp
   do while(qn>del)
      mu = mu * 1.1_dp
      q = p(1:j)*s/(mu+s*s)
      qn = sqrt(dot_product(q,q))
   end do

   y = matmul(q,vt)

   p = - matmul(h(1:j+1,1:j),y(1:j))
   p(1) = p(1) + beta
   del = sqrt(dot_product(p,p))

 end subroutine hookstep


* ----------------------- BEGIN Abs_Spectra -------------------
      subroutine Abs_Spectra( datain, dt, npts, dc_remove,
     :    taper_front, taper_back, spect, npw2, signnpw2, df_fft,
     :    nzpad)

c Returns the absolute value of the spectrum.
c The program applies a tapered window to the
c front and back of the time series, pads with zeros,  and computes the
c spectrum.

c Written by D. M. Boore

* Dates:  3/22/89 - Modified from SqrSpectFT, by removing
*                   the smoothing and interpolation.
*        11/08/89 - Pass df_fft out through the argument list.
*         5/02/95 - Changed iprcntfrtaper to iprcnttaper
*         4/07/95 - Replaced prcntfrtaper as iprcntfrtaper (an integer).
*                   In some previous versions read in prcntfrtaper but
*                   intended it to be an integer.  I wonder
*                   how many bad results were obtained as a result
*                   of this error?!
*        02/10/99 - Minor cleanup, appended called routines to end
*        12/12/00 - Replaced iprctnfrtaper with frctnfrtaper (and subroutine
*                   fbctpr with tprfrctn).  Also replaced zeropad2 with
*                   zeropad, which accepts npw2 as in input, rather than an
*                   output argument.  I had to do this in order to use
*                   allocatable arrays.  I introduced signnpw2, which controls
*                   whether npw2 is less than npts (if signnpw2<0) or greater
*                   than npts, in which case zeros are added.
*        02/01/01 - Base allocation on larger of npts or npw2, and use npw2
*                   rather than npts in conditioning routines if npw2 < npts.
*        07/10/01 - Add nzpad to output parameters
*        11/10/01 - Correct calculation of nzpad
*        12/18/01 - Uses double precision version of FORK (FORKDP)
*        12/18/01 - Removed double precision version of Fork; it did not seem
*                   to make a difference.
*        02/09/10 - Replace prctnfrnttaper with length of tapers at front and back.
*                 - Reorder input slightly

      real DATAIN(*), SPECT(*)
      real DATA(:)
      complex CX(:)
      allocatable :: data, cx
      logical dc_remove, detrend

      call get_npw2(npts,signnpw2,npw2)

      n_alloc = max0(npw2, npts)
      allocate( data(n_alloc), cx(n_alloc))

c Fill working array with input data:

      do i = 1, npw2
        data(i) = 0.0
      end do

      n_condition = min0(npw2, npts)

      do i = 1, n_condition
        data(i) = datain(i)
      end do

c
c     remove dc, apply taper, pad with zeros
c
      detrend = .false.
      call dcdt(data, dt, n_condition, 1, n_condition,
     : dc_remove, detrend)

      data_length = dt * float(n_condition)
      frctnfront = taper_front/data_length
      frctnback =  taper_back/data_length
      call tprfrctn (frctnfront, frctnback, data, n_condition)

      if (npw2 .gt. npts) then
        call zeropad( data, npts, npw2)
        nzpad = npw2 - npts
      else
        nzpad = 0
      end if

c sample rate and frequency spacing:

      sr = 1.0 / dt
      df_fft = sr/ float(npw2)

      npw2d2 = npw2 / 2

c Fill working complex array

      do j = 1, npw2
        cx(j)=cmplx(data(j), 0.0)
      end do

c     FFT to get spectrum

*      call forkdp(npw2,cx,-1.)
      call fork(npw2,cx,-1.)

      do j =1 ,npw2d2
        cx(j)=cx(j)*dt*sqrt(float(npw2))
        spect(j)=cabs( cx(j) )
      end do

      deallocate( data, cx)

      return
      end
* ----------------------- END Abs_Spectra -------------------


	subroutine FFTSC( data, n, sin_values, cos_values, iwork, work,
     1                 cwork)
C
C this subroutine is to attempt to replace the functionality of the IMSL
C library routine to obtain the SIN and COS values of a real data fourier
C transform.  Written by R.E. Grandle 8/2/2005 ( NASA employee)
C Storage area increased from 20000 points to 132000 points - B.M.Sullivan
C                                                   8/2/2005 ( NASA employee)
C		and to 525000 - 8/5/2005
C		and to 1050000 - 8/15/2005
C
C  the actual fft transforms come from the NETLIB.ORG fftpack routines
C and is distributed as open source code.  The routines were developed
C by paul n swarztrauber national center
C       atmospheric research boulder,colorado 80307
C       in 1985
C some modification of the routines were done by R.E. Grandle to
C correct language changes in fortran since 1985
C
C
C  data       -- array containing the real numbers to be transformed
C  n          -- number of data points in the array
C  sin_values -- returned sin values -- dimension n + 2
C  cos_values -- returned cos values -- dimension n + 2
C  iwork      -- not used here for compatibility with IMSL routine
C  work       -- not used here for compatibility with IMSL routine
C  cwork      -- not used here for compatibility with IMSL routine
C
C
	integer big_number
	parameter (big_number=1050000)
	integer*4 n
	real*4 data( n), sin_values( n + 2), cos_values( n + 2)
C	real*4 wave( 20000)
	real*4 wave(big_number)
C
C Since I canned in a local array for the storage of the trig
C data, I will check and make sure that the caller did not want
C to do a transform of more data than I have room for in the trig
C array
C	if ( ( n *2) + 15 .gt. 20000) then
	if ( ( n *2) + 15 .gt. big_number) then
	   write( 6, 100)
100	   format( ' number of points requested in the transform'/
     1   ' exceeds default work space in fftsc -- edit source'/
     2   ' to increase size of work space')
           stop
             endif
C initialize the trig functions
	call RFFTI( n, wave)
C do the transform
	call RFFTF( n, data, wave)
C
C ok, now to return the values for the sin and cosine in the
C correct arrays and correct for the factor of 2 that floats around
C in the fourier transforms so that we give the same answers as
C IMSL routine
C
	cos_values( 1) = data( 1) * 2
	cos_values( 2) = data( 2) * 2
	do i = 3, n, 2
	   sin_values( ( i + 1)/ 2) =  - data( i ) * 2.
	   cos_values( ( i + 1)/ 2 + 1) = data( i +1 ) * 2.
             enddo
	return
	end
      SUBROUTINE RFFTF (N,R,WSAVE)
      DIMENSION       R(1)       ,WSAVE(1)
      IF (N .EQ. 1) RETURN
      CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
      SUBROUTINE RFFTI (N,WSAVE)
      DIMENSION       WSAVE(1)
      IF (N .EQ. 1) RETURN
      CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
      SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC)
      DIMENSION       CH(1)      ,C(1)       ,WA(1)      ,IFAC(15)
      NF = IFAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = IFAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
         CALL RADF2 (IDO,L1,C,CH,WA(IW))
         GO TO 110
  103    CALL RADF2 (IDO,L1,CH,C,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
         CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 110
  105    CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  107    CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
         CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         NA = 1
         GO TO 110
  109    CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      IF (NA .EQ. 1) RETURN
      DO 112 I=1,N
         C(I) = CH(I)
  112 CONTINUE
      RETURN
      END
      SUBROUTINE RFFTI1 (N,WA,IFAC)
      DIMENSION       WA(1)      ,IFAC(15)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      if( ( j - 4) .le. 0) then
          NTRY = NTRYH(J)
         else
          NTRY = NTRY+2
         endif
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR .ne. 0) goto 101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 6.28318530717959
      ARGH = TPI/FLOAT(N)
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 110 K1=1,NFM1
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         DO 109 J=1,IPM
            LD = LD+L1
            I = IS
            ARGLD = FLOAT(LD)*ARGH
            FI = 0.
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IS = IS+IDO
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END
      SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1)
      DIMENSION       CH(IDO,2,L1)           ,CC(IDO,L1,2)           ,
     1                WA1(1)
      DO 101 K=1,L1
         CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
  101 CONTINUE
	if ( (ido - 2) .lt. 0) goto 107
	if ( (ido - 2) .eq. 0) goto 105
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(1,2,K) = -CC(IDO,K,2)
         CH(IDO,1,K) = CC(IDO,K,1)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2)
      DIMENSION       CH(IDO,3,L1)           ,CC(IDO,L1,3)           ,
     1                WA1(1)     ,WA2(1)
      DATA TAUR,TAUI /-.5,.866025403784439/
      DO 101 K=1,L1
         CR2 = CC(1,K,2)+CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2
         CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
         CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  102    CONTINUE
  103 CONTINUE
      RETURN
      END
      SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
      DIMENSION       CC(IDO,L1,4)           ,CH(IDO,4,L1)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)
      DATA HSQT2 /.7071067811865475/
      DO 101 K=1,L1
         TR1 = CC(1,K,2)+CC(1,K,4)
         TR2 = CC(1,K,1)+CC(1,K,3)
         CH(1,1,K) = TR1+TR2
         CH(IDO,4,K) = TR2-TR1
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
         CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
  101 CONTINUE
	if ( ( ido - 2) .lt. 0) goto 107
	if ( ( ido - 2) .eq. 0) goto 105
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 CONTINUE
      DO 106 K=1,L1
         TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
         TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
         CH(IDO,1,K) = TR1+CC(IDO,K,1)
         CH(IDO,3,K) = CC(IDO,K,1)-TR1
         CH(1,2,K) = TI1-CC(IDO,K,3)
         CH(1,4,K) = TI1+CC(IDO,K,3)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      DIMENSION       CC(IDO,L1,5)           ,CH(IDO,5,L1)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)     ,WA4(1)
      DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
     1-.809016994374947,.587785252292473/
      DO 101 K=1,L1
         CR2 = CC(1,K,5)+CC(1,K,2)
         CI5 = CC(1,K,5)-CC(1,K,2)
         CR3 = CC(1,K,4)+CC(1,K,3)
         CI4 = CC(1,K,4)-CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2+CR3
         CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
         CH(1,3,K) = TI11*CI5+TI12*CI4
         CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
         CH(1,5,K) = TI12*CI5-TI11*CI4
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  102    CONTINUE
  103 CONTINUE
      RETURN
      END
      SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),
     2                CH2(IDL1,IP)           ,WA(1)
      DATA TPI/6.28318530717959/
      ARG = TPI/FLOAT(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP+2
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IF (IDO .EQ. 1) GO TO 119
      DO 101 IK=1,IDL1
         CH2(IK,1) = C2(IK,1)
  101 CONTINUE
      DO 103 J=2,IP
         DO 102 K=1,L1
            CH(1,K,J) = C1(1,K,J)
  102    CONTINUE
  103 CONTINUE
      IF (NBD .GT. L1) GO TO 107
      IS = -IDO
      DO 106 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 105 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 104 K=1,L1
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  104       CONTINUE
  105    CONTINUE
  106 CONTINUE
      GO TO 111
  107 IS = -IDO
      DO 110 J=2,IP
         IS = IS+IDO
         DO 109 K=1,L1
            IDIJ = IS
            DO 108 I=3,IDO,2
               IDIJ = IDIJ+2
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  108       CONTINUE
  109    CONTINUE
  110 CONTINUE
  111 IF (NBD .LT. L1) GO TO 115
      DO 114 J=2,IPPH
         JC = IPP2-J
         DO 113 K=1,L1
            DO 112 I=3,IDO,2
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  112       CONTINUE
  113    CONTINUE
  114 CONTINUE
      GO TO 121
  115 DO 118 J=2,IPPH
         JC = IPP2-J
         DO 117 I=3,IDO,2
            DO 116 K=1,L1
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  116       CONTINUE
  117    CONTINUE
  118 CONTINUE
      GO TO 121
  119 DO 120 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  120 CONTINUE
  121 DO 123 J=2,IPPH
         JC = IPP2-J
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
            C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
  122    CONTINUE
  123 CONTINUE
C
      AR1 = 1.
      AI1 = 0.
      DO 127 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 124 IK=1,IDL1
            CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
            CH2(IK,LC) = AI1*C2(IK,IP)
  124    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 126 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 125 IK=1,IDL1
               CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
               CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      DO 129 J=2,IPPH
         DO 128 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+C2(IK,J)
  128    CONTINUE
  129 CONTINUE
C
      IF (IDO .LT. L1) GO TO 132
      DO 131 K=1,L1
         DO 130 I=1,IDO
            CC(I,1,K) = CH(I,K,1)
  130    CONTINUE
  131 CONTINUE
      GO TO 135
  132 DO 134 I=1,IDO
         DO 133 K=1,L1
            CC(I,1,K) = CH(I,K,1)
  133    CONTINUE
  134 CONTINUE
  135 DO 137 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 136 K=1,L1
            CC(IDO,J2-2,K) = CH(1,K,J)
            CC(1,J2-1,K) = CH(1,K,JC)
  136    CONTINUE
  137 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IF (NBD .LT. L1) GO TO 141
      DO 140 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 139 K=1,L1
            DO 138 I=3,IDO,2
               IC = IDP2-I
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  138       CONTINUE
  139    CONTINUE
  140 CONTINUE
      RETURN
  141 DO 144 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 143 I=3,IDO,2
            IC = IDP2-I
            DO 142 K=1,L1
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  142       CONTINUE
  143    CONTINUE
  144 CONTINUE
      RETURN
      END


MODULE interp_functions
!
     USE def_variables
     USE def_constants

     IMPLICIT NONE
     PRIVATE
     PUBLIC :: Lin_int_Left_Low ,Lin_int_Left_High,Lin_int_Log10,&
&              Lin_TP_Log10,Lin_TP,Lin_int
!
!
     CONTAINS
!
! ===================================================================
!
!                         Lin_int_Left_Low
!
! ===================================================================
!
! It receives as input a couple of values (u_in, v_in),
! identifies the cell of the grid within the point is, and, finally,
! evaluates properties using the matrices already computed, by using
! a bilinear interpolation between the vertices of the cell.
!
! * Lin_int_Left_Low - linear scaling transformation and spline
!                      coefficients "linearly" determined
! ===================================================================
SUBROUTINE Lin_int_Left_Low(T_out, p_out, c_out, u_in, v_in)
!
! Global Variables
REAL(pr), INTENT(OUT) :: T_out, p_out, c_out
REAL(pr), INTENT(IN)  :: u_in, v_in
!
! Local Variables
INTEGER :: i, j
REAL(pr) :: x_mesh_test, delta_u, delta_v, v_min_li, v_max_li,v_max_li_log, &
&           T_down_left, T_down_right, T_up_left, T_up_right, &
&           p_down_left, p_down_right, p_up_left, p_up_right, &
&           c_down_left, c_down_right, c_up_left, c_up_right, &
&           DEN, A, B, D, E
!
! to identify the cell within the test-point is:
!
delta_u = y_mesh_LL(2) - y_mesh_LL(1)
i = INT((u_in - y_mesh_LL(1))/delta_u) + 1
!
! once that the interval on the vertical axis has been identified,
! it is possible to know the spline coefficients associated to it.
! By simply using them it is possible to evaluate the v_min_li
! (related to the pmax curve) and the v_max_li
! (related to the sat curve) for that u_in:
!
v_min_li = 0_pr
v_max_li = 0_pr
v_max_li_log = 0_pr
!
!
DO j = 1, ord_spline + 1
   v_min_li = v_min_li + spline_pmax_LL(ord_spline+2-j,i) * u_in**(j-1)
!Evaluate Vmin e Vmax, on the row i(high already identified)
   v_max_li = v_max_li + spline_Lsat_LL(ord_spline+2-j,i) * u_in**(j-1)
!   v_max_li_log = v_max_li_log + spline_Lsat_LL(ord_spline+2-j,i) * u_in**(j-1)
!   v_max_li     = 10_pr ** v_max_li_log
!Approximated through the spline
ENDDO
!
! Evaluation of x_mesh_test: Lin_int_Left_Low
! We have the X to identify
x_mesh_test = ((x_mesh_LL(MMM_LL) - x_mesh_LL(1)) / &
& (v_max_li - v_min_li)) * (v_in - v_min_li) + x_mesh_LL(1)
!x_mesh_test = ((x_mesh_LL(MMM_LL) - x_mesh_LL(1)) / (LOG10(v_max_li) - LOG10(v_min_li)))&
!&* (LOG10(v_in) - LOG10(v_min_li)) +  x_mesh_LL(1)
!
! to identify the interval on the horizontal axis
delta_v = x_mesh_LL(2) - x_mesh_LL(1)
j = INT((x_mesh_test - x_mesh_LL(1))/delta_v) + 1 !X of the cell identified
!
! once that the cell has been identified,
! it is possible to evaluate properties at the vertices:
T_down_left  = TTT_LL(i,j)
T_down_right = TTT_LL(i,j+1)
T_up_left    = TTT_LL(i+1,j)
T_up_right   = TTT_LL(i+1,j+1)
!
p_down_left  = ppp_LL(i,j)
p_down_right = ppp_LL(i,j+1)
p_up_left    = ppp_LL(i+1,j)
p_up_right   = ppp_LL(i+1,j+1)
!
c_down_left  = ccc_LL(i,j)
c_down_right = ccc_LL(i,j+1)
c_up_left    = ccc_LL(i+1,j)
c_up_right   = ccc_LL(i+1,j+1)
!
! Bilinear Interpolation:
!
DEN = (x_mesh_LL(j+1)- x_mesh_LL(j))*(y_mesh_LL(i)- y_mesh_LL(i+1))
A   = (x_mesh_LL(j+1)- x_mesh_test) *(y_mesh_LL(i)- u_in)
B   = (x_mesh_test   - x_mesh_LL(j))*(y_mesh_LL(i)- u_in)
D   = (x_mesh_LL(j+1)- x_mesh_test) *(u_in - y_mesh_LL(i+1))
E   = (x_mesh_test   - x_mesh_LL(j))*(u_in - y_mesh_LL(i+1))
!
T_out = (A/DEN) * T_up_left + (B/DEN) * T_up_right + (D/DEN) * T_down_left + &
&    (E/DEN) * T_down_right
!
p_out = (A/DEN) * p_up_left + (B/DEN) * p_up_right + (D/DEN) * p_down_left + &
&    (E/DEN) * p_down_right
!
c_out = (A/DEN) * c_up_left + (B/DEN) * c_up_right + (D/DEN) * c_down_left + &
&    (E/DEN) * c_down_right
!
END SUBROUTINE Lin_int_Left_Low
!
!
! ===================================================================
!
!                              Lin_int_Left_High
!
! ===================================================================
!
! It receives as input a couple of values (u_in, v_in),
! identifies the cell of the grid within the point is, and, finally,
! evaluates properties using the matrices already computed, by using
! a bilinear interpolation between the vertices of the cell.
!
! * Lin_int_Left_High - linear scaling transformation and spline
!                       coefficients "logaritmically" determined
!                       at the saturation
! ===================================================================
SUBROUTINE Lin_int_Left_High(T_out, p_out, c_out, u_in, v_in)
!
!
! Global Variables
REAL(pr), INTENT(OUT)  :: T_out, p_out, c_out
REAL(pr), INTENT(IN)    :: u_in, v_in
!
! Local Variables
INTEGER  :: i, j
REAL(pr)  :: x_mesh_test, delta_u, delta_v, v_min_li, v_max_li, v_max_li_log, &
&           T_down_left, T_down_right, T_up_left, T_up_right, &
&           p_down_left, p_down_right, p_up_left, p_up_right, &
&           c_down_left, c_down_right, c_up_left, c_up_right, &
&           DEN, A, B, D, E
!
!
! to identify the cell within the test-point is:
!
delta_u = y_mesh_LH(2)     - y_mesh_LH(1)
i       = INT((u_in - y_mesh_LH(1))/delta_u) + 1
!
! Initialization of v_min_li and v_max_li
v_min_li     = 0_pr
v_max_li     = 0_pr
v_max_li_log = 0_pr
!
DO j = 1, ord_spline + 1
   v_min_li     = v_min_li     + spline_pmax_LH(ord_spline+2-j,i) * u_in**(j-1)
   v_max_li     = v_max_li     + spline_Lsat_LH(ord_spline+2-j,i) * u_in**(j-1)
!   v_max_li_log = v_max_li_log + spline_Lsat_LH(ord_spline+2-j,i) * u_in**(j-1)
!   v_max_li     = 10_pr ** v_max_li_log
ENDDO
!
! Evaluation of x_mesh_test:
! In the middle of the LH region v is discretized logarithmic
x_mesh_test = ((x_mesh_LH(MMM_LH) - x_mesh_LH(1)) / (LOG10(v_max_li) - LOG10(v_min_li)))&
&* (LOG10(v_in) - LOG10(v_min_li)) +  x_mesh_LH(1)
!x_mesh_test = ((x_mesh_LH(MMM_LH) - x_mesh_LH(1)) / &
!& (v_max_li - v_min_li)) * (v_in - v_min_li) + x_mesh_LH(1)
!
! to identify the interval on the horizontal axis
delta_v = x_mesh_LH(2)     - x_mesh_LH(1)
j       = INT((x_mesh_test - x_mesh_LH(1))/delta_v) + 1
!
! once that the cell has been identified,it is possible to evaluate properties at the vertices:
T_down_left  = TTT_LH(i,j)
T_down_right = TTT_LH(i,j+1)
T_up_left    = TTT_LH(i+1,j)
T_up_right   = TTT_LH(i+1,j+1)
!
p_down_left  = ppp_LH(i,j)
p_down_right = ppp_LH(i,j+1)
p_up_left    = ppp_LH(i+1,j)
p_up_right   = ppp_LH(i+1,j+1)
!
c_down_left  = ccc_LH(i,j)
c_down_right = ccc_LH(i,j+1)
c_up_left    = ccc_LH(i+1,j)
c_up_right   = ccc_LH(i+1,j+1)
!
! Bilinear Interpolation:
!
DEN = (x_mesh_LH(j+1)- x_mesh_LH(j))* (y_mesh_LH(i)- y_mesh_LH(i+1))
A   = (x_mesh_LH(j+1)- x_mesh_test) * (y_mesh_LH(i)- u_in)
B   = (x_mesh_test   - x_mesh_LH(j))* (y_mesh_LH(i)- u_in)
D   = (x_mesh_LH(j+1)- x_mesh_test) * (u_in - y_mesh_LH(i+1))
E   = (x_mesh_test   - x_mesh_LH(j))* (u_in - y_mesh_LH(i+1))
!
T_out = (A/DEN) * T_up_left + (B/DEN) * T_up_right + (D/DEN) * T_down_left + &
&    (E/DEN) * T_down_right
!
p_out = (A/DEN) * p_up_left + (B/DEN) * p_up_right + (D/DEN) * p_down_left + &
&    (E/DEN) * p_down_right
!
c_out = (A/DEN) * c_up_left + (B/DEN) * c_up_right + (D/DEN) * c_down_left + &
&    (E/DEN) * c_down_right
!
END SUBROUTINE Lin_int_Left_High
!
!
!
! ===================================================================
!
!                              Lin_int_Log10
!
! ===================================================================
!
! It receives as input a couple of values (u_in, v_in),
! identifies the cell of the grid within the point is, and, finally,
! evaluates properties using the matrices already computed, by using
! a bilinear interpolation between the vertices of the cell.
!
! * Lin_int_Log10 - log scaling transformation
! note : 23/23/2017 not log scaling any more
! ===================================================================
!
SUBROUTINE Lin_int_Log10(T_out, p_out, c_out, u_in, v_in, NNN, MMM, x_mesh,&
&y_mesh, spline_pmin, spline_Vsat, TTT, ppp, ccc)
!
! Global Variables
REAL(pr), INTENT(OUT) :: T_out, p_out, c_out
REAL(pr), INTENT(IN)  :: u_in, v_in
INTEGER, INTENT(IN)  :: NNN, MMM
REAL(pr), DIMENSION(NNN), INTENT(IN)  :: y_mesh
REAL(pr), DIMENSION(MMM), INTENT(IN)  :: x_mesh
REAL(pr), DIMENSION(ord_spline+1,NNN-1), INTENT(IN) :: spline_pmin, spline_Vsat
REAL(pr), DIMENSION(NNN,MMM), INTENT(IN) :: TTT, ppp, ccc
!
! Local Variables
INTEGER  :: i, j
REAL(pr)  :: x_mesh_test, delta_u, delta_v, v_min_li, v_max_li, &
&            T_down_left, T_down_right, T_up_left, T_up_right, &
&            p_down_left, p_down_right, p_up_left, p_up_right, &
&            c_down_left, c_down_right, c_up_left, c_up_right, &
&            DEN, A, B, D, E
!
! to identify the cell within the test-point is:
!
delta_u = y_mesh(2) - y_mesh(1)
i       = INT((u_in - y_mesh(1))/delta_u) + 1 ! to identify the interval on the vertical axis
!
! Initialization of v_min_li and v_max_li
v_min_li = 0_pr
v_max_li = 0_pr
!
DO j = 1, ord_spline + 1
   v_min_li = v_min_li + spline_Vsat(ord_spline+2-j,i) * u_in**(j-1)
   v_max_li = v_max_li + spline_pmin(ord_spline+2-j,i) * u_in**(j-1)
ENDDO
!
! Evaluation of x_mesh_test:
!
x_mesh_test = ((x_mesh(MMM) - x_mesh(1)) / (LOG10(v_max_li) - LOG10(v_min_li)))&
&* (LOG10(v_in) - LOG10(v_min_li)) +  x_mesh(1)
!
!x_mesh_test = ((x_mesh(MMM) - x_mesh(1)) / (v_max_li - v_min_li))&
!&* (v_in - v_min_li) +  x_mesh(1)
!
delta_v = x_mesh(2) - x_mesh(1)
j = INT((x_mesh_test - x_mesh(1))/delta_v) + 1 ! to identify the interval on the horizontal axis
!
!
! once that the cell has been identified,
! it is possible to evaluate properties at the vertices:
!
T_down_left  = TTT(i,j)
T_down_right = TTT(i,j+1)
T_up_left    = TTT(i+1,j)
T_up_right   = TTT(i+1,j+1)
!
p_down_left  = ppp(i,j)
p_down_right = ppp(i,j+1)
p_up_left    = ppp(i+1,j)
p_up_right   = ppp(i+1,j+1)
!
c_down_left  = ccc(i,j)
c_down_right = ccc(i,j+1)
c_up_left    = ccc(i+1,j)
c_up_right   = ccc(i+1,j+1)
!
! Bilinear Interpolation:
!
DEN = (x_mesh(j+1) - x_mesh(j))   * (y_mesh(i) - y_mesh(i+1))
A   = (x_mesh(j+1) - x_mesh_test) * (y_mesh(i) - u_in)
B   = (x_mesh_test - x_mesh(j))   * (y_mesh(i) - u_in)
D   = (x_mesh(j+1) - x_mesh_test) * (u_in - y_mesh(i+1))
E   = (x_mesh_test - x_mesh(j))   * (u_in - y_mesh(i+1))
!
T_out = (A/DEN) * T_up_left + (B/DEN) * T_up_right + (D/DEN) * T_down_left + &
&    (E/DEN) * T_down_right
!
p_out = (A/DEN) * p_up_left + (B/DEN) * p_up_right + (D/DEN) * p_down_left + &
&    (E/DEN) * p_down_right
!
c_out = (A/DEN) * c_up_left + (B/DEN) * c_up_right + (D/DEN) * c_down_left + &
&    (E/DEN) * c_down_right
!
END SUBROUTINE Lin_int_Log10
!
!=============================================================================
!
!Bilinear_interp
!
!============================================================================
SUBROUTINE Lin_int(T_out, p_out, c_out, u_in, v_in, NNN, MMM, x_mesh,&
&y_mesh, spline_pmin, spline_Vsat, TTT, ppp, ccc)
!
! Global Variables
REAL(pr), INTENT(OUT) :: T_out, p_out, c_out
REAL(pr), INTENT(IN)  :: u_in, v_in
INTEGER, INTENT(IN)  :: NNN, MMM
REAL(pr), DIMENSION(NNN), INTENT(IN)  :: y_mesh
REAL(pr), DIMENSION(MMM), INTENT(IN)  :: x_mesh
REAL(pr), DIMENSION(ord_spline+1,NNN-1), INTENT(IN) :: spline_pmin, spline_Vsat
REAL(pr), DIMENSION(NNN,MMM), INTENT(IN) :: TTT, ppp, ccc
!
! Local Variables
INTEGER  :: i, j
REAL(pr)  :: x_mesh_test, delta_u, delta_v, v_min_li, v_max_li, &
&            T_down_left, T_down_right, T_up_left, T_up_right, &
&            p_down_left, p_down_right, p_up_left, p_up_right, &
&            c_down_left, c_down_right, c_up_left, c_up_right, &
&            DEN, A, B, D, E
!
! to identify the cell within the test-point is:
!
delta_u = y_mesh(2) - y_mesh(1)
i       = INT((u_in - y_mesh(1))/delta_u) + 1 ! to identify the interval on the vertical axis
!
! Initialization of v_min_li and v_max_li
v_min_li = 0_pr
v_max_li = 0_pr
!
DO j = 1, ord_spline + 1
   v_min_li = v_min_li + spline_Vsat(ord_spline+2-j,i) * u_in**(j-1)
   v_max_li = v_max_li + spline_pmin(ord_spline+2-j,i) * u_in**(j-1)
ENDDO
!
! Evaluation of x_mesh_test:
!
!
x_mesh_test = ((x_mesh(MMM) - x_mesh(1)) / (v_max_li - v_min_li))&
&* (v_in - v_min_li) +  x_mesh(1)
!
delta_v = x_mesh(2) - x_mesh(1)
j = INT((x_mesh_test - x_mesh(1))/delta_v) + 1 ! to identify the interval on the horizontal axis
!
!
! once that the cell has been identified,
! it is possible to evaluate properties at the vertices:
!
T_down_left  = TTT(i,j)
T_down_right = TTT(i,j+1)
T_up_left    = TTT(i+1,j)
T_up_right   = TTT(i+1,j+1)
!
p_down_left  = ppp(i,j)
p_down_right = ppp(i,j+1)
p_up_left    = ppp(i+1,j)
p_up_right   = ppp(i+1,j+1)
!
c_down_left  = ccc(i,j)
c_down_right = ccc(i,j+1)
c_up_left    = ccc(i+1,j)
c_up_right   = ccc(i+1,j+1)
!
! Bilinear Interpolation:
!
DEN = (x_mesh(j+1) - x_mesh(j))   * (y_mesh(i) - y_mesh(i+1))
A   = (x_mesh(j+1) - x_mesh_test) * (y_mesh(i) - u_in)
B   = (x_mesh_test - x_mesh(j))   * (y_mesh(i) - u_in)
D   = (x_mesh(j+1) - x_mesh_test) * (u_in - y_mesh(i+1))
E   = (x_mesh_test - x_mesh(j))   * (u_in - y_mesh(i+1))
!
T_out = (A/DEN) * T_up_left + (B/DEN) * T_up_right + (D/DEN) * T_down_left + &
&    (E/DEN) * T_down_right
!
p_out = (A/DEN) * p_up_left + (B/DEN) * p_up_right + (D/DEN) * p_down_left + &
&    (E/DEN) * p_down_right
!
c_out = (A/DEN) * c_up_left + (B/DEN) * c_up_right + (D/DEN) * c_down_left + &
&    (E/DEN) * c_down_right
!
END SUBROUTINE Lin_int
! ===================================================================
!
!                         Bilinear_interp_Log10_TP
!
! ===================================================================
!
! It receives as input a couple of values (u_in, v_in),
! identifies the cell of the grid within the point is, and, finally,
! evaluates properties using the matrices already computed, by using
! a bilinear interpolation between the vertices of the cell.
!
! * Lin_int_Log10 - log scaling transformation
! BUG: v_in ~ vsat => j=0 but 1<j<100
! ===================================================================
!
SUBROUTINE Lin_TP_Log10(T_out, p_out, c_out, x_out, u_in, v_in, NNN, MMM, x_mesh,&
&y_mesh, spline_pmin, spline_Vsat, TTT, ppp, ccc, xxx)
!
! Global Variables
REAL(pr), INTENT(OUT) :: T_out, p_out, c_out, x_out
REAL(pr), INTENT(IN)  :: u_in, v_in
INTEGER, INTENT(IN)  :: NNN, MMM
REAL(pr), DIMENSION(NNN), INTENT(IN)  :: y_mesh
REAL(pr), DIMENSION(MMM), INTENT(IN)  :: x_mesh
REAL(pr), DIMENSION(ord_spline+1,NNN-1), INTENT(IN) :: spline_pmin, spline_Vsat
REAL(pr), DIMENSION(NNN,MMM), INTENT(IN) :: TTT, ppp, ccc, xxx
!
! Local Variables
INTEGER  :: i, j
REAL(pr)  :: x_mesh_test, delta_u, delta_v, v_min_li, v_max_li, &
&            T_down_left, T_down_right, T_up_left, T_up_right, &
&            p_down_left, p_down_right, p_up_left, p_up_right, &
&            c_down_left, c_down_right, c_up_left, c_up_right, &
&            x_down_left, x_down_right, x_up_left, x_up_right, &
&            DEN, A, B, D, E
!
! to identify the cell within the test-point is:
!
delta_u = y_mesh(2) - y_mesh(1)
i       = INT((u_in - y_mesh(1))/delta_u) + 1 ! to identify the interval on the vertical axis
!
! Initialization of v_min_li and v_max_li
v_min_li = 0_pr
v_max_li = 0_pr
!
DO j = 1, ord_spline + 1
   v_min_li = v_min_li + spline_Vsat(ord_spline+2-j,i) * u_in**(j-1)
   v_max_li = v_max_li + spline_pmin(ord_spline+2-j,i) * u_in**(j-1)
ENDDO
!
! Evaluation of x_mesh_test:
!
!print*, x_mesh(MMM), x_mesh(1)
!print*, LOG10(v_max_li),LOG10(v_min_li)
!print*, LOG10(v_in),LOG10(v_min_li)
x_mesh_test = ((x_mesh(MMM) - x_mesh(1)) / (LOG10(v_max_li) - LOG10(v_min_li)))&
&* (LOG10(v_in) - LOG10(v_min_li)) +  x_mesh(1)
!
delta_v = x_mesh(2) - x_mesh(1)
j = INT((x_mesh_test - x_mesh(1))/delta_v) + 1 ! to identify the interval on the horizontal axis
! for v_in very close to the saturation curve
IF (j==0) THEN
    j=1
ENDIF
!print*, 'x_mesh_test', x_mesh_test, x_mesh(1),delta_v
!
! once that the cell has been identified,
! it is possible to evaluate properties at the vertices:
!
T_down_left  = TTT(i,j)
T_down_right = TTT(i,j+1)
T_up_left    = TTT(i+1,j)
T_up_right   = TTT(i+1,j+1)
!
p_down_left  = ppp(i,j)
p_down_right = ppp(i,j+1)
p_up_left    = ppp(i+1,j)
p_up_right   = ppp(i+1,j+1)
!print*, p_down_left,p_down_right,p_up_left,p_up_right
!print*, i,j
!
c_down_left  = ccc(i,j)
c_down_right = ccc(i,j+1)
c_up_left    = ccc(i+1,j)
c_up_right   = ccc(i+1,j+1)
!
x_down_left  = xxx(i,j)
x_down_right = xxx(i,j+1)
x_up_left    = xxx(i+1,j)
x_up_right   = xxx(i+1,j+1)
!
! Bilinear Interpolation:
!
DEN = (x_mesh(j+1) - x_mesh(j))   * (y_mesh(i) - y_mesh(i+1))
A   = (x_mesh(j+1) - x_mesh_test) * (y_mesh(i) - u_in)
B   = (x_mesh_test - x_mesh(j))   * (y_mesh(i) - u_in)
D   = (x_mesh(j+1) - x_mesh_test) * (u_in - y_mesh(i+1))
E   = (x_mesh_test - x_mesh(j))   * (u_in - y_mesh(i+1))
!
T_out = (A/DEN) * T_up_left + (B/DEN) * T_up_right + (D/DEN) * T_down_left + &
&    (E/DEN) * T_down_right
!
p_out = (A/DEN) * p_up_left + (B/DEN) * p_up_right + (D/DEN) * p_down_left + &
&    (E/DEN) * p_down_right
!
c_out = (A/DEN) * c_up_left + (B/DEN) * c_up_right + (D/DEN) * c_down_left + &
&    (E/DEN) * c_down_right
!
x_out = (A/DEN) * x_up_left + (B/DEN) * x_up_right + (D/DEN) * x_down_left + &
&    (E/DEN) * x_down_right
!
END SUBROUTINE Lin_TP_Log10
!
!
! ===================================================================
!
!                         Bilinear_interp_TP
!
! ===================================================================
!
! It receives as input a couple of values (u_in, v_in),
! identifies the cell of the grid within the point is, and, finally,
! evaluates properties using the matrices already computed, by using
! a bilinear interpolation between the vertices of the cell.
!
! ===================================================================
!
SUBROUTINE Lin_TP(T_out, p_out, c_out, x_out, u_in, v_in, NNN, MMM, x_mesh,&
&y_mesh, spline_pmin, spline_Vsat, TTT, ppp, ccc, xxx)
!
! Global Variables
REAL(pr), INTENT(OUT) :: T_out, p_out, c_out, x_out
REAL(pr), INTENT(IN)  :: u_in, v_in
INTEGER, INTENT(IN)  :: NNN, MMM
REAL(pr), DIMENSION(NNN), INTENT(IN)  :: y_mesh
REAL(pr), DIMENSION(MMM), INTENT(IN)  :: x_mesh
REAL(pr), DIMENSION(ord_spline+1,NNN-1), INTENT(IN) :: spline_pmin, spline_Vsat
REAL(pr), DIMENSION(NNN,MMM), INTENT(IN) :: TTT, ppp, ccc, xxx
!
! Local Variables
INTEGER  :: i, j
REAL(pr)  :: x_mesh_test, delta_u, delta_v, v_min_li, v_max_li, &
&            T_down_left, T_down_right, T_up_left, T_up_right, &
&            p_down_left, p_down_right, p_up_left, p_up_right, &
&            c_down_left, c_down_right, c_up_left, c_up_right, &
&            x_down_left, x_down_right, x_up_left, x_up_right, &
&            DEN, A, B, D, E
!
! to identify the cell within the test-point is:
!
delta_u = y_mesh(2) - y_mesh(1)
i       = INT((u_in - y_mesh(1))/delta_u) + 1 ! to identify the interval on the vertical axis
!
! Initialization of v_min_li and v_max_li
v_min_li = 0_pr
v_max_li = 0_pr
!
DO j = 1, ord_spline + 1
   v_min_li = v_min_li + spline_Vsat(ord_spline+2-j,i) * u_in**(j-1)
   v_max_li = v_max_li + spline_pmin(ord_spline+2-j,i) * u_in**(j-1)
ENDDO
!
! Evaluation of x_mesh_test:
!
x_mesh_test = ((x_mesh(MMM) - x_mesh(1)) / &
& (v_max_li - v_min_li)) * (v_in - v_min_li) + x_mesh(1)
!
delta_v = x_mesh(2) - x_mesh(1)
j = INT((x_mesh_test - x_mesh(1))/delta_v) + 1 ! to identify the interval on the horizontal axis
!
!
! once that the cell has been identified,
! it is possible to evaluate properties at the vertices:
!
T_down_left  = TTT(i,j)
T_down_right = TTT(i,j+1)
T_up_left    = TTT(i+1,j)
T_up_right   = TTT(i+1,j+1)
!
p_down_left  = ppp(i,j)
p_down_right = ppp(i,j+1)
p_up_left    = ppp(i+1,j)
p_up_right   = ppp(i+1,j+1)
!
c_down_left  = ccc(i,j)
c_down_right = ccc(i,j+1)
c_up_left    = ccc(i+1,j)
c_up_right   = ccc(i+1,j+1)
!
x_down_left  = xxx(i,j)
x_down_right = xxx(i,j+1)
x_up_left    = xxx(i+1,j)
x_up_right   = xxx(i+1,j+1)
!
! Bilinear Interpolation:
!
DEN = (x_mesh(j+1) - x_mesh(j))   * (y_mesh(i) - y_mesh(i+1))
A   = (x_mesh(j+1) - x_mesh_test) * (y_mesh(i) - u_in)
B   = (x_mesh_test - x_mesh(j))   * (y_mesh(i) - u_in)
D   = (x_mesh(j+1) - x_mesh_test) * (u_in - y_mesh(i+1))
E   = (x_mesh_test - x_mesh(j))   * (u_in - y_mesh(i+1))
!
T_out = (A/DEN) * T_up_left + (B/DEN) * T_up_right + (D/DEN) * T_down_left + &
&    (E/DEN) * T_down_right
!
p_out = (A/DEN) * p_up_left + (B/DEN) * p_up_right + (D/DEN) * p_down_left + &
&    (E/DEN) * p_down_right
!
c_out = (A/DEN) * c_up_left + (B/DEN) * c_up_right + (D/DEN) * c_down_left + &
&    (E/DEN) * c_down_right
!
x_out = (A/DEN) * x_up_left + (B/DEN) * x_up_right + (D/DEN) * x_down_left + &
&    (E/DEN) * x_down_right
!
END SUBROUTINE Lin_TP

END MODULE interp_functions


module splineval
    use iso_c_binding
    use bspline_module
    use bspline_kinds_module, only: wp
    implicit none
    private
    integer,parameter :: order=4, derivative_no = 0
    type(bspline_1d) :: s1

    contains
        subroutine splineval_init(nx, x, fcn_1d) bind(C)
            integer,intent(in) :: nx
            real(wp),intent(in) :: x(nx), fcn_1d(nx)
            integer :: i
            s1 = bspline_1d(x,fcn_1d,order); if (.not. s1%status_ok()) error stop 'error initializing s1'
        end subroutine splineval_init

        subroutine classify(nx, x, y, c) bind(C)
            integer,intent(in) :: nx
            real(wp),intent(in) :: x(nx), y(nx)
            integer,intent(out) :: c(nx)
            real(wp) :: s1val
            integer :: i, iflag
            do i = 1, size(x)
                call s1%evaluate(x(i),derivative_no,s1val,iflag)
                c(i) = merge(1, -1, s1val > y(i)) ! 1,-1 to cancel out if summed
            end do
        end subroutine classify

        subroutine throw_darts(ndarts, nx, x, y, c) bind(C)
            !integer, parameter :: ndarts = 100
            integer,intent(in) :: ndarts, nx
            real(wp),intent(in) :: x(ndarts), y(ndarts)
            integer,intent(out) :: c(ndarts)
            integer :: i, iflag
            real(wp) :: sx(ndarts), sy(ndarts)

            ! Throw some test darts
            !call random_number(x)
            !call random_number(y)
            sx = x * nx !(nx - 1) + 1
            sy = y * nx !(2*nx) - nx
            call classify(nx, x, y, c)
        end subroutine throw_darts

        ! Points to plot the spline
        subroutine spline_dump(nx) bind(C)
            integer, parameter :: ndarts = 100
            integer,intent(in) :: nx
            real(wp) :: val, tx(nx*100), ty(nx*100), dartsx(ndarts), dartsy(ndarts)
            integer :: i, iflag, hits(ndarts), ntx
            ntx = nx*100

            tx = linspace(1._wp,dble(nx),ntx)

            ! Plot the interpolated line
            do i=1,ntx
                call s1%evaluate(tx(i),derivative_no,ty(i),iflag)
            end do

            ! Throw some test darts
            call throw_darts(ndarts, nx, dartsx, dartsy, hits)
            !call random_number(dartsx)
            !call random_number(dartsy)
            !dartsx = dartsx * (nx - 1) + 1
            !dartsy = dartsy * (2*nx) - nx
            !call classify(nx, dartsx, dartsy, hits)

            ! Write results
            open(9, file='interp.dat', form="unformatted", access='stream')
            write(9) ntx, tx, ty
            close(9)
            open(10, file='darts.dat', form="unformatted", access='stream')
            write(10) ndarts, dartsx, dartsy, hits
            close(10)
        end subroutine spline_dump

        ! Helpful translation of linspace from:
        ! http://www.math.unm.edu/~motamed/Teaching/F17/HPSC/fortran.html#more-on-arrays
        pure function linspace(a,b,n)
            implicit none
            real(wp),intent(in) :: a,b
            integer,intent(in) :: n
            real(wp) :: linspace(n)
            integer :: i
            linspace = a+(b-a)/(n-1)*[(i, i=0, n-1)]
        end function linspace
end module splineval


module basis_class

  implicit none

  private
  public :: basis

  ! Derived type for basis
  type :: basis

   contains

     procedure :: basis_vector_product
     procedure :: transposed_basis_vector_product

  end type basis

contains

   subroutine basis_vector_product(this, q, qprime)

    class(basis), intent(in) :: this
    real(8), intent(in)  :: q(3)
    real(8), intent(out) :: qprime(3)

    real(8) :: B(3,3)

    associate(r => 1.0d0, theta => 0.0d0, phi => 0.0d0)
      B(:,1) = [cos(theta)*sin(phi), sin(theta)*sin(phi), cos(phi)]
      B(:,2) = [-sin(theta), cos(theta), 0.0d0]
      B(:,3) = [cos(theta)*cos(phi), sin(theta)*cos(phi), -sin(phi)]
    end associate

    print *, B

    qprime = matmul(B, q)

!!$    associate(r => q(1), theta => q(2), z => q(3))
!!$      B(:,1) = [cos(theta), sin(theta), 0.0d0]
!!$      B(:,2) = [-sin(theta), cos(theta), 0.0d0]
!!$      B(:,3) = [0.0d0, 0.0d0, 1.0d0]
!!$    end associate

  end subroutine basis_vector_product

  pure subroutine transposed_basis_vector_product(this, q, qprime)

    class(basis), intent(in) :: this
    real(8), intent(in)  :: q(3)
    real(8), intent(out) :: qprime(3)

    real(8) :: B(3,3)

    associate(r => 1.0d0, theta => 0.0d0, phi => 0.0d0)
      B(:,1) = [cos(theta)*sin(phi), sin(theta)*sin(phi), cos(phi)]
      B(:,2) = [-sin(theta), cos(theta), 0.0d0]
      B(:,3) = [cos(theta)*cos(phi), sin(theta)*cos(phi), -sin(phi)]
    end associate

    qprime = matmul(transpose(B), q)

!!$    associate(r => q(1), theta => q(2), z => q(3))
!!$      B(:,1) = [cos(theta), sin(theta), 0.0d0]
!!$      B(:,2) = [-sin(theta), cos(theta), 0.0d0]
!!$      B(:,3) = [0.0d0, 0.0d0, 1.0d0]
!!$    end associate

  end subroutine transposed_basis_vector_product

end module basis_class