      module k1

      implicit none (type, external)
      private
      public:: besk1

      contains

      SUBROUTINE CALCK1(ARG,RESULT,JINT)
C--------------------------------------------------------------------
C
C This packet computes modified Bessel functions of the second kind
C   and order one,  K1(X)  and  EXP(X)*K1(X), for real arguments X.
C   It contains two function type subprograms, BESK1  and  BESEK1,
C   and one subroutine type subprogram, CALCK1.  The calling
C   statements for the primary entries are
C
C                   Y=BESK1(X)
C   and
C                   Y=BESEK1(X)
C
C   where the entry points correspond to the functions K1(X) and
C   EXP(X)*K1(X), respectively.  The routine CALCK1 is intended
C   for internal packet use only, all computations within the
C   packet being concentrated in this routine.  The function
C   subprograms invoke CALCK1 with the statement
C          CALL CALCK1(ARG,RESULT,JINT)
C   where the parameter usage is as follows
C
C      Function                      Parameters for CALCK1
C        Call             ARG                  RESULT          JINT
C
C     BESK1(ARG)  XLEAST .LT. ARG .LT. XMAX    K1(ARG)          1
C     BESEK1(ARG)     XLEAST .LT. ARG       EXP(ARG)*K1(ARG)    2
C
C   The main computation evaluates slightly modified forms of near
C   minimax rational approximations generated by Russon and Blair,
C   Chalk River (Atomic Energy of Canada Limited) Report AECL-3461,
C   1969.  This transportable program is patterned after the
C   machine-dependent FUNPACK packet NATSK1, but cannot match that
C   version for efficiency or accuracy.  This version uses rational
C   functions that theoretically approximate K-SUB-1(X) to at
C   least 18 significant decimal digits.  The accuracy achieved
C   depends on the arithmetic system, the compiler, the intrinsic
C   functions, and proper selection of the machine-dependent
C   constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants
C
C   beta   = Radix for the floating-point system
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C   XLEAST = Smallest acceptable argument, i.e., smallest machine
C            number X such that 1/X is machine representable.
C   XSMALL = Argument below which BESK1(X) and BESEK1(X) may
C            each be represented by 1/X.  A safe value is the
C            largest X such that  1.0 + X = 1.0  to machine
C            precision.
C   XINF   = Largest positive machine number; approximately
C            beta**maxexp
C   XMAX   = Largest argument acceptable to BESK1;  Solution to
C            equation:
C               W(X) * (1+3/8X-15/128X**2) = beta**minexp
C            where  W(X) = EXP(-X)*SQRT(PI/2X)
C
C
C     Approximate values for some important machines are:
C
C                           beta       minexp       maxexp
C
C  CRAY-1        (S.P.)       2        -8193         8191
C  Cyber 180/185
C    under NOS   (S.P.)       2         -975         1070
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)       2         -126          128
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)       2        -1022         1024
C  IBM 3033      (D.P.)      16          -65           63
C  VAX D-Format  (D.P.)       2         -128          127
C  VAX G-Format  (D.P.)       2        -1024         1023
C
C
C                         XLEAST     XSMALL      XINF       XMAX
C
C CRAY-1                1.84E-2466  3.55E-15  5.45E+2465  5674.858
C Cyber 180/855
C   under NOS   (S.P.)  3.14E-294   1.77E-15  1.26E+322    672.789
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)  1.18E-38    5.95E-8   3.40E+38      85.343
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)  2.23D-308   1.11D-16  1.79D+308    705.343
C IBM 3033      (D.P.)  1.39D-76    1.11D-16  7.23D+75     177.855
C VAX D-Format  (D.P.)  5.88D-39    6.95D-18  1.70D+38      86.721
C VAX G-Format  (D.P.)  1.12D-308   5.55D-17  8.98D+307    706.728
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns the value XINF for ARG .LE. 0.0 and the
C   BESK1 entry returns the value 0.0 for ARG .GT. XMAX.
C
C
C  Intrinsic functions required are:
C
C     LOG, SQRT, EXP
C
C
C  Authors: W. J. Cody and Laura Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C  Latest modification: January 28, 1988
C
C--------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
      DOUBLE PRECISION
     1    ARG,F,G,ONE,P,PP,Q,QQ,RESULT,SUMF,SUMG,
     2    SUMP,SUMQ,X,XINF,XMAX,XLEAST,XSMALL,XX,ZERO
      DIMENSION P(5),Q(3),PP(11),QQ(9),F(5),G(3)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ONE/1.0E0/,ZERO/0.0E0/
CD    DATA ONE/1.0D0/,ZERO/0.0D0/
C--------------------------------------------------------------------
C  Machine-dependent constants
C--------------------------------------------------------------------
CS    DATA XLEAST/1.18E-38/,XSMALL/5.95E-8/,XINF/3.40E+38/,
CS   1     XMAX/85.343E+0/
CD    DATA XLEAST/2.23D-308/,XSMALL/1.11D-16/,XINF/1.79D+308/,
CD   1     XMAX/705.343D+0/
C--------------------------------------------------------------------
C  Coefficients for  XLEAST .LE.  ARG  .LE. 1.0
C--------------------------------------------------------------------
CS    DATA   P/ 4.8127070456878442310E-1, 9.9991373567429309922E+1,
CS   1          7.1885382604084798576E+3, 1.7733324035147015630E+5,
CS   2          7.1938920065420586101E+5/
CS    DATA   Q/-2.8143915754538725829E+2, 3.7264298672067697862E+4,
CS   1         -2.2149374878243304548E+6/
CS    DATA   F/-2.2795590826955002390E-1,-5.3103913335180275253E+1,
CS   1         -4.5051623763436087023E+3,-1.4758069205414222471E+5,
CS   2         -1.3531161492785421328E+6/
CS    DATA   G/-3.0507151578787595807E+2, 4.3117653211351080007E+4,
CS   2         -2.7062322985570842656E+6/
CD    DATA   P/ 4.8127070456878442310D-1, 9.9991373567429309922D+1,
CD   1          7.1885382604084798576D+3, 1.7733324035147015630D+5,
CD   2          7.1938920065420586101D+5/
CD    DATA   Q/-2.8143915754538725829D+2, 3.7264298672067697862D+4,
CD   1         -2.2149374878243304548D+6/
CD    DATA   F/-2.2795590826955002390D-1,-5.3103913335180275253D+1,
CD   1         -4.5051623763436087023D+3,-1.4758069205414222471D+5,
CD   2         -1.3531161492785421328D+6/
CD    DATA   G/-3.0507151578787595807D+2, 4.3117653211351080007D+4,
CD   2         -2.7062322985570842656D+6/
C--------------------------------------------------------------------
C  Coefficients for  1.0 .LT.  ARG
C--------------------------------------------------------------------
CS    DATA  PP/ 6.4257745859173138767E-2, 7.5584584631176030810E+0,
CS   1          1.3182609918569941308E+2, 8.1094256146537402173E+2,
CS   2          2.3123742209168871550E+3, 3.4540675585544584407E+3,
CS   3          2.8590657697910288226E+3, 1.3319486433183221990E+3,
CS   4          3.4122953486801312910E+2, 4.4137176114230414036E+1,
CS   5          2.2196792496874548962E+0/
CS    DATA  QQ/ 3.6001069306861518855E+1, 3.3031020088765390854E+2,
CS   1          1.2082692316002348638E+3, 2.1181000487171943810E+3,
CS   2          1.9448440788918006154E+3, 9.6929165726802648634E+2,
CS   3          2.5951223655579051357E+2, 3.4552228452758912848E+1,
CS   4          1.7710478032601086579E+0/
CD    DATA  PP/ 6.4257745859173138767D-2, 7.5584584631176030810D+0,
CD   1          1.3182609918569941308D+2, 8.1094256146537402173D+2,
CD   2          2.3123742209168871550D+3, 3.4540675585544584407D+3,
CD   3          2.8590657697910288226D+3, 1.3319486433183221990D+3,
CD   4          3.4122953486801312910D+2, 4.4137176114230414036D+1,
CD   5          2.2196792496874548962D+0/
CD    DATA  QQ/ 3.6001069306861518855D+1, 3.3031020088765390854D+2,
CD   1          1.2082692316002348638D+3, 2.1181000487171943810D+3,
CD   2          1.9448440788918006154D+3, 9.6929165726802648634D+2,
CD   3          2.5951223655579051357D+2, 3.4552228452758912848D+1,
CD   4          1.7710478032601086579D+0/
C--------------------------------------------------------------------
      X = ARG
      IF (X .LT. XLEAST) THEN
C--------------------------------------------------------------------
C  Error return for  ARG  .LT. XLEAST
C--------------------------------------------------------------------
            RESULT = XINF
         ELSE IF (X .LE. ONE) THEN
C--------------------------------------------------------------------
C  XLEAST .LE.  ARG  .LE. 1.0
C--------------------------------------------------------------------
            IF (X .LT. XSMALL) THEN
C--------------------------------------------------------------------
C  Return for small ARG
C--------------------------------------------------------------------
                  RESULT = ONE / X
               ELSE
                  XX = X * X
                  SUMP = ((((P(1)*XX + P(2))*XX + P(3))*XX + P(4))*XX
     1                   + P(5))*XX + Q(3)
                  SUMQ = ((XX + Q(1))*XX + Q(2))*XX + Q(3)
                  SUMF = (((F(1)*XX + F(2))*XX + F(3))*XX + F(4))*XX
     1                   + F(5)
                  SUMG = ((XX + G(1))*XX + G(2))*XX + G(3)
                  RESULT = (XX * LOG(X) * SUMF/SUMG + SUMP/SUMQ) / X
                  IF (JINT .EQ. 2) RESULT = RESULT * EXP(X)
            END IF
         ELSE IF ((JINT .EQ. 1) .AND. (X .GT. XMAX)) THEN
C--------------------------------------------------------------------
C  Error return for  ARG  .GT. XMAX
C--------------------------------------------------------------------
            RESULT = ZERO
         ELSE
C--------------------------------------------------------------------
C  1.0 .LT.  ARG
C--------------------------------------------------------------------
            XX = ONE / X
            SUMP = PP(1)
            DO 120 I = 2, 11
               SUMP = SUMP * XX + PP(I)
  120       CONTINUE
            SUMQ = XX
            DO 140 I = 1, 8
               SUMQ = (SUMQ + QQ(I)) * XX
  140       CONTINUE
            SUMQ = SUMQ + QQ(9)
            RESULT = SUMP / SUMQ / SQRT(X)
            IF (JINT .EQ. 1) RESULT = RESULT * EXP(-X)
      END IF
      RETURN
C---------- Last line of CALCK1 ----------
      END SUBROUTINE CALCK1
CS    REAL
      DOUBLE PRECISION    FUNCTION BESK1(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order one
C   for arguments  XLEAST .LE. ARG .LE. XMAX.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION   X, RESULT
C--------------------------------------------------------------------
      JINT = 1
      CALL CALCK1(X,RESULT,JINT)
      BESK1 = RESULT
      RETURN
C---------- Last line of BESK1 ----------
      END FUNCTION BESK1
CS    REAL
      DOUBLE PRECISION   FUNCTION BESEK1(X)
C--------------------------------------------------------------------
C
C This function program computes approximate values for the
C   modified Bessel function of the second kind of order one
C   multiplied by the exponential function, for arguments
C   XLEAST .LE. ARG .LE. XMAX.
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION X, RESULT
C--------------------------------------------------------------------
      JINT = 2
      CALL CALCK1(X,RESULT,JINT)
      BESEK1 = RESULT
      RETURN
C---------- Last line of BESEK1 ----------
      END FUNCTION BESEK1

      end module k1


Program Ejemplo8
!Aqui usaremos variables tipo In, Out & InOut en una
!funcion y subroutina
! Las variables declaradas IN son solo para entrada de datos
! Las variables declaradas OUT son solo para salida de datos
! Las variables declaradas INOUT son indistintamente para entrada y salida de datos

Implicit None

Real, External :: Cubo
Real :: X, Y, Z, W

	Print *,'Ingrese un numero : '
	Read *,X
	Z = X
	Print *, 'Z es : ', Z
	Print *, 'El cubo es : ', Cubo(X, Y, Z)
	Print *, 'Y es igual a : ', Y
	Print *, 'y Z ahora es igual a :', Z

	Call Cubito(X, W)
	Print *, 'En tanto que W es : ', W

End Program Ejemplo8

Real Function Cubo(xx, yy, zz)
Implicit None
Real, Intent(IN) :: xx
Real, Intent(OUT) :: yy
Real, Intent(INOUT) :: zz

  yy = xx**3
  Cubo = yy
  zz = zz**3

End Function Cubo

Subroutine Cubito(xx, ww)
Implicit None

Real, Intent(IN) :: xx
Real, Intent(Out) :: ww

ww = xx**3

End Subroutine Cubito


subroutine tara2dHydOMP(arg)

use omp_lib
use cfgio_mod, only: cfg_t, parse_cfg

implicit none

type(cfg_t):: cfg

real ( kind = 8 ), parameter :: pi=3.14159265358979323846d0

include "fftw3.f"

integer (kind=4) Np,Nx,Ny,Nh

integer ( kind = 4 ) i,j,t,PVN,NPV,PV
real ( kind = 8 ) Lx,Ly,dx,dy,kx,ky,time,time_min,time_max,dt,mux,muy,ms,Re,CS,M,U0,n0,d,theta,C0,C1,C2,C3,G1,G2,G3
real ( kind = 8 ) Energy,Energy0,y_Energy,y_Energy0
real (kind = 8), dimension (:), allocatable :: x,y
real (kind=8), dimension(:, :), allocatable :: omega,omega_dum,n,n_dum,ux,uy,ux_dum,uy_dum
complex (kind=8), dimension(:, :), allocatable :: dn_dt_old,dn_dt_new
complex (kind=8), dimension(:, :), allocatable :: dux_dt_old,duy_dt_old,dux_dt_new,duy_dt_new
complex (kind=8), dimension(:, :), allocatable :: psik,psik_dum,omegak,omegak_dum,nk,nk_dum
complex (kind=8), dimension(:, :), allocatable :: ukx,ukx_dum,uky,uky_dum,Ek
complex (kind=8), dimension(:, :), allocatable :: nk_new,ukx_new,uky_new
integer ( kind = 8 ) plan_forward,plan_backward
integer ( kind = 4 ) thread_num,num_thread,proc_num
real ( kind = 8 ) t1,t2
common/comm/Lx,Ly,mux,muy,ms,CS,dt

integer,parameter :: seed = 99999999

character (len=90) :: filename
character (len=32) :: arg

cfg = parse_cfg(arg)

call cfg%get("grid","Nx",Nx)
call cfg%get("grid","Ny",Ny)

Nh = (Nx/2) + 1

call srand(seed)

allocate(x(Nx))
allocate(y(Ny))

allocate(omega(Nx,Ny))
allocate(omega_dum(Nx,Ny))
allocate(n(Nx,Ny))
allocate(n_dum(Nx,Ny))
allocate(ux(Nx,Ny))
allocate(uy(Nx,Ny))
allocate(ux_dum(Nx,Ny))
allocate(uy_dum(Nx,Ny))

allocate(dn_dt_old(Nh,Ny))
allocate(dn_dt_new(Nh,Ny))

allocate(dux_dt_old(Nh,Ny))
allocate(duy_dt_old(Nh,Ny))
allocate(dux_dt_new(Nh,Ny))
allocate(duy_dt_new(Nh,Ny))
allocate(psik(Nh,Ny))
allocate(psik_dum(Nh,Ny))
allocate(omegak(Nh,Ny))
allocate(omegak_dum(Nh,Ny))
allocate(nk(Nh,Ny))
allocate(nk_dum(Nh,Ny))
allocate(ukx(Nh,Ny))
allocate(ukx_dum(Nh,Ny))
allocate(uky(Nh,Ny))
allocate(uky_dum(Nh,Ny))
allocate(Ek(Nh,Ny))
allocate(nk_new(Nh,Ny))
allocate(ukx_new(Nh,Ny))
allocate(uky_new(Nh,Ny))

!===================== FILENAMES ==============================================

open(unit=5,file='output/System_information.dat',status='unknown')
open(unit=15,file='output/Initial_Grid_Data.dat',status='unknown')
!open(unit=20,file='INPUT.dat',status='old')  ! This input file is the file generated from Vorticity code.
open(unit=25,file='output/Initial_Grid_Data_Reproduced.dat',status='unknown')
!open(unit=30,file='Initial_Energy_Spectra.dat',status='unknown')
!open(unit=35,file='Energy_Spectra.dat',status='unknown')
open(unit=40,file='output/Energy.dat',status='unknown')

!===================== USER INPUTS ============================================

! Define Number of Threads.
proc_num = omp_get_num_procs()
thread_num = 28
call omp_set_num_threads (thread_num)

write(5,*) "Number of Processors=", proc_num, "Number of Threads=", thread_num

! System Size.
call cfg%get("length","Lx",Lx)
call cfg%get("length","Ly",Ly)

Lx = Lx*pi; Ly = Ly*pi

! Grid Resolution.
dx = Lx/dfloat(Nx); dy = Ly/dfloat(Ny)

! Runtime Details and Time Step Width.
call cfg%get("time","time_min",time_min)
call cfg%get("time","time_max",time_max)
call cfg%get("time","dt",dt)

! Co-efficient of Viscosity.
call cfg%get("resistivity","nu",mux)
mux = 0.00020d0
muy = mux

! Mass of the Fluid Element.
ms = 1.0d0

! Maximum Velocity.
U0 = 1.8850d0

! Mach Number.
M = 0.50d0

! Sound Speed.
 CS = U0/M

! Background Density.
n0 = 1.0d0

! Raynold's Number.
Re = ms*n0*U0*Lx/mux; write(5,*) "Re =", Re

! Position of Point Vortices.
d = 0.40d0*2.0d0*pi

! Number of Point Vortices.
PVN = 5

! Grid Generation.
do i = 1, Nx
  x(i)=0.0d0+real(i-1)*dx
  do j = 1, Ny
    y(j)=0.0d0+real(j-1)*dy
    ! Initial Density Distribution.
    n(i,j) = n0
    ! Initial Velocity Distribution.
    !read(20,*) G1,G2,G3,ux(i,j),uy(i,j)  ! You may define your own function here.
    if ( (x(i) - Lx/2.0d0)**2 + (y(j) -Ly/2.0d0)**2 <= (0.30d0*2.0d0*pi)**2 ) then
    omega(i,j) = 1.0d0
    else
    omega(i,j) = 0.0d0
    endif

      do PV = 1,PVN
      NPV = NPV-1
      theta = 2.0d0*pi/PVN
        if ( (x(i) - (Lx/2.0d0+d*dcos(NPV*theta)))**2 + (y(j) - (Ly/2.0d0+d*dsin(NPV*theta)))**2 <= (0.20d0)**2 ) then
        omega(i,j) = 10.0d0
        endif
      enddo

    ! Keep Backup of the Arrays for FFTW.
    n_dum(i,j) = n(i,j)
    !ux_dum(i,j) = ux(i,j)
    !uy_dum(i,j) = uy(i,j)
    omega_dum(i,j) = omega(i,j)
    ! Write Initial Density and Velocity Distribution in File.
    write(15,*) x(i),y(j),omega(i,j),n(i,j),ux(i,j),uy(i,j)
  end do
end do
 close (15)
!===================== INITIAL TIME DATA ===============================================

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, n_dum, nk, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

!  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, ux_dum, ukx, FFTW_ESTIMATE)
!  call dfftw_execute_ (plan_forward)

!  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, uy_dum, uky, FFTW_ESTIMATE)
!  call dfftw_execute_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, omega_dum, omegak, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)

! Evaluate Initial Vorticity Spectra.
do i = 1, Nx/2+1
  do j = 1, Ny/2
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat(j-1)/Ly
    if (i == 1 .and. j == 1) then
    psik(i,j) = (0.0d0,0.0d0)
    ukx(i,j) = (0.0d0,0.0d0)
    uky(i,j) = (0.0d0,0.0d0)
    else
    psik(i,j) = omegak(i,j)/( kx*kx + ky*ky )
    ukx(i,j) = + (0.0d0,1.0d0) * ky * psik(i,j)
    uky(i,j) = - (0.0d0,1.0d0) * kx * psik(i,j)
    endif
  psik_dum(i,j) = psik(i,j)
  omegak_dum(i,j) = omegak(i,j)
  ukx_dum(i,j) = ukx(i,j)
  uky_dum(i,j) = uky(i,j)
  !omegak(i,j) = (0.0d0,1.0d0)*kx*uky(i,j) - (0.0d0,1.0d0)*ky*ukx(i,j)
  !omegak_dum(i,j) = omegak(i,j)
  enddo
  do j = Ny/2+1,Ny
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
  psik(i,j) = omegak(i,j)/( kx*kx + ky*ky )
  ukx(i,j) = + (0.0d0,1.0d0) * ky * psik(i,j)
  uky(i,j) = - (0.0d0,1.0d0) * kx * psik(i,j)
  psik_dum(i,j) = psik(i,j)
  omegak_dum(i,j) = omegak(i,j)
  ukx_dum(i,j) = ukx(i,j)
  uky_dum(i,j) = uky(i,j)
  !omegak(i,j) = (0.0d0,1.0d0)*kx*uky(i,j) - (0.0d0,1.0d0)*ky*ukx(i,j)
  !omegak_dum(i,j) = omegak(i,j)
  enddo
enddo

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, omegak_dum, omega, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, ukx_dum, ux, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, uky_dum, uy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_destroy_plan_ (plan_forward)
  call dfftw_destroy_plan_ (plan_backward)

! Evaluate Initial Energy Spectra.
!do i = 1, Nx/2+1
  !do j = 1, Ny
  !write(30,*) i-1,j-1,abs(nk(i,j)),abs(ukx(i,j)),abs(uky(i,j))
  !end do
!end do

!Energy0 = 0.0d0; y_Energy0 = 0.0d0

do i = 1, Nx
  do j = 1, Ny
  ! FFTW Normalisation.
   omega(i,j) = omega(i,j)/(dfloat(Nx)*dfloat(Ny))
   ux(i,j) = ux(i,j)/(dfloat(Nx)*dfloat(Ny))
   uy(i,j) = uy(i,j)/(dfloat(Nx)*dfloat(Ny))
  ! Evaluate Initial Kinetic Energy.
  !Energy0 = Energy0 + (ux(i,j)**2 + uy(i,j)**2)
  !y_Energy0 = y_Energy0 + (uy(i,j)**2)
  ! Store Grid Data Reproduced from FFTW.
  write(25,*) x(i),y(j),omega(i,j),n(i,j),ux(i,j),uy(i,j)
  end do
end do
 close (25)
! Write the Initial Energy in File.
!write(40,*) 0.0d0, Energy0,y_Energy0

!======================= MAIN PROGRAM =====================================================
t1 = omp_get_wtime()

! Time Loop Starts.
do time = time_min,time_max,dt

t = nint(time/dt) - dint(time_min/dt)

! Online Check of the Progress.
!if (mod(t,int(1.0/dt)) == 0) then
!print*, t/int(1.0/dt)
!endif

!======================================================================================

! Non-Linear Term Evaluator.
  call derive2coh (Nx,Ny,Nh,pi,time,nk,ukx,uky, &
  dn_dt_old,dux_dt_old,duy_dt_old,dn_dt_new,dux_dt_new,duy_dt_new)

! Time Solvers.
! Adams-Bashforth
  call ab2coh (Nx,Ny,Nh,pi,time,nk,ukx,uky,nk_new,ukx_new,uky_new, &
  dn_dt_old,dux_dt_old,duy_dt_old,dn_dt_new,dux_dt_new,duy_dt_new)
! Euler Method
  !call euler2coh (Nx,Ny,Nh,pi,time,nk,ukx,uky,nk_new,ukx_new,uky_new,dn_dt_new,dux_dt_new,duy_dt_new)
! Predictor-Corrector
  !call pc_nk2coh (Nx,Ny,Nh,pi,time,nk,nk_new,ukx,uky,dn_dt_new,dux_dt_new,duy_dt_new)
  !call pc_ukx2coh (Nx,Ny,Nh,pi,time,nk,ukx,ukx_new,uky,dn_dt_new,dux_dt_new,duy_dt_new)
  !call pc_uky2coh (Nx,Ny,Nh,pi,time,nk,ukx,uky,uky_new,dn_dt_new,dux_dt_new,duy_dt_new)
! Runge-Kutta (4)
  !call rk4_nk2coh (Nx,Ny,Nh,pi,time,nk,nk_new,ukx,uky,dn_dt_new,dux_dt_new,duy_dt_new) ! dux_dt_new,duy_dt_new NOT NEEDED
  !call rk4_ukx2coh (Nx,Ny,Nh,pi,time,nk,ukx,ukx_new,uky,dn_dt_new,dux_dt_new,duy_dt_new)
  !call rk4_uky2coh (Nx,Ny,Nh,pi,time,nk,ukx,uky,uky_new,dn_dt_new,dux_dt_new,duy_dt_new)

!======================================================================================

!$OMP PARALLEL SHARED(dn_dt_old,dux_dt_old,duy_dt_old,dn_dt_new,dux_dt_new,duy_dt_new),&
!$OMP & SHARED(nk,ukx,uky,nk_new,ukx_new,uky_new,nk_dum,ukx_dum,uky_dum) PRIVATE(i,j)
!$OMP DO

do i = 1,Nx/2+1
  do j = 1,Ny
    ! Set the Variables in Proper Format for Next Time Iteration.
    dn_dt_old(i,j) = dn_dt_new(i,j)
    dux_dt_old(i,j) = dux_dt_new(i,j)
    duy_dt_old(i,j) = duy_dt_new(i,j)
    nk(i,j) = nk_new(i,j)
    ukx(i,j) = ukx_new(i,j)
    uky(i,j) = uky_new(i,j)
    ! Keep Backup of the Arrays for FFTW.
    nk_dum(i,j) = nk(i,j)
    ukx_dum(i,j) = ukx(i,j)
    uky_dum(i,j) = uky(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

! Evaluate Vorticity in Spectral Space.

!$OMP PARALLEL SHARED(Lx,Ly,ukx,uky,omegak,omegak_dum) PRIVATE(i,j,kx,ky)
!$OMP DO

do i = 1, Nx/2+1
  do j = 1, Ny/2
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat(j-1)/Ly
  omegak(i,j) = (0.0d0,1.0d0)*kx*uky(i,j) - (0.0d0,1.0d0)*ky*ukx(i,j)
  omegak_dum(i,j) = omegak(i,j)
  enddo
  do j = Ny/2+1,Ny
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
  omegak(i,j) = (0.0d0,1.0d0)*kx*uky(i,j) - (0.0d0,1.0d0)*ky*ukx(i,j)
  omegak_dum(i,j) = omegak(i,j)
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, nk_dum, n, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, ukx_dum, ux, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, uky_dum, uy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, omegak_dum, omega, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)

  call dfftw_destroy_plan_ (plan_backward)

! FFTW Normalisation.

!$OMP PARALLEL SHARED(n,ux,uy,omega) PRIVATE(i,j)
!$OMP DO

do i = 1,Nx
  do j = 1,Ny
  n(i,j) = n(i,j)/(dfloat(Nx)*dfloat(Ny))
  ux(i,j) = ux(i,j)/(dfloat(Nx)*dfloat(Ny))
  uy(i,j) = uy(i,j)/(dfloat(Nx)*dfloat(Ny))
  omega(i,j) = omega(i,j)/(dfloat(Nx)*dfloat(Ny))
  enddo
enddo

!$OMP END DO
!$OMP END PARALLEL

! Evaluate Energy Spectra at a Specified Time.
!if (t == 10000) then

! Try to avoid this OMP loop since it alters the sequence of i and j in Outout file.
! !$OMP PARALLEL SHARED(ukx,uky) PRIVATE(i,j)
! !$OMP DO REDUCTION (+:Ek)

  !do i = 1,Nx/2+1
  !  do j = 1,Ny
  !  Ek(i,j) = Ek(i,j) + sqrt(abs(ukx(i,j))**2 + abs(uky(i,j))**2)
  !  write(35,*) i,j,sqrt(float((i-1)**2)+float((j-1)**2)),abs(Ek(i,j))
  !  enddo
  !enddo

! !$OMP END PARALLEL

!endif

Energy = 0.0d0; y_Energy = 0.0d0
 C0 = 0.0d0
 C1 = 0.0d0
 C2 = 0.0d0
 C3 = 0.0d0

! Try to avoid this OMP loop since it alters the sequence of i and j in Outout file.
! !$OMP PARALLEL SHARED(t,dt,x,y,omega,n,ux,uy) PRIVATE(i,j)
! !$OMP DO REDUCTION (+:Energy,y_Energy,C0,C1,C2,C3)

do i = 1,Nx
  do j = 1,Ny
  ! Evaluate Energy
  Energy = Energy + (ux(i,j)**2 + uy(i,j)**2)
  ! Evaluate Growth Rate.
  y_Energy = y_Energy + (uy(i,j)**2)
  C0 = C0 + omega(i,j)**0.0d0
  C1 = C1 + omega(i,j)**1.0d0
  C2 = C2 + omega(i,j)**2.0d0
  C3 = C3 + omega(i,j)**3.0d0
    ! Write Grid Data in State Files.
    if (mod(float(t),1.0d0/(10.0d0*dt)) == 0.0) then
      write(filename, '("output/fort.",I8.8)') t+100
      open(unit=t+100,file=filename,status='unknown')
      write(t+100,*) x(i),y(j),omega(i,j),n(i,j),ux(i,j),uy(i,j)
    endif
  enddo
enddo

! !$OMP END PARALLEL

if (mod(float(t),1.0d0/(10.0d0*dt)) == 0.0) then
  close(t+100)
endif

write(40,*) time,Energy/(2.0d0*dfloat(Nx)*dfloat(Ny)),(y_Energy)/(2.0d0*dfloat(Nx)*dfloat(Ny)), &
 C0/(dfloat(Nx)*dfloat(Ny)),C1/(dfloat(Nx)*dfloat(Ny)),C2/(dfloat(Nx)*dfloat(Ny)),C3/(dfloat(Nx)*dfloat(Ny))

enddo ! time

t2 = omp_get_wtime()

write(5,*) "Time taken for the run = ",t2 - t1

!====================================================================================

end subroutine tara2dHydOMP


! Riemann solver for the LWR traffic model with an on-ramp or off-ramp

! q_t + (q(1-q))_x = D \delta(x)

! waves: 1
! equations: 1

! Conserved quantities:
!       1 q

! The strength of the on-ramp delta function and the index of the cell with
! the ramp (at the left edge) should be in the variables dramp, iramp in the
! common block cparam.

! See http://www.clawpack.org/riemann.html for a detailed explanation
! of the Riemann solver API.

subroutine rp1(maxm,num_eqn,num_waves,num_aux,num_ghost,num_cells, &
               ql,qr,auxl,auxr,fwave,s,amdq,apdq)

    implicit none

    ! Inputs
    integer, intent(in) :: maxm, num_eqn, num_waves, num_aux, num_ghost, num_cells
    double precision, intent(in), dimension(num_eqn, 1-num_ghost:maxm+num_ghost) :: ql,qr
    double precision, intent(in), dimension(num_aux, 1-num_ghost:maxm+num_ghost) :: auxl,auxr
    ! Outputs
    double precision, intent(out) :: s(num_waves,1-num_ghost:num_cells+num_ghost)
    double precision, intent(out) :: fwave(num_eqn,num_waves,1-num_ghost:num_cells+num_ghost)
    double precision, intent(out), dimension(num_eqn, 1-num_ghost:maxm+num_ghost) :: amdq,apdq
    ! Locals
    integer :: i, iramp
    double precision :: fim1, fi, sim1, si, f0
    double precision :: dramp

    common /cparam/ iramp, dramp

    do i=2-num_ghost, num_cells+num_ghost

        ! compute characteristic speed in each cell:
        sim1 = 1.d0 - 2.d0*qr(1,i-1)
        si   = 1.d0 - 2.d0*ql(1,i  )

        ! compute flux in each cell and flux difference:
        fim1 = qr(1,i-1)*(1.d0 - qr(1,i-1))
        fi   = ql(1,i  )*(1.d0 - ql(1,i  ))

        if (i.eq.iramp) then
            ! on-ramp here
            fwave(1,1,i) = fi - fim1 - dramp
            if (fim1+dramp .lt. 0.25d0 .and. si .le. 0.d0) then
                ! left-going
                s(1,i) = sim1
                amdq(1,i) = fwave(1,1,i)
                apdq(1,i) = 0.d0
            else if (sim1 .ge. 0.d0 .and. si .gt. 0.d0) then
                ! right-going
                s(1,i) = si
                amdq(1,i) = 0.d0
                apdq(1,i) = fwave(1,1,i)
            else if (sim1+dramp .gt. 0.25d0 .and. si .gt. 0.d0) then ! Should sim1 be fim1 here?
                ! transonic rarefaction
                s(1,i) = 0.5d0*(sim1 + si)

                ! entropy fix
                f0 = 0.25d0
                ! split fwave between amdq and apdq:
                amdq(1,i) = f0 - fim1 - dramp
                apdq(1,i) = fi - f0
            else
                ! transonic shock
                s(1,i) = 0.5d0*(sim1 + si)
                if (fi-fim1 .lt. 0.d0) then
                    amdq(1,i) = fwave(1,1,i)
                    apdq(1,i) = 0.d0
                else if (fi-fim1 .gt. 0.d0) then
                    amdq(1,i) = 0.d0
                    apdq(1,i) = fwave(1,1,i)
                else
                    amdq(1,i) = 0.5d0 * fwave(1,1,i)
                    apdq(1,i) = 0.5d0 * fwave(1,1,i)
                endif
            endif
        else
            ! No ramp here; use regular solver
            fwave(1,1,i) = fi - fim1

            if (sim1 .lt. 0.d0 .and. si .le. 0.d0) then
                ! left-going
                s(1,i) = sim1
                amdq(1,i) = fwave(1,1,i)
                apdq(1,i) = 0.d0
            else if (sim1 .ge. 0.d0 .and. si .gt. 0.d0) then
                ! right-going
                s(1,i) = si
                amdq(1,i) = 0.d0
                apdq(1,i) = fwave(1,1,i)
            else if (sim1 .lt. 0.d0 .and. si .gt. 0.d0) then
                ! transonic rarefaction
                s(1,i) = 0.5d0*(sim1 + si)

                ! entropy fix
                f0 = 0.25d0
                ! split fwave between amdq and apdq:
                amdq(1,i) = f0 - fim1
                apdq(1,i) = fi - f0
            else
                ! transonic shock
                s(1,i) = 0.5d0*(sim1 + si)
                if (fi-fim1 .lt. 0.d0) then
                    amdq(1,i) = fwave(1,1,i)
                    apdq(1,i) = 0.d0
                else if (fi-fim1 .gt. 0.d0) then
                    amdq(1,i) = 0.d0
                    apdq(1,i) = fwave(1,1,i)
                else
                    amdq(1,i) = 0.5d0 * fwave(1,1,i)
                    apdq(1,i) = 0.5d0 * fwave(1,1,i)
                endif
            endif
        endif
    end do
end subroutine rp1


      program main
      double precision x,y,z, y_int
      write(6,*) 'input x:'
      read(5,*) x
      write(6,*) 'input y:'
      read(5,*) y

      y_int=int(y)

      if (x.gt.0) then
        z=x**y
        write(6,*) '(',x,')^(',y,')=',z
      else if (x.eq.0) then
        z=0.0d0
        write(6,*) '(',x,')^(',y,')=',z
      else if (y.eq.y_int) then
        z=x**y
        write(6,*) '(',x,')^(',y,')=',z
      else
        write(6,*) 'Range error in x and/or y'
      end if
      stop
      end


*DECK DPPVAL
      DOUBLE PRECISION FUNCTION DPPVAL (LDC, C, XI, LXI, K, IDERIV, X,
     +   INPPV)
C***BEGIN PROLOGUE  DPPVAL
C***PURPOSE  Calculate the value of the IDERIV-th derivative of the
C            B-spline from the PP-representation.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      DOUBLE PRECISION (PPVAL-S, DPPVAL-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract    **** a double precision routine ****
C         DPPVAL is the PPVALU function of the reference.
C
C         DPPVAL calculates (at X) the value of the IDERIV-th
C         derivative of the B-spline from the PP-representation
C         (C,XI,LXI,K).  The Taylor expansion about XI(J) for X in
C         the interval XI(J) .LE. X .LT. XI(J+1) is evaluated, J=1,LXI.
C         Right limiting values at X=XI(J) are obtained.  DPPVAL will
C         extrapolate beyond XI(1) and XI(LXI+1).
C
C         To obtain left limiting values (left derivatives) at XI(J)
C         replace LXI by J-1 and set X=XI(J),J=2,LXI+1.
C
C     Description of Arguments
C
C         Input      C,XI,X are double precision
C          LDC     - leading dimension of C matrix, LDC .GE. K
C          C       - matrix of dimension at least (K,LXI) containing
C                    right derivatives at break points XI(*).
C          XI      - break point vector of length LXI+1
C          LXI     - number of polynomial pieces
C          K       - order of B-spline, K .GE. 1
C          IDERIV  - order of the derivative, 0 .LE. IDERIV .LE. K-1
C                    IDERIV=0 gives the B-spline value
C          X       - argument, XI(1) .LE. X .LE. XI(LXI+1)
C          INPPV   - an initialization parameter which must be set
C                    to 1 the first time DPPVAL is called.
C
C         Output     DPPVAL is double precision
C          INPPV   - INPPV contains information for efficient process-
C                    ing after the initial call and INPPV must not
C                    be changed by the user.  Distinct splines require
C                    distinct INPPV parameters.
C          DPPVAL  - value of the IDERIV-th derivative at X
C
C     Error Conditions
C         Improper input is a fatal error
C
C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C***ROUTINES CALLED  DINTRV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPVAL
C
      INTEGER I, IDERIV, INPPV, J, K, LDC, LXI, NDUMMY, KK
      DOUBLE PRECISION C, DX, X, XI
      DIMENSION XI(*), C(LDC,*)
C***FIRST EXECUTABLE STATEMENT  DPPVAL
      DPPVAL = 0.0D0
      IF(K.LT.1) GO TO 90
      IF(LDC.LT.K) GO TO 80
      IF(LXI.LT.1) GO TO 85
      IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 95
      I = K - IDERIV
      KK = I
      CALL DINTRV(XI, LXI, X, INPPV, I, NDUMMY)
      DX = X - XI(I)
      J = K
   10 DPPVAL = (DPPVAL/KK)*DX + C(J,I)
      J = J - 1
      KK = KK - 1
      IF (KK.GT.0) GO TO 10
      RETURN
C
C
   80 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPVAL', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
   85 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPVAL', 'LXI DOES NOT SATISFY LXI.GE.1',
     +   2, 1)
      RETURN
   90 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPVAL', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
   95 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPVAL',
     +   'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1)
      RETURN
      END


       FUNCTION IW3JDN(IYEAR,MONTH,IDAY)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: IW3JDN         COMPUTE JULIAN DAY NUMBER
C   AUTHOR: JONES,R.E.       ORG: W342       DATE: 87-03-29
C
C ABSTRACT: COMPUTES JULIAN DAY NUMBER FROM YEAR (4 DIGITS), MONTH,
C   AND DAY. IW3JDN IS VALID FOR YEARS 1583 A.D. TO 3300 A.D.
C   JULIAN DAY NUMBER CAN BE USED TO COMPUTE DAY OF WEEK, DAY OF
C   YEAR, RECORD NUMBERS IN AN ARCHIVE, REPLACE DAY OF CENTURY,
C   FIND THE NUMBER OF DAYS BETWEEN TWO DATES.
C
C PROGRAM HISTORY LOG:
C   87-03-29  R.E.JONES
C   89-10-25  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:   II = IW3JDN(IYEAR,MONTH,IDAY)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     IYEAR  ARG LIST  INTEGER   YEAR           ( 4 DIGITS)
C     MONTH  ARG LIST  INTEGER   MONTH OF YEAR   (1 - 12)
C     IDAY   ARG LIST  INTEGER   DAY OF MONTH    (1 - 31)
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     IW3JDN FUNTION   INTEGER   JULIAN DAY NUMBER
C                      JAN. 1,1960 IS JULIAN DAY NUMBER 2436935
C                      JAN. 1,1987 IS JULIAN DAY NUMBER 2446797
C
C   REMARKS: JULIAN PERIOD WAS DEVISED BY JOSEPH SCALIGER IN 1582.
C     JULIAN DAY NUMBER #1 STARTED ON JAN. 1,4713 B.C. THREE MAJOR
C     CHRONOLOGICAL CYCLES BEGIN ON THE SAME DAY. A 28-YEAR SOLAR
C     CYCLE, A 19-YEAR LUNER CYCLE, A 15-YEAR INDICTION CYCLE, USED
C     IN ANCIENT ROME TO REGULATE TAXES. IT WILL TAKE 7980 YEARS
C     TO COMPLETE THE PERIOD, THE PRODUCT OF 28, 19, AND 15.
C     SCALIGER NAMED THE PERIOD, DATE, AND NUMBER AFTER HIS FATHER
C     JULIUS (NOT AFTER THE JULIAN CALENDAR). THIS SEEMS TO HAVE
C     CAUSED A LOT OF CONFUSION IN TEXT BOOKS. SCALIGER NAME IS
C     SPELLED THREE DIFFERENT WAYS. JULIAN DATE AND JULIAN DAY
C     NUMBER ARE INTERCHANGED. A JULIAN DATE IS USED BY ASTRONOMERS
C     TO COMPUTE ACCURATE TIME, IT HAS A FRACTION. WHEN TRUNCATED TO
C     AN INTEGER IT IS CALLED AN JULIAN DAY NUMBER. THIS FUNCTION
C     WAS IN A LETTER TO THE EDITOR OF THE COMMUNICATIONS OF THE ACM
C     VOLUME 11 / NUMBER 10 / OCTOBER 1968. THE JULIAN DAY NUMBER
C     CAN BE CONVERTED TO A YEAR, MONTH, DAY, DAY OF WEEK, DAY OF
C     YEAR BY CALLING SUBROUTINE W3FS26.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/864, CRAY Y-MP EL2/256
C
C$$$
C
       IW3JDN  =    IDAY - 32075
     &            + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4
     &            + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12
     &            - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4
       RETURN
       END


!----------------------------------------------------------------------------- best with 100 columns

function basicFEM1() result(ierr)
  use modPolyFeGrid
  use modFileIO
  use modSparse
  use modBasicFEM
  type(polyFeGrid)::grid
  type(multiFront)::A
  double precision,allocatable::phi(:),rhs(:)
  logical,allocatable::isDirichlet(:)
  integer::ierr

  ierr=0
  open(10,file='data/tet10.msh',action='read')
    call readGMSH(10,grid)
  close(10)
  call grid%up()

  allocate(phi(grid%nN))
  allocate(rhs(grid%nN))
  allocate(isDirichlet(grid%nN))

  rhs(:)=0d0
  isDirichlet(:)=.false.
  do i=grid%nC+1,grid%nE
    if(grid%gid(i)==1)then
      isDirichlet(grid%iNE(1:grid%nNE(i),i))=.true.
      rhs((grid%iNE(1:grid%nNE(i),i)))=0d0
    end if
    if(grid%gid(i)==2)then
      isDirichlet(grid%iNE(1:grid%nNE(i),i))=.true.
      rhs((grid%iNE(1:grid%nNE(i),i)))=100d0
    end if
  end do
  call A%init(grid%nN,size(grid%iNE,1)**2*grid%nE)
  call findLaplacian(grid,A,isDirichlet)

  call A%fact()
  call A%solve(rhs,phi)

  do i=1,grid%nN
    if(abs(phi(i)-grid%pN(1,i)*100d0)>1d-6)then
      ierr=1
    end if
  end do

end function


module state_lists
  implicit none
  integer, allocatable :: combination(:,:)
contains

  subroutine get_combination(NOS,NOD)
    integer, intent(in) :: NOS, NOD
    integer :: i, j
    allocate(combination(NOS,NOD))
    do j = 1, NOD
      do i = 1, NOS
        combination(i,j) = f_combination(i,j)
      end do
    end do
  end subroutine get_combination

  function f_combination(n,k) result(nCk)
    integer, intent(in) :: n, k
    integer :: i
    integer ::nCk

    if(n < k)then
      nCk = 0
      return
    end if

    nCk=1
    do i=1,k
      nCk=nCk*(n-k+i)
      nCk=nCk/i
    end do

  end function f_combination

  !   !for Lx*Ly*Lz lattice (x=[1,LX], y=[1,Ly], z=[1,Lz]) <=> x + LX*(y-1) + LX*LY*(z-1)
  function mk_shift_x_SQ(LX,LY,LZ) result(shift_x_SQ)
    integer, intent(in) :: LX, LY, LZ
    integer :: shift_x_SQ(LX*LY*LZ)
    integer :: x, y, z
    forall(x=1:LX,y=1:LY,z=1:LZ)
      shift_x_SQ( x + LX*((y-1) + LY*(z-1)) ) = &
        (mod(x, LX)+1) + LX*(y-1) + LX*LY*(z-1)
    end forall
  end function mk_shift_x_SQ

  function mk_shift_y_SQ(LX,LY,LZ) result(shift_y_SQ)
    integer, intent(in) :: LX, LY, LZ
    integer :: shift_y_SQ(LX*LY*LZ)
    integer :: x, y, z
    forall(x=1:LX,y=1:LY,z=1:LZ)
      shift_y_SQ( x + LX*((y-1) + LY*(z-1)) ) = &
        x + LX*mod(y, LY) + LX*LY*(z-1)
    end forall
  end function mk_shift_y_SQ

  function mk_shift_z_SQ(LX,LY,LZ) result(shift_z_SQ)
    integer, intent(in) :: LX, LY, LZ
    integer :: shift_z_SQ(LX*LY*LZ)
    integer :: x, y, z
    forall(x=1:LX,y=1:LY,z=1:LZ)
      shift_z_SQ( x + LX*((y-1) + LY*(z-1)) ) = &
        x + LX*(y-1) + LX*LY*mod(z, LZ)
    end forall
  end function mk_shift_z_SQ

  subroutine checkstate_SQ(s,ro,NOD,pkx,pky,pkz)
    use input_param, only: LX,LY,LZ,NOS,shift_x_SQ,shift_y_SQ,shift_z_SQ
    integer, intent(in) :: s
    integer, intent(in) :: NOD
    real(8), intent(in) :: pkx,pky,pkz
    real(8), intent(out) :: ro
    complex(8) :: coef
    integer :: i, j, k, l, count
    integer, allocatable :: n(:), np(:)
    real(8) :: p1, p2
    allocate(n(NOD),np(NOD))
    n = list_fly(s,NOD,NOS)
    np = n
    !
    ro = 0.0d0
    count = 0
    coef = (0.0d0,0.0d0)
    !
    do k = 1, LZ
      np = shift_z_SQ(np)
      p1 = pkz * dble(k)
      do j = 1, LY
        np = shift_y_SQ(np)
        p2 = pky * dble(j) + p1
        do i = 1, LX
          np = shift_x_SQ(np)
          call insertion_sort(np,NOD)
          !
          do l = NOD, 1, -1
            if(np(l) < n(l))then
              return
            else if(np(l) > n(l))then
              exit
            end if
          end do
          if(l==0)then
            coef = coef + exp( (0.0d0,-1.0d0) * ( pkx * dble(i) + p2) )
            count = count + 1
          end if
          !
        end do
      end do
    end do
    !
    ro = (abs(coef)**2) *dble(NOS)/dble(count)
    !NOS/count='Ra', where, T^{Ra}|s>=|s>, and  ro='Na', see the eq. (118) in the Sandvik ref.
  end subroutine checkstate_SQ

  pure subroutine insertion_sort(a,NOD)
    integer, intent(in) :: NOD
    integer, intent(inout) :: a(NOD)
    integer :: temp, i, j
    do i = 2, NOD
      j = i - 1
      temp = a(i)
      do while (a(j)>temp)
        a(j+1) = a(j)
        j = j - 1
        if(j==0) exit
      end do
      a(j+1) = temp
    end do
  end subroutine insertion_sort

  integer function inv_list(ni,NOD)
    integer, intent(in) :: NOD
    integer, intent(in) :: ni(NOD)
    integer :: i
    inv_list = ni(1)
    do i = 2, NOD
      inv_list = inv_list + combination(ni(i)-1,i)
    end do
  end function inv_list

  recursive subroutine qsort_w_order(a, o, first, last)
    integer :: a(*), o(*), first, last
    integer :: x, t8, i, j
    integer :: t
    x = a( (first+last) / 2 )
    i = first
    j = last
    do
      do while (a(i) < x)
        i=i+1
      end do
      do while (x < a(j))
        j=j-1
      end do
      if (i >= j) exit
      t8 = a(i);  a(i) = a(j);  a(j) = t8
      t  = o(i);  o(i) = o(j);  o(j) = t
      i=i+1
      j=j-1
    end do
    if (first < i - 1) call qsort_w_order(a, o, first, i - 1)
    if (j + 1 < last)  call qsort_w_order(a, o, j + 1, last)
  end subroutine qsort_w_order

  subroutine calcu_lm_trans(NOD,psi_l,list_r_l,site,n0,pkx,pky,pkz,lm_tmp) !see Notability
    use input_param, only: LX,LY,LZ,shift_x_SQ,shift_y_SQ,shift_z_SQ
    integer,intent(in)::NOD,site,n0(1:NOD)
    complex(8),intent(in)::psi_l
    real(8),intent(in)::list_r_l
    real(8),intent(in)::pkx,pky,pkz
    integer, allocatable :: n(:),np(:)
    integer :: r_x, r_y, r_z, rp_x, rp_y, rp_z
    integer :: lm_int
    complex(8),intent(out) :: lm_tmp
    real(8) :: p1, p2, c

    allocate(n(1:NOD),np(1:NOD))

    lm_int = 0
    lm_tmp = (0.0d0,0.0d0)
    c = dble(conjg(psi_l)*psi_l*0.50d0/(list_r_l**2))

    n = n0 !n0 means |a>_l
    do r_z = 1, LZ
      n = shift_z_SQ(n)
      do r_y = 1, LY
        n = shift_y_SQ(n)
        do r_x = 1, LX
          n = shift_x_SQ(n)
          call insertion_sort(n,NOD)
          !We obtain now |b>=T^r|a>_l

          !Look <S_site^z> in |b>
          lm_int=0
          if(any(n(1:NOD) == site))then !down
            lm_int=-1
          else!up
            lm_int=1
          end if

          !search T^r'|a>_l=|b>
          np = n0
          do rp_z = 1, LZ
            np = shift_z_SQ(np)
            p1 = pkz*dble(rp_z-r_z)
            do rp_y=1,LY
              np = shift_y_SQ(np)
              p2 = pky*dble(rp_y-r_y) + p1
              do rp_x=1,LX
                np = shift_x_SQ(np)
                call insertion_sort(np,NOD)
                !We obtain now T^r'|a>
                if( all(n==np) )then
                  lm_tmp=lm_tmp+c*dble(lm_int)*exp((0.0d0,1.0d0)*(pkx*dble(rp_x-r_x) + p2))
                end if
              end do
            end do
          end do
          !
        end do
      end do
    end do
  end subroutine calcu_lm_trans

  subroutine allocate_lists_omp_SQ
    use input_param, only: NOD,rkx,rky,rkz,THS,NOS,list_s,list_r
    use omp_lib
    integer :: a, i, j
    real(8) :: r
    integer :: num = 1
    real(8), allocatable :: tmp_list_r(:)
    integer, allocatable :: order(:)
    num = omp_get_max_threads()
    write(*,*) "********************"
    write(*,*) "max_threads", num
    write(*,*) "********************"
    !
    write(*,'(" ### Count # of representative states. ")')
    a = 0
    !$omp parallel
    !$omp do private(j,i,r)
    do j = 1, num
      do i = j, THS, num
        call checkstate_SQ(i,r,NOD,rkx,rky,rkz)
        if(r>1.0d-15) then
          !$omp atomic
          a = a + 1
        end if
      end do
    end do
    !$omp end do
    !$omp end parallel
    !
    write(*,'(" ### Allocate work arrays for lists. ")')
    allocate(list_s(a),tmp_list_r(a))
    !
    write(*,'(" ### Store representative states. ")')
    a = 0
    !$omp parallel
    !$omp do private(j,i,r)
    do j = 1, num
      do i = j, THS, num
        call checkstate_SQ(i,r,NOD,rkx,rky,rkz)
        if(r>1.0d-15) then
          !$omp critical
          a = a + 1
          list_s(a) = i
          tmp_list_r(a) = r
          !$omp end critical
        end if
      end do
    end do
    !$omp end do
    !$omp end parallel
    !
    write(*,'(" ### Allocate arrays for lists. ")')
    THS = a
    allocate(order(THS),list_r(THS))
    !
    write(*,'(" ### Store reordered lists. ")')
    !$omp parallel do
    do i = 1, THS
      order(i) = i
    end do
    call qsort_w_order(list_s, order, 1, THS)
    !$omp parallel do
    do i = 1, THS
      list_r(i) = sqrt( tmp_list_r(order(i)) )
    end do
    !
    return
  end subroutine allocate_lists_omp_SQ

  function list_fly(t,NOD,NOS) result(ni)
    integer, intent(in) :: t, NOD, NOS
    integer :: s
    integer :: i, j, b, j0
    integer :: ni(NOD)
    s = t
    j = NOS - 1
    do i = NOD, 2, -1
       call binary_search(s,combination(:,i), i, j, b, j0)
       j = j0 - 1
       ni(i) = j0
       s = s - combination(j,i)
    end do
    ni(1) = s
  end function list_fly
  !
  subroutine binary_search(s,list_s,ls,le,b,bmin)
    integer, intent(out) :: b, bmin
    integer, intent(in) :: s,ls,le
    integer, intent(in) :: list_s(le)
    integer :: bmax
    bmin = ls; bmax = le
    do
       b = bmin + (bmax-bmin)/2
       if(s<list_s(b))then
          bmax = b-1
       else if(list_s(b)<s)then
          bmin = b+1
       else
          bmin = b
          return
       end if
       if(bmin>bmax)then
          b = -1
          return
       end if
    end do
  end subroutine binary_search

  function j_flip_ni(i,j,n,NOD) result(nd)
    integer, intent(in) :: NOD, i, j, n(NOD)
    integer :: kr, kl
    integer :: nd(NOD)
    nd = 1
    do kr = NOD, 1, -1
      if(j < n(kr)) then
        cycle
      else if(j > n(kr)) then
        exit
      else
        nd = 0; exit
      end if
    end do
    if(nd(NOD) == 1)then ! S+_i S-_j
      do kl = 1, kr
        if(i == n(kl)) exit
      end do
      nd(kl:kr-1) = n(kl+1:kr)
      nd(kr) = j
    else ! S-_i S+_j
      do kl = 1, kr
        if(i < n(kl)) exit
      end do
      nd(kl) = i
      nd(kl+1:kr) = n(kl:kr-1)
    end if
    nd(1:kl-1) = n(1:kl-1)
    nd(kr+1:NOD) = n(kr+1:NOD)
  end function j_flip_ni

  subroutine findstate(s,list_s,b,m)
    integer, intent(out) :: b
    integer, intent(in) :: s, m, list_s(m)
    integer :: bmin, bmax
    bmin = 1; bmax = m
    do
      b = bmin + (bmax-bmin)/2
      if(s < list_s(b))then
        bmax = b-1
      else if(s > list_s(b))then
        bmin = b+1
      else
        return
      end if
      if(bmin>bmax)then
        b = -1; return
      end if
    end do
  end subroutine findstate

  subroutine representative_SQ(NOD,t,ell,n)
    use input_param, only: LX,LY,LZ,shift_x_SQ,shift_y_SQ,shift_z_SQ
    integer,intent(in)::NOD
    integer,intent(inout)::n(NOD)
    integer,intent(out) :: t, ell(3)
    integer :: i,j,k,l
    integer, allocatable :: nd(:)
    allocate(nd(NOD))
    ell = 0
    nd = n
    do k = 1, LZ
      nd(:) = shift_z_SQ(nd(:))
      do j = 1, LY
        nd(:) = shift_y_SQ(nd(:))
        do i = 1, LX
          nd(:) = shift_x_SQ(nd(:))
          call insertion_sort(nd,NOD)
          !
          do l = NOD, 1, -1
            if(nd(l)>n(l))then
              exit
            else if(nd(l)<n(l))then
              ell=(/i,j,k/)
              n(1:l) = nd(1:l)
              exit
            end if
          end do
          !
        end do
      end do
    end do
    t = inv_list(n,NOD)
  end subroutine representative_SQ
  !
  subroutine allocate_lists_omp_SQ_new
    use input_param, only: list_s_new,list_r_new,NOD_new,THS_new,NOS,&
      rkx_new,rky_new,rkz_new
    use omp_lib
    integer :: i, j, a
    real(8) :: r
    integer :: num = 1
    real(8), allocatable :: tmp_list_r(:)
    integer, allocatable :: order(:)
    num = omp_get_max_threads()
    write(*,*) "********************"
    write(*,*) "max_threads", num
    write(*,*) "********************"
    !
    write(*,'(" ### Count # of representative states. ")')
    a = 0
    !$omp parallel
    !$omp do private(j,i,r)
    do j = 1, num
      do i = j, THS_new, num
        call checkstate_SQ(i,r,NOD_new,rkx_new,rky_new,rkz_new)
        if(r>1.0d-15) then
          !$omp atomic
          a = a + 1
          !
        end if
      end do
    end do
    !$omp end do
    !$omp end parallel
    write(*,'(" ### Allocate work arrays for lists_new. ")')
    allocate(list_s_new(a),tmp_list_r(a))
    !
    write(*,'(" ### Store representative states_new. ")')
    a = 0
    !$omp parallel
    !$omp do private(j,i,r)
    do j = 1, num
      do i = j, THS_new, num
        call checkstate_SQ(i,r,NOD_new,rkx_new,rky_new,rkz_new)
        if(r>1.0d-15) then
          !$omp critical
          a = a + 1
          list_s_new(a) = i
          tmp_list_r(a) = r
          !$omp end critical
        end if
      end do
    end do
    !$omp end do
    !$omp end parallel
    !
    write(*,'(" ### Allocate arrays for lists_new. ")')
    THS_new = a
    allocate(order(THS_new),list_r_new(THS_new))
    !
    write(*,'(" ### Store reordered lists_new. ")')
    !$omp parallel do
    do i = 1, THS_new
      order(i) = i
    end do
    call qsort_w_order(list_s_new, order, 1, THS_new)
    !$omp parallel do
    do i = 1, THS_new
      list_r_new(i) = sqrt( tmp_list_r(order(i)) )
    end do
    !
    return
  end subroutine allocate_lists_omp_SQ_new

  subroutine search_representative_Spi_state_SQ(i,NOD,NOD_new,dim_new,list_s_new,n,lp,ell)
    integer,intent(in)::i,NOD,NOD_new
    integer,intent(in)::dim_new
    integer,intent(in)::list_s_new(1:dim_new)
    integer,intent(in)::n(1:NOD)
    integer,intent(inout) :: ell(3)
    integer,intent(inout)::lp
    integer :: s
    integer::l,kr
    integer, allocatable :: bp(:)
    allocate(bp(1:NOD_new))

    if(NOD>1)then !not FM state
      l = 1
      do kr = 1, NOD
        if(n(kr)==i)then
          l=kr
          exit
        end if
      end do

      bp(1:l-1)=n(1:l-1)
      !bp(l:NOD_new)=n(l+1:NOD)!when l=NOD then this is not operated
      bp(l:NOD-1)=n(l+1:NOD)

    else if (NOD==1.or.NOD==0)then
      print *, "You can not calculate...when sztot=NOS/2-1..."
      stop
    end if

    call representative_SQ(NOD_new,s,ell,bp) !Here, bp is changed to representative state |b>_lp, that means ni2 is "not" |b>.
    call findstate(s,list_s_new,lp,dim_new)

  end subroutine search_representative_Spi_state_SQ

  subroutine search_representative_Smi_state_SQ(i,NOD,NOD_new,dim_new,list_s_new,n,lp,ell)
    integer,intent(in)::i,NOD,NOD_new
    integer,intent(in)::dim_new
    integer,intent(in)::list_s_new(1:dim_new)
    integer,intent(in)::n(1:NOD)
    integer,intent(inout) :: ell(3)
    integer,intent(inout)::lp
    integer :: s
    integer::l,kr
    integer, allocatable :: bp(:)
    allocate(bp(1:NOD_new))

    if(NOD/=0)then !not FM state
      if(i<n(1))then
        bp(1)=i
        !bp(2:NOD_new)=n(1:NOD)
        bp(2:NOD+1)=n(1:NOD)
      else if(i>n(NOD))then
        bp(1:NOD)=n(1:NOD)
        bp(NOD_new)=i
      else
        l = 1
        do kr = 1, NOD-1
          if(n(kr)<i)then
            l=kr
          else if(n(kr)>i)then
            exit
          end if
        end do

        bp(1:l)=n(1:l)
        bp(l+1)=i
        bp(l+2:NOD+1)=n(l+1:NOD)
      end if
    else if (NOD==0)then
      bp(1)=i
    end if

    call representative_SQ(NOD_new,s,ell,bp)
    !Here, bp is changed to representative state |b>_lp, that means ni2 is "not" |b>.
    call findstate(s,list_s_new,lp,dim_new)
    !
  end subroutine search_representative_Smi_state_SQ

  subroutine search_representative_Szi_state_SQ(NOD,NOD_new,dim_new,list_s_new,n,lp,ell)
    integer,intent(in)::NOD,NOD_new
    integer,intent(in)::dim_new
    integer,intent(in)::list_s_new(1:dim_new)
    integer,intent(in)::n(1:NOD)
    integer,intent(inout) :: ell(3)
    integer,intent(inout)::lp
    integer :: s
    integer, allocatable ::bp(:)
    allocate(bp(1:NOD_new))

    bp(1:NOD)=n(1:NOD)

    call representative_SQ(NOD_new,s,ell,bp)
    !Here, bp is changed to representative state |b>_lp, that means ni2 is "not" |b>.
    call findstate(s,list_s_new,lp,dim_new)
  end subroutine search_representative_Szi_state_SQ

  !
end module state_lists


program main
  implicit none

  double precision, parameter :: pi = 3.141592653589793238462643383279502884197d0
  integer, parameter          :: w = 10
  integer, parameter          :: iters = 10

  double precision :: data(w), result(w)
  integer          :: i, iter
  character(len=128) :: filename

  do i = 1,w
     data(i) = pi/i
  end do

  open (unit=7,file="floattest/initialcond-f90.dat",action="write")
  write (7,*), data(:)
  close (7)

  do iter=1, iters
     do i = 1,w
        result(i) = sin((data(i) + data(i) + data(i)) + (data(i) + data(i) + data(i)))
     end do

     write (filename,'(A16,I1,A8)'), "floattest/f.iter", iter-1, "-f90.dat"

     open (unit=7,file=filename,action="write")
     write (7,*), result(:)
     close (7)

     do i = 1,w
        data(i) = result(i)
     end do
  end do

end program main


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

MODULE GAUSSIAN

    USE CONSTANTS, only : PI
    USE FACT

    IMPLICIT NONE

    CONTAINS

        ! ------------------------
        ! Compute Gaussian product
        ! ------------------------
        SUBROUTINE gaussian_product(aa,bb,Ra,Rb,pp,Rp,cp)
            IMPLICIT NONE

            ! INPUT
            REAL*8, intent(in) :: aa, bb ! Gaussian exponential coefficients
            REAL*8, dimension(3), intent(in) :: Ra, Rb ! Gaussian centers

            ! INTERMEDIATE VARIABLE
            REAL*8, dimension(3) :: Rab ! Differente between Gaussian centers

            ! OUTPUT
            REAL*8, intent(out) :: pp ! Gaussian product exponential coefficient
            REAL*8, intent(out) :: cp ! Gaussian product coefficient
            REAL*8, dimension(3), intent(out) :: Rp ! Gaussian product center

            ! Compute Gaussian product exponential coefficient
            pp = aa + bb

            ! Compute difference between Gaussian centers
            Rab = Ra - Rb

            ! Compute Gaussian product coefficient
            cp = DOT_PRODUCT(Rab,Rab)
            cp =  - aa * bb / pp * cp
            cp = EXP(cp)

            ! Compute Gaussian product center
            Rp = (aa * Ra + bb * Rb) / pp

        END SUBROUTINE gaussian_product

        ! --------------------------------------------------------------------
        ! Norm of Cartesian Gaussian integrals with arbitrary angular momentum
        ! --------------------------------------------------------------------
        FUNCTION norm(ax,ay,az,aa) result(N)
            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: ax, ay, az ! Cartesian Gaussian angular momenta projections
            REAL*8, intent(in) :: aa ! Gaussian exponential coefficient

            ! OUTPUT
            REAL*8 :: N ! Normalization factor

            N = (2 * aa / PI)**(3.0D0 / 4.0D0) * (4.0D0 * aa)**((ax + ay + az) / 2.0D0)
            N = N / SQRT(REAL(factorial2(2 * ax - 1) * factorial2(2 * ay - 1) * factorial2(2 * az - 1)))

        END FUNCTION norm

END MODULE GAUSSIAN


************************************************************
      SUBROUTINE LUDCMP(A,N,NP,INDX,D)

      PARAMETER (NMAX=100,TINY=1.0E-20)

      DIMENSION A(NP,NP),INDX(N),VV(NMAX)

      D=1.

      DO 12 I=1,N
        AAMAX=0.
        DO 11 J=1,N
          IF(ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
   11   CONTINUE
        IF(AAMAX.EQ.0.) PAUSE 'singular'
        VV(I)=1./AAMAX
   12 CONTINUE

      DO 19 J=1,N

        IF(J.GT.1) THEN
          DO 14 I=1,J-1
            SUM=A(I,J)
            IF(I.GT.1) THEN
              DO 13 K=1,I-1
                SUM=SUM-A(I,K)*A(K,J)
   13         CONTINUE
              A(I,J)=SUM
            ENDIF
   14     CONTINUE
        ENDIF

        AAMAX=0.
        DO 16 I=J,N
          SUM=A(I,J)
          IF(J.GT.1) THEN
            DO 15 K=1,J-1
              SUM=SUM-A(I,K)*A(K,J)
   15       CONTINUE
            A(I,J)=SUM
          ENDIF
          DUM=VV(I)*ABS(SUM)
         IF(DUM.GE.AAMAX) THEN
            IMAX=I
            AAMAX=DUM
          ENDIF
   16   CONTINUE

        IF(J.NE.IMAX) THEN
          DO 17 K=1,N
            DUM=A(IMAX,K)
            A(IMAX,K)=A(J,K)
            A(J,K)=DUM
   17     CONTINUE
          D=-D
          VV(IMAX)=VV(J)
        ENDIF

        INDX(J)=IMAX
        IF(J.NE.N) THEN
          IF(A(J,J).EQ.0) A(J,J)=TINY
          DUM=1./A(J,J)
          DO 18 I=J+1,N
            A(I,J)=A(I,J)*DUM
   18     CONTINUE
        ENDIF

   19 CONTINUE

      IF(A(N,N).EQ.0.) A(N,N)=TINY

      RETURN
      END
***************************************************************
      SUBROUTINE LUBKSB(A,N,NP,INDX,B)

      DIMENSION A(NP,NP),INDX(N),B(N)

      II=0

      DO 12 I=1,N
        LL=INDX(I)
        SUM=B(LL)
        B(LL)=B(I)
        IF(II.NE.0) THEN
          DO 11 J=II,I-1
            SUM=SUM-A(I,J)*B(J)
   11     CONTINUE
        ELSE IF(SUM.NE.0) THEN
          II=I
        ENDIF
        B(I)=SUM
   12 CONTINUE

      DO 14 I=N,1,-1
        SUM=B(I)
        IF(I.LT.N) THEN
          DO 13 J=I+1,N
            SUM=SUM-A(I,J)*B(J)
   13     CONTINUE
        ENDIF
        B(I)=SUM/A(I,I)
   14 CONTINUE

      RETURN
      END
****************************************************************
      SUBROUTINE INV(A,Y,INDX,N)

      DIMENSION A(N,N),Y(N,N),INDX(N)

      DO 12 I=1,N
        DO 11 J=1,N
          Y(I,J)=0.
   11   CONTINUE
        Y(I,I)=1.
   12 CONTINUE

      CALL LUDCMP(A,N,N,INDX,D)

      DO 13 J=1,N
        CALL LUBKSB(A,N,N,INDX,Y(1,J))
   13 CONTINUE

      RETURN
      END
****************************************************************


!> module for noise (error) addition
!! used for Data Assimilation purpose
!!
!<
PROGRAM rand_test
  USE randmod
  USE random
  USE general_tools
  USE debug_tools
IMPLICIT NONE
  INTEGER, PARAMETER :: IMAX=8
  INTEGER, DIMENSION(IMAX) :: ila_vec
  REAL(KIND=cp), DIMENSION(IMAX) :: rla_vec
  REAL(KIND=cp), DIMENSION(1000) :: rla_rand

	PRINT*, "normal random generator "
	!(mu=0.0_cp, sigma=0.1_cp, radius=0.5_cp, nright=100, stat=.TRUE.)
	CALL test_grand(stat=.TRUE.)
	PRINT*, "extern random generator "
	CALL test_extern_nrand()
!   CALL rand_normal_vector(rla_rand, stat=.TRUE.)
!   CALL write_vector_for_plot(rla_rand, "rt_rand.dat")

  CALL finilize_normal_rand()

CONTAINS

  !> \brief Test the Gaussian random numbers generator
  !! \param[in] mu mean of the distribution
  !! \param[in] sigma Standard deviation of the distribution
  !! \param[in] radius Distance from the mean to the maximum/minimum number that can be generated, default is set to 4*rd_sigma
  !! \param[in] nright Number of possible values greater than the mean, default is set to 127
  !! \param[in] stat says if it is necessary to save statistics
  !! \details the total number of possible values that can be generated is 2*id_nright + 1
  !<
	SUBROUTINE test_grand(mu, sigma, radius, nright, stat)
    REAL(KIND=cp), OPTIONAL, INTENT(IN) :: mu, sigma
    REAL(KIND=cp), OPTIONAL, INTENT(IN) :: radius
    INTEGER, OPTIONAL, INTENT(IN) :: nright
    LOGICAL, OPTIONAL, INTENT(IN) :: stat
    !local var
		INTEGER :: ibi, clock1, clock2
		REAL(KIND=cp) :: rl_rand

		CALL init_normal_rand(mu=mu, sigma=sigma, radius=radius, nright=nright, stat=stat)
		CALL SYSTEM_CLOCK(COUNT=clock1)
		DO ibi = 1, 10000000
			CALL normal_rand(rl_rand)
		END DO
		CALL SYSTEM_CLOCK(COUNT=clock2)
		CALL debug(clock2-clock1, 'Total time = ', tag=dALLWAYS)
		CALL save_grand_stat()
		CALL finilize_normal_rand()
	END SUBROUTINE test_grand

	!> \brief Test the extern normal random numbers generator
	SUBROUTINE test_extern_nrand()
    !local var
		INTEGER :: ibi, clock1, clock2
		REAL(KIND=cp) :: rl_rand
		TYPE(rng_environment) :: tl_rnge

		CALL init_normal_rand(stat=.TRUE.)
		CALL copy_normal_rnge(tl_rnge)
		CALL finilize_normal_rand()

		CALL SYSTEM_CLOCK(COUNT=clock1)
		DO ibi = 1, 10000000
			rl_rand = random_normal()
			!CALL update_rnge_stat(tl_rnge, rl_rand)
		END DO
		CALL SYSTEM_CLOCK(COUNT=clock2)
		CALL debug(clock2-clock1, 'Total time = ', tag=dALLWAYS)
		CALL save_extern_nstat(tl_rnge)
		CALL finilize_rng_environment(tl_rnge)
	END SUBROUTINE test_extern_nrand

  !> \brief generate a vector of Gaussian random numbers. Each element of the vector is an independant Gaussian with mean mu and std deviation sigma
  !! \param[out] rda_rand vector that contains the generated numbers
  !! \param[in] mu mean of the distribution
  !! \param[in] sigma Standard deviation of the distribution
  !! \param[in] radius Distance from the mean to the maximum/minimum number that can be generated, default is set to 4*rd_sigma
  !! \param[in] nright Number of possible values greater than the mean, default is set to 127
  !! \param[in] stat says if it is necessary to save statistics
  !! \details the total number of possible values that can be generated is 2*id_nright + 1
  !<
	SUBROUTINE rand_normal_vector(rda_rand, mu, sigma, radius, nright, stat)
		REAL(KIND=cp), DIMENSION(:) :: rda_rand
    REAL(KIND=cp), OPTIONAL, INTENT(IN) :: mu, sigma
    REAL(KIND=cp), OPTIONAL, INTENT(IN) :: radius
    INTEGER, OPTIONAL, INTENT(IN) :: nright
    LOGICAL, OPTIONAL, INTENT(IN) :: stat
    !local var
    INTEGER :: ibi

    CALL init_normal_rand(mu=mu, sigma=sigma, radius=radius, nright=nright, stat=stat)
    DO ibi = 1, SIZE(rda_rand)
			CALL init_random_seed()
			CALL normal_rand( rda_rand(ibi) )
    END DO
    CALL finilize_normal_rand()
	END SUBROUTINE rand_normal_vector

	SUBROUTINE save_grand_stat()
		INTEGER :: ibi, il_size
		REAL(cp), DIMENSION( : ), ALLOCATABLE :: rla_x, rla_f
		!getting and saving stats
		CALL get_normal_stat(ssize=il_size)
		ALLOCATE( rla_x(il_size), rla_f(il_size) )
		CALL get_normal_stat( x = rla_x, y = rla_f )
		CALL write_vector_for_plot( "rt_grand_stat.dat", rla_f, rla_x )
		CALL get_normal_stat( x = rla_x, pdf = rla_f )
		CALL write_vector_for_plot( "rt_grand_pdf.dat", rla_f, rla_x )
	END SUBROUTINE save_grand_stat

	SUBROUTINE save_extern_nstat(td_rnge)
		TYPE(rng_environment), INTENT(IN) :: td_rnge
		INTEGER :: ibi, il_size
		REAL(cp), DIMENSION( : ), ALLOCATABLE :: rla_x, rla_f
		!getting and saving stats
		CALL get_rng_stat(td_rnge, ssize=il_size)
		ALLOCATE( rla_x( il_size), rla_f(il_size) )
		CALL get_rng_stat(td_rnge,  x = rla_x, y = rla_f )
		CALL write_vector_for_plot( "rt_ext_stat.dat", rla_f, rla_x )
		CALL get_rng_stat( td_rnge, x = rla_x, pdf = rla_f )
		CALL write_vector_for_plot( "rt_ext_pdf.dat", rla_f, rla_x )
	END SUBROUTINE save_extern_nstat

END PROGRAM rand_test


      FUNCTION bessk(n,x)
      INTEGER n
      REAL bessk,x
CU    USES bessk0,bessk1
      INTEGER j
      REAL bk,bkm,bkp,tox,bessk0,bessk1
      if (n.lt.2) pause 'bad argument n in bessk'
      tox=2.0/x
      bkm=bessk0(x)
      bk=bessk1(x)
      do 11 j=1,n-1
        bkp=bkm+j*tox*bk
        bkm=bk
        bk=bkp
11    continue
      bessk=bk
      return
      END

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


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! FEAST Driver Example - Dense Storage
!!!!!!! solving Ax=eBx with A and B real non-symmetric (non-Hermitian)
!!!!!!! James Kestyn, Eric Polizzi 2015
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program driver

  implicit none

!!!!!!!!!!!!!!!!! Feast declaration variable
  integer,dimension(64) :: feastparam
  integer :: loop

!!!!!!!!!!!!!!!!! Matrix declaration variable
  character(len=100) :: name
  integer :: n,nnz,kl,ku,LDA,LDB
  double precision,dimension(:,:),allocatable :: A,B

!!!!!!!!!!!!!!!!! FEAST
  integer :: M0,M,info
  complex(kind=kind(1.0d0)) :: Emid
  double precision :: r,epsout
  double precision,dimension(:),allocatable :: res ! residual
  complex(kind=kind(1.0d0)),dimension(:,:),allocatable :: X ! eigenvectors
  complex(kind=kind(1.0d0)),dimension(:),allocatable :: E ! eigenvalues

!!!!!!!!!!!!!!!!! Others
  integer :: t1,t2,tim
  integer :: i,j,k

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!! read input file in coordinate format!!!!!!!
!!!!!!!!!!!!!!!!transform  in banded format directly !!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  name='../../system3'

  !! find kl,ku
  kl=0
  ku=0
  open(10,file=trim(name),status='old')
  read(10,*) n,nnz
  do k=1,nnz
     read(10,*) i,j
     if ((i-j)>kl) kl=(i-j)
     if ((j-i)>ku) ku=(j-i)
  end do
  close(10)

  !! form the banded matrices A and B
  allocate(A(1+kl+ku,N))
  allocate(B(1+kl+ku,N))
  LDA=ku+kl+1
  LDB=ku+kl+1
  A=0.0d0
  B=0.0d0
  open(10,file=trim(name),status='old')
  read(10,*) N,nnz
  do k=1,nnz
     read(10,*) i,j,A(ku+1+(i-j),j),B(ku+1+(i-j),j)
  end do
  close(10)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!! INFORMATION ABOUT MATRIX !!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  print *,'banded matrix -system3- size',n
  print *,'bandwidth',kl,ku,kl+ku+1

  call system_clock(t1,tim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!! FEAST in banded format !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!! search interval [Emid,r] including M eigenpairs
  Emid=(0.590d0,0.0d0)
  r=0.410d0
  M0=30 !! M0>=M

!!!!!!!!!!!!! ALLOCATE VARIABLE
  allocate(E(1:M0))     ! Eigenvalue
  allocate(X(1:n,1:2*M0)) ! Eigenvectors
  allocate(res(1:2*M0))   ! Residual (if needed)

!!!!!!!!!!!!!  FEAST
  call feastinit(feastparam)
  feastparam(1)=1
  call dfeast_gbgv(N,kl,ku,A,LDA,kl,ku,B,LDB,feastparam,epsout,loop,Emid,r,M0,E,X,M,res,info)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!! POST-PROCESSING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  call system_clock(t2,tim)
  print *,'FEAST OUTPUT INFO',info
  if (info==0) then
     print *,'*************************************************'
     print *,'************** REPORT ***************************'
     print *,'*************************************************'
     print *,'SIMULATION TIME',(t2-t1)*1.0d0/tim
     print *,'# Search interval [Emid; r]',Emid,r
     print *,'# mode found/subspace',M,M0
     print *,'# iterations',loop
     print *,'TRACE',sum(E(1:M))
     print *,'Relative error on the Trace',epsout
     print *,'Eigenvalues/Residuals'
     do i=1,M
        print *,i,E(i),MAX(res(i),res(M0+i))
     enddo
  endif

end program driver


*> \brief zminMax tests the robustness and precision of the double-valued intrinsic operators MIN and MAX
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Authors:
*  ========
*
*> \author Weslley S. Pereira, University of Colorado Denver, U.S.
*
*> \verbatim
*>
*> Tests with pairs of numbers (x,y):
*> Inf inputs where x < y:
*>    (1) (-Inf,   0)
*>    (2) ( 0  , Inf)
*>    (3) (-Inf, Inf)
*> Inf inputs where x > y:
*>    (4) ( 0  ,-Inf)
*>    (5) ( Inf,   0)
*>    (6) ( Inf,-Inf)
*> NaN inputs to test NaN propagation:
*>    (7) ( 0  , NaN)
*>    (8) ( NaN,   0)
*> The program tests MIN(x,y) and MAX(x,y) for every pair
*>
*> \endverbatim
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      program zmul
*
*  -- LAPACK test routine --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..

*     ..
*     .. Parameters ..
      integer           n
      parameter       ( n = 8 )
      double precision  zero
      parameter       ( zero = 0.0d0 )
*     ..
*     .. Local Variables ..
      integer           i
      double precision  aInf, aNaN, OV, R, X(n), Y(n)
*
*     .. Intrinsic Functions ..
      intrinsic         HUGE, MIN, MAX

*
*     .. Inf and NaN entries ..
      OV = HUGE(0.0d0)
      aInf = OV * 2
      aNaN = aInf / aInf
      X = (/ -aInf, zero, -aInf,  zero, aInf,  aInf, zero, aNaN /)
      Y = (/  zero, aInf,  aInf, -aInf, zero, -aInf, aNaN, zero /)

*
*     .. Tests ..
*
      do 10 i = 1, 3
          R = MIN( X(i), Y(i) )
          if( R .ne. X(i) ) then
              WRITE( *, FMT = 9998 ) 'i',i, 'MIN', X(i), Y(i), R
          endif
          R = MAX( X(i), Y(i) )
          if( R .ne. Y(i) ) then
              WRITE( *, FMT = 9998 ) 'i',i, 'MAX', X(i), Y(i), R
          endif
  10  continue
      do 20 i = 4, 6
          R = MIN( X(i), Y(i) )
          if( R .ne. Y(i) ) then
              WRITE( *, FMT = 9998 ) 'i',i, 'MIN', X(i), Y(i), R
          endif
          R = MAX( X(i), Y(i) )
          if( R .ne. X(i) ) then
              WRITE( *, FMT = 9998 ) 'i',i, 'MAX', X(i), Y(i), R
          endif
  20  continue
      do 30 i = 7, 8
          R = MIN( X(i), Y(i) )
          if( R .eq. R ) then
              WRITE( *, FMT = 9998 ) 'i',i, 'MIN', X(i), Y(i), R
          endif
          R = MAX( X(i), Y(i) )
          if( R .eq. R ) then
              WRITE( *, FMT = 9998 ) 'i',i, 'MAX', X(i), Y(i), R
          endif
  30  continue
*
*     .. Formats ..
 9998 FORMAT( '[',A1,I1, '] ', A3, '(', F5.0, ',', F5.0, ') = ', F5.0 )
*
*     End of zmul
*
      END


           program demo_acosh
           implicit none
           real(8), dimension(3) :: x = [ 1.0, 2.0, 3.0 ]
             write (*,*) acosh(x)
           end program demo_acosh


      SUBROUTINE SAMPWM(X,N,XMOM,NMOM,A,B,KIND)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  PROBABILITY WEIGHTED MOMENTS OF A DATA ARRAY
C
C  PARAMETERS OF ROUTINE:
C  X      * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING
C                  ORDER.
C  N      * INPUT* NUMBER OF DATA VALUES
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE SAMPLE
C                  PROBABILITY WEIGHTED MOMENTS. XMOM(I) CONTAINS
C                  ALPHA-SUB-(I-1) OR BETA-SUB-(I-1).
C  NMOM   * INPUT* NUMBER OF PROBABILITY WEIGHTED MOMENTS TO BE FOUND.
C                  AT MOST MAX(N,20).
C  A      * INPUT* ) PARAMETERS OF PLOTTING
C  B      * INPUT* ) POSITION (SEE BELOW)
C  KIND   * INPUT* SPECIFIES WHICH KIND OF PWM'S ARE TO BE FOUND.
C                  1  ALPHA-SUB-R = E ( X (1-F(X))**R )
C                  2  BETA -SUB-R = E ( X F(X)**R )
C
C  FOR UNBIASED ESTIMATES SET A AND B EQUAL TO ZERO. OTHERWISE,
C  PLOTTING-POSITION ESTIMATORS ARE USED, BASED ON THE PLOTTING POSITION
C  (J+A)/(N+B)  FOR THE J'TH SMALLEST OF N OBSERVATIONS. FOR EXAMPLE,
C  A=-0.35D0 AND B=0.0D0 YIELDS THE ESTIMATORS RECOMMENDED BY
C  HOSKING ET AL. (1985, TECHNOMETRICS) FOR THE GEV DISTRIBUTION.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION X(N),XMOM(NMOM)
      DATA ZERO/0D0/,ONE/1D0/
      IF(NMOM.GT.20.OR.NMOM.GT.N)GOTO 1000
      IF(KIND.NE.1.AND.KIND.NE.2)GOTO 1010
      DO 10 J=1,NMOM
   10 XMOM(J)=ZERO
      DN=N
      IF(A.EQ.ZERO.AND.B.EQ.ZERO)GOTO 50
      IF(A.LE.-ONE.OR.A.GE.B)GOTO 1020
C
C         PLOTTING-POSITION ESTIMATES OF PWM'S
C
      DO 30 I=1,N
      PPOS=(I+A)/(N+B)
      IF(KIND.EQ.1)PPOS=ONE-PPOS
      TERM=X(I)
      XMOM(1)=XMOM(1)+TERM
      DO 20 J=2,NMOM
      TERM=TERM*PPOS
   20 XMOM(J)=XMOM(J)+TERM
   30 CONTINUE
      DO 40 J=1,NMOM
   40 XMOM(J)=XMOM(J)/DN
      RETURN
C
C         UNBIASED ESTIMATES OF PWM'S
C
   50 DO 70 I=1,N
      DI=I
      WEIGHT=ONE/DN
      XMOM(1)=XMOM(1)+WEIGHT*X(I)
      DO 60 J=2,NMOM
      DJ=J-ONE
      IF(KIND.EQ.1)WEIGHT=WEIGHT*(DN-DI-DJ+ONE)/(DN-DJ)
      IF(KIND.EQ.2)WEIGHT=WEIGHT*(DI-DJ)/(DN-DJ)
   60 XMOM(J)=XMOM(J)+WEIGHT*X(I)
   70 CONTINUE
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
 1020 WRITE(6,7020)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE SAMPWM : PARAMETER NMOM INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE SAMPWM : PARAMETER KIND INVALID')
 7020 FORMAT(' *** ERROR *** ROUTINE SAMPWM :',
     *  ' PLOTTING-POSITION PARAMETERS INVALID')
      END


1 1 +
48 + EMIT \ print 1 digit number
10 EMIT \ newline
\ should output 2


program do_statistics_decorrelated_err
use libatoms_module, only : dp, system_initialise, system_finalise, system_abort, verbosity_push, verbosity_pop, verbosity_of_str, initialise, finalise, read_file, print, operator(//), param_register, param_read_args
use libatoms_module, only : PRINT_SILENT, PRINT_ALWAYS, INPUT, STRING_LENGTH
use libatoms_module, only : inoutput, dictionary
use statistics_module, only : mean_var_decorrelated_err
implicit none
   integer :: i, N
   real(dp), allocatable :: A(:,:)
   real(dp) :: m, v, decorrelation_t, decorrelated_error
   character(len=100), allocatable :: lines(:)
   type(inoutput) :: io
   type(Dictionary) :: cli
   character(len=STRING_LENGTH) :: verbosity_str
   integer :: n_col

   call system_initialise(verbosity=PRINT_SILENT)
   call initialise(cli)
   call param_register(cli, "verbosity", "NORMAL", verbosity_str, help_string="verbosity level")
   call param_register(cli, "n_col", "1", n_col, help_string="number of columns of data to be analyzed")
   if (.not. param_read_args(cli, ignore_unknown=.false., task="mean_var_decorrelated_err CLI arguments")) then
      call print("Usage: mean_var_decorrelated_err [ verbosity=LEVEL ] [ n_col=n(1) ]", PRINT_ALWAYS)
      call system_abort("Failed to parse command line arguments")
   end if
   call finalise(cli)
   call verbosity_push(verbosity_of_str(trim(verbosity_str)))

   call initialise(io, "stdin", INPUT)

   call read_file(io, lines, N)
   allocate(A(N,n_col))
   do i=1, N
      read (lines(i), *) A(i,:)
   end do
   do i=1, n_col
      call mean_var_decorrelated_err(A(:,i), m, v, decorrelated_error, decorrelation_t)
      call print("col " // i // " mean " // m // " variance " // v // " decorrelation_t " // decorrelation_t // " decorrelated_error " // decorrelated_error)
   end do

   call verbosity_pop()
   call system_finalise()

end program


!*******************************************************************
!> author: Akira Kageyama
!  date: 2020.01.22
!
!  Fortran定数と数学定数
!
!@note 定数であることが目で見てわかりやすいように全ての文字を
!      大文字で書く。コンパイラには無意味であるので注意。
!
!@note シミュレーション領域は直方体と仮定している。
!      x方向の長さXMAX-XMINである。座標系の原点を
!      シミュレーション領域の中心におくためには
!      XMAXとXMIN絶対値を等しくとる。
!
!@note シミュレーションの（x方向の）空間解像度を上げる
!      ためには同じXMAX-XMINに対して格子点数NXを上げれば良い。
!
!@note x,y,z それぞれの方向の空間解像度、
!      つまり格子間隔dx,dy,dzが異なっていても構わないが、
!      その差が極端に大きくしないほうがよい。
!
module constants_m
  implicit none

  ! << f90 constants >>
  integer, parameter :: SI = selected_int_kind(8)   ! 単精度整数種別値
  integer, parameter :: DI = selected_int_kind(16)  ! 倍精度整数種別値
  integer, parameter :: SR = selected_real_kind(6)  ! 単精度実数種別値
  integer, parameter :: DR = selected_real_kind(12) ! 倍精度実数種別値

  ! << Mathematical constants >>
  real(DR), parameter :: PI = 3.1415926535897932_DR ! 円周率
  real(DR), parameter :: TWOPI = PI*2               ! 円周率の2倍

  ! << Grid Size >>
  integer(SI), parameter :: NX =  60    ! 格子点数 x方向 粗い解像度
  integer(SI), parameter :: NY =  20    ! 格子点数 y方向 粗い解像度
  integer(SI), parameter :: NZ =  20    ! 格子点数 z方向 粗い解像度

  ! integer(SI), parameter :: NX =  92    ! 格子点数 x方向
  ! integer(SI), parameter :: NY =  32    ! 格子点数 y方向
  ! integer(SI), parameter :: NZ =  32    ! 格子点数 z方向

  ! integer(SI), parameter :: NX = 152  ! 格子点数 x方向 少し高めの解像度
  ! integer(SI), parameter :: NY =  52  ! 格子点数 y方向 少し高めの解像度
  ! integer(SI), parameter :: NZ =  52  ! 格子点数 z方向 少し高めの解像度

  ! << Box Size >>
  real(DR), parameter :: XMIN = -1.5_DR ! 計算領域範囲 +x
  real(DR), parameter :: XMAX = +1.5_DR ! 計算領域範囲 -x
  real(DR), parameter :: YMIN = -0.5_DR ! 計算領域範囲 +y
  real(DR), parameter :: YMAX = +0.5_DR ! 計算領域範囲 -y
  real(DR), parameter :: ZMIN = -0.5_DR ! 計算領域範囲 +z
  real(DR), parameter :: ZMAX = +0.5_DR ! 計算領域範囲 -z
end module constants_m


c
c
c     =====================================================
      subroutine rp1(maxm,meqn,mwaves,mbc,mx,ql,qr,auxl,auxr,
     &			wave,s,amdq,apdq)
c     =====================================================
c
c     # Riemann solver for the acoustics equations in 1d,
c     #  variable coefficients
c
c     # aux(i,1) = impedance Z
c     # aux(i,2) = sound speed c
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c
c     # On output, wave contains the waves,
c     #            s the speeds,
c     #
c     #            amdq = A^- Delta q,
c     #            apdq = A^+ Delta q,
c     #                   the decomposition of the flux difference
c     #                       f(qr(i-1)) - f(ql(i))
c     #                   into leftgoing and rightgoing parts respectively.
c     #
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routines, this routine is called with ql = qr
c
c
      implicit double precision (a-h,o-z)
c
      dimension auxl(1-mbc:maxm+mbc, 2)
      dimension auxr(1-mbc:maxm+mbc, 2)
      dimension wave(1-mbc:maxm+mbc, meqn, mwaves)
      dimension    s(1-mbc:maxm+mbc, mwaves)
      dimension   ql(1-mbc:maxm+mbc, meqn)
      dimension   qr(1-mbc:maxm+mbc, meqn)
      dimension apdq(1-mbc:maxm+mbc, meqn)
      dimension amdq(1-mbc:maxm+mbc, meqn)
c
c     local arrays
c     ------------
      dimension delta(2)
c
c
c     # split the jump in q at each interface into waves
c
c     # find a1 and a2, the coefficients of the 2 eigenvectors:
      do 20 i = 2-mbc, mx+mbc
         delta(1) = ql(i,1) - qr(i-1,1)
         delta(2) = ql(i,2) - qr(i-1,2)

c        # impedances:
	 zi = auxl(i,1)
	 zim = auxl(i-1,1)

	 a1 = (-delta(1) + zi*delta(2)) / (zim + zi)
	 a2 =  (delta(1) + zim*delta(2)) / (zim + zi)
c
c        # Compute the waves.
c
         wave(i,1,1) = -a1*zim
         wave(i,2,1) = a1
         s(i,1) = -auxl(i-1,2)
c
         wave(i,1,2) = a2*zi
         wave(i,2,2) = a2
         s(i,2) = auxl(i,2)
c
   20    continue
c
c
c     # compute the leftgoing and rightgoing fluctuations:
c     # Note s(i,1) < 0   and   s(i,2) > 0.
c
      do 220 m=1,meqn
         do 220 i = 2-mbc, mx+mbc
            amdq(i,m) = s(i,1)*wave(i,m,1)
            apdq(i,m) = s(i,2)*wave(i,m,2)
  220       continue
c
      return
      end


	subroutine derivacuad(s,ds,n,x)

	integer n
	real*4 s(*), ds(*),x(*),x1,x2,x3,d1,d2,d3

	ds(1)=(s(2)-s(1))/(x(2)-x(1))
        do i=2,n-1
           x1=x(i-1)
           x2=x(i)
           x3=x(i+1)
           d1=1./(x2-x3)
           d2=1./(x1-x2)
           d3=1./(x1-x3)
           ds(i)=s(i+1)*(d3-d1)+s(i)*(d1-d2)+s(i-1)*(d2-d3)
        end do
	ds(n)=(s(n)-s(n-1))/(x(n)-x(n-1))

	return
	end


      subroutine apply_metric(lo, hi, &
                              rhs, rl1, rl2, rh1, rh2,  &
                              ecx, ecxl1, ecxl2, ecxh1, ecxh2, &
                              ecy, ecyl1, ecyl2, ecyh1, ecyh2, dx, coord_type)

      implicit none
      integer lo(2),hi(2)
      integer rl1, rl2, rh1, rh2
      integer ecxl1, ecxl2, ecxh1, ecxh2
      integer ecyl1, ecyl2, ecyh1, ecyh2
      integer coord_type
      double precision rhs(rl1:rh1,rl2:rh2)
      double precision ecx(ecxl1:ecxh1,ecxl2:ecxh2)
      double precision ecy(ecyl1:ecyh1,ecyl2:ecyh2)
      double precision dx(2)

      double precision r
      integer i,j

      ! r-z
      if (coord_type .eq. 1) then

         ! At centers
         do i=lo(1),hi(1)
            r = (dble(i)+0.5d0) * dx(1)
            do j=lo(2),hi(2)
               rhs(i,j) = rhs(i,j) * r
            enddo
         enddo

         ! On x-edges
         do i=lo(1),hi(1)+1
            r = dble(i)*dx(1)
            do j=lo(2),hi(2)
               ecx(i,j) = ecx(i,j) * r
            enddo
         enddo

         ! On y-edges
         do i=lo(1),hi(1)
            r = (dble(i)+0.5d0) * dx(1)
            do j=lo(2),hi(2)+1
               ecy(i,j) = ecy(i,j) * r
            enddo
         enddo

      else
         print *,'Bogus coord_type in apply_metric ' ,coord_type
         call bl_error("Error:: MGutils_2d.f90 :: apply_metric")
      end if

      end subroutine apply_metric

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

      subroutine unweight_cc(lo, hi, &
                             cc, cl1, cl2, ch1, ch2,  &
                             dx, coord_type)

      implicit none
      integer lo(2),hi(2)
      integer cl1, cl2, ch1, ch2
      integer coord_type
      double precision cc(cl1:ch1,cl2:ch2)
      double precision dx(2)

      double precision r
      integer i,j

      ! r-z
      if (coord_type .eq. 1) then

         ! At centers
         do i=lo(1),hi(1)
            r = (dble(i)+0.5d0) * dx(1)
            do j=lo(2),hi(2)
               cc(i,j) = cc(i,j) / r
            enddo
         enddo

      else
         print *,'Bogus coord_type in unweight_cc ' ,coord_type
         call bl_error("Error:: MGutils_2d.f90 :: unweight_cc")
      end if

      end subroutine unweight_cc

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

      subroutine unweight_edges(lo, hi, &
                                ecx, ecxl1, ecxl2, ecxh1, ecxh2, &
                                ecy, ecyl1, ecyl2, ecyh1, ecyh2, dx, coord_type)

      implicit none
      integer lo(2),hi(2)
      integer ecxl1, ecxl2, ecxh1, ecxh2
      integer ecyl1, ecyl2, ecyh1, ecyh2
      integer coord_type
      double precision ecx(ecxl1:ecxh1,ecxl2:ecxh2)
      double precision ecy(ecyl1:ecyh1,ecyl2:ecyh2)
      double precision dx(2)

      double precision :: r
      integer          :: i,j

      ! r-z
      if (coord_type .eq. 1) then

         ! On x-edges
         do i = lo(1), hi(1)+1
            if (i .ne. 0) then
               r = dble(i)*dx(1)
               do j = lo(2),hi(2)
                  ecx(i,j) = ecx(i,j) / r
               enddo
            end if
         enddo

         ! On y-edges
         do i = lo(1), hi(1)
            r = (dble(i)+0.5d0) * dx(1)
            do j = lo(2),hi(2)+1
               ecy(i,j) = ecy(i,j) / r
            enddo
         enddo

      else
         print *,'Bogus coord_type in unweight_edges ' ,coord_type
         call bl_error("Error:: MGutils_2d.f90 :: unweight_edges")
      end if

      end subroutine unweight_edges


program Det

DOUBLE PRECISION a11,a12,a13,a21,a22,a23,a31,a32,a33,det1,det2

integer menu,submenu

10 continue

write(*,*) ''

write(*,*) '1-Calcular'
write(*,*) '2-Sair'

read(*,*,iostat=ierr)menu

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 10

end if

select case (menu)

case(1)

20 continue

write(*,*) ''

write(*,*) '2-Ordem 2'
write(*,*) '3-Ordem 3'

read(*,*,iostat=ierr)submenu

if(ierr/=0) then

write(*,*) 'Erro,tente novamente'

go to 20

end if

select case(submenu)

case(2)

30 continue

write(*,*) ''

write(*,*) 'Digite o valor de a11'

read(*,*,iostat=ierr)a11

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 30

end if

write(*,*) 'Digite o valor de a12'

read(*,*,iostat=ierr)a12

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 30

end if

write(*,*) 'Digite o valor de a21'

read(*,*,iostat=ierr)a21

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 30

end if

write(*,*) 'Digite o valor de a22'

read(*,*,iostat=ierr)a22

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 30

end if

write(*,*) ''

write(*,*) 'O determinante e'
det1=(a11*a22)-(a12*a21)
write(*,*)det1

go to 10

case(3)

40 continue

write(*,*) ''

write(*,*) 'Digite o valor de a11'

read(*,*,iostat=ierr)a11

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) 'Digite o valor de a12'

read(*,*,iostat=ierr)a12

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) 'Digite o valor de a13'

read(*,*,iostat=ierr)a13

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) 'Digite o valor de a21'

read(*,*,iostat=ierr)a21

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) 'Digite o valor de a22'

read(*,*,iostat=ierr)a22

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) 'Digite o valor de a23'

read(*,*,iostat=ierr)a23

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) 'Digite o valor de a31'

read(*,*,iostat=ierr)a31

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) 'Digite o valor de a32'

read(*,*,iostat=ierr)a32

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) 'Digite o valor de a33'

read(*,*,iostat=ierr)a33

if(ierr/=0) then

write(*,*) 'Erro, tente novamente'

go to 40

end if

write(*,*) ''

write(*,*) 'O determinante e'
det2=((a11*a22*a33)+(a21*a32*a13)+(a31*a12*a23))-((a13*a22*a31)+(a23*a32*a11)+(a33*a12*a21))
write(*,*)det2

go to 10

case default

write(*,*) 'Erro, tente novamente'

go to 20

end select

case(2)

write(*,*) 'Tchau'

pause

stop

case default

write(*,*) 'Erro, tente novamente'

go to 10

end select

stop

end


module globals

  integer, parameter :: n=10, dim=3
  real(8), parameter :: pi=3.14159265359, e0=8.854187817d-12, dt=1.0d-4, &
       q=1.6d-19, m=9.11d-31, delta=1.0d-8

end module globals

program nbody

  use globals

  implicit none

  real(8), dimension(dim, n) :: a, v, s
  real(8), dimension(dim) :: r
  integer :: i, j
  real(8) :: t, d, e, twrite

  a = 0.0d0
  v = 0.0d0
  twrite = 0.0d0
  t = 0.0d0

  call random_number(s)

  open(unit=1, file="nbody.dat", action="write")

  do while ( t < 100.0d0)

     e = 0.0d0

     do j = 1, n
        a(:, j) = 0.0d0
        e = e + 0.5d0*m*sum(v(:, j)**2)

        do i = 1, n
           r = s(:, i) - s(:, j)
           d = max(sqrt(sum(r**2)), delta)
           a(:, j) = a(:, j)  - 0.25d0*q*q*r/m/e0/pi/d**3
           e = e + 0.25d0*q*q/e0/pi/d/2.0d0
        end do
     end do

     do j = 1, n
        s(:, j) = s(:, j) + v(:, j)*dt + 0.5d0*a(:, j)*dt**2
        v(:, j) = v(:, j) + a(:, j)*dt

        where(s(:, j) < 0.0d0)
           s(:,j) = -s(:,j)
           v(:,j) = -v(:,j)
        end where

        where(s(:, j) > 1.0d0)
           s(:,j) = 2.0d0-s(:,j)
           v(:,j) = -v(:,j)
        end where
     end do

     t = t + dt

     if (t > twrite) then
        do j = 1,n
           write(1, '(3es)') s(:,j)
        end do
        twrite = t+0.001d0
     end if
  end do

  close(1)

end program nbody


program problem9
  implicit none
  integer*8 :: a,b,c,abc

  do a=1,1000
     do b=a+1,1000
        c=1000-a-b
        if (c .lt. 1) then
           go to 1
        end if
        if (a*a + b*b == c*c) then
           abc=a*b*c
           goto 2
        end if
     end do
1    continue
  end do
2 continue

  print *, abc

end program problem9


SUBROUTINE clawpack5_b4step2(mbc,mx,my,meqn,q, &
  xlower,ylower,dx,dy,time,dt,maux,aux)
  IMPLICIT NONE

  INTEGER :: mbc,mx,my,maux,meqn
  DOUBLE PRECISION :: xlower,ylower,dx,dy,time,dt

  DOUBLE PRECISION :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
  DOUBLE PRECISION :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

  DOUBLE PRECISION :: pi, pi2
  COMMON /compi/ pi, pi2

  DOUBLE PRECISION :: tperiod
  COMMON /comvt/ tperiod

  INTEGER :: i,j
  DOUBLE PRECISION :: xll,yll, psi, vt, vtx,vty,pij

  IF (tperiod .EQ. 0.d0) THEN
     !! # special case --- indication that velocities specified in
     !! # setaux should be used for all time.
     RETURN
  ENDIF

  vt = dcos(pi2*(time+dt/2.d0)/tperiod)
  vtx = vt/dx
  vty = vt/dy

  DO  j=1-mbc,my+mbc
    DO i=1-mbc,mx+mbc
        !! # coordinates of lower left corner of grid cell:
        xll = xlower + (i-1)*dx
        yll = ylower + (j-1)*dy

        !! # difference stream function psi to get normal velocities:
        pij = psi(xll,yll)
        aux(1,i,j) =  vty*(psi(xll, yll+dy) - pij)
        aux(2,i,j) = -vtx*(psi(xll+dx, yll) - pij)

     ENDDO
  ENDDO
  RETURN
END SUBROUTINE clawpack5_b4step2


      SUBROUTINE slRFCO ( HM, TDK, PMB, RH, WL, PHI, TLR, EPS,
     :                       REFA, REFB )
*+
*     - - - - - -
*      R F C O
*     - - - - - -
*
*  Determine the constants A and B in the atmospheric refraction
*  model dZ = A tan Z + B tan**3 Z.
*
*  Z is the "observed" zenith distance (i.e. affected by refraction)
*  and dZ is what to add to Z to give the "topocentric" (i.e. in vacuo)
*  zenith distance.
*
*  Given:
*    HM      d     height of the observer above sea level (metre)
*    TDK     d     ambient temperature at the observer (K)
*    PMB     d     pressure at the observer (millibar)
*    RH      d     relative humidity at the observer (range 0-1)
*    WL      d     effective wavelength of the source (micrometre)
*    PHI     d     latitude of the observer (radian, astronomical)
*    TLR     d     temperature lapse rate in the troposphere (K/metre)
*    EPS     d     precision required to terminate iteration (radian)
*
*  Returned:
*    REFA    d     tan Z coefficient (radian)
*    REFB    d     tan**3 Z coefficient (radian)
*
*  Called:  slRFRO
*
*  Notes:
*
*  1  Typical values for the TLR and EPS arguments might be 0.0065D0 and
*     1D-10 respectively.
*
*  2  The radio refraction is chosen by specifying WL > 100 micrometres.
*
*  3  The routine is a slower but more accurate alternative to the
*     slRFCQ routine.  The constants it produces give perfect
*     agreement with slRFRO at zenith distances arctan(1) (45 deg)
*     and arctan(4) (about 76 deg).  It achieves 0.5 arcsec accuracy
*     for ZD < 80 deg, 0.01 arcsec accuracy for ZD < 60 deg, and
*     0.001 arcsec accuracy for ZD < 45 deg.
*
*  P.T.Wallace   Starlink   22 May 2004
*
*  Copyright (C) 2004 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION HM,TDK,PMB,RH,WL,PHI,TLR,EPS,REFA,REFB

      DOUBLE PRECISION ATN1,ATN4,R1,R2

*  Sample zenith distances: arctan(1) and arctan(4)
      PARAMETER (ATN1=0.7853981633974483D0,
     :           ATN4=1.325817663668033D0)

*  Determine refraction for the two sample zenith distances
      CALL slRFRO(ATN1,HM,TDK,PMB,RH,WL,PHI,TLR,EPS,R1)
      CALL slRFRO(ATN4,HM,TDK,PMB,RH,WL,PHI,TLR,EPS,R2)

*  Solve for refraction constants
      REFA = (64D0*R1-R2)/60D0
      REFB = (R2-4D0*R1)/60D0

      END