! Wind turbine subroutine
! Lubello: jan 2020

subroutine WindTurb(rho,              & ! (I) Air density                       [kg/m^3]
                    WindSpeed,        & ! (I) Wind speed                        [m/s]
                    SweptArea,        & ! (I) Swept area                        [m^2] e.g. 39.6 m^2 (Aircon 10/10 kW)
                    etaWindTurb,      & ! (I) Wind turbine efficiency           [-] default: 0.45 (ca. 0.593*0.76, i.e. Betz*efficiency)
                    RatedPower,       & ! (I) Rated power of the wind turbine   [kW]
                    RatedWindSpeed,   & ! (I) Rated wind speed                  [m/s] e.g. 11.0 m/s (Aircon 10/10 kW)
                    CutIn,            & ! (I) Cut in wind speed                 [m/s] e.g.  2.5 m/s (Aircon 10/10 kW)
                    CutOut,           & ! (I) Cout out wind speed               [m/s] e.g. 32.0 m/s (Aircon 10/10 kW)
                    CostWindTurb,     & ! (I) Cost per kW turbine               [eur/kW] default: 990 eur/kW from EnergyPlan Cost Database
                    WWel,             & ! (O) Energy produced                   [kWh]
                    CapexWindTurb)      ! (O) Capex wind turbine                [eur]

      USE MODparam,  ONLY: timestep

      implicit real(8) (a-h,o-z), integer(i-n)

      real(8), intent(IN   ) :: rho,WindSpeed,SweptArea,etaWindTurb,RatedPower,RatedWindSpeed,CutIn,CutOut,CostWindTurb
      real(8), intent(  OUT) :: WWel,CapexWindTurb

      WWel          = 0.d0
      CapexWindTurb = 0.d0

      if(WindSpeed.ge.CutIn .and. WindSpeed.le.CutOut) then ! Wind speed allows the turbine to produce power

        if(WindSpeed.gt.RatedWindSpeed)then ! Wind speed higher than rated wind speed, max power produced
          WWel = RatedPower
        else ! Wind speed higher lower rated wind speed, power according to Betz
          WWel = 0.5d0*rho*SweptArea*WindSpeed**3*etaWindTurb/1.d3
        endif

      elseif(WindSpeed.lt.CutIn)then ! Wind speed lower than cut in speed, power=0
        WWel = 0.d0
      else ! Wind speed higher than cut out speed, power=0
        WWel = 0.d0
      endif

      WWel = WWel * timestep ! [kWh] Energy produced

      CapexWindTurb = CostWindTurb*RatedPower ! [eur] Capex

      return

end subroutine WindTurb


PROGRAM diskbars

    ! ESTE CODIGO FORTRAN RESOLVE A CINEMATICA DE UM MECANISMO
    ! COM DISCO E DUAS BARRAS ARTICULADAS.
    ! TRES OPÇOES DE CONFIGURAÇÃO SÃO POSSIVEIS.
    ! Referencia: SHAMES, Irving H. Engineering Mechanics.
    ! Programação inicial por Luciano FLEISCHFRESSER em 23 JULHO DE 2013.
    ! Última atualização em Janeiro DE 2016.
    !
    ! v0.2 - Alfa Primeira versão no repositório: três opções de mecanismo. Janeiro de 2014
    ! v0.3 - Alfa Programa renomeado e código debugado. Maio de 2104
    ! v0.8 - Beta Revisão ampla das formulações e adição de arquivos de saída. Outubro 2014
    ! v0.9 - Interface do usuário otimizada com opção de passo angular. Janeiro de 2016
    ! v0.91- Padronização da declaração de variáveis com "kind", tabulações aplicadas, compilando com flags
    !        e alocação dinâmica de memória
    !
    ! 14 Abril 2017
    ! Declaração de variáveis padronizada para GFortran.
    ! Melhoramento estético com tabulações aplicadas.
    ! Compilando com flags: gfortran -Og -Wall -fcheck=all -pedantic -o diskbars diskbars.f95
    ! Utilizando alocação dinâmica de memória.

       IMPLICIT NONE

       INTEGER(kind = 8) :: I, J, T

       REAL(kind = 8), PARAMETER :: PI = 3.14159265359

       REAL(kind = 8) :: AB, OA, BC, OC, PSS_NGLR, MG_PNT, NGLR_STP
       REAL(kind = 8), ALLOCATABLE :: L(:), M(:), N(:), O(:), P(:), Q(:), LF(:), BT(:), GM_NM(:), &
                                      GM_DN(:), GM(:), MG(:), FTR(:), V_A(:), V_B(:), MG_AB(:), MG_BC(:), &
                                      BTRM1(:), BTRM2(:), BTRM3(:), BTRM4(:), DNAB(:), MG_AB_PNT(:), BCTRM1(:), &
                                      BCTRM2(:), BCTRM3(:), BCTRM4(:), DNBC(:), MG_BC_PNT(:)

20     WRITE(*,*) "Digite:"
       WRITE(*,*) "1: se deseja simular o mecanismo original"
       WRITE(*,*) "2: se deseja simular o mecanismo que permite giro completo"
       WRITE(*,*) "3: se deseja simular o mecanismo com velocidade variavel"
       WRITE(*,*) "4: se deseja sair do programa"

       READ(*,*) J
       SELECT CASE (J)

!******************************************************************************
       CASE (1)

       OPEN (unit = 10, file = "mecanismo1.dat", status = "old",  &
             action = "write", form = "formatted", position = "rewind")

       WRITE(*,*) "Escolha o passo angular em graus"
       READ(*,*) NGLR_STP

       OA = 0.3000000000000
       BC = OA
       OC = 1.3000000000000
       AB = SQRT((OC - BC)**2 + OA**2)
       PSS_NGLR = NGLR_STP * ( PI / 180.0 )
       T = INT(90.0/NGLR_STP)

       ALLOCATE(L(T+1), M(T+1), N(T+1), O(T+1), P(T+1), Q(T+1), LF(T+2), BT(T+1), GM_NM(T+1), GM_DN(T+1), GM(T+1), MG(T+1), &
                FTR(T+1), V_A(T+1), V_B(T+1), MG_AB(T+1), MG_BC(T+1), BTRM1(T+1), BTRM2(T+1), BTRM3(T+1), BTRM4(T+1), &
                DNAB(T+1), MG_AB_PNT(T+1), BCTRM1(T+1), BCTRM2(T+1), BCTRM3(T+1), BCTRM4(T+1), DNBC(T+1), MG_BC_PNT(T+1))

       LF(1) = 0.0

       DO I = 1, T + 1
           MG(I) = 2.0
           V_A(I) = MG(I) * OA
           L(I) = SIN (LF(I))
           M(I) = COS (LF(I))
           BT(I) = ACOS ( 1.0 - L(I))
           N(I) = SIN (BT(I))
           O(I) = COS (BT(I))
           GM_NM(I) = BC * N(I) + OA * M(I)
           GM_DN(I) = AB
           GM(I) = ASIN (GM_NM(I) / GM_DN(I))
           P(I) = SIN(GM(I))
           Q(I) = COS(GM(I))

           FTR(I) = (M(I)*Q(I) + L(I)*P(I)) / (N(I)*Q(I) + O(I)*P(I))
           V_B(I) = V_A(I) * FTR(I)

           MG_AB(I) = (V_A(I) / AB) * (M(I) * O(I) - L(I) * N(I)) / (O(I) * P(I) + N(I) * Q(I))
           MG_BC(I) = -V_B(I) / BC

           BTRM1(I) = OA * MG(I)**2 * (L(I) * O(I) + M(I) * N(I))
           BTRM2(I) = BC * MG_BC(I)**2 * ( O(I)**2 + N(I)**2)
           BTRM3(I) = AB * MG_AB(I)**2 * ( O(I) * Q(I) - N(I) * P(I))
           DNAB(I) = AB * (O(I) * P(I) + N(I) * Q(I))

           MG_AB_PNT(I) = - (BTRM1(I) + BTRM2(I) + BTRM3(I)) / DNAB(I)

           BCTRM1(I) = OA * MG(I)**2 * (M(I) * P(I) - L(I) * Q(I))
           BCTRM2(I) = MG_AB(I)**2 * AB * (P(I)**2 + Q(I)**2)
           BCTRM3(I) = MG_BC(I)**2 * BC * (N(I) * P(I) - O(I) * Q(I))

           DNBC(I) = BC * (O(I)*P(I) + N(I)*Q(I))
           MG_BC_PNT(I) = - (BCTRM1(I) - BCTRM2(I) + BCTRM3(I)) / DNBC(I)
           LF(I+1) = LF(I) + PSS_NGLR
       END DO

       PRINT *
       PRINT *, "Mecanismo original"
       PRINT *, "Compare os valores para ALFA = 0 com o exemplo resolvido no livro..."
       PRINT *
       PRINT *, " Alfa ", "      Vel. Ang. BC ", " Acel. Ang. BC "
       PRINT *, "(graus)", "      (rad/s) ", "      (rad/s²) "
       PRINT *, "_________________________________________________"
       PRINT *

       WRITE (unit = 10, fmt = "(/, a, /, /, a, a, a, a, /, /, a, a, a, a, /)") "    RESULTADOS P/ GIRO CONST. ANTI-HORARIO", &
              "         ANGULOS (graus)   "," VELOC. LINEARES (m/s) ","   VELOC. ANGULARES (rad/s)  ", &
              " ACEL. ANGULARES (rad/s²)  ",   "    alfa    beta    gama ", "       V_a       V_b    ", &
              "    W        W_ab     W_bc   ", "    dW_ab     dW_bc "

       DO I = 1, T + 1
           PRINT "(f5.1,2f15.3)", LF(I) * 180.0 / PI, MG_BC(I), MG_BC_PNT(I)

           WRITE (unit = 10, &
                  fmt = "(F8.3,',',f8.3,',',f8.3,',',F10.4,',',f10.4,',',f10.4,',',f10.4,',',f10.4,',',F10.4,',',F10.4)") &
                  LF(I)*180.0/PI, BT(I)*180.0/PI, GM(I)*180.0/PI, V_A(I), V_B(I), MG(I), MG_AB(I), &
                  MG_BC(I), MG_AB_PNT(I), MG_BC_PNT(I)

       END DO

       DEALLOCATE(L, M, N, O, P, Q, LF, BT, GM_NM, GM_DN, GM, MG, FTR, V_A, V_B, MG_AB, MG_BC, BTRM1, &
                  BTRM2, BTRM3, BTRM4, DNAB, MG_AB_PNT, BCTRM1, BCTRM2, BCTRM3, BCTRM4, DNBC, MG_BC_PNT)

       PRINT *

!******************************************************************************
       CASE (2)

       OPEN (unit = 10, file = "mecanismo2.dat", status = "old",  &
             action = "write", form = "formatted", position = "rewind")

       WRITE(*,*) "Escolha o passo angular em graus"
       READ(*,*) NGLR_STP

       OA = 0.3000000000000
       BC = OA
       AB = 1.044030651 ! o comprimento da barra conectora nao muda
       OC = SQRT(AB**2 - (OA+BC)**2)
       PSS_NGLR = NGLR_STP * ( PI / 180.0 )
       T = INT(90.0/NGLR_STP)

       ALLOCATE(L(T+1), M(T+1), N(T+1), O(T+1), P(T+1), Q(T+1), LF(T+2), BT(T+1), GM_NM(T+1), GM_DN(T+1), GM(T+1), MG(T+1), &
                FTR(T+1), V_A(T+1), V_B(T+1), MG_AB(T+1), MG_BC(T+1), BTRM1(T+1), BTRM2(T+1), BTRM3(T+1), BTRM4(T+1), &
                DNAB(T+1), MG_AB_PNT(T+1), BCTRM1(T+1), BCTRM2(T+1), BCTRM3(T+1), BCTRM4(T+1), DNBC(T+1), MG_BC_PNT(T+1))

       LF(1) = 0.0

       DO I = 1, T + 1 !-1
           MG(I) = -2.0
           V_A(I) = ABS (MG(I)*OA)
           L(I) = SIN(LF(I))
           M(I) = COS(LF(I))
           BT(I) = ACOS (L(I))
           N(I) = SIN(BT(I))
           O(I) = COS(BT(I))
           GM_NM(I) = BC * N(I) + OA * M(I)
           GM(I) = ASIN (GM_NM(I) / AB)

           IF (GM(I) .LE. 1.0e-5) THEN
               GM(I) = 0.0
           ENDIF

           P(I) = SIN(GM(I))
           Q(I) = COS(GM(I))

           FTR(I) = (M(I) * Q(I) - L(I) * P(I)) / (O(I) * P(I) + N(I) * Q(I))

           MG_AB(I) = MG(I) * (OA/AB) * (M(I) * O(I) + L(I) * N(I))/(O(I) * P(I) + N(I) * Q(I))
           MG_BC(I) = -MG(I) * (OA/BC) * FTR(I)

           V_B(I) = MG_BC(I) * BC

           BTRM1(I) = MG(I)**2 * OA * (L(I)*O(I) - M(I)*N(I))
           BTRM2(I) = BC * MG_BC(I)**2 * (O(I)**2 + N(I)**2)
           BTRM3(I) = MG_AB(I)**2 * AB * (O(I)*Q(I) - N(I)*P(I))
           DNAB(I) = AB * (O(I)*P(I) + N(I)*Q(I))

           MG_AB_PNT(I) = (BTRM1(I) - BTRM2(I) - BTRM3(I)) / DNAB(I)

           BCTRM1(I) = OA * MG(I)**2 * (L(I) * Q(I) + M(I) * P(I))
           BCTRM2(I) = MG_AB(I)**2 * AB * (Q(I)**2 + P(I)**2)
           BCTRM3(I) = MG_BC(I)**2 * BC * (O(I) * Q(I) - N(I) * P(I))
           DNBC(I) = BC * (N(I) * Q(I) + O(I) * P(I))

           MG_BC_PNT(I) = -(BCTRM1(I) - BCTRM2(I) - BCTRM3(I)) / DNBC(I)

           LF(I+1) = LF(I) + PSS_NGLR
       END DO

       PRINT *
       PRINT *, "Mecanismo modificado para o projeto computacional com giro completo"
       PRINT *,
       PRINT *, " Alfa ", "      Vel. Ang. BC ", " Acel. Ang. BC "
       PRINT *, "(graus)", "      (rad/s) ", "      (rad/s²) "
       PRINT *, "_________________________________________________"
       PRINT *

       WRITE (unit = 10, fmt = "(/, a, /, /, a, a, a, a, /, /, a, a, a, a, /)") "    RESULTADOS P/ GIRO COMPLETO HORARIO", &
              "         ANGULOS (graus)   "," VELOC. LINEARES (m/s) ","   VELOC. ANGULARES (rad/s)  ", &
              " ACEL. ANGULARES (rad/s²)  ",   "    alfa    beta    gama ", "       V_a       V_b    ", &
              "    W        W_ab     W_bc   ", "    dW_ab     dW_bc "

       DO I = 1, T !-1
           PRINT "(f5.1, f15.3, f15.3)", LF(I) * 180.0 / PI, MG_BC(I), MG_BC_PNT(I)

           WRITE (unit = 10, &
                  fmt = "(F8.3,',',f8.3,',',f8.3,',',F10.4,',',f10.4,',',f10.4,',',f10.4,',',f10.4,',',F10.4,',',F10.4)") &
                  LF(I)*180.0/PI, BT(I)*180.0/PI, GM(I)*180.0/PI, V_A(I), ABS (V_B(I)), MG(I), MG_AB(I), &
                  MG_BC(I), MG_AB_PNT(I), MG_BC_PNT(I)

       END DO

       DEALLOCATE(L, M, N, O, P, Q, LF, BT, GM_NM, GM_DN, GM, MG, FTR, V_A, V_B, MG_AB, MG_BC, BTRM1, &
                  BTRM2, BTRM3, BTRM4, DNAB, MG_AB_PNT, BCTRM1, BCTRM2, BCTRM3, BCTRM4, DNBC, MG_BC_PNT)

       PRINT *
       WRITE(*,*)"NESTE CASO, A BARRA DE CONEXÃO FICA HORIZONTAL PARA ALFA = 90 GRAUS."
       WRITE(*,*)"ENTÃO O PROGRAMA É TERMINADO UM PASSO ANGULAR ANTES PARA EVITAR DIVISÃO POR ZERO"

       PRINT *

!******************************************************************************
       CASE (3)

       OPEN (unit = 10, file = "mecanismo3.dat", status = "old",  &
             action = "write", form = "formatted", position = "rewind")

       WRITE(*,*) "Escolha o passo angular em graus"
       READ(*,*) NGLR_STP

       OA = 0.3000000000000
       BC = OA
       OC = 1.3000000000000
       AB = SQRT((OC - BC)**2 + OA**2)

       MG_PNT = 4.37
       PSS_NGLR = NGLR_STP * ( PI / 180.0 )
       T = INT(90.0/NGLR_STP)

       ALLOCATE(L(T+1), M(T+1), N(T+1), O(T+1), P(T+1), Q(T+1), LF(T+2), BT(T+1), GM_NM(T+1), GM_DN(T+1), GM(T+1), MG(T+2), &
                FTR(T+1), V_A(T+1), V_B(T+1), MG_AB(T+1), MG_BC(T+1), BTRM1(T+1), BTRM2(T+1), BTRM3(T+1), BTRM4(T+1), &
                DNAB(T+1), MG_AB_PNT(T+1), BCTRM1(T+1), BCTRM2(T+1), BCTRM3(T+1), BCTRM4(T+1), DNBC(T+1), MG_BC_PNT(T+1))

       MG(1) = 0.10
       LF(1) = 0.0

       DO I = 1, T + 1
           L(I) = SIN (LF(I))
           M(I) = COS (LF(I))
           V_A(I) = MG(I) * OA
           BT(I) = ACOS ( 1.0 - L(I))
           N(I) = SIN (BT(I))
           O(I) = COS (BT(I))
           GM_NM(I) = BC * N(I) + OA * M(I)
           GM_DN(I) = AB
           GM(I) = ASIN (GM_NM(I) / GM_DN(I))
           P(I) = SIN(GM(I))
           Q(I) = COS(GM(I))

           FTR(I) = (M(I)*Q(I) + L(I)*P(I)) / (N(I)*Q(I) + O(I)*P(I))
           MG_AB(I) = (V_A(I) / (AB * Q(I))) * (O(I) * FTR(I) - L(I))
           V_B(I) = V_A(I) * FTR(I)
           MG_BC(I) = -V_B(I) / BC

           BTRM1(I) = MG(I)**2 * OA * (L(I)*O(I) + M(I)*N(I))
           BTRM2(I) = MG_PNT * OA * (M(I) * O(I) - L(I) * N(I))
           BTRM3(I) = MG_BC(I)**2 * BC * (O(I)**2 + N(I)**2)
           BTRM4(I) = MG_AB(I)**2 * AB * (O(I) * Q(I) - N(I) * P(I))

           DNAB(I) = AB * (O(I) * P(I) + N(I) * Q(I))

           MG_AB_PNT(I) = 1.0/DNAB(I) * (-BTRM1(I)+BTRM2(I)-BTRM3(I)-BTRM4(I))

           BCTRM1(I) = MG(I)**2 * OA * (L(I)*Q(I) - M(I)*P(I))
           BCTRM2(I) = MG_PNT * OA * (M(I) * Q(I) + L(I) * P(I))
           BCTRM3(I) = MG_BC(I)**2 * BC * (N(I)*P(I) - O(I)*Q(I))
           BCTRM4(I) = MG_AB(I)**2 * AB * (P(I)**2 + Q(I)**2)

           DNBC(I) = BC * (O(I) * P(I) + N(I) * Q(I))

           MG_BC_PNT(I) = 1.0/DNBC(I) * (BCTRM1(I)-BCTRM2(I)-BCTRM3(I)+BCTRM4(I))

           LF(I+1) = LF(I) + PSS_NGLR
           MG(I+1) = MG(1) + MG_PNT * LF(I+1)
       END DO

       PRINT *
       PRINT *, "Mecanismo modificado para o projeto computacional com velocidade variavel"
       PRINT *
       PRINT *, " Alfa ", "      Vel. Ang. BC ", " Acel. Ang. BC "
       PRINT *, "(graus)", "       (rad/s) ", "      (rad/s²) "
       PRINT *, "__________________________________________"
       PRINT *

       WRITE (unit = 10, fmt = "(/, a, /, /, a, a, a, a, /, /, a, a, a, a, /)") "    RESULTADOS P/ GIRO VAR. ANTI-HORARIO", &
              "         ANGULOS (graus)   "," VELOC. LINEARES (m/s) ","   VELOC. ANGULARES (rad/s)  ", &
              " ACEL. ANGULARES (rad/s²)  ",   "    alfa    beta    gama ", "       V_a       V_b    ", &
              "    W        W_ab     W_bc   ", "    dW_ab     dW_bc "

       DO I = 1, T + 1
           PRINT "(f5.1, f15.3, f15.3)", LF(I) * 180.0 / PI, MG_BC(I), MG_BC_PNT(I)

           WRITE (unit = 10, &
                  fmt = "(F8.3,',',f8.3,',',f8.3,',',F10.4,',',f10.4,',',f10.4,',',f10.4,',',f10.4,',',F10.4,',',F10.4)") &
                  LF(I)*180.0/PI, BT(I)*180.0/PI, GM(I)*180.0/PI, V_A(I), V_B(I), MG(I), MG_AB(I), &
                  MG_BC(I), MG_AB_PNT(I), MG_BC_PNT(I)

       END DO

       DEALLOCATE(L, M, N, O, P, Q, LF, BT, GM_NM, GM_DN, GM, MG, FTR, V_A, V_B, MG_AB, MG_BC, BTRM1, &
                  BTRM2, BTRM3, BTRM4, DNAB, MG_AB_PNT, BCTRM1, BCTRM2, BCTRM3, BCTRM4, DNBC, MG_BC_PNT)

       PRINT *

!******************************************************************************
       CASE (4)
           WRITE(*,*)
           WRITE(*,*)"ATÉ A PRÓXIMA!"
           WRITE(*,*)
       STOP

       CASE DEFAULT
           WRITE(*,*)
           WRITE(*,*)"OPÇÃO INVÁLIDA: ESCOLHA NOVAMENTE"
           WRITE(*,*)
       END SELECT

       GO TO 20 ! pode comentar se for pra rodar apenas 1 vez

       CLOSE(unit = 10)

END PROGRAM diskbars


Module mdproj
!*************************************************************************
! The Module initializes the following variables for the program:
!   fij    :  sum of forces exerted on particle i from particles j = [1,N]
!   tstep  :  time step
!   en     :  total energy of system
!   temp   :  temperature
!   press  :  pressure
!   rdist  :  distance between two particles
!   kb     :  boltzmann constant
!   sigma  :  diameter of particle
!   num    :  number of particles
!   dens   :  density of the particles
!   vol    :  volume of the box the particles are in (assumed its a cube)
!   vel    :  velocity of the particles (vx, vy, vz)
!   temp0  :  inital temperature estimate to calculate v0
!   mass   :  mass of a particle
!   pi     :  define pi (3.14159)
!   posit  :  position of particles (x, y, z)
!   deltap :  distance between particles i and j
!   force  :  force exerted on particle i from particle j
!   fx     :  force in the x-direction
!   fy     :  force in the y-direction
!   fz     :  force in the z-direction
!   cx     :  difference of distance of particle i and j in x-direction
!   cy     :  difference of distance of particle i and j in y-direction
!   cz     :  difference of distance of particle i and j in z-direction
!	rmsvel :  the root mean squared velocity
!
! Input:   dens
! Output:  en, temp, press, vol
!
! for an inert gas such as Ar:
!   mass = 6.69E-26 kg
!   sigma = 0.34 nm = 0.34E-9
!	http://www.sklogwiki.org/SklogWiki/index.php/Argon
!
! for Xe:
!	mass = 2.1801714E-25 kg
!	sigma = 4.1E-10 m
!	http://chem.libretexts.org/Core/Physical_and_Theoretical_Chemistry/Physical_Properties_of_Matter/Atomic_and_Molecular_Properties/Intermolecular_Forces/Specific_Interactions/Lennard-Jones_Potential
!
! The units utilized to carry out the calculation are based on the
! relative length of an atom, the mass of an atom, and kbT
!	mass = 1.
!	kbT = 1.
!	sigma = 1.
!	cutoff = 2.5*sigma
!*************************************************************************

integer, parameter :: DP = SELECTED_REAL_KIND(8)
!real, parameter :: tstep = 1.E-10
!Sets accuracy, time step and max time
real (Kind = DP), parameter:: tmax=0.1, tstep = 1.E-5, accuracy = 1.E-25
real (Kind = DP) :: en, temp, temp2, press, press2, dens, vol
real (Kind = DP) :: rmsvel, rmsvel2, en2, v_frac
!real (Kind = DP) :: temp0, equilT, equilE, equilP, equilVel
real (Kind = SELECTED_REAL_KIND(8)) :: side
real, parameter :: cutoff=2.5, kbT = 2.
!real, parameter :: kb=1.38064852E-23, h = 6.62607004E-34
integer, parameter :: num = 300
!real :: maxcalc
real (Kind = DP), dimension(num, 3) :: vel0, vel, vel2, posit0, posit, posit2
real (Kind = DP), dimension(num, 3) :: vel_NVE, vel_And, posit_NVE, posit_And
real (Kind = DP), dimension(num, num):: deltap, deltap2
real (Kind = DP), dimension(num, 3) :: fij, fij2
real (Kind = DP), dimension(3):: rms_dis_NVE, rms_dis_And
real, parameter :: pi = 4. * atan(1.), sigma = 1., v_frac_unit = 1.0E-1
real, parameter :: mass = 1.
real (Kind = DP):: t, velavg, velmin, velmax, velstddev
real, parameter :: half = 0.5
!real, parameter :: x = 1E10
!integer :: acc_count
!v_frac is # change per timestep
integer:: counter1

End Module mdproj

Program project
!*************************************************************************
! This program performs a NVE molecular dynamics simulation using
! the velocity verlet algorithm
!*************************************************************************
Use mdproj

dens = 0.8
!Read(*,*), dens
vol = num / dens
side = vol**(1./3.)

!Print *, 'At this density, with N =', num, ' particles, the volume is', vol
Print *, 'side', side

!Next the starting velocity of the particles are estimated using
! the Boltzmann distribution given a starting temperature
!EDIT: Currently, the velocities are calculated using kbT, not temp0

!Print *, 'Enter an estimate of the temperature (K):'
!temp0 = 100
!Read(*,*), temp0
!Print *, 'The estimated temperature is', temp0, 'K'

!Initializes the velocities
call init_posit(posit0)
call init_v0(vel0)
!Prints initial position and velocity
!Print *, ' '

!Do i = 1, num
!	posit0()
!Print *, 'posit0', posit0
!Print *, ' '
!Print *, 'vel0', vel0

!Sets the accuracy of the calculations for setting values equal to zero
!acc_count=0

call vel_rms(vel, rmsvel)
!Print *, ' '
!Print *, 'rmsvel', rmsvel

!Calculate postion (posit) and velocity (vel) using velocity verlet
! approximation which continues to iterate until time, t, has
! reached max time, tmax.
vel = vel0
posit = posit0
call NVE_sim()

!Stores the values of velocity and position for the NVE simulation
vel_NVE = vel2
posit_NVE = posit2

!Prints final values of NVE sim
!Print *, 'side:', side
Print *, ' '
!Print *, 'posit_NVE', posit_NVE
!Print *, ' '
Print *, 'vel_NVE', vel_NVE
!Print *, ' '
Print *, 'temp2', temp2
Print *, 'press2', press2
Print *, 'en2', en2
Print *, 'rmsvel2', rmsvel2

!Calculates the root mean square dispalcement for the NVE Simulation
Call displace_rms(rms_dis_NVE)
Print *, 'NVE rms_dis', rms_dis_NVE

!Calculates the average, minimum, maximum, and standard deviation for the velocity
Call vel_analysis(vel_NVE, velavg, velmin, velmax, velstddev)
Print *, 'NVE: velavg', velavg, 'velmin', velmin, 'velmax', velmax, 'velstddev', velstddev

!Calculates the rms displacement for the simulation at the final time step
! compared to the initial position
!Call displace_rms(rms_dis_NVE)
!Print *, 'NVE rms_dis', rms_dis_NVE

!Calculate postion (posit) and velocity (vel) using velocity verlet
! approximation with an Andersen thermostat, which continues to
! iterate until time, t, has reached max time, tmax.
!
!The velocity array, vel, is set to the initial condition calculated
! previously. The position array, posit, is recalculated based on
! the size of the box
!
!The density is changed and to determine the different pressure
! at densities between 0.1 and 0.8 with increments of 0.1
!
!v_frac is # of part that change per timestep for the Andersen thermostat
v_frac = v_frac_unit * tstep

Do counter1 = 1, 8
!Do counter1 = 1, 2
	dens = Real(counter1, 8) * 0.1
!	dens = 0.8
!	Print *, 'counter1', counter1, 'density', dens
	vol = num / dens
	side = vol**(1./3.)
	vel = vel0
	call init_posit(posit)
	call Andersen_sim()
	Print *, 'dens =', dens,'  side:', side
	!Stores the values of velocity and position for the Andersen simulation
	vel_And = vel2
	posit_And = posit2

!	Print *, 'side:', side
!	Print *, ' '
!	Print *, 'posit_And', posit_And
!	Print *, ' '
	Print *, 'vel_And', vel_And
!	Print *, ' '
	Print *, 'temp2', temp2
	Print *, 'press2', press2
	Print *, 'en2', en2
	Print *, 'rmsvel2', rmsvel2

	!Calculates the rms displacement for the simulation at the final time step
	! compared to the initial position
	Call displace_rms(rms_dis_And)
	Print *, 'And rms_dis', rms_dis_And

	!Calculates the average, minimum, maximum, and standard deviation for the velocity
	Call vel_analysis(vel_And, velavg, velmin, velmax, velstddev)
	Print *, 'And: velavg', velavg, 'velmin', velmin, 'velmax', velmax, 'velstddev', velstddev

End Do

End Program project

!The Subroutine init_posit initializes the initial positions of the
! particles into a lattice like structure
Subroutine init_posit(positin)
Use mdproj
real :: lattice, latticepart, posit_max, posit_min
, dimension(num, 3)::positin
integer :: dovarx, dovary, dovarz, partcount, latticepartint

posit_max=-1.0
posit_min=100000.0

latticepart = num**(0.33333333333333)
latticepartint = nint(latticepart)
lattice = side/(latticepart)
!Print *, 'latticepart', latticepart
!Print *, 'latticepartint', latticepartint
!Print *, 'lattice', lattice
!STOP
partcount = 1

!Do loop populates posit0
Do dovarz = 0, (latticepartint-1)
	Do dovary = 0, (latticepartint-1)
		Do dovarx = 0, (latticepartint-1)
		if(partcount > num) then
			Exit
		else
			positin(partcount, 1) = lattice * dovarx
			positin(partcount, 2) = lattice * dovary
			positin(partcount, 3) = lattice * dovarz
!			Print *, 'posit0', positin(partcount,1), positin(partcount,2), positin(partcount,3)
!			Print *, 'dovarx, y, z', dovarx, dovary, dovarz
!			Print *, 'partcount', partcount
			partcount = partcount + 1
		End if
		End Do
	End Do
End Do
!Print *, 'dovarx, y, z', dovarx, dovary, dovarz
!Print *, 'partcount', partcount
End Subroutine init_posit

!The subroutine init_v0 sets the inital velocities of the particles
! utilizing the Boltzmann distribution by multiplying the random
! Gaussian generator by sqrt(kbT/mass)
!Reference: https://en.wikibooks.org/wiki/Fortran/Fortran_procedures_and_functions
Subroutine init_v0(velin)
Use mdproj
real :: mean, stdDev, u, v, s, spare, mul, outvar
integer :: dovar1, dovar2
real (Kind = DP), dimension(num, 3):: velin
logical :: isSpareReady = .FALSE.

mean = 0.
stdDev = 1.

!Do loops populate the entire array for vel0
Do dovar1 = 1, num
    Do dovar2 = 1, 3
    isSpareReady = .FALSE.

    !If statement handles generation of the boltmann distribution
    ! for the initial veloities
    If (isSpareReady) then
    isSpareReady = .FALSE.
    outvar = spare * stdDev + mean
    Else
    Do
        Call random_number(u)
        u = u * 2 - 1
        Call random_number(v)
        v = v * 2 - 1
        s = u*u + v*v
        If((s < 1.) .AND. (s /= 0)) then
        Exit
        End if
    End Do
    mul = sqrt(-2.0*log(s)/s)
    spare = v * mul
    isSpareREady=.TRUE.
    outvar = mean + stdDev * u * mul
    End if

	velin(dovar1,dovar2)=sqrt(kbT/mass)*outvar

	End Do
End Do

End Subroutine init_v0

!Loop Calculated the force between the particles by first calculating the distance
! by taking the difference in the x, y, and z directions, calculating the length
! of the vector and storing it in array deltap, then normalizing the vector c to use it
! to break down the force vector into fx, fy, fz and summing the forces exerted on
! particle i in the x(1), y(2), and z(3) directions in array fij
Subroutine force_calc(positin, fij_out, deltap1)
Use mdproj
real (KIND = DP), dimension(num, 3) :: positin, fij_out
real (Kind = DP), dimension(num, num) :: deltap1
real (Kind = DP):: force, fx, fy, fz, cx, cy, cz
integer :: count1, count2, i, j
real :: cmin, cmax
!logical :: truthtest
!infinite = HUGE(infinite)

Do count1 = 1, num
	Do count2 = 1, 3
		fij_out(count1,count2)=0.
	End Do
End Do

cmin = 10
cmax = -10

!Print *, '0positin', positin

Do i = 1, num
	Do j = 1, num
		if(i == j) then
!			Print *, "Entered the if at i=", i, 'and j=', j
			deltap1(i,j) = 0.
!			Print *, '1positin', positin(i,1), 'j', positin(j,1)
		else
!			Print *, '1posit', posit, 'posit2', posit2
!			Print *, '2positin', positin(i,1), 'j', positin(j,1)
!			Print *, "Entered the else if at i=", i, 'and j=', j

			cx = positin(i,1) - positin(j,1)
			cy = positin(i,2) - positin(j,2)
			cz = positin(i,3) - positin(j,3)
!			Print *, 'cx', cx, 'cy', cy, 'cz', cz

!			if(cx > (side/2)) then
!				cx = cx - (side/2)
!			Print *,'cx', cx, 'i', i, 'j', j
!			End if
!			if(cx < (-side/2)) then
!				cx = cx + (side/2)
!			Print *,'cx', cx, 'i', i, 'j', j
!			End if
!
!			if(cy > (side/2)) then
!				cy = cy - (side/2)
!				Print *, 'cy', cy, 'i', i, 'j', j
!			End if
!			if(cy < (-side/2)) then
!				cy = cy + (side/2)
!!				Print *, 'cy', cy, 'i', i, 'j', j
!			End if

!			if(cz > (side/2)) then
!				cz = cz - (side/2)
!				Print *, 'cz', cz, 'i', i, 'j', j
!			End if
!			if(cz < (-side/2)) then
!				cz = cz + (side/2)
!				Print *, 'cz', cz, 'i', i, 'j', j
!			End if

			if(cx < cmin) cmin = cx
			if(cy < cmin) cmin = cy
			if(cz < cmin) cmin = cz
			if(cx > cmax) cmax = cx
			if(cy > cmax) cmax = cy
			if(cz > cmax) cmax = cz

!			Print *, '3positin', positin(i,1), 'j', positin(j,1), 'i,j', i, j
			deltap1(i,j) = sqrt((cx)**2 + (cy)**2 + (cz)**2)
!			Print *, 'deltap1', deltap1(i,j), 'i', i, 'j', j
!			truthtest = (deltap1(i,j) == 0.) .OR. (deltap1(i,j) >= cutoff)
!			Print *, 'Truthtest', truthtest

!				if(deltap(i,j) /= deltap(i,j)) then
!				Print *, 'FATAL ERROR (NaN) at ', i, j
!				End if

!				if(deltap(i,j) >= infinite) then
!				Print *, ' FATAL ERROR (Infinity) at', i, j
!				End if

			if((deltap1(i,j) == 0.) .OR. (deltap1(i,j) >= cutoff)) then
!			if(deltap1(i,j) >= cutoff) then
				fij_out(i,1) = fij_out(i,1) + 0.0
				fij_out(i,2) = fij_out(i,2) + 0.0
				fij_out(i,3) = fij_out(i,3) + 0.0
!				Print *, "the program exited the else if at i=", i, 'and j=', j
!				Print *, 'deltap1', deltap1(i,j), 'i', i, 'j', j
!				Print *, 'positin: i', positin(i,1), 'j', positin(j,1)
!				Print *, 'positin: i', positin(i,2), 'j', positin(j,2)
!				Print *, 'positin: i', positin(i,3), 'j', positin(j,3)
!				Print *, 'cx', cx, 'cy', cy, 'cz', cz
			else
!				Print *, "the program entered the else at i=", i, 'and j=', j
				cx = cx/deltap1(i,j)
				cy = cy/deltap1(i,j)
				cz = cz/deltap1(i,j)

!				if(cx < accuracy) then
!					cx = 0.
!				End if
!				if(cy < accuracy) then
!					cy = 0.
!				End if
!				if(cz < accuracy) then
!					cz = 0.
!				End if

!				Print *, 'cx, y, z', cx, cy, cz, deltap(i,j)
!				force = -1/kbT*((sigma/deltap(i,j))**12 - (sigma/deltap(i,j))**6)/deltap(i,j)
!				Print *, ' force:', force
				force = 4/kbT*((12*sigma**12/(deltap1(i,j)**13)) - (6*sigma**6/(deltap1(i,j)**7)))
				fx = force * cx
				fy = force * cy
				fz = force * cz
				fij_out(i,1) = fij_out(i,1) + fx
				fij_out(i,2) = fij_out(i,2) + fy
				fij_out(i,3) = fij_out(i,3) + fz
!				Print *, 'force', force, 'dist', deltap1(i,j)
!				Print *, 'i', i, 'j', j
!				Print *, 'fx', fx, 'fy', fy, 'fz', fz
!				Print *, '     The sum forces for particle i are:', fij_out(i,1), fij_out(i,2), fij_out(i,3)
!				Print *, ' '
!				Print *, ' deltap', deltap(i,j)
			End if
!				if(fx /= fx) then
!				Print *, 'FATAL ERROR (NaN) fx at ', i, j
!				End if

!				if(fx >= infinite) then
!				Print *, ' FATAL ERROR (Infinity) fx at', i, j
!				End if

!				if(fy /= fy) then
!				Print *, 'FATAL ERROR (NaN) fy at ', i, j
!				End if

!				if(fy >= infinite) then
!				Print *, ' FATAL ERROR (Infinity) fy at', i, j
!				End if

!				if(fz /= fz) then
!				Print *, 'FATAL ERROR (NaN) fz at ', i, j
!				End if

!				if(fz >= infinite) then
!				Print *, ' FATAL ERROR (Infinity) fz at', i, j
!				End if

		End if
!		Print *, "the program completed the if statement at i=", i, 'and j=', j
	End Do
!	Print *, 'i', i, 'fij_outx', fij_out(i,1), 'fij_outy', fij_out(i,2), 'fij_outz', fij_out(i,3)

!	if(fij_outin(i,1) < accuracy) then
!	fij_outin(i,1) = 0.
!	acc_count = acc_count + 1
!	End if
!	If(fij_outin(i,2) < accuracy) then
!	fij_outin(i,2) = 0.
!	acc_count = acc_count + 1
!	End if
!	if(fij_outin(i,3) < accuracy) then
!	fij_outin(i,3) = 0.
!	acc_count = acc_count + 1
!	End if

End Do

!Print *, 'cmin', cmin, 'cmax', cmax
!Print *, '2posit', posit, 'posit2', posit2

End Subroutine force_calc

!The NVE_sim subroutine performs the verlet approximation on
! the position (posit) and velocity (vel) vectors
Subroutine NVE_sim()
Use mdproj
integer :: m, j1, j2, j3, l1
REAL(Kind = DP):: posit_max, posit_min
!logical :: equilTtruth = .FALSE.
!real (Kind = SELECTED_REAL_KIND(16)):: j5
!integer (Kind = Selected_Int_Kind(32))::j4
!infinite = HUGE(infinite)

!Print *, '1posit', posit, 'posit2', posit2
!Sets counter variables
m = 1
t = 0.

posit_max=-1
posit_min=1000000

Do
!	Print *, 'm NVE', m
	!Calculate distance between particles and the forces exerted on the particles
	Call force_calc(posit, fij, deltap)
!	Print *, 'forcecalc ', m, ' completed'
!	Print *, '2posit', posit, 'posit2', posit2
!	posit2 = posit + vel*tstep + (fij/2/mass*(tstep**2))
!	Print *, '3posit', posit, 'posit2', posit2
!	Print *, 'acc_count', acc_count

	Do j1 = 1, num
		Do j2 = 1, 3
!			if(posit(j1,j2) > 10*side) then
!			Print *, 'Error - particle1'
!			Exit
!			Endif

!			if(posit2(j1,j2) > 10*side) then
!			Print *, 'Error - particle2'
!			Exit
!			Endif
			posit2(j1,j2) = posit(j1,j2) + vel(j1,j2)*tstep + (fij(j1,j2)/2/mass*(tstep**2))
!			Print *, '   posit2', posit2(j1,j2), 'posit', posit(j1,j2), 'vel', vel(j1,j2), 'fij', fij(j1,j2) !'tstep', tstep

!			if((vel(j1,j2)*tstep) /= (vel(j1,j2)*tstep)) then
!			Print *, 'FATAL ERROR (NaN) for vel term', vel(j1, j2), tstep
!			End if

!			if((vel(j1,j2)*tstep) >= infinite) then
!			Print *, ' FATAL ERROR (Infinity) for vel term', vel(j1, j2), tstep
!			End if

!			if((fij(j1,j2)/2/mass*(tstep**2)) /= (fij(j1,j2)/2/mass*(tstep**2)) ) then
!			Print *, 'FATAL ERROR (NaN) for fij term', fij(j1, j2), 1/2/mass*(tstep**2)
!			End if

!			if((fij(j1,j2)/2/mass*(tstep**2)) >= infinite) then
!			Print *, ' FATAL ERROR (Infinity) fij term', fij(j1, j2), 1/2/mass*(tstep**2)
!			End if

			if(posit2(j1,j2) >= side) then
				j3 = posit2(j1,j2)/side
				posit2(j1,j2) = posit2(j1,j2) - (j3 * side)
!				if(j3>2) then
!				Print *, 'j3', j3
!				End if
!				Print *, 'j1', j1, 'j2', j2, 'posit2', posit2(j1,j2)
				!Based on the bulk system, the velocity does not change direction
!				vel(j1,j2) = - vel(j1,j2)
!				Print *, 'neg vel', vel(j1, j2)
!				elseif(posit2(j1,j2) == side) then
!				vel(j1,j2) = -vel(j1, j2)
!				Print *, 'negvel', vel(j1, j2)
			End if
			if (posit2(j1,j2) < 0.0) then
				j3 = -(posit2(j1,j2)/side) + 1
				posit2(j1,j2) = posit2(j1,j2) + (j3 * side)
!				if(j3>2) then
!				Print *, 'j3', j3
!				End if
!				Print *, 'neg fix', posit2(j1,j2), j3, (j3*side)
			End if

			IF (posit2(j1,j2)>posit_max) posit_max=posit2(j1,j2)
			IF (posit2(j1,j2)<posit_min) posit_min=posit2(j1,j2)

!			if (posit2(j1,j2) < -0.0001) then
!				posit2(j1,j2) = abs(posit2(j1,j2))
!				j4 = ((posit2(j1,j2)-side)/side)
!				j5 = j4
!				Print *, 'neg fix', posit2(j1,j2), j5, (side*j5)
!				posit2(j1,j2) = posit2(j1,j2) - (side*j5)
!				Print *, 'neg fix pt 2', posit2(j1,j2)
!				Print *, 'j1', j1, 'j2', j2, 'posit2 neg', posit2(j1,j2), 'j3', j3
!			End if

!			Print *, posit2(j1,j2)

		End Do
	End Do
!PRINT*, posit_max, posit_min
!STOP

	!Calculates the force after the first time step, used to calculate vel2
	Call force_calc(posit2, fij2, deltap2)
!	Print *, 'forcecalc2 ', m, ' completed'
!	Print *, 'acc_count', acc_count

	!Calculates the velocity vel2, after the first time step
	Do l1 = 1, num
		vel2(l1, 1) = vel(l1, 1) + ((fij(l1, 1)+fij2(l1, 1))/2/mass*tstep)
		vel2(l1, 2) = vel(l1, 2) + ((fij(l1, 2)+fij2(l1, 2))/2/mass*tstep)
		vel2(l1, 3) = vel(l1, 3) + ((fij(l1, 3)+fij2(l1, 3))/2/mass*tstep)
!		Print *, '   vel2x', vel2(l1,1), 'velx', vel(l1,1), 'fij2x', fij2(l1,1), 'fijx', fij(l1,1)
!		Print *, '   vel2y', vel2(l1,2), 'vely', vel(l1,2), 'fij2y', fij2(l1,2), 'fijy', fij(l1,2)
!		Print *, '   vel2z', vel2(l1,3), 'velz', vel(l1,3), 'fij2z', fij2(l1,3), 'fijz', fij(l1,3)

!		If(vel2(l1,1) < accuracy) then
!			vel2(l1,1) = 0.
!			Print *, 'min vel2 x'
!			acc_count = acc_count + 1
!		End if
!		If(vel2(l1,2) < accuracy) then
!			vel2(l1,2) = 0.
!			Print *, 'min vel2 y'
!			acc_count = acc_count + 1
!		End if
!		If(vel2(l1,3) < accuracy) then
!			vel2(l1,3) = 0.
!			Print *, 'min vel2 z'
!			acc_count = acc_count + 1
!		End if

!		Print *, 'vel', vel(l1, 1), vel(l1, 2), vel(l1, 3)
!		Print *, 'vel2', vel2(l1, 1), vel2(l1, 2), vel2(l1, 3)
!		Print *, 'fij', fij(l1, 1), fij(l1, 2), fij(l1, 3)
!		Print *, 'fij2', fij2(l1, 1), fij2(l1, 2), fij2(l1, 3)
	End Do

	Call vel_rms(vel, rmsvel)
!	Print *, 'The rms vel =', rmsvel
	Call vel_rms(vel2, rmsvel2)
!	Print *, 'The rms vel2 =', rmsvel2

	!Calculates the thermodynamic properties for the initialized variables
	Call thermo_calc(rmsvel, temp, press, en, fij, deltap, posit)
!	Print *, 'rmsvel =', rmsvel
!	Print *, 'temp =', temp
!	Print *, 'press =', press
!	Print *, 'en =', en

	!Calculates the thermodynamic properties for the initialized variables
	Call thermo_calc(rmsvel2, temp2, press2, en2, fij2, deltap2, posit2)
!	Print *, 'rmsvel2 =', rmsvel2
!	Print *, 'temp2 =', temp2
!	Print *, 'press2 =', press2
!	Print *, 'en2 =', en2

	!The following 'equilibrium' variables calculates the difference
	! between the variables: temp, press, en, and rmsvel for before
	! the time step and after the time step
!	equilT = (temp2 - temp)/temp2
!	Print *, '   The equilT =', equilT
!	equilP = (press2 - press)/press2
!	Print *, '   The equilP =', equilP
!	equilE = (en2 - en)/en2
!	Print *, '   The equilE =', equilE
!	equilVel = (rmsvel2 - rmsvel)/rmsvel2
!	Print *, '   The equilVel =', equilVel

	if(t >= tmax) then
		Exit
	else
		!sets vel and posit values for next time step
		vel = vel2
		posit = posit2
		!adds to the counter for the number of iterations completed
		m = m + 1
		t = t + tstep
		Cycle
	End if
End Do

End Subroutine NVE_sim

!Subroutine vel_rms calculates the root mean square velocity of the given velocity
! array (velarray) and outputs the velocity in the variable velout
Subroutine vel_rms(velarray, velout)
Use mdproj
real (Kind = DP), Dimension(num, 3) :: velarray
real (Kind = DP), Dimension(num) :: magarray
real (Kind = DP) :: velout, velsum
integer :: loop1

velsum = 0.

Do loop1 = 1, num
	!Takes the magnitude of the velocity vector of particle i = loop1
	magarray(loop1) = sqrt(velarray(loop1,1)**2 + velarray(loop1,2)**2 + velarray(loop1,3)**2)
!	Print *, 'loop1', loop1
!	Print *, 'velarray', velarray(loop1,1), velarray(loop1,2), velarray(loop1,3)

	!Adds the square of the magnitude of particle i = loop1
	velsum = velsum + magarray(loop1)**2
!	Print *, 'velsum', velsum
End Do

!Print *, 'velsum', velsum, 'magarray', magarray, 'velout', velout
!Outputs the root mean square velocity in the velout variable
velout = sqrt(velsum/num)

End Subroutine vel_rms

!Subroutine thermo_calc takes the root mean square velocity (rms_velin),
! and returns the temperature (tempout), pressure (pressout),
! and the total energy (enout)
Subroutine thermo_calc(rms_velin, tempout, pressout, enout, fijin, deltapin, positin)
Use mdproj
real (Kind = DP), intent(in):: rms_velin
real (Kind = DP), intent(out)::tempout, pressout, enout
real (Kind = DP) :: ensum, press_force_term
real (Kind = DP), dimension(num, 3), intent(in)::fijin, positin
real (Kind = DP), dimension(num, 3)::Uij
real (Kind = DP), dimension(num, num), intent(in)::deltapin
real (Kind = DP):: force, cx, cy, cz
real (Kind = DP), dimension(num, num, 3)::Ucalc
integer:: e1, d1

!Calculates the temperature based on the root mean squared velocity
tempout = (rms_velin**2) * mass / 3

!Calculates the pressure
pressout = num * tempout / vol
press_force_term = 0.
Do d1 = 1, num
		press_force_term = press_force_term + fijin(d1, 1) + fijin(d1, 2) + fijin(d1, 3)
End Do
press_force_term = press_force_term / vol
pressout = pressout + press_force_term

!Calculates the energy based on ideal gas
Call Uij_calc(positin, Uij, deltapin)
ensum = 0.
Do e1 = 1, num
	ensum = ensum + sqrt(Uij(e1,1)**2 + Uij(e1,2)**2 + Uij(e1,3)**2)
	ensum = ensum + 1/2*mass*sqrt(vel2(e1,1)**2 + vel2(e1,2)**2 + vel2(e1,3)**2)
End Do
enout = ensum
!enout = (rms_velin**2)*mass*num/2 + ensum

End Subroutine thermo_calc

!This subroutine runs a NVT simulation utilizing the Andersen thermostat
! to progress the simulation while holding temperature constant
! by continuously scaling the velocities after each time step
! that is calculated by the velocity position verlet approximation
Subroutine Andersen_sim()
Use mdproj
integer :: m, j1, j2, j3
!logical :: equilPtruth = .FALSE.

!Print *, '1posit', posit, 'posit2', posit2
!Initializes counters
m = 1
t = 0.

Do
!	Print *, 'm And', m
	!Calculate distance between particles and the forces exerted on the particles
	Call force_calc(posit, fij, deltap)
!	Print *, 'acc_count', acc_count
!	Print *, '2posit', posit, 'posit2', posit2
!	posit2 = posit + vel*tstep + (fij/2/mass*(tstep**2))

	!Print *, '3posit', posit, 'posit2', posit2

	Do j1 = 1, num
		Do j2 = 1, 3
!			if(posit(j1,j2) > 10*side) then
!			Print *, 'Error - particle1'
!			Exit
!			Endif

!			if(posit2(j1,j2) > 10*side) then
!			Print *, 'Error - particle2'
!			Exit
!			Endif
		posit2(j1,j2) = posit(j1,j2) + vel(j1,j2)*tstep + (fij(j1,j2)/2/mass*(tstep**2))
!		Print *, '   posit2', posit2(j1,j2), 'posit', posit(j1,j2), 'vel', vel(j1,j2), 'fij', fij(j1,j2) !'tstep', tstep

		if(posit2(j1,j2) > side) then
			j3 = posit2(j1,j2)/side
			posit2(j1,j2) = posit2(j1,j2) - (j3 * side)
!			Print *, 'posit2', posit2(j1,j2)
!			vel(j1,j2) = - vel(j1,j2)
!			Print *, 'neg vel', vel(j1, j2)
		End if
!		elseif(posit2(j1,j2) == side) then
!			vel(j1,j2) = -vel(j1, j2)
!			Print *, 'negvel', vel(j1, j2)
		if (posit2(j1,j2) < 0.0) then
			j3 = -(posit2(j1,j2)/side) + 1
			posit2(j1,j2) = posit2(j1,j2) + (j3 * side)
!			Print *, 'neg fix', posit2(j1,j2), j3, (j3*side)
		End if

		End Do
	End Do

	!Calculates the force after the first time step, used to calculate vel2
	Call force_calc(posit2, fij2, deltap2)
!	Print *, 'acc_count', acc_count
!	vel2 = vel + ((fij+fij2)/2/mass*tstep)
!	Print *, 'vel', vel, 'vel2', vel2
	!This calculation no longer needs to be performed as the velocities
	! are in essense 'reset' below by using the subroutine init_v0

	!This calculation rescales the velocity to achieve the desired
	! temperature for the simulation, then recalculates the
	! rmsvel2 and the thermodynamic variables (temp2, press2, en2)
!	vel2 = sqrt(kbT/temp2)*vel2

	!After futher research, it appears the above method, scaling the
	! velocities, is not desired and the preferred method is to reset
	! the velocities by utilizing the same method for initializing
	! the velocities by using the Gaussian distribution as shown
	! below
	Call thermostat_v(vel2)

	Call vel_rms(vel, rmsvel)
!	Print *, 'The rms vel =', rmsvel
	Call vel_rms(vel2, rmsvel2)
!	Print *, 'The rms vel2 =', rmsvel2

	!Calculates the thermodynamic properties for the initialized variables
	Call thermo_calc(rmsvel, temp, press, en, fij, deltap, posit)
!	Print *, 'rmsvel =', rmsvel
!	Print *, 'temp =', temp
!	Print *, 'press =', press
!	Print *, 'en =', en

	!Calculates the thermodynamic properties for the initialized variables
	Call thermo_calc(rmsvel2, temp2, press2, en2, fij2, deltap2, posit2)
!	Print *, 'rmsvel2 =', rmsvel2
!	Print *, 'temp2 =', temp2
!	Print *, 'press2 =', press2
!	Print *, 'en2 =', en2

	!The following 'equilibrium' variables calculates the difference
	! between the variables: temp, press, en, and rmsvel for before
	! the time step and after the time step
!	equilT = (temp2 - temp)/temp2
!	Print *, '   The equilT =', equilT

!	equilP = (press2 - press)/press2
!	Print *, '   The equilP =', equilP

!	equilE = (en2 - en)/en2
!	Print *, '   The equilE =', equilE

!	equilVel = (rmsvel2 - rmsvel)/rmsvel2
!	Print *, '   The equilVel =', equilVel

	!The pressure is pressure is printed to compare at different densities8
!	Print *, 'Press2:', press2

	if(t >= tmax) then
		Exit
	else
		!sets vel and posit values for next time step
		vel = vel2
		posit = posit2
		!adds to the counter for the number of iterations completed
		m = m + 1
		t = t + tstep
		Cycle
	End if
End Do

End Subroutine Andersen_sim

!Subroutine rms_displace calculates the root mean square displacement
! for a given timestep
Subroutine displace_rms(rms_dis)
Use mdproj
real(Kind = DP), dimension(3):: rms_dis
integer :: loop1

rms_dis(1) = 0
rms_dis(2) = 0
rms_dis(3) = 0

Do loop1 = 1, num
!Takes the square of the displacement of each particle for the time step
rms_dis(1) = (posit2(loop1,1)-posit0(loop1,1))**2 + rms_dis(1)
rms_dis(2) = (posit2(loop1,2)-posit0(loop1,2))**2 + rms_dis(2)
rms_dis(3) = (posit2(loop1,3)-posit0(loop1,3))**2 + rms_dis(3)
End Do

!Divides the sum of the squared displacements by the number of molecules
rms_dis(1) = rms_dis(1)/num
rms_dis(2) = rms_dis(2)/num
rms_dis(3) = rms_dis(3)/num

!Print *, 'rms_dis', rms_dis
!Print *, 'posit0', posit0
!Print *, posit2

End Subroutine displace_rms

!Reset_v subroutine simulates collision with heat bath, resets a fraction
! of the velocities by the set v_frac by using the original technique
! utilized for the initialization of velocities
Subroutine thermostat_v(velin)

Use mdproj
real :: mean, stdDev, u, v, s, spare, mul, outvar, rand_num_part
integer :: dovar1, dovar2, loopcount, rand_part
real (Kind = DP), dimension(num, 3):: velin
!integer, dimension(loopcount) :: already_used
logical :: isSpareReady = .FALSE.

mean = 0.
stdDev = 1.
loopcount = num * v_frac

!Do loops simulate collision with heat bath for v_frac of particles
Do dovar1 = 1, loopcount

	Call random_number(rand_num_part)
	rand_part = num * rand_num_part

	Do dovar2 = 1, 3
	isSpareReady = .FALSE.

	!If statement handles generation of the boltmann distribution
	! for the initial veloities
	if (isSpareReady) then
		isSpareReady = .FALSE.
		outvar = spare * stdDev + mean
	else
		Do
			call random_number(u)
			u = u * 2 - 1
			call random_number(v)
			v = v * 2 - 1
			s = u*u + v*v

			if((s < 1.) .AND. (s /= 0)) then
				Exit
			End if
		End Do

		mul = sqrt(-2.0*log(s)/s)
		spare = v * mul
		isSpareREady=.TRUE.
		outvar = mean + stdDev * u * mul
	End if

	velin(rand_part,dovar2)=sqrt(kbT/mass)*outvar
!	Print *, 'part', rand_part, 'direction', dovar2, 'vel', velin(rand_part,dovar2)

	End Do
End Do

End Subroutine thermostat_v

Subroutine vel_analysis(velarrayin, velavgout, velminout, velmaxout, stddevout)
Use mdproj
real (Kind = DP), dimension(num, 3):: velarrayin
real (Kind = DP):: velavgout, velminout, velmaxout, stddevout, vel1
integer::counter_a, counter_b

velminout = 10000000
velmaxout = -10000000

Do counter_a = 1, num
	vel1 = velarrayin(counter_a, 1) + velarrayin(counter_a, 2) + velarrayin(counter_a, 3)
	if(velarrayin(counter_a, 1) < velminout) velminout = velarrayin(counter_a, 1)
	if(velarrayin(counter_a, 2) < velminout) velminout = velarrayin(counter_a, 2)
	if(velarrayin(counter_a, 3) < velminout) velminout = velarrayin(counter_a, 3)

	if(velarrayin(counter_a, 1) > velmaxout) velmaxout = velarrayin(counter_a, 1)
	if(velarrayin(counter_a, 2) > velmaxout) velmaxout = velarrayin(counter_a, 2)
	if(velarrayin(counter_a, 3) > velmaxout) velmaxout = velarrayin(counter_a, 3)

End Do

velavgout = vel1 / num / 3
vel1 = 0.

Do counter_a = 1, num
	Do counter_b = 1, 3
		vel1 = vel1 + (velarrayin(counter_a, counter_b) - velavgout)**2
	End Do
End Do

stddevout = sqrt(vel1 / num / 3)

End Subroutine vel_analysis

Subroutine Uij_calc(positin, Uij_out, deltap1)
Use mdproj
real (KIND = DP), dimension(num, 3) :: positin, Uij_out
real (Kind = DP), dimension(num, num) :: deltap1
real (Kind = DP):: u, ux, uy, uz, cx, cy, cz
integer :: count1, count2, i, j
real :: cmin, cmax
!logical :: truthtest
!infinite = HUGE(infinite)

Do count1 = 1, num
	Do count2 = 1, 3
		Uij_out(count1,count2)=0.
	End Do
End Do

cmin = 10
cmax = -10

!Print *, '0positin', positin

Do i = 1, num
	Do j = 1, num
		if(i == j) then
!			Print *, "Entered the if at i=", i, 'and j=', j
			deltap1(i,j) = 0.
!			Print *, '1positin', positin(i,1), 'j', positin(j,1)
		else
!			Print *, '1posit', posit, 'posit2', posit2
!			Print *, '2positin', positin(i,1), 'j', positin(j,1)
!			Print *, "Entered the else if at i=", i, 'and j=', j

			cx = positin(i,1) - positin(j,1)
			cy = positin(i,2) - positin(j,2)
			cz = positin(i,3) - positin(j,3)
!			Print *, 'cx', cx, 'cy', cy, 'cz', cz

!			if(cx > (side/2)) cx = cx - (side/2)
!			if(cy > (side/2)) cy = cy - (side/2)
!			if(cz > (side/2)) cz = cz - (side/2)
!			if(cx < (-side/2)) cx = cx + (side/2)
!			if(cy < (-side/2)) cy = cy + (side/2)
!			if(cz < (-side/2)) cz = cz + (side/2)

			if(cx < cmin) cmin = cx
			if(cy < cmin) cmin = cy
			if(cz < cmin) cmin = cz
			if(cx > cmax) cmax = cx
			if(cy > cmax) cmax = cy
			if(cz > cmax) cmax = cz

!			Print *, '3positin', positin(i,1), 'j', positin(j,1), 'i,j', i, j
			deltap1(i,j) = sqrt((cx)**2 + (cy)**2 + (cz)**2)
!			Print *, 'deltap1', deltap1(i,j), 'i', i, 'j', j

			if((deltap1(i,j) == 0.) .OR. (deltap1(i,j) >= cutoff)) then
!			if(deltap1(i,j) >= cutoff) then
				Uij_out(i,1) = Uij_out(i,1) + 0.0
				Uij_out(i,2) = Uij_out(i,2) + 0.0
				Uij_out(i,3) = Uij_out(i,3) + 0.0
!				Print *, 'deltap1', deltap1(i,j), 'i', i, 'j', j
!				Print *, 'cx', cx, 'cy', cy, 'cz', cz
			else
!				Print *, "the program entered the else at i=", i, 'and j=', j
				cx = cx/deltap1(i,j)
				cy = cy/deltap1(i,j)
				cz = cz/deltap1(i,j)
				u = 4/kbT*((sigma**12/(deltap1(i,j)**12)) - (sigma**6/(deltap1(i,j)**6)))
				ux = u * cx
				uy = u * cy
				uz = u * cz
				Uij_out(i,1) = Uij_out(i,1) + ux
				Uij_out(i,2) = Uij_out(i,2) + uy
				Uij_out(i,3) = Uij_out(i,3) + uz
!				Print *, 'i', i, 'j', j
!				Print *, 'ux', ux, 'uy', uy, 'uz', uz
!				Print *, 'The sum potenetial en for particle i are:', Uij_out(i,1), Uij_out(i,2), Uij_out(i,3)
!				Print *, ' '
!				Print *, ' deltap', deltap(i,j)
			End if
		End if
!		Print *, "the program completed the if statement at i=", i, 'and j=', j
	End Do
!	Print *, 'i', i, 'fij_outx', fij_out(i,1), 'fij_outy', fij_out(i,2), 'fij_outz', fij_out(i,3)
End Do
!Print *, 'cmin', cmin, 'cmax', cmax
!Print *, '2posit', posit, 'posit2', posit2

End Subroutine Uij_calc


!*DECK CFFTI1
      SUBROUTINE ZFFTI1 (N,WA,IFAC)
!***BEGIN PROLOGUE  CFFTI1
!***PURPOSE  Initialize a real and an integer work array for CFFTF1 and
!            CFFTB1.
!***LIBRARY   SLATEC (FFTPACK)
!***CATEGORY  J1A2
!***TYPE      COMPLEX (RFFTI1-S, CFFTI1-C)
!***KEYWORDS  FFTPACK, FOURIER TRANSFORM
!***AUTHOR  Swarztrauber, P. N., (NCAR)
!***DESCRIPTION
!
!  Subroutine CFFTI1 initializes the work arrays WA and IFAC which are
!  used in both CFFTF1 and CFFTB1.  The prime factorization of N and a
!  tabulation of the trigonometric functions are computed and stored in
!  IFAC and WA, respectively.
!
!  Input Parameter
!
!  N       the length of the sequence to be transformed
!
!  Output Parameters
!
!  WA      a real work array which must be dimensioned at least 2*N.
!
!  IFAC    an integer work array which must be dimensioned at least 15.
!
!          The same work arrays can be used for both CFFTF1 and CFFTB1
!          as long as N remains unchanged.  Different WA and IFAC arrays
!          are required for different values of N.  The contents of
!          WA and IFAC must not be changed between calls of CFFTF1 or
!          CFFTB1.
!
!***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
!                 Computations (G. Rodrigue, ed.), Academic Press,
!                 1982, pp. 51-83.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   790601  DATE WRITTEN
!   830401  Modified to use SLATEC library source file format.
!   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
!           (a) changing dummy array size declarations (1) to (*),
!           (b) changing references to intrinsic function FLOAT
!               to REAL, and
!           (c) changing definition of variable TPI by using
!               FORTRAN intrinsic function ATAN instead of a DATA
!               statement.
!   881128  Modified by Dick Valent to meet prologue standards.
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900131  Routine changed from subsidiary to user-callable.  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  CFFTI1
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION       WA(*)      ,IFAC(*)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
!***FIRST EXECUTABLE STATEMENT  CFFTI1
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J.le.4) GO TO 102
      GO TO 103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRYH(4)+2*(J-4)
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR.eq.0) GO TO 105
      GO TO 101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI =  6.28318530717958647692D0
      ARGH = TPI/FLOAT(N)
      I = 2
      L1 = 1
      DO 110 K1=1,NF
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IDOT = IDO+IDO+2
         IPM = IP-1
         DO 109 J=1,IPM
            I1 = I
            WA(I-1) = 1.0D0
            WA(I) = 0.0D0
            LD = LD+L1
            FI = 0.0D0
            ARGLD = FLOAT(LD)*ARGH
            DO 108 II=4,IDOT,2
               I = I+2
               FI = FI+1.D0
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IF (IP .LE. 5) GO TO 109
            WA(I1-1) = WA(I-1)
            WA(I1) = WA(I)
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END


!*==dlagts.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal matrix and λ a scalar, using the LU factorization computed by slagtf.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAGTS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, JOB, N
!       DOUBLE PRECISION   TOL
!       ..
!       .. Array Arguments ..
!       INTEGER            IN( * )
!       DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * ), Y( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAGTS may be used to solve one of the systems of equations
!>
!>    (T - lambda*I)*x = y   or   (T - lambda*I)**T*x = y,
!>
!> where T is an n by n tridiagonal matrix, for x, following the
!> factorization of (T - lambda*I) as
!>
!>    (T - lambda*I) = P*L*U ,
!>
!> by routine DLAGTF. The choice of equation to be solved is
!> controlled by the argument JOB, and in each case there is an option
!> to perturb zero or very small diagonal elements of U, this option
!> being intended for use in applications such as inverse iteration.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOB
!> \verbatim
!>          JOB is INTEGER
!>          Specifies the job to be performed by DLAGTS as follows:
!>          =  1: The equations  (T - lambda*I)x = y  are to be solved,
!>                but diagonal elements of U are not to be perturbed.
!>          = -1: The equations  (T - lambda*I)x = y  are to be solved
!>                and, if overflow would otherwise occur, the diagonal
!>                elements of U are to be perturbed. See argument TOL
!>                below.
!>          =  2: The equations  (T - lambda*I)**Tx = y  are to be solved,
!>                but diagonal elements of U are not to be perturbed.
!>          = -2: The equations  (T - lambda*I)**Tx = y  are to be solved
!>                and, if overflow would otherwise occur, the diagonal
!>                elements of U are to be perturbed. See argument TOL
!>                below.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix T.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (N)
!>          On entry, A must contain the diagonal elements of U as
!>          returned from DLAGTF.
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, B must contain the first super-diagonal elements of
!>          U as returned from DLAGTF.
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, C must contain the sub-diagonal elements of L as
!>          returned from DLAGTF.
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N-2)
!>          On entry, D must contain the second super-diagonal elements
!>          of U as returned from DLAGTF.
!> \endverbatim
!>
!> \param[in] IN
!> \verbatim
!>          IN is INTEGER array, dimension (N)
!>          On entry, IN must contain details of the matrix P as returned
!>          from DLAGTF.
!> \endverbatim
!>
!> \param[in,out] Y
!> \verbatim
!>          Y is DOUBLE PRECISION array, dimension (N)
!>          On entry, the right hand side vector y.
!>          On exit, Y is overwritten by the solution vector x.
!> \endverbatim
!>
!> \param[in,out] TOL
!> \verbatim
!>          TOL is DOUBLE PRECISION
!>          On entry, with  JOB < 0, TOL should be the minimum
!>          perturbation to be made to very small diagonal elements of U.
!>          TOL should normally be chosen as about eps*norm(U), where eps
!>          is the relative machine precision, but if TOL is supplied as
!>          non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
!>          If  JOB > 0  then TOL is not referenced.
!>
!>          On exit, TOL is changed as described above, only if TOL is
!>          non-positive on entry. Otherwise TOL is unchanged.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  overflow would occur when computing the INFO(th)
!>                element of the solution vector x. This can only occur
!>                when JOB is supplied as positive and either means
!>                that a diagonal element of U is very small, or that
!>                the elements of the right-hand side vector y are very
!>                large.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup OTHERauxiliary
!
!  =====================================================================
      SUBROUTINE DLAGTS(Job,N,A,B,C,D,In,Y,Tol,Info)
      IMPLICIT NONE
!*--DLAGTS165
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Job , N
      DOUBLE PRECISION Tol
!     ..
!     .. Array Arguments ..
      INTEGER In(*)
      DOUBLE PRECISION A(*) , B(*) , C(*) , D(*) , Y(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
!     ..
!     .. Local Scalars ..
      INTEGER k
      DOUBLE PRECISION absak , ak , bignum , eps , pert , sfmin , temp
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , SIGN
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Executable Statements ..
!
      Info = 0
      IF ( (ABS(Job)>2) .OR. (Job==0) ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DLAGTS',-Info)
         RETURN
      ENDIF
!
      IF ( N==0 ) RETURN
!
      eps = DLAMCH('Epsilon')
      sfmin = DLAMCH('Safe minimum')
      bignum = ONE/sfmin
!
      IF ( Job<0 ) THEN
         IF ( Tol<=ZERO ) THEN
            Tol = ABS(A(1))
            IF ( N>1 ) Tol = MAX(Tol,ABS(A(2)),ABS(B(1)))
            DO k = 3 , N
               Tol = MAX(Tol,ABS(A(k)),ABS(B(k-1)),ABS(D(k-2)))
            ENDDO
            Tol = Tol*eps
            IF ( Tol==ZERO ) Tol = eps
         ENDIF
      ENDIF
!
      IF ( ABS(Job)==1 ) THEN
         DO k = 2 , N
            IF ( In(k-1)==0 ) THEN
               Y(k) = Y(k) - C(k-1)*Y(k-1)
            ELSE
               temp = Y(k-1)
               Y(k-1) = Y(k)
               Y(k) = temp - C(k-1)*Y(k)
            ENDIF
         ENDDO
         IF ( Job==1 ) THEN
            DO k = N , 1 , -1
               IF ( k<=N-2 ) THEN
                  temp = Y(k) - B(k)*Y(k+1) - D(k)*Y(k+2)
               ELSEIF ( k==N-1 ) THEN
                  temp = Y(k) - B(k)*Y(k+1)
               ELSE
                  temp = Y(k)
               ENDIF
               ak = A(k)
               absak = ABS(ak)
               IF ( absak<ONE ) THEN
                  IF ( absak<sfmin ) THEN
                     IF ( absak==ZERO .OR. ABS(temp)*sfmin>absak ) THEN
                        Info = k
                        RETURN
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     ENDIF
                  ELSEIF ( ABS(temp)>absak*bignum ) THEN
                     Info = k
                     RETURN
                  ENDIF
               ENDIF
               Y(k) = temp/ak
            ENDDO
         ELSE
            DO k = N , 1 , -1
               IF ( k<=N-2 ) THEN
                  temp = Y(k) - B(k)*Y(k+1) - D(k)*Y(k+2)
               ELSEIF ( k==N-1 ) THEN
                  temp = Y(k) - B(k)*Y(k+1)
               ELSE
                  temp = Y(k)
               ENDIF
               ak = A(k)
               pert = SIGN(Tol,ak)
               DO
                  absak = ABS(ak)
                  IF ( absak<ONE ) THEN
                     IF ( absak<sfmin ) THEN
                        IF ( absak==ZERO .OR. ABS(temp)*sfmin>absak )   &
     &                       THEN
                           ak = ak + pert
                           pert = 2*pert
                           CYCLE
                        ELSE
                           temp = temp*bignum
                           ak = ak*bignum
                        ENDIF
                     ELSEIF ( ABS(temp)>absak*bignum ) THEN
                        ak = ak + pert
                        pert = 2*pert
                        CYCLE
                     ENDIF
                  ENDIF
                  Y(k) = temp/ak
                  EXIT
               ENDDO
            ENDDO
         ENDIF
      ELSE
!
!        Come to here if  JOB = 2 or -2
!
         IF ( Job==2 ) THEN
            DO k = 1 , N
               IF ( k>=3 ) THEN
                  temp = Y(k) - B(k-1)*Y(k-1) - D(k-2)*Y(k-2)
               ELSEIF ( k==2 ) THEN
                  temp = Y(k) - B(k-1)*Y(k-1)
               ELSE
                  temp = Y(k)
               ENDIF
               ak = A(k)
               absak = ABS(ak)
               IF ( absak<ONE ) THEN
                  IF ( absak<sfmin ) THEN
                     IF ( absak==ZERO .OR. ABS(temp)*sfmin>absak ) THEN
                        Info = k
                        RETURN
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     ENDIF
                  ELSEIF ( ABS(temp)>absak*bignum ) THEN
                     Info = k
                     RETURN
                  ENDIF
               ENDIF
               Y(k) = temp/ak
            ENDDO
         ELSE
            DO k = 1 , N
               IF ( k>=3 ) THEN
                  temp = Y(k) - B(k-1)*Y(k-1) - D(k-2)*Y(k-2)
               ELSEIF ( k==2 ) THEN
                  temp = Y(k) - B(k-1)*Y(k-1)
               ELSE
                  temp = Y(k)
               ENDIF
               ak = A(k)
               pert = SIGN(Tol,ak)
               DO
                  absak = ABS(ak)
                  IF ( absak<ONE ) THEN
                     IF ( absak<sfmin ) THEN
                        IF ( absak==ZERO .OR. ABS(temp)*sfmin>absak )   &
     &                       THEN
                           ak = ak + pert
                           pert = 2*pert
                           CYCLE
                        ELSE
                           temp = temp*bignum
                           ak = ak*bignum
                        ENDIF
                     ELSEIF ( ABS(temp)>absak*bignum ) THEN
                        ak = ak + pert
                        pert = 2*pert
                        CYCLE
                     ENDIF
                  ENDIF
                  Y(k) = temp/ak
                  EXIT
               ENDDO
            ENDDO
         ENDIF
!
         DO k = N , 2 , -1
            IF ( In(k-1)==0 ) THEN
               Y(k-1) = Y(k-1) - C(k-1)*Y(k)
            ELSE
               temp = Y(k-1)
               Y(k-1) = Y(k)
               Y(k) = temp - C(k-1)*Y(k)
            ENDIF
         ENDDO
      ENDIF
!
!     End of DLAGTS
!
      END SUBROUTINE DLAGTS


C*******************************************************************************
      SUBROUTINE SVDFIT(X,Y,SIG,NDATA,INDVAR,IORDER,NCOEFFS,COEFFS,
     +			U,V,W,CHISQ)
C
C	Taken from Numerical Recipes
C	Adapted to make fitting funtion a IORDER polynomial fit of INDVAR
C	independent variables.       11/30/93   Ron Alley
C
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(NMAX=1000,MMAX=50,TOL=1.0E-14)
      REAL*8 X(INDVAR,NDATA)		! input	- Independent variable values
      REAL*8 Y(NDATA)			! input	- Dependent variable values
      REAL*8 SIG(NDATA)			! input - Relative error estimate
      INTEGER NDATA			! input - Number of data points
      INTEGER INDVAR			! input - Num of independent variables
      INTEGER IORDER			! input - Order of the polynomial fit
      INTEGER NCOEFFS			! input - Number of coefficients output
      REAL*8 COEFFS(NCOEFFS)		! output- Fitting function coefficients
      REAL*8 U(NDATA,NCOEFFS)		! output- Scratch work buffer
      REAL*8 V(NCOEFFS,NCOEFFS)		! output- Scratch work buffer
      REAL*8 W(NCOEFFS)			! output- Scratch work buffer
      REAL*8 CHISQ			! output- chi-squared, figure of merit
C
      REAL*8 B(NMAX),AFUNC(MMAX)
C						compute terms for observed data
	DO I=1,NDATA
	    CALL NPOLY(X(1,I),AFUNC,W,NCOEFFS,INDVAR,IORDER)
	    TMP = 1.0/SIG(I)
	    DO  J=1,NCOEFFS
	        U(I,J) = AFUNC(J)*TMP
	    END DO
	    B(I) = Y(I)*TMP
	END DO
C
	CALL SVDCMP(U,NDATA,NCOEFFS,NDATA,NCOEFFS,W,V)
C						edit out singular values near 0
	WMAX = 0.0
	DO J=1,NCOEFFS
	    IF(W(J).GT.WMAX) WMAX=W(J)
	END DO
	THRESH = TOL*WMAX
	DO J=1,NCOEFFS
	    IF(W(J).LT.THRESH) W(J)=0.0
	END DO
C
	CALL SVBKSB(U,W,V,NDATA,NCOEFFS,NDATA,NCOEFFS,B,COEFFS)
C							compute chi-squared
	CHISQ = 0.0
	DO I=1,NDATA
	       CALL NPOLY(X(1,I),AFUNC,W,NCOEFFS,INDVAR,IORDER)
	    SUM = 0.0
	    DO J=1,NCOEFFS
	        SUM = SUM + COEFFS(J)*AFUNC(J)
	    END DO
	    CHISQ = CHISQ+((Y(I)-SUM)/SIG(I))**2
	END DO
	RETURN
	END
C*******************************************************************************
      SUBROUTINE SVDCMP(A,M,N,MP,NP,W,V)
C
C	Taken from Numerical Recipes
C
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (NMAX=100)
      DIMENSION A(MP,NP),W(NP),V(NP,NP),RV1(NMAX)
      G=0.0
      SCALE=0.0
      ANORM=0.0
      DO 25 I=1,N
        L=I+1
        RV1(I)=SCALE*G
        G=0.0
        S=0.0
        SCALE=0.0
        IF (I.LE.M) THEN
          DO 11 K=I,M
            SCALE=SCALE+ABS(A(K,I))
11        CONTINUE
          IF (SCALE.NE.0.0) THEN
            DO 12 K=I,M
              A(K,I)=A(K,I)/SCALE
              S=S+A(K,I)*A(K,I)
12          CONTINUE
            F=A(I,I)
            G=-SIGN(SQRT(S),F)
            H=F*G-S
            A(I,I)=F-G
            IF (I.NE.N) THEN
              DO 15 J=L,N
                S=0.0
                DO 13 K=I,M
                  S=S+A(K,I)*A(K,J)
13              CONTINUE
                F=S/H
                DO 14 K=I,M
                  A(K,J)=A(K,J)+F*A(K,I)
14              CONTINUE
15            CONTINUE
            ENDIF
            DO 16 K= I,M
              A(K,I)=SCALE*A(K,I)
16          CONTINUE
          ENDIF
        ENDIF
        W(I)=SCALE *G
        G=0.0
        S=0.0
        SCALE=0.0
        IF ((I.LE.M).AND.(I.NE.N)) THEN
          DO 17 K=L,N
            SCALE=SCALE+ABS(A(I,K))
17        CONTINUE
          IF (SCALE.NE.0.0) THEN
            DO 18 K=L,N
              A(I,K)=A(I,K)/SCALE
              S=S+A(I,K)*A(I,K)
18          CONTINUE
            F=A(I,L)
            G=-SIGN(SQRT(S),F)
            H=F*G-S
            A(I,L)=F-G
            DO 19 K=L,N
              RV1(K)=A(I,K)/H
19          CONTINUE
            IF (I.NE.M) THEN
              DO 23 J=L,M
                S=0.0
                DO 21 K=L,N
                  S=S+A(J,K)*A(I,K)
21              CONTINUE
                DO 22 K=L,N
                  A(J,K)=A(J,K)+S*RV1(K)
22              CONTINUE
23            CONTINUE
            ENDIF
            DO 24 K=L,N
              A(I,K)=SCALE*A(I,K)
24          CONTINUE
          ENDIF
        ENDIF
        ANORM=MAX(ANORM,(ABS(W(I))+ABS(RV1(I))))
25    CONTINUE
      DO 32 I=N,1,-1
        IF (I.LT.N) THEN
          IF (G.NE.0.0) THEN
            DO 26 J=L,N
              V(J,I)=(A(I,J)/A(I,L))/G
26          CONTINUE
            DO 29 J=L,N
              S=0.0
              DO 27 K=L,N
                S=S+A(I,K)*V(K,J)
27            CONTINUE
              DO 28 K=L,N
                V(K,J)=V(K,J)+S*V(K,I)
28            CONTINUE
29          CONTINUE
          ENDIF
          DO 31 J=L,N
            V(I,J)=0.0
            V(J,I)=0.0
31        CONTINUE
        ENDIF
        V(I,I)=1.0
        G=RV1(I)
        L=I
32    CONTINUE
      DO 39 I=N,1,-1
        L=I+1
        G=W(I)
        IF (I.LT.N) THEN
          DO 33 J=L,N
            A(I,J)=0.0
33        CONTINUE
        ENDIF
        IF (G.NE.0.0) THEN
          G=1.0/G
          IF (I.NE.N) THEN
            DO 36 J=L,N
              S=0.0
              DO 34 K=L,M
                S=S+A(K,I)*A(K,J)
34            CONTINUE
              F=(S/A(I,I))*G
              DO 35 K=I,M
                A(K,J)=A(K,J)+F*A(K,I)
35            CONTINUE
36          CONTINUE
          ENDIF
          DO 37 J=I,M
            A(J,I)=A(J,I)*G
37        CONTINUE
        ELSE
          DO 38 J= I,M
            A(J,I)=0.0
38        CONTINUE
        ENDIF
        A(I,I)=A(I,I)+1.0
39    CONTINUE
      DO 49 K=N,1,-1
        DO 48 ITS=1,30
          DO 41 L=K,1,-1
            NM=L-1
            IF ((ABS(RV1(L))+ANORM).EQ.ANORM)  GO TO 2
            IF ((ABS(W(NM))+ANORM).EQ.ANORM)  GO TO 1
41        CONTINUE
1         C=0.0
          S=1.0
          DO 43 I=L,K
            F=S*RV1(I)
            IF ((ABS(F)+ANORM).NE.ANORM) THEN
              G=W(I)
              H=SQRT(F*F+G*G)
              W(I)=H
              H=1.0/H
              C= (G*H)
              S=-(F*H)
              DO 42 J=1,M
                Y=A(J,NM)
                Z=A(J,I)
                A(J,NM)=(Y*C)+(Z*S)
                A(J,I)=-(Y*S)+(Z*C)
42            CONTINUE
            ENDIF
43        CONTINUE
2         Z=W(K)
          IF (L.EQ.K) THEN
            IF (Z.LT.0.0) THEN
              W(K)=-Z
              DO 44 J=1,N
                V(J,K)=-V(J,K)
44            CONTINUE
            ENDIF
            GO TO 3
          ENDIF
          IF (ITS.EQ.30) PAUSE 'No convergence in 30 iterations'
          X=W(L)
          NM=K-1
          Y=W(NM)
          G=RV1(NM)
          H=RV1(K)
          F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.0*H*Y)
          G=SQRT(F*F+1.0)
          F=((X-Z)*(X+Z)+H*((Y/(F+SIGN(G,F)))-H))/X
          C=1.0
          S=1.0
          DO 47 J=L,NM
            I=J+1
            G=RV1(I)
            Y=W(I)
            H=S*G
            G=C*G
            Z=SQRT(F*F+H*H)
            RV1(J)=Z
            C=F/Z
            S=H/Z
            F= (X*C)+(G*S)
            G=-(X*S)+(G*C)
            H=Y*S
            Y=Y*C
            DO 45 NM=1,N
              X=V(NM,J)
              Z=V(NM,I)
              V(NM,J)= (X*C)+(Z*S)
              V(NM,I)=-(X*S)+(Z*C)
45          CONTINUE
            Z=SQRT(F*F+H*H)
            W(J)=Z
            IF (Z.NE.0.0) THEN
              Z=1.0/Z
              C=F*Z
              S=H*Z
            ENDIF
            F= (C*G)+(S*Y)
            X=-(S*G)+(C*Y)
            DO 46 NM=1,M
              Y=A(NM,J)
              Z=A(NM,I)
              A(NM,J)= (Y*C)+(Z*S)
              A(NM,I)=-(Y*S)+(Z*C)
46          CONTINUE
47        CONTINUE
          RV1(L)=0.0
          RV1(K)=F
          W(K)=X
48      CONTINUE
3       CONTINUE
49    CONTINUE
      RETURN
      END
C*******************************************************************************
      SUBROUTINE SVBKSB(U,W,V,M,N,MP,NP,B,X)
C
C	Taken from Numerical Recipes
C
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (NMAX=100)
      DIMENSION U(MP,NP),W(NP),V(NP,NP),B(MP),X(NP),TMP(NMAX)
      DO 12 J=1,N
        S=0.
        IF(W(J).NE.0.)THEN
          DO 11 I=1,M
            S=S+U(I,J)*B(I)
11        CONTINUE
          S=S/W(J)
        ENDIF
        TMP(J)=S
12    CONTINUE
      DO 14 J=1,N
        S=0.
        DO 13 JJ=1,N
          S=S+V(J,JJ)*TMP(JJ)
13      CONTINUE
        X(J)=S
14    CONTINUE
      RETURN
      END
C*******************************************************************************
	SUBROUTINE NPOLY(X,AFUNC,IPOW,NCOEFFS,INDVAR,IORDER)
C
	IMPLICIT REAL*8 (A-H,O-Z)
	REAL*8 X(INDVAR),AFUNC(NCOEFFS)
	INTEGER IPOW(INDVAR)
	LOGICAL UNFINISHED
C
	LOC = 0
	DO I=1,INDVAR
	    IPOW(I) = IORDER
	END DO
C
	DO WHILE(IPOW(1).GE.0)
	    N = 0
	    DO I=1,INDVAR
		N = N+IPOW(I)
	    END DO
	    IF (N .LE. IORDER) THEN
		LOC = LOC+1
		AFUNC(LOC) = 1.0
		DO I=1,INDVAR
		    AFUNC(LOC) = AFUNC(LOC)*(X(I)**IPOW(I))
		END DO
	    END IF
	    M = INDVAR
	    UNFINISHED = .TRUE.
	    DO WHILE (UNFINISHED)
		IPOW(M) = IPOW(M)-1
		IF (IPOW(M).GE.0 .OR. M.EQ.1) THEN
		    UNFINISHED = .FALSE.
		ELSE
		    IPOW(M) = IORDER
		    M = M-1
		END IF
	    END DO
	END DO
	RETURN
	END