C --------------------------------------------------------------------
C --------------------------DINTEG------------------------------------
C Subroutine to perform a definite integral
C --------------------------------------------------------------------
      subroutine DINTEG(seism, dt2, nt2, output)
      implicit none
      integer                 :: nt2, i, j
      real                    :: dt2
      real, dimension(nt2)   :: seism, output

      output(1) = 0.0
      do i=2,nt2
         output(i) = output(i-1)+(seism(i-1)*dt2)+
     +              (seism(i)-seism(i-1))*(0.5)*dt2
      enddo

      end subroutine DINTEG
C --------------------------------------------------------------------
C --------------------------DIFF--------------------------------------
C Subroutine to differentiate (4th Order)
C central (-f(i+2)+8*f(i+1)-8*f(i-1)+f(i-2))/(12*hh);
C forward (-f(i+2)+4*f(i+1)-3*f(i))/(2*hh);
C backward (3*f(i)-4*f(i-1)+f(i-2))/(2*hh);
C --------------------------------------------------------------------
      subroutine DIFF(seism, dt2, nt2, output)
      implicit none
      integer                 :: nt2, i
      real                    :: dt2
      real, dimension(nt2)   :: seism, output

C Forward difference
      output(1) = (-seism(3)+4.0*seism(2)-3.0*seism(1))/(2.0*dt2)
      output(2) = (-seism(4)+4.0*seism(3)-3.0*seism(2))/(2.0*dt2)
C Central Difference
      do i=3,nt2-2
        output(i) = (-seism(i+2)+8.0*seism(i+1)-8.0*seism(i-1)+
     +               seism(i-2))/(12.0*dt2)
      enddo
C Backward Difference
      output(nt2-1) = (3.0*seism(nt2-1)-4.0*seism(nt2-2)+
     +                  seism(nt2-3))/(2.0*dt2)
      output(nt2)   = (3.0*seism(nt2)-4.0*seism(nt2-1)+
     +                  seism(nt2-2))/(2.0*dt2)

      end subroutine DIFF

      subroutine MYSIN(val, sum)
      implicit none
      real                  :: myval, val, sum, term, pi
      integer               :: n

      data pi/3.14159265358979323846/

      if (val .ge. 0) then
         myval=mod(val,2*pi)
      endif
      if (val .lt. 0) then
         myval=mod(val,-2*pi)
      endif
      sum=0.0
      term=myval
      do n=1,20
         sum=sum+term
         term=term*(-myval**2/(2*n*(2*n+1)))
      enddo

      end subroutine MYSIN

      subroutine MYCOS(val, sum)
      implicit none
      real                  :: myval, val, sum, term, pi
      integer               :: n

      data pi/3.14159265358979323846/

      myval=val+pi/2
      if (myval .ge. 0) then
         myval=mod(myval,2*pi)
      endif
      if (myval .lt. 0) then
         myval=mod(myval,-2*pi)
      endif
      myval=myval-pi/2

      sum=0.0
      term=1.0
      do n=1,20
         sum=sum+term
         term=term*(-myval**2/(2*n*(2*n-1)))
      enddo

      end subroutine MYCOS

C --------------------------------------------------------------------
C --------------------------FFT---------------------------------------
C Subroutine to FFT a vector
C exp(CMPLX(a,b)) = exp(a)*(cos(b)+i*sin(b))
C http://www.dspguide.com/ch8/6.htm
C---------------------------------------------------------------------
C New routine is modeled off of (and verified) Matlab routine
C --------------------------------------------------------------------
C This subroutine is based off of the psuedo-code in Numerical Recipes
C If sign = 1, routine performs DFT and output is real(odd), complex(even)
C If sign = -1, input is real(odd), complex(even) and output is all real
C --------------------------------------------------------------------
      subroutine FFT(DATA, n, isn)
      implicit none
      integer               :: n, nn, i, j, k, isn, M, Istep, Mmax
      real                  :: WR, WI, WPR, WPI, Wtemp, theta
      real                  :: tempR, tempI, pi, tempcos, tempsin
      real, dimension(n)    :: DATA, XXr, XXi, XXa

      data pi/3.14159265358979323846/

!      write(*,*)'nt =', n

      do k = 1,n
          XXr(k) = 0.0
          XXi(k) = 0.0
          do j = 1,n
             call MYSIN(-2.0*pi*(j-1)*(k-1)/n, tempsin)
             call MYCOS(-2.0*pi*(j-1)*(k-1)/n, tempcos)
!              XXr(k)=XXr(k)+DATA(j)*COS(-2.0*pi*REAL(isn*(j-1)*(k-1))/n)
!              XXi(k)=XXi(k)+DATA(j)*SIN(-2.0*pi*REAL(isn*(j-1)*(k-1))/n)
!              XXr(k)=XXr(k)+DATA(j)*COS(-2.0*pi*(j-1)*(k-1)/n)
!              XXi(k)=XXi(k)+DATA(j)*SIN(-2.0*pi*(j-1)*(k-1)/n)
              XXr(k)=XXr(k)+DATA(j)*tempcos
              XXi(k)=XXi(k)+DATA(j)*tempsin
          enddo
          XXa(k) = sqrt(XXr(k)**2+XXi(k)**2)
!          if(isn .EQ. -1) then
!             XXa(k) = XXa(k)/n
!          endif
      enddo

      DATA(:) = XXa(:)

C      nn = INT(n/2)
C      j = 1
C
C      do i = 1,n,2
C            if(j .GT. i) then
C                  tempR = DATA(j)
C                  tempI = DATA(j+1)
C                  DATA(j) = DATA(i)
C                  DATA(j+1) = DATA(i+1)
C                  DATA(i) = tempR
C                  DATA(i+1) = tempI
C            endif
C            M = nn
C 1000       if((M .GE. 2) .AND. (j .GT. M)) then
C                  j = j-M
C                  M = M/2
C            GOTO 1000
C            endif
C            j = j + M
C      enddo
C      Mmax = 2
C 2000 if(n .GT. Mmax) then
C            Istep = 2*Mmax
C            theta = 2*pi/real(isn*Mmax)
C            WPR = -2.0*SIN(0.50*theta)**2.0
C            WPI = SIN(theta)
C            WR  = 1.0
C            WI  = 0.0
C            do M = 1,Mmax, 2
C                  do i = M, n, Istep
C                        j = i+Mmax
C                        tempR = WR*DATA(j) - WI*DATA(j+1)
C                        tempI = WR*DATA(j+1) + WI*DATA(j)
C                        DATA(j) = DATA(i) - tempR
C                        DATA(j+1) = DATA(i+1) - tempI
C                        DATA(i) = DATA(i) + tempR
C                        DATA(i+1) = DATA(i+1) + tempI
C                  enddo
C                  Wtemp = WR
C                  WR = WR*WPR-WI*WPI+WR
C                  WI = WI*WPR+Wtemp*WPI+WI
C            enddo
C            Mmax = Istep
C      GOTO 2000
C      endif

      end subroutine FFT
C --------------------------------------------------------------------
C --------------------------GOF------------------------------------
C Computes the "goodness of fit" measure
C IN1 = Synthetic Data
C IN2 = Reference Data
C --------------------------------------------------------------------
      subroutine GOF(IN1, IN2, nt, nts, ntf, SSQ)
      implicit none
      integer                :: nts, ntf, i, j, k, nt
      real                   :: SSQ, pi, vv, vv2, STDV
      real                   :: ss, ss2, StDevIN1, z0, tmp
      real                   :: StDevR, StDevIN2, rr, rr2
      real, dimension(nt)    :: IN1, IN2, rVec, IN3, IN4
      real, dimension(20001) :: ErrVec
      data pi/3.14159265358979323846/

      call ERFVEC(ErrVec)

      SSQ      = 0.0
      vv       = 0.0
      vv2      = 0.0
      rr       = 0.0
      rr2      = 0.0
      StDevR   = 0.0
      StDevIN1 = 0.0
      StDevIN2 = 0.0

C Sum the vectors, the residuals and the component wise squares
      do i = nts,ntf
          ss       = ss + ABS(IN1(i))
          ss2      = ss2 + ABS(IN1(i))**2.0
          vv       = vv + ABS(IN2(i))
          vv2      = vv2 + ABS(IN2(i))**2.0
          rr       = rr + ABS(IN1(i)-IN2(i))
          rr2      = rr2 + ABS(IN1(i)-IN2(i))**2.0
          rVec(i)  = (IN1(i)-IN2(i))
      enddo
C Calculate the Means and the Means of the squares
          ss  = ss/(ntf-nts+1.0)
          ss2 = ss2/(ntf-nts+1.0)
          vv  = vv/(ntf-nts+1.0)
          vv2 = vv2/(ntf-nts+1.0)
          rr  = rr/(ntf-nts+1.0)
          rr2 = rr2/(ntf-nts+1.0)
C Calculate the Standard Deviations
          StDevIN1 = SQRT(ss2-ss**2.0)
          StDevIN2 = SQRT(vv2-vv**2.0)
C         StDevR   = SQRT(rr2-rr**2.0)
C Generate z0
C New GOF Measure
      tmp = 0.0
      vv  = 0.0
      rr  = 0.0
      z0  = 0.0
      SSQ = 0.0
      do i = nts,ntf
           rr =  SQRT((IN1(i)-IN2(i))**2.0)
           vv =  (IN1(i)+IN2(i))/2.0
	       if(vv .EQ. 0.0)then
		      tmp = 0.0
           else
		      tmp = rr/vv
           endif
           z0 = z0 + ErrVec(INT(tmp/0.0001)+1)
      enddo
C          z0 = SQRT(rr/vv)
          SSQ = z0/(ntf-nts+1.0)
C          call ERF(z0, SSQ)
C          STDV = StDevR/StDevIN2
      end subroutine GOF
C --------------------------------------------------------------------
C --------------------------GOFFS------------------------------------
C Computes the "goodness of fit" measure for the Fourier Spectrum
C IN1 = Synthetic Data
C IN2 = Reference Data
C --------------------------------------------------------------------
      subroutine GOFFS(INS, INR, nt, dt, freq1, freq2, SSQ)
      implicit none
      integer                :: nts, ntf, i, j, k, nt, wind
      real                   :: SSQ, pi, vv, vv2, STDV, freq1, freq2
      real                   :: ss, ss2, StDevIN1, z0, tmp, dt
      real                   :: StDevR, StDevIN2, rr, rr2
      real                   :: tempR, tempI
      real, dimension(nt)    :: rVec, INR, INS, INTT
      real, dimension(nt/2)  :: IN1, IN2, IN3, IN4, tmp1, tmp2
      real, dimension(20001) :: ErrVec
      data pi/3.14159265358979323846/

      call ERFVEC(ErrVec)

      SSQ      = 0.0
      vv       = 0.0
      vv2      = 0.0
      rr       = 0.0
      rr2      = 0.0
      StDevR   = 0.0
      StDevIN1 = 0.0
      StDevIN2 = 0.0

      wind = INT(0.1*dt*nt+1)

      nts = INT(freq1*dt*nt+1)
      ntf = INT(freq2*dt*nt+1)

C calculate the FFT
C      INTT = INR
C      call FFT(INR, nt, 1)
C      do i = 1,nt/2
C            tempR = (i-1)*2+1
C            tempI = (i)*2
C            IN1(i) = SQRT((INR(tempR)**2.0)+(INR(tempI)**2.0))
C      enddo
C      INR = INTT
C      INTT = INS
C
C      call FFT(INS, nt, 1)
C      do i = 1,nt/2
C            tempR = (i-1)*2+1
C            tempI = (i)*2
C            IN2(i) = SQRT((INS(tempR)**2.0)+(INS(tempI)**2.0))
C      enddo
C      INS = INTT

      call FFT(INR, nt, 1)
      call FFT(INS, nt, 1)

      do i = 1,nt/2
            IN1(i) = INR(i)
            IN2(i) = INS(i)

            IN3(i) = IN1(i)
            IN4(i) = IN2(i)
      enddo
C Smooth out the data
      do i = wind+1,(nt/2)-wind
            tmp1(i) = 0.0
            tmp2(i) = 0.0
            do j = -1*wind,wind,1
                  tmp1(i) = tmp1(i) + (IN1(i+j))
                  tmp2(i) = tmp2(i) + (IN2(i+j))
            enddo
            IN3(i) = tmp1(i)/REAL(wind*2.0+1.0)
            IN4(i) = tmp2(i)/REAL(wind*2.0+1.0)
      enddo

C Sum the vectors, the residuals and the component wise squares
C      do i = nts,ntf
C          ss       = ss + ABS(IN1(i))
C          ss2      = ss2 + ABS(IN1(i))**2.0
C          vv       = vv + ABS(IN2(i))
C          vv2      = vv2 + ABS(IN2(i))**2.0
C          rr       = rr + ABS(IN1(i)-IN2(i))
C          rr2      = rr2 + ABS(IN1(i)-IN2(i))**2.0
C          rVec(i)  = (IN1(i)-IN2(i))
C      enddo
C Calculate the Means and the Means of the squares
C          ss  = ss/(ntf-nts+1.0)
C          ss2 = ss2/(ntf-nts+1.0)
C          vv  = vv/(ntf-nts+1.0)
C          vv2 = vv2/(ntf-nts+1.0)
C          rr  = rr/(ntf-nts+1.0)
C          rr2 = rr2/(ntf-nts+1.0)
C Calculate the Standard Deviations
C          StDevIN1 = SQRT(ss2-ss**2.0)
C          StDevIN2 = SQRT(vv2-vv**2.0)
C         StDevR   = SQRT(rr2-rr**2.0)
C Generate z0
C New GOF Measure
      tmp = 0.0
      vv  = 0.0
      rr  = 0.0
      z0  = 0.0
      SSQ = 0.0
      do i = nts,ntf
           rr =  SQRT((IN3(i)-IN4(i))**2.0)
           vv =  (IN3(i)+IN4(i))/2.0
	       if(vv .EQ. 0.0)then
		      tmp = 0.0
           else
		      tmp = rr/vv
           endif
           z0 = z0 + ErrVec(INT(tmp/0.0001)+1)
      enddo
C          z0 = SQRT(rr/vv)
          SSQ = z0/(ntf-nts+1.0)
C          call ERF(z0, SSQ)
C          STDV = StDevR/StDevIN2
      end subroutine GOFFS
C --------------------------------------------------------------------
C --------------------------NORM--------------------------------------
C example ---> x**(2.5) = (x**(2+0.5)) = (x**2)*sqrt(x)
C --------------------------------------------------------------------
      subroutine NORM(IN1, nt, nts, ntf, nm, pwr)
      implicit none
      integer                :: nts, ntf, i, j, k, nt
      real                   :: nm, pwr, pi
      real, dimension(nt)    :: IN1
      data pi/3.14159265358979323846/

      nm = 0.0
C Calculate the norm
      do i = nts,ntf
          nm = nm + (IN1(i))**pwr
      enddo

      nm = nm**(1.0/pwr)

      end subroutine NORM
C --------------------------------------------------------------------
C --------------------------SpecComp----------------------------------
C Compares the two spectral response series by a binned method
C --------------------------------------------------------------------
      subroutine SpecComp(SPECS, SPECR, COMPMDEV)
      implicit none
      integer                :: i, j, k
      real                   :: pi
      real, dimension(12)    :: COMPMDEV
      integer, dimension(13) :: indVec
      real, dimension(991)  :: SPECS, SPECR, perList
      data pi/3.14159265358979323846/
      data indVec/1,31,51,76,118,201,451,951,961,991,1041,1091,1141/

      do j = 1,901
           perList(j) = 0.001*real(j-1)+0.1
      enddo
      do j = 902,991
           perList(j) = 0.1*real(j-901)+1.0
      enddo
C      write(*,*) 'period 1 ','-period 2-', ' Mean Deviation in Bracket'
      do i = 1,12
         COMPMDEV(i) = 0.0
         do j = indVec(i),indVec(i+1)
              COMPMDEV(i) = COMPMDEV(i) + ABS(SPECS(j)-SPECR(j))
         enddo
         COMPMDEV(i) = COMPMDEV(i)/(indVec(i+1)-indVec(i)+1)
C         write(*,*) perList(indVec(i)),perList(indVec(i+1)), COMPMDEV(i)
C     +              ,SPECS(j)
      enddo

      end subroutine SpecComp
C --------------------------------------------------------------------
C --------------------------NGAComp----------------------------------
C Compares the two spectral response series
C --------------------------------------------------------------------
      subroutine NGAComp(NGA, SPEC, COMPMDEV)
      implicit none
      integer                :: i, j, k
      real                   :: pi
      real, dimension(16)    :: NGA, SPEC, COMPMDEV
      data pi/3.14159265358979323846/

      do i = 1,16
         COMPMDEV(i) = (SPEC(i)-NGA(i))/NGA(i)
      enddo

      end subroutine NGAComp
C --------------------------------------------------------------------
C --------------------------organize----------------------------------
C Compares the two spectral response series
C --------------------------------------------------------------------
      subroutine organize(INPUT, OUTPUT2, num)
      implicit none
      integer                :: i, j, k, num
      real                   :: pi
      real, dimension(num)   :: INPUT, OUTPUT
      integer, dimension(num):: OUTPUT2
      data pi/3.14159265358979323846/

      OUTPUT(1) = minval(INPUT)
      do i = 2,num-1
         OUTPUT(i) = maxval(INPUT)
         do j = 1,num
            if(INPUT(j) .GT. OUTPUT(i-1) .AND.
     +         INPUT(j) .LT. OUTPUT(i)) then
               OUTPUT(i) = INPUT(j)
            endif
         enddo
      enddo
      OUTPUT(num) = maxval(INPUT)

      do i = 1,num
         do j = 1,num
            if(OUTPUT(i) .EQ. INPUT(j)) then
               OUTPUT2(j) = i
            endif
         enddo
      enddo

      end subroutine organize
C --------------------------------------------------------------------
C-------------------------MODEL BIAS----------------------------------
C BB_GOF_Hartzell
C Model Bias Abramson Somerville "Uncertainty in Numerical Strong Ground motions .."
C --------------------------------------------------------------------
      subroutine MODBIAS(INPUTR, INPUTS, numSta, numPts, B)
      implicit none
      integer                       :: i, j, k, numSta, numPts
      real                          :: pi
      real, dimension(numPts)       :: B
      real, dimension(numSta,numPts):: INPUTR, INPUTS
      data pi/3.14159265358979323846/

      do i = 1,numPts
         B(i) = 0.0
      enddo

      do i = 1,numPts
         do j = 1,numSta
             B(i) = B(i) + LOG(INPUTR(j,i)/INPUTS(j,i))
         enddo
         B(i) = B(i)/REAL(numSta)
      enddo

      end subroutine MODBIAS
C --------------------------------------------------------------------
C ------------------------MODEL ERROR---------------------------------
C BB_GOF_Hartzell
C Model Bias Abramson Somerville "Uncertainty in Numerical Strong Ground motions .."
C --------------------------------------------------------------------
      subroutine MODERROR(INPUTR, INPUTS, numSta, numPts, B, E)
      implicit none
      integer                       :: i, j, k, numSta, numPts
      real                          :: pi
      real, dimension(numPts)       :: B, E
      real, dimension(numSta,numPts):: INPUTR, INPUTS

      data pi/3.14159265358979323846/

      do i = 1,numPts
         E(i) = 0.0
      enddo

      do i = 1,numPts
         do j = 1,numSta
             E(i) = E(i) + (LOG(INPUTR(j,i)) - LOG(INPUTS(j,i))
     +              - B(i))**2.0
         enddo
         E(i) = SQRT(E(i)/REAL(numSta))
      enddo

      end subroutine MODERROR
C --------------------------------------------------------------------
C ----------------------------- ERF ----------------------------------
C Error function described by Scherbaum "On use of Response Spectral-Ref.."
C Returns a value between 0 and 1 ... one = perfect fit, zero error
C --------------------------------------------------------------------
      subroutine ERF(INPUT, OUTPUT)
      implicit none
      integer                       :: i, n
      real                          :: pi, INPUT, OUTPUT, t, z0
      real, dimension(10001)       :: eT, outT

      data pi/3.14159265358979323846/
      z0 = ABS(INPUT)
      OUTPUT = 0.0
      eT(1) = EXP(-(z0**2.0))

      do i=2,10001
         t     = z0+(REAL(i-1)*0.001)
         eT(i) = EXP(-(t**2.0))
         OUTPUT = OUTPUT+(eT(i-1)*0.001)+
     +              (eT(i)-eT(i-1))*(0.5)*0.001
      enddo

      OUTPUT = OUTPUT*(2.0/SQRT(pi))
      end subroutine ERF
C --------------------------------------------------------------------
C ----------------------------- ERFVEC ----------------------------------
C Error function described by Scherbaum "On use of Response Spectral-Ref.."
C Returns a value between 0 and 1 ... one = perfect fit, zero error
C --------------------------------------------------------------------
      subroutine ERFVEC(OUTPUT)
      implicit none
      integer                      :: i, n
      real                         :: pi, gg, rr, delX
      real, dimension(20001)       :: OUTPUT, qq

      data pi/3.14159265358979323846/
      delX = 0.0001
      OUTPUT(1) = 1.0
      qq(1) = 0.0

      do i = 2,20001
         gg = REAL(i-1)*delX
         rr = EXP(-(gg**2.0))
         qq(i) = qq(i-1)+(2.0/SQRT(pi))*rr*delX
         OUTPUT(i) = 1.0 - qq(i)
      enddo
C     OUTPUT(20001) = 0.0

      end subroutine ERFVEC
C --------------------------------------------------------------------
C ------------------- Cross - Correlation ----------------------------
C Compute the delay and the Cross - Correlation values
C Computes the "normalized" cross-correlation
C --------------------------------------------------------------------
      subroutine CROSSC(IN1, IN2, nt, dt, R, D)
      implicit none
      integer               :: i, nt, D, j, sft
      real                  :: pi, X, Y, XM, YM, XS, YS, X2, Y2, R
      real                  :: P1, P2, Dout, dt
      real, dimension(nt)   :: IN1, IN2, DEN, NUM
      real, dimension(2*nt) :: RR, IN3

      data pi/3.14159265358979323846/

      XM = 0.0
      YM = 0.0
      XS = 0.0
      P1 = 0.0
      P2 = 0.0

      do i=1,nt
         if(ABS(IN1(i)) .GT. P1) P1 = ABS(IN1(i))
         if(ABS(IN2(i)) .GT. P2) P2 = ABS(IN2(i))
         XM     = XM + IN1(i)
         YM     = YM + IN2(i)
         IN3(i) = IN2(i)
      enddo

C      XM = XM/nt
C      YM = YM/nt
      XM = 0.0
      YM = 0.0
      X2  = 0.0

      do i=nt+1,nt*2
         X2     = X2 + (IN1(i-nt)-XM)**2.0
         IN3(i) = IN2(i-nt)
      enddo

      XS = SQRT(X2)

C Calculate
      do i=0,nt-1
          Y2 = 0.0
          YS = 0.0
          NUM(i+1) = 0.0
         do j=1+i,nt+i
            NUM(i+1) = NUM(i+1) + (IN1(j-i)-XM)*(IN3(j)-YM)
            Y2 = Y2 + (IN3(j)-YM)**2.0
         enddo
          YS       = SQRT(Y2)
          DEN(i+1) = XS*YS
          RR(i+1)  = (NUM(i+1)/DEN(i+1))
      enddo

C calculate the cross-correlation without a shift
      X2 = 0.0
      Y2 = 0.0
      XM = 0.0
      do i=1,nt
         X2 = X2 + IN1(i)**2.0
         Y2 = Y2 + IN2(i)**2.0
         XM = XM + IN1(i)*IN2(i)
      enddo

      D = 0
      R = 0.0
      do i=1,nt
          if(RR(i) .GT. R) then
             D = (i-1)
          endif
      enddo

      IF(X2 .EQ. 0.0 .OR. Y2 .EQ. 0.0) then
          R = 0.0
      ELSE
          R = XM/(SQRT(X2)*SQRT(Y2))
      ENDIF
      IF(R .LT. 0.0) R = 0.0
      end subroutine CROSSC
C --------------------------------------------------------------------
C ------------------- Covariance ----------------------------
C Compute the covariance
C --------------------------------------------------------------------
      subroutine COVAR(IN1, IN2, nt, CV)
      implicit none
      integer               :: i, nt, D, j
      real                  :: pi, X, Y, XM, YM, CV
      real, dimension(nt)   :: IN1, IN2

      data pi/3.14159265358979323846/

      XM = 0.0
      YM = 0.0
      CV = 0.0

      do i=1,nt
         XM     = XM + IN1(i)
         YM     = YM + IN2(i)
      enddo

      XM = XM/nt
      YM = YM/nt

C Calculate
      do i=1,nt
          CV = CV + (IN1(i)-XM)*(IN2(i)-YM)
      enddo
      CV = CV/nt

      end subroutine COVAR
C --------------------------------------------------------------------
C --------------------------RESIZE------------------------------------
C Subroutine to resize the seismograms (Spline)
C --------------------------------------------------------------------
      subroutine ReSize(seism, output, dt, dt2, nt, nt2)
      implicit none
      integer              :: nt, nt2, i, j, k, loc1
      real                 :: a, b, c, d, dt, dt2, xn, xo
      real, dimension(nt)  :: seism, x1, dif1, dif2
      real, dimension(nt2) :: output, x2

      call DIFF(seism, dt, nt, dif1)
      call DIFF(dif1, dt, nt, dif2)

C Generate time vectors
      do i = 1,nt
          x1(i) = real(i-1)*dt
      enddo
      do i = 1,nt2
          x2(i) = real(i-1)*dt2
      enddo

C Evaluate a linear interploation between points
      output(1) = seism(1)
      output(nt2) = seism(nt)

      do j = 2,nt2-1
         loc1 = int(dt2*(j-1)/dt)+1
         d = seism(loc1)
         c = dif1(loc1)
         b = dif2(loc1)/2.0
         a = (seism(loc1+1) - b*(dt**2.0) - c*dt - d)/dt**3.0
         output(j) = a*(x2(j)-x1(loc1))**3.0+b*(x2(j)-x1(loc1))**2.0+
     +               c*(x2(j)-x1(loc1))+d
      enddo

      end subroutine ReSize
C --------------------------------------------------------------------
C ---------------------------PPMCC------------------------------------
C Pearson Product-Moment Correlation Coefficiant
C Determines how well a linear function can be fit to the variables X and Y
C --------------------------------------------------------------------
      subroutine PPMCC(XX, YY, nt, rr)
      implicit none
      integer              :: nt, i
      real                 :: rr, sx, sy, Xm, Ym
      real, dimension(nt)  :: XX, YY

      Xm = 0.0
      Ym = 0.0
      sx = 0.0
      sy = 0.0
      rr = 0.0

      do i = 1,nt
            Xm = Xm + XX(i)
            Ym = Ym + YY(i)
      enddo

      Xm = Xm/nt
      Ym = Ym/nt

      do i = 1,nt
            sx = sx + (XX(i)-Xm)**2.0
            sy = sy + (YY(i)-Ym)**2.0
      enddo

      sx = SQRT(sx/real(nt-1))
      sy = SQRT(sy/real(nt-1))

      do i = 1,nt
            rr = rr + ((XX(i)-Xm)/sx)*((YY(i)-Ym)/sy)
      enddo

      rr = rr/(nt-1)

C sX = sum of X vec, sXY = sum X*Y vec, sX2 = sum X**2.0
C      rho = (nt*sXY-sX*sY)/(SQRT(nt*sX2-sX**2)*SQRT(nt*sY2-sY**2))

      end subroutine PPMCC
C --------------------------------------------------------------------
C ---------------------------SRCC------------------------------------
C Spearman's Rank Correlation Coefficiant
C Determines how well a monotonic function can be fit to the variables X and Y
C --------------------------------------------------------------------
      subroutine SRCC(XX, YY, nt, rho)
      implicit none
      integer               :: nt, i, dd
      real               :: rho
      real, dimension(nt):: XX, YY
      integer, dimension(nt):: XI, YI

      call organize(XX, XI, nt)
      call organize(YY, YI, nt)

      dd  = 0.0
      rho = 0.0

      do i = 1,nt
            dd  = dd + (XI(i)-YI(i))**2.0
      enddo

      rho = 1.0 - 6.0*REAL(dd)/real(nt*(nt**2-1))

      end subroutine SRCC
C --------------------------------------------------------------------
C ---------------------------SDOTP------------------------------------
C Scaled Dot Product = Cos(Theta), Theta = angle between XX and YY vectors
C --------------------------------------------------------------------
      subroutine SDOTP(XX, YY, nt, CosT)
      implicit none
      integer               :: nt, i, dd
      real               :: CosT, SSqX, SSqY, SSqXY
      real, dimension(nt):: XX, YY

      SSqX  = 0.0
      SSqY  = 0.0
      SSqXY = 0.0
      CosT  = 0.0

      do i = 1,nt
            SSqX  = SSqX  + XX(i)**2.0
            SSqY  = SSqY  + YY(i)**2.0
            SSqXY = SSqXY + XX(i)*YY(i)
      enddo

      SSqX  = SQRT(SSqX)
      SSqY  = SQRT(SSQY)
      CosT  = SSqXY/(SSqX*SSqY)

      end subroutine SDOTP
C --------------------------------------------------------------------
C ---------------------------NGAROT------------------------------------
C Input a seismogram and get out the 17 values coresponding to the 50th
C percentile and possibly the standard deviations associated
C --------------------------------------------------------------------
      subroutine NGAROT(AcX, AcY, nt, dt, Per50)
      implicit none
      integer               :: nt, i, j, k, nuM
      real                  :: deg, pi, dt, tmpD, tmpDP, XR, YR
      real, dimension(nt)   :: XROT, YROT, AX, AY, AcX, AcY
      real, dimension(17)   :: Per50
      real, dimension(16)   :: period
      real, dimension(91,17):: values, ValOrg
      integer, dimension(91):: OrgList, penF

      data period/.1,.15,.2,.25,.3,.4,.5,.75,
     +1,1.5,2,3,4,5,7.5,10/

      data pi/3.14159265358979323846/
      do k = 1,16
           call RESPSPECNGA(AcX, dt, nt, period(k), AX)
           call RESPSPECNGA(AcY, dt, nt, period(k), AY)
           do i = 1,91
                deg = real(i-1)*pi/180.0

                do j = 1,nt
                     XROT(j) = COS(deg)*AX(j)+SIN(deg)*AY(j)
                     YROT(j) = COS(deg)*AY(j)-SIN(deg)*AX(j)
                enddo
                values(i,k) = SQRT(MAXVAL(ABS(XROT))*MAXVAL(ABS(YROT)))
           enddo
      enddo
      do i = 1,91
           deg = real(i-1)*pi/180.0

           do j = 1,nt
                XROT(j) = COS(deg)*AcX(j)+SIN(deg)*AcY(j)
                YROT(j) = COS(deg)*AcY(j)-SIN(deg)*AcX(j)
           enddo
           values(i,17) = SQRT(MAXVAL(ABS(XROT))*MAXVAL(ABS(YROT)))
      enddo

      do i = 1,17
           call organize(values(1:91,i), OrgList, 91)
           do j = 1,91
                ValOrg(OrgList(j),i) = values(j,i)
           enddo

           per50(i) = (ValOrg(46,i))
      enddo

C Compute the penalty function
      tmpDP = 10000.0
      nuM = 0

      do j = 1,91
           tmpD = 0.0
           do k = 1,17
                tmpD = tmpD + ((values(j,k)/per50(k))-1)**2
           enddo
           penF(j) = tmpD/17.0
           if(penF(j) .LT. tmpDP) then
              tmpDP = penF(j)
              nuM = j
           endif
      enddo

      do i = 1,17
         per50(i) = values(nuM,i)
      enddo

      end subroutine NGAROT
C --------------------------------------------------------------------


c function area.f
c
c source
c   Bevington, pages 272-273.
c
c purpose
c   integrate the area beneath a set of data points
c
c usage
c   result = area (x, y, npts, nterms)
c
c description of parameters
c   x	   - array of data points for independent variable
c   y	   - array of data points for dependent variable
c   npts   - number of pairs of data points
c   nterms - number of terms in fitting polynomial
c
c subroutines and function subprograms required
c   integ (x, y, nterms, i1, x1, x2 sum)
c      fits a polynomial with nterms starting at i1
c      and integrates area from x1 to x2
c
	function area (x,y,npts,nterms)
	double precision sum
	dimension x(1),y(1)
11	sum=0.
	if (npts-nterms) 21,21,13
13	neven=2*(nterms/2)
	idelta=nterms/2-1
	if (nterms-neven) 31,31,51
c
c fit all points with one curve
c
21	x1=x(1)
	x2=x(npts)
23	call integ (x,y,npts,1,x1,x2,sum)
	goto 71
c
c even number of terms
c
31	x1=x(1)
	j=nterms-idelta
	x2=x(j)
	call integ (x,y,nterms,1,x1,x2,sum)
	i1=npts-nterms+1
	j=i1+idelta
	x1=x(j)
	x2=x(npts)
39	call integ (x,y,nterms,i1,x1,x2,sum)
	if (i1-2) 71,71,41
41	imax=i1-1
	do 46 i=2,imax
	j=i+idelta
	x1=x(j)
	x2=x(j+1)
46	call integ (x,y,nterms,i,x1,x2,sum)
	goto 71
c
c odd number of terms
c
51	x1=x(1)
	j=nterms-idelta
	x2=(x(j)+x(j-1))/2.
	call integ (x,y,nterms,1,x1,x2,sum)
	i1=npts-nterms+1
	j=i1+idelta
	x1=(x(j)+x(j+1))/2.
	x2=x(npts)
59	call integ (x,y,nterms,i1,x1,x2,sum)
	if (i1-2) 71,71,61
61	imax=i1-1
	do 66 i=2,imax
	j=i+idelta
	x1=(x(j+1)+x(j))/2.
	x2=(x(j+2)+x(j+1))/2.
66	call integ (x,y,nterms,i,x1,x2,sum)
71	area=sum
	return
	end


PROGRAM dtest1
USE multidim_integrate
IMPLICIT NONE

INTEGER            :: key, n, mincls, maxcls, ifail, neval, nsub
INTEGER, PARAMETER :: ndim = 5, nf = ndim+1
REAL (dp)          :: a(ndim), b(ndim)
REAL (dp)          :: absest(nf), finest(nf), absreq, relreq

INTERFACE
  SUBROUTINE ftest(ndim, z, nfun, f)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
    INTEGER, INTENT(IN)    :: ndim, nfun
    REAL (dp), INTENT(IN)  :: z(:)
    REAL (dp), INTENT(OUT) :: f(:)
  END SUBROUTINE ftest
END INTERFACE

DO n = 1,ndim
  a(n) = 0
  b(n) = 1
END DO
mincls = 0
maxcls = 10000
key = 0
absreq = 0
relreq = 1.D-3
CALL dcuhre(ndim, nf, a, b, mincls, maxcls, ftest, absreq, relreq,  &
            key, 0, finest, absest, neval, ifail, nsub)
WRITE(*,9999) neval, ifail
9999 FORMAT ('        DCUHRE TEST RESULTS' // '     FTEST CALLS = ', i4,  &
	     ', IFAIL = ', i2 / '    N   ESTIMATED ERROR    INTEGRAL')
DO n = 1, nf
  WRITE(*, 9998) n, absest(n), finest(n)
  9998 FORMAT ("   ", i2, 2F15.6)
END DO
WRITE(*, '(a, i6)') ' No. of subregions generated = ', nsub

STOP
END PROGRAM dtest1

SUBROUTINE ftest(ndim, z, nfun, f)
IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
INTEGER, INTENT(IN)    :: ndim, nfun
REAL (dp), INTENT(IN)  :: z(:)
REAL (dp), INTENT(OUT) :: f(:)

! Local variables
INTEGER   :: n
REAL (dp) :: sum

sum = 0
DO n = 1, ndim
  sum = sum + n*z(n)**2
END DO
f(1) = EXP(-sum/2)
f(2:nfun) = f(1) * z(1:nfun-1)

RETURN
END SUBROUTINE ftest


program besselI0

   implicit none
   real(8) :: x,dx

   x = 0.
   dx = 0.1

   do while (x <= 4.)
      write(*,*) x,BessI0(x)
      x = x + dx
   enddo

   contains
      function BessI0(x)
      !  Evaluates the modified Bessel function of the first kind at x.
      !  Polynomial approximation taken from Abramowitz & Stegun, 1964, Handbook
      !   of mathematical functions
         implicit none
         integer,parameter :: r8=8
         integer,parameter :: rs=r8
         real(rs),intent(in) :: x
         real(rs)            :: BessI0
         real(r8)            :: t

         if (abs(x) < 3.75_r8) then
            t = abs(x/3.75_r8)
            BessI0 = 1._r8 + &
                     3.5156229_r8*t**2 + 3.0899424_r8*t**4 +  1.2067492_r8*t**6 + &
                     0.2659732_r8*t**8 + 0.0360768_r8*t**10 + 0.0045813_r8*t**12
         else
            t = abs(3.75_r8/x)
            BessI0 = (exp(abs(x))/sqrt(abs(x)))*(0.39894228_rs + &
                     0.01328592_r8*t    + 0.00225319_r8*t**2 - 0.00157565_r8*t**3 + &
                     0.00916281_r8*t**4 - 0.02057706_r8*t**5 + 0.02635537_r8*t**6 - &
                     0.01647633_r8*t**7 + 0.00392377_r8*t**8)
         endif
         return
      end function BessI0

end program


! ======================================================================
! NAME
!
!     WAVEFUNC
!
! DESCRIPTION
!
!     WAVEFUNC is a supporting program of GPECN1DTDPBC that generates
!     the initial state wave functions for its simulations.
!
! AUTHOR
!
!     Marty Kandes, Ph.D.
!     Computational & Data Science Research Specialist
!     User Services Group
!     San Diego Supercomputer Center
!     University of California, San Diego
!
! COPYRIGHT
!
!     Copyright (c) 2010 - 2021 Martin Charles Kandes
!
! LICENSE
!
!     The MIT License (MIT)
!
! LAST UPDATED
!
!     Monday, August 3rd, 2020
!
! ----------------------------------------------------------------------
      PROGRAM WAVEFUNC
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: WAVEFUNCTION_SWITCH
      INTEGER :: ANGULAR_MOMENTUM_1
      INTEGER :: ANGULAR_MOMENTUM_2

      REAL :: RADIUS
      REAL :: ROTATION_RATE
      REAL :: GAUSSIAN_OSCILLATOR_STRENGTH
      REAL :: INITIAL_ANGULAR_POSITION
      REAL :: ANGULAR_WAVEVECTOR
      REAL :: AMPLITUDE_1
      REAL :: AMPLITUDE_2
      REAL :: INITIAL_PHASE_1
      REAL :: INITIAL_PHASE_2

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE
      REAL :: NORMALIZATION_FACTOR

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: WAVEFUNCTION

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) WAVEFUNCTION_SWITCH

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) ROTATION_RATE

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) GAUSSIAN_OSCILLATOR_STRENGTH

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) INITIAL_ANGULAR_POSITION

      CALL GET_COMMAND_ARGUMENT(7,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) AMPLITUDE_1

      CALL GET_COMMAND_ARGUMENT(8,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) AMPLITUDE_2

      CALL GET_COMMAND_ARGUMENT(9,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) ANGULAR_MOMENTUM_1

      CALL GET_COMMAND_ARGUMENT(10,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) ANGULAR_MOMENTUM_2

      CALL GET_COMMAND_ARGUMENT(11,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) INITIAL_PHASE_1

      CALL GET_COMMAND_ARGUMENT(12,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) INITIAL_PHASE_2

      WRITE(6,*) NUMBER_OF_GRID_POINTS
      WRITE(6,*) WAVEFUNCTION_SWITCH
      WRITE(6,*) RADIUS
      WRITE(6,*) ROTATION_RATE
      WRITE(6,*) GAUSSIAN_OSCILLATOR_STRENGTH
      WRITE(6,*) INITIAL_ANGULAR_POSITION
      WRITE(6,*) AMPLITUDE_1
      WRITE(6,*) AMPLITUDE_2
      WRITE(6,*) ANGULAR_MOMENTUM_1
      WRITE(6,*) ANGULAR_MOMENTUM_2
      WRITE(6,*) INITIAL_PHASE_1
      WRITE(6,*) INITIAL_PHASE_2

!     Allocate Arrays:
!     ----------------
      ALLOCATE(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)

!     Main Program:
!     -------------
      IF (WAVEFUNCTION_SWITCH.EQ.0) THEN
         AMPLITUDE_2 = SQRT(1.0E0-AMPLITUDE_1**2)
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            WAVEFUNCTION(CURRENT_GRID_POINT) = CMPLX(SQRT(SQRT(GAUSSIAN_OSCILLATOR_STRENGTH/PI)),0.0E0)*EXP(CMPLX(-0.5E0*GAUSSIAN_OSCILLATOR_STRENGTH*RADIUS**2*(FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE-INITIAL_ANGULAR_POSITION)**2,ROTATION_RATE*RADIUS**2*(FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE-INITIAL_ANGULAR_POSITION)))
            WAVEFUNCTION(CURRENT_GRID_POINT) = CMPLX(AMPLITUDE_1,0.0E0)*WAVEFUNCTION(CURRENT_GRID_POINT)*EXP(CMPLX(0.0E0,FLOAT(ANGULAR_MOMENTUM_1)*(FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE-INITIAL_ANGULAR_POSITION)))+CMPLX(AMPLITUDE_2,0.0E0)*WAVEFUNCTION(CURRENT_GRID_POINT)*EXP(CMPLX(0.0E0,FLOAT(ANGULAR_MOMENTUM_2)*(FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE-INITIAL_ANGULAR_POSITION)))
         ENDDO
      ELSEIF (WAVEFUNCTION_SWITCH.EQ.1) THEN
         AMPLITUDE_2 = SQRT(1.0E0-AMPLITUDE_1**2)
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            WAVEFUNCTION(CURRENT_GRID_POINT) = CMPLX(1.0E0/SQRT(2.0E0*PI*RADIUS),0.0E0)*(CMPLX(AMPLITUDE_1,0.0E0)*EXP(CMPLX(0.0E0,FLOAT(ANGULAR_MOMENTUM_1)*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE+INITIAL_PHASE_1))+CMPLX(AMPLITUDE_2,0.0E0)*EXP(CMPLX(0.0E0,FLOAT(ANGULAR_MOMENTUM_2)*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE+INITIAL_PHASE_2)))
         ENDDO
      ELSEIF (WAVEFUNCTION_SWITCH.EQ.2) THEN
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            WAVEFUNCTION(CURRENT_GRID_POINT) = CMPLX(1.0E0/SQRT(2.0E0*PI*RADIUS),0.0E0)*(CMPLX(1.0E0-AMPLITUDE_1**2-AMPLITUDE_2**2,0.0E0)+CMPLX(AMPLITUDE_1,0.0E0)*EXP(CMPLX(0.0E0,FLOAT(ANGULAR_MOMENTUM_1)*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE+INITIAL_PHASE_1))+CMPLX(AMPLITUDE_2,0.0E0)*EXP(CMPLX(0.0E0,FLOAT(ANGULAR_MOMENTUM_2)*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE+INITIAL_PHASE_2)))
         ENDDO
      ENDIF

      NORMALIZATION_FACTOR = 0.0E0
      DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
         NORMALIZATION_FACTOR = NORMALIZATION_FACTOR+ABS(WAVEFUNCTION(CURRENT_GRID_POINT))**2*RADIUS*ANGULAR_GRID_SPACING_SIZE
      ENDDO
      WAVEFUNCTION = CMPLX(1.0E0/SQRT(NORMALIZATION_FACTOR))*WAVEFUNCTION

      OPEN(UNIT=1000,ACTION='WRITE',FORM='UNFORMATTED')
      WRITE(UNIT=1000) WAVEFUNCTION
      CLOSE(UNIT=1000)

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(WAVEFUNCTION)

      STOP
      ENDPROGRAM WAVEFUNC
! ======================================================================


!*******************************************************************************
!  File functions.f
!
!  Module is part of the libstell.a. This module containes functions used by the
!  profiles.
!
!*******************************************************************************

      MODULE functions
      USE stel_kinds

      PUBLIC :: two_power, two_power_gs, function_test
      PRIVATE :: check

      CONTAINS

!*******************************************************************************
!  Public Functions and Subroutines.
!*******************************************************************************
!*******************************************************************************
!  Profile function for the two_power profile.
!
!    b(0) * (1 - x ** b(1)) ** b(2)
!
!*******************************************************************************
      REAL(rprec) PURE FUNCTION two_power(x, b)
      IMPLICIT none

!-------------------------------------------------------------------------------
!  Variable declarations.
!-------------------------------------------------------------------------------
      REAL(rprec), INTENT(in)                  :: x
      REAL(rprec), DIMENSION(0:20), INTENT(in) :: b
!-------------------------------------------------------------------------------
!  Start of executable code
!-------------------------------------------------------------------------------
      two_power = b(0)*((1 - x**b(1))**b(2))

      END FUNCTION

!*******************************************************************************
!  Profile function for the two_power_gs profile.
!
!    two_power(x)*(1 + Sum[b(i)*Exp(-(x - b(i+1))/b(i+2)) ** 2])
!
!*******************************************************************************
      REAL(rprec) PURE FUNCTION two_power_gs(x, b)
      IMPLICIT none

!-------------------------------------------------------------------------------
!  Variable declarations.
!-------------------------------------------------------------------------------
      REAL(rprec), INTENT(in)                  :: x
      REAL(rprec), DIMENSION(0:20), INTENT(in) :: b

!-------------------------------------------------------------------------------
!  Local Variable declarations.
!-------------------------------------------------------------------------------
      INTEGER :: i

!-------------------------------------------------------------------------------
!  Start of executable code
!-------------------------------------------------------------------------------
      two_power_gs = 1.0
      DO i = 3, 18, 3
         two_power_gs = two_power_gs +                                         &
     &                  b(i)*exp(-((x - b(i+1))/b(i+2))**2)
      END DO
      two_power_gs = two_power_gs*two_power(x,b)

      END FUNCTION

!*******************************************************************************
!  Unit Test Functions
!*******************************************************************************
!*******************************************************************************
!  Main test function
!*******************************************************************************
      FUNCTION function_test()
!-------------------------------------------------------------------------------
!  Variable declarations.
!-------------------------------------------------------------------------------
      LOGICAL :: function_test
      REAL(rprec) :: result
      REAL(rprec), DIMENSION(0:20) :: b(0:20) = 0

!-------------------------------------------------------------------------------
!  Start of executable code
!-------------------------------------------------------------------------------
! Test two_power function for x = 0, b = {1,10,2} is 1
      b(0:2) = (/ 1.0d+0, 10.0d+0, 2.0d+0 /)
      result = two_power(0.0d+0, b)
      function_test = check(1.0d+0,result,1,"two_power()")
      IF (.not.function_test) RETURN

! Test two_power function for x = 1, b = {1,10,2} is 0
      result = two_power(1.0d+0, b)
      function_test = check(0.0d+0,result,2,"two_power()")
      IF (.not.function_test) RETURN

! Test two_power function for x = 0.5, b = {1,1,1} is 0.5
      b(0:2) = (/ 1.0d+0, 1.0d+0, 1.0d+0 /)
      result = two_power(0.5d+0, b)
      function_test = check(0.5d+0,result,3,"two_power()")
      IF (.not.function_test) RETURN

! Test two_power function for x = 0.5, b = {1,1,2} is 0.25
      b(0:2) = (/ 1.0d+0, 1.0d+0, 2.0d+0 /)
      result = two_power(0.5d+0, b)
      function_test = check(0.25d+0,result,4,"two_power()")
      IF (.not.function_test) RETURN

! Test two_power_gs function for x = 0.4, b = {1,1,1,0,0,1} is twopower(x,b)
      b(0:5) = (/ 1.0d+0, 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0, 1.0d+0 /)
      result = two_power_gs(0.4d+0, b)
      function_test = check(two_power(0.4d+0, b),                              &
     &                      result,1,"two_power_gs")
      IF (.not.function_test) RETURN

! Test two_power_gs function for x = 0.8, b = {1,1,0,1,0.8,0.1} is 2
      b(0:5) = (/ 1.0d+0, 1.0d+0, 0.0d+0, 1.0d+0, 0.8d+0, 0.1d+0 /)
      result = two_power_gs(0.8d+0, b)
      function_test = check(2.0d+0,result,1,"two_power_gs")
      IF (.not.function_test) RETURN

      END FUNCTION

!*******************************************************************************
!  Check Test result
!*******************************************************************************
      FUNCTION check(expected, received, testNum, name)
!-------------------------------------------------------------------------------
!  Variable declarations.
!-------------------------------------------------------------------------------
      LOGICAL :: check
      REAL(rprec), INTENT(in) :: expected, received
      INTEGER, INTENT(in) :: testNum
      CHARACTER (LEN=*), INTENT(in) :: name
!-------------------------------------------------------------------------------
!  Start of executable code
!-------------------------------------------------------------------------------
      check = expected .eq. received
      IF (.not.check) THEN
         write(*,*) "functions.f: ", name, " test", testNum,                   &
     &              "failed."
         write(*,*) "Expected", expected, "Received", received
      END IF

      END FUNCTION

      END MODULE


      PROGRAM xqtrap
C     driver for routine qtrap
      REAL PIO2
      PARAMETER(PIO2=1.5707963)
      REAL a,b,fint,func,s
      EXTERNAL func
      a=0.0
      b=PIO2
      write(*,'(1x,a)') 'Integral of FUNC computed with QTRAP'
      write(*,'(1x,a,f10.6)') 'Actual value of integral is',
     *     fint(b)-fint(a)
      call qtrap(func,a,b,s)
      write(*,'(1x,a,f10.6)') 'Result from routine QTRAP is',s
      END
      REAL FUNCTION func(x)
      REAL x
      func=(x**2)*(x**2-2.0)*sin(x)
      END
      REAL FUNCTION fint(x)
C     integral of FUNC
      REAL x
      fint=4.0*x*((x**2)-7.0)*sin(x)-((x**4)-14.0*(x**2)+28.0)*cos(x)
      END

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


! :: ----------------------------------------------------------
! :: summass
! ::             MASS = sum{ vol(i,j)*rho(i,j) }
! ::
! :: INPUTS / OUTPUTS:
! ::  rho        => density field
! ::  rlo,rhi    => index limits of rho aray
! ::  lo,hi      => index limits of grid interior
! ::  dx         => cell size
! ::  mass      <=  total mass
! ::  tmp        => temp column array
! :: ----------------------------------------------------------
! ::

       subroutine summass(rho,r_l1,r_l2,r_h1,r_h2,lo,hi,dx,mass)

       use prob_params_module, only : coord_type

       implicit none
       integer r_l1,r_l2,r_h1,r_h2
       integer lo(2), hi(2)
       double precision mass, dx(2)
       double precision rho(r_l1:r_h1,r_l2:r_h2)
       double precision  tmp(lo(2):hi(2))

       integer i, j
       double precision vol

       vol = dx(1) * dx(2)

       do j = lo(2),hi(2)
          tmp(j) = 0.d0
       enddo

       do i = lo(1), hi(1)
          do j = lo(2), hi(2)
             tmp(j) = tmp(j) + vol * rho(i,j)
          enddo
       enddo

       mass = 0.d0
       do j = lo(2), hi(2)
          mass = mass + tmp(j)
       enddo

       end subroutine summass


MODULE tools
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
CONTAINS
  ! Sum n calls of func(x)
  REAL(KIND=DBL) FUNCTION sum_func(func, x, n)
  IMPLICIT NONE
  REAL(KIND=DBL), EXTERNAL :: func
  REAL(KIND=DBL), INTENT(IN) :: x
  INTEGER, INTENT(IN) :: n
  INTEGER :: i
  REAL(KIND=DBL) :: sum
  sum = 0._DBL
  DO i = 1, n
    sum = sum + func(x)
  END DO
  sum_func = sum
  END FUNCTION sum_func

  REAL(KIND=DBL) FUNCTION inc(x)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
  REAL(KIND=DBL), INTENT(IN) :: x
  inc = x + 1._DBL
  END FUNCTION inc
END MODULE tools

!REAL FUNCTION inc(x)
!IMPLICIT NONE
!INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
!REAL(KIND=DBL), INTENT(IN) :: x
!inc = x + 1._DBL
!END FUNCTION inc

! Sum n calls of func(x)
SUBROUTINE sum_func_sub(func, x, n, result)
IMPLICIT NONE
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
REAL(KIND=DBL), EXTERNAL :: func
REAL(KIND=DBL), INTENT(IN) :: x
INTEGER, INTENT(IN) :: n
REAL(KIND=DBL), INTENT(OUT) :: result
INTEGER :: i
REAL(KIND=DBL) :: sum
sum = 0._DBL
DO i = 1, n
  sum = sum + func(x)
END DO
result = sum
END SUBROUTINE sum_func_sub

PROGRAM passing_funcs
USE tools
IMPLICIT NONE
!REAL, EXTERNAL :: inc
REAL(KIND=DBL) :: a, result
a = 1._DBL
WRITE(*, *) "func: ", sum_func(inc, a, 10)
CALL sum_func_sub(inc, a, 10, result)
WRITE(*, *) "sub: ", result
END PROGRAM passing_funcs


program foo
  real :: r4_res, r4_x = 2, r4_y = 10
  real(kind = 8) :: r8_res, r8_x = 2.5, r8_y = 3

  integer :: i4_res, i4_x = 3, i4_y = 12

  r4_res = r4_x ** r4_y
  r8_res = r8_x ** r8_y
  print *, r4_res
  print *, r8_res

  r4_res = r4_x ** i4_y
  print *, r4_res
end program foo


        SUBROUTINE errorcalc(Nt,Nx,dt,c,x,u,err)
        !--------------------------------------------------------------------
        !
        !
        ! PURPOSE
        !
        ! This subroutine calculates the error in the approximate
        ! solution
        ! of the nonlinear Klein-Gordon equation in 1 dimensions
        ! u_{tt}-u_{xx}+u=Es*u^3+
        !
        ! The boundary conditions are u(x=-Lx*\pi)=u(x=Lx*\pi),
        ! The initial condition is
        ! u=sqrt(2)*sech((x(i)-c*t)/sqrt(1-c**2)
        !
        ! INPUT
        !
        ! .. Parameters ..
        !  Nx   = number of modes in x - power of 2 for FFT
        !  Nt   = number of timesteps taken
        !  dt   = timestep
        !  c    = wavespeed
        ! .. Vectors ..
        !  x    = x locations
        !  u    = solution at current timestep
        !
        ! OUTPUT
        !
        ! .. L2 norm of error ..
        !
        ! LOCAL VARIABLES
        !
        ! .. Scalars ..
        !  i    = loop counter in x direction
        !
        ! REFERENCES
        !
        ! ACKNOWLEDGEMENTS
        !
        ! ACCURACY
        !
        ! ERROR INDICATORS AND WARNINGS
        !
        ! FURTHER COMMENTS
        ! Check that the initial iterate is consistent with the
        ! boundary conditions for the domain specified
        !--------------------------------------------------------------------
        ! External routines required
        !
        ! External libraries required
        ! OpenMP library
        IMPLICIT NONE
        ! Declare variables
        INTEGER(KIND=4), INTENT(IN)                             :: Nx,Nt
        REAL(KIND=8), DIMENSION(1:NX), INTENT(IN)               :: x
        COMPLEX(KIND=8), DIMENSION(1:NX), INTENT(IN)            :: u
        INTEGER(KIND=4)                                         :: i
        REAL(KIND=8), INTENT(IN)                                :: c,dt
        REAL(KIND=8), INTENT(OUT)                               :: err
        REAL(KIND=8)                                            :: t
        t=DBLE(Nt)*dt
        err=0.0d0
        DO i=1,Nx
          err=err+&
          (u(i)-sqrt(2.0d0)/(cosh((x(i)-c*t)/sqrt(1.0d0-c**2))))**2
        !        err=err+&
        !        (u(i)-sqrt(2.0d0)/cosh(x(i)+t))**2
        END DO
        PRINT *,'The final L2 error is ',sqrt(err/DBLE(Nx))
        END SUBROUTINE errorcalc


module day01

implicit none

contains

  integer elemental function fuel_from_mass(mod_mass) result(mod_fuel)
    ! find the fuel required for a module
    use types, only: dp
    real(dp), intent(in) :: mod_mass
    ! take its mass, divide by three, round down, and subtract 2
    mod_fuel = floor(mod_mass / 3) - 2
  end function

  integer function total_fuel(masses) result(total)
    use types, only: dp
    real(dp), intent(in) :: masses(:)
    integer :: fuels(size(masses))

    fuels = fuel_from_mass(masses)
    total = sum(fuels)
  end function

  integer elemental function fuel_from_mass_rec(mod_mass) result(rec_fuel)
    ! recursively find the fuel required for a module
    use types, only: dp
    real(dp), intent(in) :: mod_mass
    real(dp) :: tmp_mass
    real(dp) :: mod_fuel

    tmp_mass = mod_mass
    mod_fuel = 0._dp
    rec_fuel = 0
    do while(mod_fuel .ge. 0)
      rec_fuel = rec_fuel + mod_fuel
      mod_fuel = floor(tmp_mass / 3) - 2
      tmp_mass = mod_fuel
    end do

  end function

  integer function total_fuel_rec(masses) result(total)
    use types, only: dp
    real(dp), intent(in) :: masses(:)
    integer :: fuels(size(masses))

    fuels = fuel_from_mass_rec(masses)
    total = sum(fuels)
  end function

end module


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   USE GALAHAD_ROOTS_double         ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )  ! set precision
   REAL ( KIND = wp ), PARAMETER :: one = 1.0_wp
   INTEGER :: degree, nroots, status
   REAL ( KIND = wp ) :: tol, A( 0 : 4 ), ROOTS( 4 )
   tol = EPSILON( one ) ** 0.75               ! accuracy requested
   DO degree = 2, 4                           ! polynomials of degree 2 to 4
     IF ( degree == 2 ) THEN
       A( 0 ) = 2.0_wp
       A( 1 ) = - 3.0_wp
       A( 2 ) = 1.0_wp
       WRITE( 6, "( ' Quadratic ' )" )
       CALL ROOTS_solve( A( : degree ), tol, nroots, ROOTS( : degree ), status )
     ELSE IF ( degree == 3 ) THEN
       A( 0 ) = - 6.0_wp
       A( 1 ) = 11.0_wp
       A( 2 ) = -6.0_wp
       A( 3 ) = 1.0_wp
       WRITE( 6, "( /, ' Cubic ' )" )
       CALL ROOTS_solve( A( : degree ), tol, nroots, ROOTS( : degree ), status )
     ELSE
       A( 0 ) = 24.0_wp
       A( 1 ) = -50.0_wp
       A( 2 ) = 35.0_wp
       A( 3 ) = -10.0_wp
       A( 4 ) = 1.0_wp
       WRITE( 6, "( /, ' Quartic ' )" )
       CALL ROOTS_solve( A( : degree ), tol, nroots, ROOTS( : degree ), status )
     END IF
     IF ( nroots == 0 ) THEN
       WRITE( 6, "( ' no real roots ' )" )
     ELSE IF ( nroots == 1 ) THEN
       WRITE( 6, "( ' 1 real root ' )" )
     ELSE IF ( nroots == 2 ) THEN
       WRITE( 6, "( ' 2 real roots ' )" )
     ELSE IF ( nroots == 3 ) THEN
       WRITE( 6, "( ' 3 real roots ' )" )
     ELSE IF ( nroots == 4 ) THEN
       WRITE( 6, "( ' 4 real roots ' )" )
     END IF
     IF ( nroots /= 0 ) WRITE( 6, "( ' roots: ', 4ES10.2 )" ) ROOTS( : nroots )
   END DO
   END PROGRAM GALAHAD_ROOTS_EXAMPLE


program main
  implicit none
  integer, parameter :: i4b = selected_int_kind(9)
  real times, timet, time
  integer(kind=i4b) :: strt, stp, x, z
  character(len=20) :: buffer
  ! NOTE: getarg is an extension (not strictly F90/95) but is supported in most
  ! compilers.
  call getarg(1,buffer)
  read(buffer,*) strt
  call getarg(2,buffer)
  read(buffer,*) stp

  do x = strt, stp, strt
    call cpu_time(times)
    Z = genprime(x)
    call cpu_time(timet)
    time = timet - times
    print '(a6, i8, a11, f10.5, a19, i10, a)', &
      'Found ',x,' primes in ',time,' seconds (last was ',z,')'
  end do

contains

  function genprime(mx) result (res)
    integer(kind=i4b), intent(in) :: mx
    integer(kind=i4b) :: res, cnt, cur
    cur = 0
    cnt = 0
    do while(cnt.lt.mx)
      if(isprime(cur)) then
        cnt = cnt + 1
      end if
      cur = cur + 1
    end do
    res = cur - 1
  end function genprime

  function isprime(x) result (res)
    integer(kind=i4b), intent(in) :: x
    integer(kind=i4b) :: lim, y
    logical :: res

    if(x.lt.2) then
      res = .false.
      return
    end if
    if(x.eq.2) then
      res = .true.
      return
    end if
    if(modulo(x,2).eq.0) then
      res = .false.
      return
    end if
    if(x.lt.9) then
      res = .true.
      return
    end if
    if(modulo(x + 1, 6) .ne. 0) then
      if(modulo(x - 1, 6) .ne. 0) then
        res = .false.
        return
      end if
    end if
    lim = int(sqrt(real(x)) + 1.0)
    do y = 3, lim, 2
      if(modulo(x,y).eq.0) then
        res = .false.
        return
      end if
    end do
    res = .true.
    return
  end function isprime

end program main


module Polynom
  implicit none

contains

  subroutine poly_long_div(n, d, q, r)
    real, dimension(:), intent(in) :: n, d
    real, dimension(:), intent(out), allocatable :: q
    real, dimension(:), intent(out), allocatable, optional :: r

    real, dimension(:), allocatable :: nt, dt, rt
    integer :: gn, gt, gd

    if ( (size(n) >= size(d)) .and. (size(d) > 0) .and. (size(n) > 0) ) then
       allocate(nt(size(n)), dt(size(n)), rt(size(n)))

       nt = n
       dt = 0
       dt(1:size(d)) = d
       rt = 0
       gn = size(n)-1
       gd = size(d)-1
       gt = 0

       do while ( d(gd+1) == 0 )
          gd = gd - 1
       end do

       do while( gn >= gd )
          dt = eoshift(dt, -(gn-gd))
          rt(gn-gd+1) = nt(gn+1) / dt(gn+1)
          nt = nt - dt * rt(gn-gd+1)
          gt = max(gt, gn-gd)
          do
             gn = gn - 1
             if ( nt(gn+1) /= 0 ) exit
          end do
          dt = 0
          dt(1:size(d)) = d
       end do

       allocate(q(gt+1))
       q = rt(1:gt+1)
       if ( present(r) ) then
          if ( (gn+1) > 0 ) then
             allocate(r(gn+1))
             r = nt(1:gn+1)
          else
             allocate(r(1))
             r = 0.0
          end if
       end if
       deallocate(nt, dt, rt)
    else
       allocate(q(1))
       q = 0
       if ( present(r) ) then
          allocate(r(size(n)))
          r = n
       end if
    end if

  end subroutine poly_long_div

  subroutine poly_print(p)
    real, dimension(:), intent(in) :: p

    integer :: i

    do i = size(p), 1, -1
       if ( i > 1 ) then
          write(*, '(F0.2,"x^",I0," + ")', advance="no") p(i), i-1
       else
          write(*, '(F0.2)') p(i)
       end if
    end do

  end subroutine poly_print

end module Polynom


!
!-----------------------------------------------------------------------------------------
!
SUBROUTINE linear_interp(x,x_tables,f_tables,fx,ierr)
! 2 points linear interpolation formula
  implicit none
  INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
  real*8, intent(in) :: x ! point where function needed
  real*8, intent(in) ::x_tables(2),f_tables(2) ! 2 points from tables F_i(x_i), i=1..2
  real*8, intent(out) :: fx !function value at x f(x)
  integer, intent(out) :: ierr
  real*8 hx

  ierr=0
  hx=(x_tables(2)-x_tables(1))
  if(hx.eq.0.0_R8) then
     ierr=1
     return
  endif
  fx = f_tables(1)+(x-x_tables(1))/hx*(f_tables(2)-f_tables(1))
  return

end SUBROUTINE linear_interp
!
!-----------------------------------------------------------------------------------------
!
SUBROUTINE linear_interp_2d(x,x_tables,f_tables,fx,ierr)
! 4 points 2D linear interpolation formula
  implicit none
  INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
  real*8, intent(in) :: x(2) ! point where function needed
  real*8, intent(in) ::x_tables(4),f_tables(2,2) ! 2 points from tables F_i(x_i), i=1..2
  real*8, intent(out) :: fx !function value at x f(x)
  integer, intent(out) :: ierr
  real*8 hx1,hx2,pe,qn,pe1,qn1

  ierr=0
  hx1=(x_tables(2)-x_tables(1))
  hx2=(x_tables(4)-x_tables(3))
  if((hx1.eq.0.0_R8).or.(hx2.eq.0.0_R8)) then
     ierr=1
     return
  endif
  !pe=(e-e0)/(e1-e0)
  pe=(x(1)-x_tables(1))/hx1
  !qn=(n-n0)/(n1-n0)
  qn=(x(2)-x_tables(3))/hx2
  !1-pe=(e1-e)/(e1-e0)
  pe1=1.0_R8 - pe
  !1-qn=(n1-n)/(n1-n0)
  qn1=1.0_R8 - qn
  !four points linear extrapolation
  fx = pe1*qn1*f_tables(1,1)+pe*qn1*f_tables(2,1)+qn*pe1*f_tables(1,2)+&
       &pe*qn*f_tables(2,2)
  return

end SUBROUTINE linear_interp_2d


program mkgrid

! Simple two-dimensional grid generator
!
! S. Scott Collis
! Rice University
! MEMS, MS 321
! Houston, TX 77005
! 713-348-3617
! collis@rice.edu

implicit none

integer :: nx, ny, i, j
real, allocatable :: x(:), y(:), xi(:), eta(:)

!real :: xmin=-32, xmax=32, ymin=0, ymax=32
!real :: xmin=-20, xmax=20, ymin=0, ymax=30
real :: xmin=-20, xmax=20, ymin=0, ymax=40
real :: dx, dy, dxi, deta
real :: xs, ys, aa, bb

write(*,"('Enter number of cells (nx, ny) ==> ',$)")
read(*,*) nx, ny
write(*,"('Enter Xs, Ys (Xs = Ys = 0 makes a uniform mesh) ==> ',$)")
read(*,*) xs, ys

allocate( x(nx+2), y(ny+2), xi(nx+2), eta(ny+2) )

dx = (xmax - xmin) / real(nx)
dy = (ymax - ymin) / real(ny)

if (xs.eq.0) then
  do i = 1, nx+1
    x(i) = xmin + dx * (i-1)
  end do
  x(nx+2) = x(nx+1)
else
  dxi = 1.0 / float(nx)
  write(*,"('Algebraic grid in x')")
  aa = (xmax-xmin) * xs / ( (xmax-xmin) - 2.0 * xs )
  bb = 1.0 + aa / (xmax-xmin)

  do i = 1, nx+1
    xi(i) = -0.5 + (i-1) * dxi
    x(i)  = 4.0 * ( aa * xi(i) / (bb - abs(xi(i))) )
  end do
  x(nx+2) = x(nx+1)
  do i = 1, nx+1
    write(11,"(2(1pe13.6,1x))") xi(i), x(i)
  end do
end if

if (ys.eq.0) then
  do j = 1, ny+1
    y(j) = ymin + dy * (j-1)
  end do
  y(ny+2) = y(ny+1)
else
  deta = 1.0 / float(ny)
  write(*,"('Algebraic grid in y')")
  aa = ymax * ys / ( ymax - 2.0 * ys )
  bb = 1.0 + aa / ymax
  do j = 1, ny+1
    eta(j) = (j-1) * deta
    y(j)   = aa * eta(j) / (bb - eta(j))
  end do
  y(ny+2) = y(ny+1)
  do j = 1, ny+1
    write(12,"(2(1pe13.6,1x))") eta(j), y(j)
  end do
end if

open(10,file='grid.in',form='formatted',status='unknown')
write(10,*) nx+2, ny+2
write(10,*) x
write(10,*) y
close(10)

stop
end program mkgrid


!> the problem is to determine the values of x(1), x(2), ..., x(9),
!>  which solve the system of tridiagonal equations.
!>
!>  (3-2*x(1))*x(1)           -2*x(2)                   = -1
!>          -x(i-1) + (3-2*x(i))*x(i)         -2*x(i+1) = -1, i=2-8
!>                              -x(8) + (3-2*x(9))*x(9) = -1
program example_hybrd1

    use minpack, only: hybrd1, dpmpar, enorm
    implicit none
    integer j, n, info, lwa, nwrite
    double precision tol, fnorm
    double precision x(9), fvec(9), wa(180)

    !> Logical output unit is assumed to be number 6.
    data nwrite/6/

    n = 9

    !> The following starting values provide a rough solution.
    do j = 1, 9
        x(j) = -1.d0
    end do

    lwa = 180

    !> Set tol to the square root of the machine precision.
    !>  unless high precision solutions are required,
    !>  this is the recommended setting.
    tol = dsqrt(dpmpar(1))

    call hybrd1(fcn, n, x, fvec, tol, info, wa, lwa)
    fnorm = enorm(n, fvec)
    write (nwrite, 1000) fnorm, info, (x(j), j=1, n)

1000 format(5x, "FINAL L2 NORM OF THE RESIDUALS", d15.7// &
           5x, "EXIT PARAMETER", 16x, i10// &
           5x, "FINAL APPROXIMATE SOLUTION"// &
           (5x, 3d15.7))

    !> Results obtained with different compilers or machines
    !>  may be slightly different.
    !>
    !>> FINAL L2 NORM OF THE RESIDUALS  0.1192636D-07
    !>>
    !>> EXIT PARAMETER                         1
    !>>
    !>> FINAL APPROXIMATE SOLUTION
    !>>
    !>>  -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
    !>>  -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
    !>>  -0.6657920D+00 -0.5960342D+00 -0.4164121D+00

contains

    !> Subroutine fcn for hybrd1 example.
    subroutine fcn(n, x, fvec, iflag)

        implicit none
        integer n, iflag
        double precision x(n), fvec(n)

        integer k
        double precision one, temp, temp1, temp2, three, two, zero
        data zero, one, two, three/0.0d0, 1.0d0, 2.0d0, 3.0d0/

        do k = 1, n
            temp = (three - two*x(k))*x(k)
            temp1 = zero
            if (k /= 1) temp1 = x(k - 1)
            temp2 = zero
            if (k /= n) temp2 = x(k + 1)
            fvec(k) = temp - temp1 - two*temp2 + one
        end do

    end subroutine fcn

end program example_hybrd1


      REAL FUNCTION new_wdir(U,V,D)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:    WDIR        MEAN ICE-DRIFT VECTOR DIRECTION
!   PRGMMR: TOWNSHEND        ORG: W/NMC411   DATE: 89-09-27
!
! ABSTRACT: CALCULATE DIRECTION OF MEAN ICE-DRIFT VECTOR.
!
! PROGRAM HISTORY LOG:
!   89-09-27  TOWNSHEND   ORIGINAL AUTHOR
!   92-03-06  GRUMBINE    REVISION TO CALL AS FUNCTION
! 2014-11-19  Grumbine    Update to Ftn 90 standard (no goto)
!
! USAGE:    CALL WDIR(U,V,D)
!   INPUT ARGUMENT LIST:
!     U    - E-W COMPONENT OF MEAN ICE-DRIFT VECTOR
!     V    - N-S COMPONENT OF MEAN ICE-DRIFT VECTOR
!
!   OUTPUT ARGUMENT LIST:
!     D    - DIRECTION (DEGREES) OF MEAN ICE-DRIFT VECTOR
!
!   LANGUAGE: Fortran 90
!   MACHINE:  wcoss-tide/gyre
!
!$$$
!
      IMPLICIT none
      REAL D, U, V
      REAL R, RADIAN
!
      DATA  RADIAN/57.29577951308232D0/
!
      IF (U.EQ.0.) THEN
        IF (V.GT.0.) D=180.
        IF (V.LE.0.) D=0.
      ELSE
        R = V/U
        IF (U.GT.0.) THEN
          D = 270.-ATAN(R)*RADIAN
        ELSE
          D = 90. -ATAN(R)*RADIAN
        ENDIF
      ENDIF

      new_WDIR = D

      RETURN
      END


C      FGHEVEN
C      F. Gogtas, G.G. Balint-Kurti and C.C. Marston,
C      QCPE Program No. 647, (1993).
C
C     ***************************************************************
C     This program solves one dimensional Schrodinger equation for
C     bound state eigenvalues and eigenfunctions corresponding to a
C     potential V(x).
C
C     The Fourier Grid Hamiltonian method is used in the program.
C     This method is fully described in:
C     C.C. Marston and G.G.Balint-Kurti, J.Chem. Phys.,91,3571(1989).
C     and
C     G.G. Balint-Kurti, R.N. Dixon and C.C. Marston, Internat. Rev.
C     Phys. Chem.,11, 317 (1992).
C
C     The program uses an even number of grid points. The Hamiltonian
C     matrix elements are calculated using analytic formula described
C     in the second of the above references.
C
C     The analytical Hamiltonian expression given in the reference
C     contains a small error.  The formula should read:
C
C                H(i,j) = {(h**2)/(4*m*(L**2)} *
C                          [(N-1)(N-2)/6 + (N/2)] + V(Xi),   if i=j
C
C                H(i,j) = {[(-1)**(i-j)] / m } *
C                          { h/[2*L*sin(pi*(i-j)/N)]}**2 ,     if i#j
C
C     The eigenvalues of the Hamiltonian matrix which lie below the
C     asymptotic (large x) value of V(x) correspond to the bound state
C     energies. The corresponding eigenvectors are the representation
C     of the bound state wavefunctions on a regular one dimensional grid.
C
C     The user must supply a self contained subroutine VSUB(X,V)
C     which is called with a value of X and returns the value of the
C     potential in V.
C
C     As supplied the program uses a Morse potential with parameters chosen
C     to represent the HF molecule.
C
C     The Program should work on any computer
C     Programming language used                    : Fortran77
C     Memory required to execute with typical data : 1 Mbyte
C
C     To run the program on a SUN workstation (or any Unix based system)
C     First type:
C        f77 -o fgheven fgheven.f
C     to create an executable program (fgheven).
C     Then type:
C        fgheven > fgheven.out &
C     to run the program.
C
C     The dimensions of the arrays generally depend on the number of grid
C     points used.  This number NX is set in a PARAMETER statement.
C     The following arrays represent  :
C
C        XA  : X-coordinates i.e. position on a grid.
C
C        AR  : The Hamiltonian Matrix
C
C        WCH : The eigenvalues for respective energy levels.
C
C        ZR  : The eigenvectors (X,Y); where
C                                      X : Wavefunction.
C                                      Y : Energy level.
C    The folowing data constans represent :
C        ZMA, ZMB : Mass of atoms.
C        R0       : Equilibrium bond separation
C        NPRIN    : 0 or 1 for eigenvalue or eigenvector respectively
C        NWRIT    : Number of eigenvales/eigenvectors to be printed
C        RMIN     : Starting point of grid
C        RMAX     : End point of grid
C        ZL       : Grid length
C        DX       : Grid spacings
C
C       All quantities in au (unless otherwise stated)
C     ****************************************************************
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (NX=1800)
C
C.....Declare arrays.
      DIMENSION XA(NX),AR(NX,NX),WCH(NX),ZR(NX,NX)
      DIMENSION FV1(NX),FV2(NX)
      DIMENSION POT(NX)
C
C.....Variable data input.
C     DATA ZMA/1836.9822D0/
C     DATA ZMB/34629.61319D0/
C     DATA R0/1.7329D0/
C     DATA DHART/0.2250073497D0/
C     DATA BETA/1.1741D0/
      DATA PI/3.141592653589793D0/
      DATA NPRIN/0/
      DATA NWRIT/20/
      INTEGER :: L
      LOGICAL :: MORLJ

C     NAMELIST DATA
      NAMELIST /TTDATA/ ZMA, ZMB, R0, BETA, DHART, NPRIN, NWRIT, L,
     &RMAX, RMIN, MORLJ, C6, C8, C10, C12
      READ(5,NML=TTDATA)

C
C....Test that NX is even
      ITEST=MOD(NX,2)
      IF(ITEST.NE.0) THEN
        WRITE(6,*)' **** NX MUST BE EVEN-FATAL ERROR  ****'
        STOP
      END IF
C
C.....Set up grid
      WRITE(6,*)'Grid paremeters:'
      WRITE(6,*)'   Number of grid poins    = ',NX
C      RMIN=R0*0.2D0
C      RMAX=R0*3.0D0
      ZL=(RMAX-RMIN)
      WRITE(6,*)'   Grid length             = ',ZL
      DX=ZL/DFLOAT(NX)
      WRITE(6,*)'   Grid spacings           = ',DX
C.....Print mass of atoms A and B
      WRITE(6,*)'Mass of atoms:'
      WRITE(6,*)'   Atomic mass of atom A      = ',ZMA
      WRITE(6,*)'   Atomic mass of atom B      = ',ZMB
      WRITE(6,*)'   R0                         = ',R0
      WRITE(6,*)'   BETA                       = ',BETA
      WRITE(6,*)'   DHART                      = ',DHART
C.....Compute reduced mass.
      ZMU=ZMA*ZMB/(ZMA+ZMB)
      WRITE(6,*)'   Reduced mass of AB         = ',ZMU
C
C.....Compute contants:
      PSQ=PI*PI
      CONST1=PSQ/(ZMU*(ZL**2))
      NFACT1=(NX-1)*(NX-2)
      NFACT2=(NX-2)/2
      CONST2=CONST1*(DFLOAT(NFACT1)/6.0D0 +1.0D0+DFLOAT(NFACT2))
      DARG=PI/DFLOAT(NX)
      VMIN=0.0D10
C
C.....Now compute Hamiltonian matrix:
      X=RMIN
      DO 003 I=1,NX
         XA(I)=X
       DO 004 J=1,I
          IJD=(I-J)
        IF(IJD.EQ.0)THEN
          AR(I,J)=CONST2
        ELSE
          RATIO=1.0D0/DSIN(DARG*DFLOAT(IJD))
          AR(I,J)=((-1)**IJD)*CONST1*(RATIO**2)
        END IF
 004  CONTINUE
C.....Find the potential value at x
      IF(MORLJ) THEN
       CALL VSUB_M(X,VV,R0,BETA,DHART,L,ZMU)
      ELSE
       CALL VSUB_LJ(X,VV,R0,C6,C8,C10,C12,L,ZMU)
      ENDIF
      POT(I) = VV
      IF(VMIN .gt. VV) VMIN = VV
C.....Add the potential value when the kronecker delta function
C.....equals to one, i.e. when I and J are equal
        AR(I,I)=AR(I,I)+VV
        X=X+DX
 003  CONTINUE
C.....Now fill out Hamiltonian matrix.
      DO 006 I=1,NX
       DO 007 J=1,I
        AR(J,I)=AR(I,J)
007    CONTINUE
006   CONTINUE
C.....Now call eigenvalue solver.
      call flush(6)
      CALL RS(NX,NX,AR,WCH,NPRIN,ZR,FV1,FV2,IERR)
C.....Print out eigenvalues and eigenvectors.
      WRITE(6,12)
12    FORMAT(/)
      WRITE(6,*)' The first',NWRIT,' energy levels for AB molecule '
      DO 009 I=1,NWRIT
       WRITE(6,*)' ENERGY LEVEL NO ',I,' EIGENVALUE= ',WCH(I)
       IF (WCH(I) .LT. 0.0D0 .AND. WCH(I) .GT. VMIN) THEN
        WRITE(10,*) I-1.0, WCH(I)
       ENDIF
 009  CONTINUE
      WRITE(6,12)
      WRITE(6,*)' THE CORRESPONDING EIGENFUNCTIONS ARE:'
      DO 010 I=1,NWRIT
       WRITE(6,*)' ENERGY LEVEL NO ',I,' EIGENVALUE= ',WCH(I)
       IF (NPRIN.EQ.1) THEN
       DO 011 J=1,NX
         WRITE(6,*)' R = ',XA(J),' WAVEFUNCTION=',ZR(J,I)
 011   CONTINUE
       ENDIF
 010  CONTINUE
      OPEN(unit=99,file="pot.dat")
      DO 013 I=1,NX
         WRITE(99,*)XA(I),POT(I)
 013  CONTINUE
      CLOSE(99)
      STOP
      END
C
C
      SUBROUTINE VSUB_M(X,V,R0,BETA,DHART,L,MU)
C     **************************************************************
C.....SUBROUTINE TO COMPUTE POTENTIAL ENERGY AT SEPERATION X (IN
C.....ATOMIC UNITS). THE VALUE OF THE POTENTIAL IS RETURNED IN V,
C.....AGAIN IN ATOMIC UNITS.THE POTENTIAL ENERGY IS ASSUMED TO
C..... BE A MORSE CURVE:V(X) = DHART * (EXP(-BETA*(X-R0)) - 1)**2
C..... THE FOLLOWING DATA CONSTANTS REPRESENT :
C.....    DHART : THE DISSOCIATION ENERGY FOR THE GIVEN MOLECULE
C.....    BETA  : THE EXPONENTIAL PARAMETER
C.....    R0    : THE BOND LENGTH AT EQUILIBRIUM FOR GIVEN MOLECULE
C     **************************************************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION :: MU
      INTEGER :: L
C      DATA DHART/0.2250073497D0/
C      DATA BETA/1.1741D0/
C      DATA R0/1.7329D0/
C.....Set morse curve parameters.
      ARG=X-R0
      ARG=-BETA*ARG
      EF=DEXP(ARG)
      EF=1.0D0-EF
      EF=EF*EF
      V=DHART*EF-DHART
      V = V + DBLE(L)*(DBLE(L)+1.0)/(2.0*MU*X**2)
      RETURN
      END
CC
      SUBROUTINE VSUB_LJ(X,V,R0,C6,C8,C10,C12,L,MU)
C     **************************************************************
C.....SUBROUTINE TO COMPUTE POTENTIAL ENERGY AT SEPERATION X (IN
C.....ATOMIC UNITS). THE VALUE OF THE POTENTIAL IS RETURNED IN V,
C.....AGAIN IN ATOMIC UNITS.THE POTENTIAL ENERGY IS ASSUMED TO
C..... BE A MORSE CURVE:V(X) = DHART * (EXP(-BETA*(X-R0)) - 1)**2
C..... THE FOLLOWING DATA CONSTANTS REPRESENT :
C.....    DHART : THE DISSOCIATION ENERGY FOR THE GIVEN MOLECULE
C.....    BETA  : THE EXPONENTIAL PARAMETER
C.....    R0    : THE BOND LENGTH AT EQUILIBRIUM FOR GIVEN MOLECULE
C     **************************************************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION :: MU
      INTEGER :: L
C      DATA DHART/0.2250073497D0/
C      DATA BETA/1.1741D0/
C      DATA R0/1.7329D0/
C.....Set morse curve parameters.
      V =C12/X**12-C10/X**6-C8/X**6-C6/X**6
      V = V + DBLE(L)*(DBLE(L)+1.0)/(2.0*MU*X**2)
      RETURN
      END
C
C
      SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
C     ****************************************************************
C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
C     OF A REAL SYMMETRIC MATRIX.
C
C     ON INPUT :
C
C        N,M  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C        DIMENSION STATEMENT,
C        N  IS THE ORDER OF THE MATRIX  A,
C        A  CONTAINS THE REAL SYMMETRIC MATRIX,
C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
C        ONLY EIGENVALUES ARE DESIRED,  OTHERWISE IT IS SET TO
C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
C
C     ON OUTPUT :
C
C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER,
C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO,
C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN
C        ERROR COMPLETION CODE DESCRIBED IN SECTION 2B OF THE
C        DOCUMENTATION.  THE NORMAL COMPLETION CODE IS ZERO,
C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C    *******************************************************************
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     ********** FIND EIGENVALUES ONLY **********
      CALL  TRED1(NM,N,A,W,FV1,FV2)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     ********** FIND BOTH EIGENVALUES AND EIGENVECTORS **********
   20 CALL  TRED2(NM,N,A,W,FV1,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
   50 RETURN
C     ********** LAST CARD OF RS **********
      END
C
C
      SUBROUTINE TRED1(NM,N,A,D,E,E2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NM,N),D(N),E(N),E2(N)
C     ***************************************************************
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C     TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT :
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT :
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C          TRIANGLE.  THE FULL UPPER TRIANGLE OF A IS UNALTERED,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ****************************************************************
C
      DO 100 I = 1, N
  100 D(I) = A(I,I)
C     ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         IF (L .LT. 1) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
  120    SCALE = SCALE + DABS(A(I,K))
C
         IF (SCALE .NE. 0.0D0) GO TO 140
  130    E(I) = 0.0D0
         E2(I) = 0.0D0
         GO TO 290
C
  140    DO 150 K = 1, L
            A(I,K) = A(I,K) / SCALE
            H = H + A(I,K) * A(I,K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = A(I,L)
         G = -DSIGN(DSQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         A(I,L) = F - G
         IF (L .EQ. 1) GO TO 270
         F = 0.0D0
C
        DO 240 J = 1, L
            G = 0.0D0
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, J
  180       G = G + A(J,K) * A(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + A(K,J) * A(I,K)
C     ********** FORM ELEMENT OF P **********
  220       E(J) = G / H
            F = F + E(J) * A(I,J)
  240    CONTINUE
C
         H = F / (H + H)
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = A(I,J)
            G = E(J) - H * F
            E(J) = G
C
            DO 260 K = 1, J
               A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  260    CONTINUE
C
  270    DO 280 K = 1, L
  280    A(I,K) = SCALE * A(I,K)
C
  290    H = D(I)
         D(I) = A(I,I)
         A(I,I) = H
  300 CONTINUE
C
      RETURN
C     ********** LAST CARD OF TRED1 **********
      END
C
C
      SUBROUTINE TRED2(NM,N,A,D,E,Z)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(NM,N),D(N),E(N),Z(NM,N)
C     ****************************************************************
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A
C     SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT :
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT :
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX
C          PRODUCED IN THE REDUCTION,
C
C        A AND Z MAY COINCIDE.  IF DISTINCT, A IS UNALTERED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     *************************************************************
      DO 100 I = 1, N
         DO 100 J = 1, I
            Z(I,J) = A(I,J)
  100 CONTINUE
C
      IF (N .EQ. 1) GO TO 320
C     ********** FOR I=N STEP -1 UNTIL 2 DO -- **********
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         IF (L .LT. 2) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
  120    SCALE = SCALE + DABS(Z(I,K))
C
         IF (SCALE .NE. 0.0D0) GO TO 140
  130    E(I) = Z(I,L)
         GO TO 290
C
  140    DO 150 K = 1, L
            Z(I,K) = Z(I,K) / SCALE
            H = H + Z(I,K) * Z(I,K)
  150    CONTINUE
C
         F = Z(I,L)
         G = -DSIGN(DSQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         Z(I,L) = F - G
         F = 0.0D0
C
         DO 240 J = 1, L
            Z(J,I) = Z(I,J) / H
            G = 0.0D0
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, J
  180       G = G + Z(J,K) * Z(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + Z(K,J) * Z(I,K)
C     ********** FORM ELEMENT OF P **********
  220       E(J) = G / H
            F = F + E(J) * Z(I,J)
  240    CONTINUE
C
         HH = F / (H + H)
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = Z(I,J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  260    CONTINUE
C
  290    D(I) = H
  300 CONTINUE
C
  320 D(1) = 0.0D0
      E(1) = 0.0D0
C     ********** ACCUMULATION OF TRANSFORMATION MATRICES **********
      DO 500 I = 1, N
         L = I - 1
         IF (D(I) .EQ. 0.0D0) GO TO 380
C
         DO 360 J = 1, L
            G = 0.0D0
C
            DO 340 K = 1, L
  340       G = G + Z(I,K) * Z(K,J)
C
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * Z(K,I)
  360    CONTINUE
C
  380    D(I) = Z(I,I)
         Z(I,I) = 1.0D0
         IF (L .LT. 1) GO TO 500
C
         DO 400 J = 1, L
            Z(I,J) = 0.0D0
            Z(J,I) = 0.0D0
  400    CONTINUE
C
  500 CONTINUE
C
      RETURN
C     ********** LAST CARD OF TRED2 **********
      END
C
C
      SUBROUTINE TQLRAT(N,D,E2,IERR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION D(N),E2(N)
      REAL*8 MACHEP
C     *****************************************************************
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT :
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX'
C
C        E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT :
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     **************************************************************
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C
      MACHEP = 2.D0**(-26)
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E2(I-1) = E2(I)
C
      F = 0.0D0
      B = 0.0D0
      C = 0.0D0
      E2(N) = 0.0D0
C
      DO 290 L = 1, N
         J = 0
         H = MACHEP * (DABS(D(L)) + DSQRT(E2(L)))
         IF (B .GT. H) GO TO 105
         B = H
         C = B * B
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
  105    DO 110 M = L, N
            IF (E2(M) .LE. C) GO TO 120
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
  110    CONTINUE
         WRITE(6,*)' **** FATAL ERROR IN TQLRAT **** '
         WRITE(6,*)' **** FALLEN THROUGH BOTTOM OF LOOP 110 *** '
         STOP
C
  120    IF (M .EQ. L) GO TO 210
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         S = DSQRT(E2(L))
         G = D(L)
         P = (D(L1) - G) / (2.0D0 * S)
         R = DSQRT(P*P+1.0D0)
         D(L) = S / (P + DSIGN(R,P))
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     ********** RATIONAL QL TRANSFORMATION **********
         G = D(M)
         IF (G .EQ. 0.0D0) G = B
         H = G
         S = 0.0D0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            P = G * H
            R = P + E2(I)
            E2(I+1) = S * R
            S = E2(I) / R
            D(I+1) = H + S * (H + D(I))
            G = D(I) - E2(I) / G
            IF (G .EQ. 0.0D0) G = B
            H = G * P / R
  200    CONTINUE
C
         E2(L) = S * G
         D(L) = H
C     ********** GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST **********
         IF (H .EQ. 0.0D0) GO TO 210
         IF (DABS(E2(L)) .LE.DABS(C/H)) GO TO 210
         E2(L) = H * E2(L)
         IF (E2(L) .NE. 0.0D0) GO TO 130
  210    P = D(L) + F
C     ********** ORDER EIGENVALUES **********
         IF (L .EQ. 1) GO TO 250
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- *********
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF TQLRAT **********
      END
C
C
      SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION D(N),E(N),Z(NM,N)
      REAL*8 MACHEP
C     **************************************************************
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
C     WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT :
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT :
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1,
C
C        E HAS BEEN DESTROYED,
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ***************************************************************
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.

      MACHEP = 2.D0**(-26)
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      F = 0.0D0
      B = 0.0D0
      E(N) = 0.0D0
C
      DO 240 L = 1, N
         J = 0
         H = MACHEP * (DABS(D(L)) + DABS(E(L)))
         IF (B .LT. H) B = H
C     ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
         DO 110 M = L, N
            IF (DABS(E(M)) .LE. B) GO TO 120
C     ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
  110    CONTINUE
  120    IF (M .EQ. L) GO TO 220
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         G = D(L)
         P = (D(L1) - G) / (2.0D0 * E(L))
         R = DSQRT(P*P+1.0D0)
         D(L) = E(L) / (P + DSIGN(R,P))
         H = G - D(L)
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     ********** QL TRANSFORMATION **********
         P = D(M)
         C = 1.0D0
         S = 0.0D0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            G = C * E(I)
            H = C * P
            IF (DABS(P) .LT. DABS(E(I))) GO TO 150
            C = E(I) / P
            R = DSQRT(C*C+1.0D0)
            E(I+1) = S * P * R
            S = C / R
            C = 1.0D0 / R
            GO TO 160
  150       C = P / E(I)
            R = DSQRT(C*C+1.0D0)
            E(I+1) = S * E(I) * R
            S = 1.0D0 / R
            C = C * S
  160       P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
C     ********** FORM VECTOR **********
            DO 180 K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * H
               Z(K,I) = C * Z(K,I) - S * H
  180       CONTINUE
  200    CONTINUE
         E(L) = S * P
         D(L) = C * P
         IF (DABS(E(L)) .GT. B) GO TO 130
  220    D(L) = D(L) + F
  240 CONTINUE
C     ********** ORDER EIGENVALUES AND EIGENVECTORS **********
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
  300 CONTINUE
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF TQL2 **********
      END


      SUBROUTINE tptest(data1,data2,n,t,prob)
      INTEGER n
      REAL prob,t,data1(n),data2(n)
CU    USES avevar,betai
      INTEGER j
      REAL ave1,ave2,cov,df,sd,var1,var2,betai
      call avevar(data1,n,ave1,var1)
      call avevar(data2,n,ave2,var2)
      cov=0.
      do 11 j=1,n
        cov=cov+(data1(j)-ave1)*(data2(j)-ave2)
11    continue
      df=n-1
      cov=cov/df
      sd=sqrt((var1+var2-2.*cov)/n)
      t=(ave1-ave2)/sd
      prob=betai(0.5*df,0.5,df/(df+t**2))
      return
      END

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


!
! An adaptation of KWM's subroutine for computing RH.
!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     PURPOSE  COMPUTES THE RELATIVE HUMIDITY FROM THE TEMPERATURE,
!              MIXING RATIO, AND PRESSURE.
!
!     INPUT       Q        MIXING RATIO               kg/kg
!                 T        T                          K
!                 P        P                          Pa
!
!     OUTPUT      RH       RELATIVE HUMIDITY          %
!
!      DIMENSION Q ,T, P
!      DIMENSION RH
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function calc_rh(t, q, p)

   implicit none

   ! Arguments
   real t, q, p

   ! Return value
   real calc_rh

   ! Local variables
   real :: es, qs

   real, parameter :: e0    = 611.2
   real, parameter :: svp2  = 17.67
   real, parameter :: svp3  = 29.65
   real, parameter :: t00   = 273.15
   real, parameter :: eps   = 0.622

   es=e0*exp(svp2*(t-t00)/(t-svp3))
   qs=eps*es/(p-es)
   calc_rh=100.*q/qs

end function calc_rh


program bspline_tests
use utils
use bspline
use finite_elements
use ogpf

implicit none
!---------------
! Variables
!---------------
integer :: i,j,total_tests, passed_tests
real(wp), allocatable :: y(:),x(:)
real(wp) :: result,true

!---------------
! Logic
!---------------
total_tests = 1
passed_tests = 0

write(*,*)
write(*,*) "!-----------------------"
write(*,*) "! Testing linear splines"
write(*,*) "!-----------------------"
write(*,*)

!call plot_linear_spline()

write(*,*)
write(*,*) "!----------------------------------"
write(*,*) "! Testing linear spline derivatives"
write(*,*) "!----------------------------------"
write(*,*)

!call plot_linear_spline_deriv()

write(*,*)
write(*,*) "!----------------------"
write(*,*) "! Testing cubic splines"
write(*,*) "!----------------------"
write(*,*)

!call plot_cubic_spline(cubic_spline_basis)

write(*,*)
write(*,*) "!---------------------------------"
write(*,*) "! Testing cubic spline derivatives"
write(*,*) "!---------------------------------"
write(*,*)

call plot_cubic_spline(cubic_spline_basis_deriv)

contains

subroutine plot_cubic_spline(s)
  real(wp), external :: s
  integer, parameter :: i = 101
  integer, parameter :: n = 7
  integer, parameter :: m = n+2
  integer :: j,k
  real(wp) :: y(m)
  real(wp) :: x(i),fx(i),h
  type(gpf):: gp
  type(inner_product_obj) :: ipo

  y = linspace(0.0_wp,1.0_wp,m)
  h = y(2) - y(1)
  write(*,*) "Node grid:"
  write(*,'(F10.5)', advance="no") y
  write(*,*)

  k = 0
  call set_inner_product(ipo,y,k,n,constant_fun,s,.true.)
  x = linspace(y(1),y(3),i)
  do j = 1,i
    fx(j) = ipo%eval(x(j))
  end do
  call gp%title('Cubic B-Spline Phi_0')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  k = 1
  call set_inner_product(ipo,y,k,n,constant_fun,s,.true.)
  x = linspace(y(1),y(4),i)
  do j = 1,i
    fx(j) = ipo%eval(x(j))
  end do
  call gp%title('Cubic B-Spline Phi_1')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  k = 2
  call set_inner_product(ipo,y,k,n,constant_fun,s,.true.)
  x = linspace(y(1),y(5),i)
  do j = 1,i
    fx(j) = ipo%eval(x(j))
  end do
  call gp%title('Cubic B-Spline Phi_2')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  k = 7
  call set_inner_product(ipo,y,k,n,constant_fun,s,.true.)
  x = linspace(y(m-3),y(m),i)
  do j = 1,i
    fx(j) = ipo%eval(x(j))
  end do
  call gp%title('Cubic B-Spline Phi_7')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  k = 8
  call set_inner_product(ipo,y,k,n,constant_fun,s,.true.)
  x = linspace(y(m-2),y(m),i)
  do j = 1,i
    fx(j) = ipo%eval(x(j))
  end do
  call gp%title('Cubic B-Spline Phi_8')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

end subroutine plot_cubic_spline

subroutine plot_linear_spline()
  integer, parameter :: i = 101
  integer, parameter :: n = 7
  integer, parameter :: m = n+2
  integer :: j,k
  real(wp) :: x(i),fx(i),h
  type(gpf):: gp
  type(inner_product_obj) :: ipo

  y = linspace(0.0_wp,1.0_wp,m)
  h = y(2) - y(1)

  ! --------------
  ! B-Spline Tests
  ! --------------
  ! ---------
  ! Test One
  ! ---------
  write(*,*) "Node grid:"
  write(*,'(F10.5)', advance="no") y
  write(*,*)

  k = 0
  x = linspace(y(1),y(3),i)
  call set_inner_product(ipo,y,k,n,&
                        constant_fun,linear_spline_basis,.false.)
  do j = 1, i
    fx(j) = ipo%eval(x(j))
  end do
  call gp%title('Linear B-Spline Phi_0')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  k = 1
  x = linspace(y(2),y(4),i)
  call set_inner_product(ipo,y,k,n,&
                        constant_fun,linear_spline_basis,.false.)
  do j = 1, i
    fx(j) = ipo%eval(x(j))
  end do
  call gp%title('Linear B-Spline Phi_1')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  k = 6
  x = linspace(y(m-2),y(m),i)
  call set_inner_product(ipo,y,k,n,&
                        constant_fun,linear_spline_basis,.false.)
  do j = 1, i
    fx(j) = ipo%eval(x(j))
  end do
  call gp%title('Linear B-Spline Phi_7')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

end subroutine plot_linear_spline

subroutine plot_linear_spline_deriv()
  integer, parameter :: i = 101
  integer, parameter :: n = 7
  integer, parameter :: m = n+2
  integer :: j,k
  real(wp) :: x(i),fx(i),h
  type(gpf):: gp

  y = linspace(0.0_wp,1.0_wp,m)
  h = y(2) - y(1)

  write(*,*) "Node grid:"
  write(*,'(F10.5)', advance="no") y
  write(*,*)

  k = 0
  x = linspace(y(1),y(3),i)
  do j = 1, i
    if ( x(j) == 0 ) then
      fx(j) = 1.0/h
    elseif ( x(j) == size(y) ) then
      fx(j) = -1.0/h
    elseif ( x(j) <= y( k+2 ) ) then
      fx(j) = 1.0/h
    elseif ( x(j) <= y( k+3 ) ) then
      fx(j) = -1.0/h
    else
      fx(j) = 0.0/h
      !write(*,*) "Error ", x
    end if
  end do
  call gp%title('Linear B-Spline Phi_0 Deriv')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  k = 1
  x = linspace(y(2),y(4),i)
  do j = 1, i
    if ( x(j) == 0 ) then
      fx(j) = 1.0/h
    elseif ( x(j) == size(y) ) then
      fx(j) = -1.0/h
    elseif ( x(j) <= y( k+2 ) ) then
      fx(j) = 1.0/h
    elseif ( x(j) <= y( k+3 ) ) then
      fx(j) = -1.0/h
    else
      fx(j) = 0.0/h
      !write(*,*) "Error ", x
    end if
  end do
  call gp%title('Linear B-Spline Phi_1 Deriv')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  k = 6
  x = linspace(y(m-2),y(m),i)
  do j = 1, i
    if ( x(j) == 0 ) then
      fx(j) = 1.0/h
    elseif ( x(j) == size(y) ) then
      fx(j) = -1.0/h
    elseif ( x(j) <= y( k+2 ) ) then
      fx(j) = 1.0/h
    elseif ( x(j) <= y( k+3 ) ) then
      fx(j) = -1.0/h
    else
      fx(j) = 0.0/h
      !write(*,*) "Error ", x
    end if
  end do
  call gp%title('Linear B-Spline Phi_7 Deriv')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

end subroutine plot_linear_spline_deriv

function constant_fun(x)
  real(wp) :: constant_fun
  real(wp), intent(in) :: x
  constant_fun = 1.0_wp
end function constant_fun

end program bspline_tests