      SUBROUTINE CALJY0(ARG,RESULT,JINT)
C---------------------------------------------------------------------
C
C This packet computes zero-order Bessel functions of the first and
C   second kind (J0 and Y0), for real arguments X, where 0 < X <= XMAX
C   for Y0, and |X| <= XMAX for J0.  It contains two function-type
C   subprograms,  BESJ0  and  BESY0,  and one subroutine-type
C   subprogram,  CALJY0.  The calling statements for the primary
C   entries are:
C
C           Y = BESJ0(X)
C   and
C           Y = BESY0(X),
C
C   where the entry points correspond to the functions J0(X) and Y0(X),
C   respectively.  The routine  CALJY0  is intended for internal packet
C   use only, all computations within the packet being concentrated in
C   this one routine.  The function subprograms invoke  CALJY0  with
C   the statement
C           CALL CALJY0(ARG,RESULT,JINT),
C   where the parameter usage is as follows:
C
C      Function                  Parameters for CALJY0
C       call              ARG             RESULT          JINT
C
C     BESJ0(ARG)     |ARG| .LE. XMAX       J0(ARG)          0
C     BESY0(ARG)   0 .LT. ARG .LE. XMAX    Y0(ARG)          1
C
C   The main computation uses unpublished minimax rational
C   approximations for X .LE. 8.0, and an approximation from the
C   book  Computer Approximations  by Hart, et. al., Wiley and Sons,
C   New York, 1968, for arguments larger than 8.0   Part of this
C   transportable packet is patterned after the machine-dependent
C   FUNPACK program BESJ0(X), but cannot match that version for
C   efficiency or accuracy.  This version uses rational functions
C   that are theoretically accurate to at least 18 significant decimal
C   digits for X <= 8, and at least 18 decimal places for X > 8.  The
C   accuracy achieved depends on the arithmetic system, the compiler,
C   the intrinsic functions, and proper selection of the machine-
C   dependent constants.
C
C*******************************************************************
C
C The following machine-dependent constants must be declared in
C   DATA statements.  IEEE values are provided as a default.
C
C   XINF   = largest positive machine number
C   XMAX   = largest acceptable argument.  The functions AINT, SIN
C            and COS must perform properly for  ABS(X) .LE. XMAX.
C            We recommend that XMAX be a small integer multiple of
C            sqrt(1/eps), where eps is the smallest positive number
C            such that  1+eps > 1.
C   XSMALL = positive argument such that  1.0-(X/2)**2 = 1.0
C            to machine precision for all  ABS(X) .LE. XSMALL.
C            We recommend that  XSMALL < sqrt(eps)/beta, where beta
C            is the floating-point radix (usually 2 or 16).
C
C     Approximate values for some important machines are
C
C                          eps      XMAX     XSMALL      XINF
C
C  CDC 7600      (S.P.)  7.11E-15  1.34E+08  2.98E-08  1.26E+322
C  CRAY-1        (S.P.)  7.11E-15  1.34E+08  2.98E-08  5.45E+2465
C  IBM PC (8087) (S.P.)  5.96E-08  8.19E+03  1.22E-04  3.40E+38
C  IBM PC (8087) (D.P.)  1.11D-16  2.68D+08  3.72D-09  1.79D+308
C  IBM 195       (D.P.)  2.22D-16  6.87D+09  9.09D-13  7.23D+75
C  UNIVAC 1108   (D.P.)  1.73D-18  4.30D+09  2.33D-10  8.98D+307
C  VAX 11/780    (D.P.)  1.39D-17  1.07D+09  9.31D-10  1.70D+38
C
C*******************************************************************
C*******************************************************************
C
C Error Returns
C
C  The program returns the value zero for  X .GT. XMAX, and returns
C    -XINF when BESLY0 is called with a negative or zero argument.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, COS, LOG, SIN, SQRT
C
C
C  Latest modification: March 13, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C--------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
      DOUBLE PRECISION
     1       ARG,AX,CONS,DOWN,EIGHT,FIVE5,FOUR,ONE,ONEOV8,PI2,PJ0,
     2       PJ1,PLG,PROD,PY0,PY1,PY2,P0,P1,P17,QJ0,QJ1,QLG,QY0,QY1,
     3       QY2,Q0,Q1,RESJ,RESULT,R0,R1,SIXTY4,THREE,TWOPI,TWOPI1,
     4       TWOPI2,TWO56,UP,W,WSQ,XDEN,XINF,XMAX,XNUM,XSMALL,XJ0,
     5       XJ1,XJ01,XJ02,XJ11,XJ12,XY,XY0,XY01,XY02,XY1,XY11,XY12,
     6       XY2,XY21,XY22,Z,ZERO,ZSQ
      DIMENSION PJ0(7),PJ1(8),PLG(4),PY0(6),PY1(7),PY2(8),P0(6),P1(6),
     1          QJ0(5),QJ1(7),QLG(4),QY0(5),QY1(6),QY2(7),Q0(5),Q1(5)
C-------------------------------------------------------------------
C  Mathematical constants
C    CONS = ln(.5) + Euler's gamma
C-------------------------------------------------------------------
CS    DATA ZERO,ONE,THREE,FOUR,EIGHT/0.0E0,1.0E0,3.0E0,4.0E0,8.0E0/,
CS   1     FIVE5,SIXTY4,ONEOV8,P17/5.5E0,64.0E0,0.125E0,1.716E-1/,
CS   2     TWO56,CONS/256.0E0,-1.1593151565841244881E-1/,
CS   3     PI2,TWOPI/6.3661977236758134308E-1,6.2831853071795864769E0/,
CS   4     TWOPI1,TWOPI2/6.28125E0,1.9353071795864769253E-3/
      DATA ZERO,ONE,THREE,FOUR,EIGHT/0.0D0,1.0D0,3.0D0,4.0D0,8.0D0/,
     1     FIVE5,SIXTY4,ONEOV8,P17/5.5D0,64.0D0,0.125D0,1.716D-1/,
     2     TWO56,CONS/256.0D0,-1.1593151565841244881D-1/,
     3     PI2,TWOPI/6.3661977236758134308D-1,6.2831853071795864769D0/,
     4     TWOPI1,TWOPI2/6.28125D0,1.9353071795864769253D-3/
C-------------------------------------------------------------------
C  Machine-dependent constants
C-------------------------------------------------------------------
CS    DATA XMAX/8.19E+03/,XSMALL/1.22E-04/,XINF/3.40E+38/
      DATA XMAX/2.68D+08/,XSMALL/3.72D-09/,XINF/1.79D+308/
C-------------------------------------------------------------------
C  Zeroes of Bessel functions
C-------------------------------------------------------------------
CS    DATA XJ0/2.4048255576957727686E+0/,XJ1/5.5200781102863106496E+0/,
CS   1     XY0/8.9357696627916752158E-1/,XY1/3.9576784193148578684E+0/,
CS   2     XY2/7.0860510603017726976E+0/,
CS   3     XJ01/ 616.0E+0/, XJ02/-1.4244423042272313784E-03/,
CS   4     XJ11/1413.0E+0/, XJ12/ 5.4686028631064959660E-04/,
CS   5     XY01/ 228.0E+0/, XY02/ 2.9519662791675215849E-03/,
CS   6     XY11/1013.0E+0/, XY12/ 6.4716931485786837568E-04/,
CS   7     XY21/1814.0E+0/, XY22/ 1.1356030177269762362E-04/
      DATA XJ0/2.4048255576957727686D+0/,XJ1/5.5200781102863106496D+0/,
     1     XY0/8.9357696627916752158D-1/,XY1/3.9576784193148578684D+0/,
     2     XY2/7.0860510603017726976D+0/,
     3     XJ01/ 616.0D+0/, XJ02/-1.4244423042272313784D-03/,
     4     XJ11/1413.0D+0/, XJ12/ 5.4686028631064959660D-04/,
     5     XY01/ 228.0D+0/, XY02/ 2.9519662791675215849D-03/,
     6     XY11/1013.0D+0/, XY12/ 6.4716931485786837568D-04/,
     7     XY21/1814.0D+0/, XY22/ 1.1356030177269762362D-04/
C-------------------------------------------------------------------
C  Coefficients for rational approximation to ln(x/a)
C--------------------------------------------------------------------
CS    DATA PLG/-2.4562334077563243311E+01,2.3642701335621505212E+02,
CS   1         -5.4989956895857911039E+02,3.5687548468071500413E+02/
CS    DATA QLG/-3.5553900764052419184E+01,1.9400230218539473193E+02,
CS   1         -3.3442903192607538956E+02,1.7843774234035750207E+02/
      DATA PLG/-2.4562334077563243311D+01,2.3642701335621505212D+02,
     1         -5.4989956895857911039D+02,3.5687548468071500413D+02/
      DATA QLG/-3.5553900764052419184D+01,1.9400230218539473193D+02,
     1         -3.3442903192607538956D+02,1.7843774234035750207D+02/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C  J0(X) / (X**2 - XJ0**2),  XSMALL  <  |X|  <=  4.0
C--------------------------------------------------------------------
CS    DATA PJ0/6.6302997904833794242E+06,-6.2140700423540120665E+08,
CS   1         2.7282507878605942706E+10,-4.1298668500990866786E+11,
CS   2        -1.2117036164593528341E-01, 1.0344222815443188943E+02,
CS   3        -3.6629814655107086448E+04/
CS    DATA QJ0/4.5612696224219938200E+05, 1.3985097372263433271E+08,
CS   1         2.6328198300859648632E+10, 2.3883787996332290397E+12,
CS   2         9.3614022392337710626E+02/
      DATA PJ0/6.6302997904833794242D+06,-6.2140700423540120665D+08,
     1         2.7282507878605942706D+10,-4.1298668500990866786D+11,
     2        -1.2117036164593528341D-01, 1.0344222815443188943D+02,
     3        -3.6629814655107086448D+04/
      DATA QJ0/4.5612696224219938200D+05, 1.3985097372263433271D+08,
     1         2.6328198300859648632D+10, 2.3883787996332290397D+12,
     2         9.3614022392337710626D+02/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C  J0(X) / (X**2 - XJ1**2),  4.0  <  |X|  <=  8.0
C-------------------------------------------------------------------
CS    DATA PJ1/4.4176707025325087628E+03, 1.1725046279757103576E+04,
CS   1         1.0341910641583726701E+04,-7.2879702464464618998E+03,
CS   2        -1.2254078161378989535E+04,-1.8319397969392084011E+03,
CS   3         4.8591703355916499363E+01, 7.4321196680624245801E+02/
CS    DATA QJ1/3.3307310774649071172E+02,-2.9458766545509337327E+03,
CS   1         1.8680990008359188352E+04,-8.4055062591169562211E+04,
CS   2         2.4599102262586308984E+05,-3.5783478026152301072E+05,
CS   3        -2.5258076240801555057E+01/
      DATA PJ1/4.4176707025325087628D+03, 1.1725046279757103576D+04,
     1         1.0341910641583726701D+04,-7.2879702464464618998D+03,
     2        -1.2254078161378989535D+04,-1.8319397969392084011D+03,
     3         4.8591703355916499363D+01, 7.4321196680624245801D+02/
      DATA QJ1/3.3307310774649071172D+02,-2.9458766545509337327D+03,
     1         1.8680990008359188352D+04,-8.4055062591169562211D+04,
     2         2.4599102262586308984D+05,-3.5783478026152301072D+05,
     3        -2.5258076240801555057D+01/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y0(X) - 2 LN(X/XY0) J0(X)) / (X**2 - XY0**2),
C        XSMALL  <  |X|  <=  3.0
C--------------------------------------------------------------------
CS    DATA PY0/1.0102532948020907590E+04,-2.1287548474401797963E+06,
CS   1         2.0422274357376619816E+08,-8.3716255451260504098E+09,
CS   2         1.0723538782003176831E+11,-1.8402381979244993524E+01/
CS    DATA QY0/6.6475986689240190091E+02, 2.3889393209447253406E+05,
CS   1         5.5662956624278251596E+07, 8.1617187777290363573E+09,
CS   2         5.8873865738997033405E+11/
      DATA PY0/1.0102532948020907590D+04,-2.1287548474401797963D+06,
     1         2.0422274357376619816D+08,-8.3716255451260504098D+09,
     2         1.0723538782003176831D+11,-1.8402381979244993524D+01/
      DATA QY0/6.6475986689240190091D+02, 2.3889393209447253406D+05,
     1         5.5662956624278251596D+07, 8.1617187777290363573D+09,
     2         5.8873865738997033405D+11/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y0(X) - 2 LN(X/XY1) J0(X)) / (X**2 - XY1**2),
C        3.0  <  |X|  <=  5.5
C--------------------------------------------------------------------
CS    DATA PY1/-1.4566865832663635920E+04, 4.6905288611678631510E+06,
CS   1         -6.9590439394619619534E+08, 4.3600098638603061642E+10,
CS   2         -5.5107435206722644429E+11,-2.2213976967566192242E+13,
CS   3          1.7427031242901594547E+01/
CS    DATA QY1/ 8.3030857612070288823E+02, 4.0669982352539552018E+05,
CS   1          1.3960202770986831075E+08, 3.4015103849971240096E+10,
CS   2          5.4266824419412347550E+12, 4.3386146580707264428E+14/
      DATA PY1/-1.4566865832663635920D+04, 4.6905288611678631510D+06,
     1         -6.9590439394619619534D+08, 4.3600098638603061642D+10,
     2         -5.5107435206722644429D+11,-2.2213976967566192242D+13,
     3          1.7427031242901594547D+01/
      DATA QY1/ 8.3030857612070288823D+02, 4.0669982352539552018D+05,
     1          1.3960202770986831075D+08, 3.4015103849971240096D+10,
     2          5.4266824419412347550D+12, 4.3386146580707264428D+14/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y0(X) - 2 LN(X/XY2) J0(X)) / (X**2 - XY2**2),
C        5.5  <  |X|  <=  8.0
C--------------------------------------------------------------------
CS    DATA PY2/ 2.1363534169313901632E+04,-1.0085539923498211426E+07,
CS   1          2.1958827170518100757E+09,-1.9363051266772083678E+11,
CS   2         -1.2829912364088687306E+11, 6.7016641869173237784E+14,
CS   3         -8.0728726905150210443E+15,-1.7439661319197499338E+01/
CS    DATA QY2/ 8.7903362168128450017E+02, 5.3924739209768057030E+05,
CS   1          2.4727219475672302327E+08, 8.6926121104209825246E+10,
CS   2          2.2598377924042897629E+13, 3.9272425569640309819E+15,
CS   3          3.4563724628846457519E+17/
      DATA PY2/ 2.1363534169313901632D+04,-1.0085539923498211426D+07,
     1          2.1958827170518100757D+09,-1.9363051266772083678D+11,
     2         -1.2829912364088687306D+11, 6.7016641869173237784D+14,
     3         -8.0728726905150210443D+15,-1.7439661319197499338D+01/
      DATA QY2/ 8.7903362168128450017D+02, 5.3924739209768057030D+05,
     1          2.4727219475672302327D+08, 8.6926121104209825246D+10,
     2          2.2598377924042897629D+13, 3.9272425569640309819D+15,
     3          3.4563724628846457519D+17/
C-------------------------------------------------------------------
C  Coefficients for Hart,s approximation,  |X| > 8.0
C-------------------------------------------------------------------
CS    DATA P0/3.4806486443249270347E+03, 2.1170523380864944322E+04,
CS   1        4.1345386639580765797E+04, 2.2779090197304684302E+04,
CS   2        8.8961548424210455236E-01, 1.5376201909008354296E+02/
CS    DATA Q0/3.5028735138235608207E+03, 2.1215350561880115730E+04,
CS   1        4.1370412495510416640E+04, 2.2779090197304684318E+04,
CS   2        1.5711159858080893649E+02/
CS    DATA P1/-2.2300261666214198472E+01,-1.1183429920482737611E+02,
CS   1        -1.8591953644342993800E+02,-8.9226600200800094098E+01,
CS   2        -8.8033303048680751817E-03,-1.2441026745835638459E+00/
CS    DATA Q1/1.4887231232283756582E+03, 7.2642780169211018836E+03,
CS   1        1.1951131543434613647E+04, 5.7105024128512061905E+03,
CS   2        9.0593769594993125859E+01/
      DATA P0/3.4806486443249270347D+03, 2.1170523380864944322D+04,
     1        4.1345386639580765797D+04, 2.2779090197304684302D+04,
     2        8.8961548424210455236D-01, 1.5376201909008354296D+02/
      DATA Q0/3.5028735138235608207D+03, 2.1215350561880115730D+04,
     1        4.1370412495510416640D+04, 2.2779090197304684318D+04,
     2        1.5711159858080893649D+02/
      DATA P1/-2.2300261666214198472D+01,-1.1183429920482737611D+02,
     1        -1.8591953644342993800D+02,-8.9226600200800094098D+01,
     2        -8.8033303048680751817D-03,-1.2441026745835638459D+00/
      DATA Q1/1.4887231232283756582D+03, 7.2642780169211018836D+03,
     1        1.1951131543434613647D+04, 5.7105024128512061905D+03,
     2        9.0593769594993125859D+01/
C-------------------------------------------------------------------
C  Check for error conditions
C-------------------------------------------------------------------
      AX = ABS(ARG)
      IF ((JINT .EQ. 1) .AND. (ARG .LE. ZERO)) THEN
            RESULT = -XINF
            GO TO 2000
         ELSE IF (AX .GT. XMAX) THEN
            RESULT = ZERO
            GO TO 2000
      END IF
      IF (AX .GT. EIGHT) GO TO 800
      IF (AX .LE. XSMALL) THEN
         IF (JINT .EQ. 0) THEN
               RESULT = ONE
            ELSE
               RESULT = PI2 * (LOG(AX) + CONS)
         END IF
         GO TO 2000
      END IF
C-------------------------------------------------------------------
C  Calculate J0 for appropriate interval, preserving
C     accuracy near the zero of J0
C-------------------------------------------------------------------
      ZSQ = AX * AX
      IF (AX .LE. FOUR) THEN
            XNUM = (PJ0(5) * ZSQ + PJ0(6)) * ZSQ + PJ0(7)
            XDEN = ZSQ + QJ0(5)
            DO 50 I = 1, 4
               XNUM = XNUM * ZSQ + PJ0(I)
               XDEN = XDEN * ZSQ + QJ0(I)
   50       CONTINUE
            PROD = ((AX - XJ01/TWO56) - XJ02) * (AX + XJ0)
         ELSE
            WSQ = ONE - ZSQ / SIXTY4
            XNUM = PJ1(7) * WSQ + PJ1(8)
            XDEN = WSQ + QJ1(7)
            DO 220 I = 1, 6
               XNUM = XNUM * WSQ + PJ1(I)
               XDEN = XDEN * WSQ + QJ1(I)
  220       CONTINUE
            PROD = (AX + XJ1) * ((AX - XJ11/TWO56) - XJ12)
      END IF
      RESULT = PROD * XNUM / XDEN
      IF (JINT .EQ. 0) GO TO 2000
C-------------------------------------------------------------------
C  Calculate Y0.  First find  RESJ = pi/2 ln(x/xn) J0(x),
C    where xn is a zero of Y0
C-------------------------------------------------------------------
      IF (AX .LE. THREE) THEN
            UP = (AX-XY01/TWO56)-XY02
            XY = XY0
         ELSE IF (AX .LE. FIVE5) THEN
            UP = (AX-XY11/TWO56)-XY12
            XY = XY1
         ELSE
            UP = (AX-XY21/TWO56)-XY22
            XY = XY2
      END IF
      DOWN = AX + XY
      IF (ABS(UP) .LT. P17*DOWN) THEN
            W = UP/DOWN
            WSQ = W*W
            XNUM = PLG(1)
            XDEN = WSQ + QLG(1)
            DO 320 I = 2, 4
               XNUM = XNUM*WSQ + PLG(I)
               XDEN = XDEN*WSQ + QLG(I)
  320       CONTINUE
            RESJ = PI2 * RESULT * W * XNUM/XDEN
         ELSE
            RESJ = PI2 * RESULT * LOG(AX/XY)
      END IF
C-------------------------------------------------------------------
C  Now calculate Y0 for appropriate interval, preserving
C     accuracy near the zero of Y0
C-------------------------------------------------------------------
      IF (AX .LE. THREE) THEN
            XNUM = PY0(6) * ZSQ + PY0(1)
            XDEN = ZSQ + QY0(1)
            DO 340 I = 2, 5
               XNUM = XNUM * ZSQ + PY0(I)
               XDEN = XDEN * ZSQ + QY0(I)
  340       CONTINUE
         ELSE IF (AX .LE. FIVE5) THEN
            XNUM = PY1(7) * ZSQ + PY1(1)
            XDEN = ZSQ + QY1(1)
            DO 360 I = 2, 6
               XNUM = XNUM * ZSQ + PY1(I)
               XDEN = XDEN * ZSQ + QY1(I)
  360       CONTINUE
         ELSE
            XNUM = PY2(8) * ZSQ + PY2(1)
            XDEN = ZSQ + QY2(1)
            DO 380 I = 2, 7
               XNUM = XNUM * ZSQ + PY2(I)
               XDEN = XDEN * ZSQ + QY2(I)
  380       CONTINUE
      END IF
      RESULT = RESJ + UP * DOWN * XNUM / XDEN
      GO TO 2000
C-------------------------------------------------------------------
C  Calculate J0 or Y0 for |ARG|  >  8.0
C-------------------------------------------------------------------
  800 Z = EIGHT / AX
      W = AX / TWOPI
      W = AINT(W) + ONEOV8
      W = (AX - W * TWOPI1) - W * TWOPI2
      ZSQ = Z * Z
      XNUM = P0(5) * ZSQ + P0(6)
      XDEN = ZSQ + Q0(5)
      UP = P1(5) * ZSQ + P1(6)
      DOWN = ZSQ + Q1(5)
      DO 850 I = 1, 4
         XNUM = XNUM * ZSQ + P0(I)
         XDEN = XDEN * ZSQ + Q0(I)
         UP = UP * ZSQ + P1(I)
         DOWN = DOWN * ZSQ + Q1(I)
  850 CONTINUE
      R0 = XNUM / XDEN
      R1 = UP / DOWN
      IF (JINT .EQ. 0) THEN
            RESULT = SQRT(PI2/AX) * (R0*COS(W) - Z*R1*SIN(W))
         ELSE
            RESULT = SQRT(PI2/AX) * (R0*SIN(W) + Z*R1*COS(W))
      END IF
 2000 RETURN
C---------- Last line of CALJY0 ----------
      END


program multtable
implicit none

  integer :: i, j, k

    write(*, "(a)") " x|   1   2   3   4   5   6   7   8   9  10  11  12"
    write(*, "(a)") "--+------------------------------------------------"
    do i = 1, 12
      write(*, "(i2, a)", advance="no") i, "|"
	do k = 2, i
    	  write(*, "(a4)", advance="no") ""
        end do
    	do j = i, 12
          write(*, "(i4)", advance="no") i*j
        end do
        write(*, *)
    end do

end program multtable


program ex4p1
    use mt_mod
    implicit none
    integer, parameter:: ik=selected_int_kind(11), rk=selected_real_kind(11,100)
    integer(kind=ik) :: i, j, h, l, Np, runs=500
    real(kind=rk), parameter :: pi = 4.0*atan(1.0), k=8.6173324E-5, T=600
    real(kind=rk) :: x, x0, x1, trial, state, u, u1, a=1/real(2,rk)*k*T, mean, E_theor=3/2*k*T, sumrun=0, x_max, b
    real(kind=rk), allocatable :: E_MC(:), means(:), rms(:)

    b=sqrt(2/pi)*1/(a**3)

    call init_genrand64(int(123465, ik))

    open(1, action="write", file="data_max.txt", status="replace", position="append")
    open(2, action="write", file="data_points.txt", status="replace", position="append")

    allocate(means(runs))
    allocate(rms(1000))

    !Data for (E_max, RMS) plot with N=10^3
    Np = 10**3
    allocate(E_MC(Np))
    !Vary E_max from 0.001 to 0.1
    do l=1, 100
        !Markov Chain
        x_max=0.001*l       !0b
        do h=1, runs
            !Inital config.
            x = 3/real(2,rk)*k*T    !0a
            do i=1, Np
                state = rho(x)      !0c
                x0 = x              !1
                u = genrand64_real1()*2-1   !2
                x1 = x + u*x_max    !3
                trial = rho(x1)     !4

                if (trial/state >= 1) then
                    x = x1
                    state = trial   !5
                else if (trial/state >= genrand64_real1()) then
                    x = x1
                    state = trial   !5
                else
                    x = x0
                end if
                E_MC(i) = abs(x)    !6
            end do

            means(h)=sum(E_MC)/real(Np, rk) !Mean energy of distribution
        end do

        !Sum inside RMS
        do i=1, runs
            sumrun=sumrun+(means(i)-E_theor)**2
        end do

        !RMS for x_max=0.001*l
        rms(l)=sqrt(1/real(runs,rk)*sumrun)
        sumrun=0

        print *, l*0.001,"done."
    end do

    !Save data
    do l=1, 1000
        write(1, *) rms(h), 0.001*l
    end do
    deallocate(E_MC)
    deallocate(rms)

    print*, "E_max done"

    allocate(rms(6))

    !Set x_max according to previous results
    x_max=0.05

    !Markov Chain as before, but now with looping over N_points
    do j=2, 7
        Np = 10**j
        allocate(E_MC(Np))
        do h=1, runs
            x = 3/real(2,rk)*k*T
            do i=1, Np
                x0 = x
                E_MC(i) = abs(x)
                state = rho(x)
                u = genrand64_real1()*2-1
                x1 = x + u*x_max
                trial = rho(x1)
                if (trial/state >= 1) then
                    x = x1
                    state = trial
                else if (trial/state >= genrand64_real1()) then
                    x = x1
                    state = trial
                else
                    x = x0
                end if
            end do
            means(h)=sum(E_MC)/real(Np, rk)
        end do
        do i=1, runs
            sumrun=sumrun+(means(i)-E_theor)**2
        end do
        rms(j-1)=sqrt(1/real(runs,rk)*sumrun)
        sumrun=0
        write(2, *) rms(j-1), 10**j
        deallocate(E_MC)
        print*, j, "-power done"
    end do

    close(1)
    close(2)

contains

real(kind=rk) function rho(E)
    implicit none
    real(kind=rk), intent(in) :: E
    rho=b*E**2*exp(-1/real(2,rk)*(E/a)**2)
end function rho
end program ex4p1


!
! ===================================
! NIST Guide to Available Math Software.
! Fullsource for module TVAL from package NAPACK.
! Retrieved from NETLIB on Fri Aug 7 17:41:59 1998.
! ===================================
!
      SUBROUTINE TVAL(E, K, L, D, U, N, W)

!      ________________________________________________________
!     |                                                        |
!     |   FIND THE K-TH SMALLEST EIGENVALUE OF A TRIDIAGONAL   |
!     |  MATRIX WHOSE CROSS-DIAGONAL PRODUCTS ARE NONNEGATIVE  |
!     |USING BOTH THE BISECTION METHOD AND A NEWTON-LIKE METHOD|
!     |                                                        |
!     |    INPUT:                                              |
!     |                                                        |
!     |         K     --INDEX OF DESIRED EIGENVALUE (REPLACE K |
!     |                 BY -K TO GET K-TH LARGEST EIGENVALUE)  |
!     |                                                        |
!     |         L     --SUBDIAGONAL (CAN BE IDENTIFIED WITH U) |
!     |                                                        |
!     |         D     --DIAGONAL                               |
!     |                                                        |
!     |         U     --SUPERDIAGONAL                          |
!     |                                                        |
!     |         N     --MATRIX DIMENSION                       |
!     |                                                        |
!     |         W     --WORK ARRAY (LENGTH AT LEAST N)         |
!     |                                                        |
!     |    OUTPUT:                                             |
!     |                                                        |
!     |         E     --EIGENVALUE                             |
!     |                                                        |
!     |    BUILTIN FUNCTIONS: ABS,MAX                        |
!     |    PACKAGE SUBROUTINES: CP,EQL,INP,STM                 |
!     |________________________________________________________|
!
      use kind_spec
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer, intent(in) :: K, N
      REAL(rprec):: E
      REAL(rprec), DIMENSION(N) :: L, D, U, W
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      real(rprec), parameter :: zero = 0, one = 1
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: I, M
      REAL(rprec) :: S, T, Y, Z
!-----------------------------------------------
      IF (N > 1) THEN
!     -------------------------------------------------------
!     |*** BOUND EIGENVALUES USING GERSCHGORIN'S THEOREM ***|
!     -------------------------------------------------------
         M = N - 1
         Y = D(1)
         Z = D(1)
         S = 0
         DO I = 1, M
            W(I) = L(I)*U(I)
            IF (W(I) < ZERO) GO TO 50
            S = S + ABS(U(I))
            T = D(I) + S
            Z = MAX(T,Z)
            T = D(I) - S
            Y = MIN(T,Y)
            S = ABS(L(I))
         END DO
         T = D(N) + S
         Z = MAX(T,Z)
         T = D(N) - S
         Y = MIN(T,Y)
         M = K
         IF (K .LE. 0) M = N + K + 1
         T = ONE
         T = T/2
         S = ONE + T
 1003    CONTINUE
         IF (S .LE. ONE) GO TO 1002
         T = T/2
         S = ONE + T
         IF (S .LE. ONE) GO TO 1002
         T = T/2
         S = ONE + T
         IF (S .LE. ONE) GO TO 1002
         T = T/2
         S = ONE + T
         IF (S .LE. ONE) GO TO 1002
         T = T/2
         S = ONE + T
         GO TO 1003
 1002    CONTINUE
         T = 8*N*T*MAX(ABS(Y),ABS(Z))
         IF (T .NE. ZERO) THEN
            CALL STM (E, Y, Z, M, T, D, W, N)
            RETURN
         ENDIF
      ENDIF
      E = D(1)
      RETURN

   50 CONTINUE
      WRITE (6, *) 'ERROR: SUBROUTINE TVAL CAN ONLY BE APPLIED'
      WRITE (6, *) 'WHEN THE CROSS-DIAGONAL PRODUCTS ARE NONNEGATIVE'
      STOP

      END SUBROUTINE TVAL

      SUBROUTINE STM(E, Y, Z, K, T, D, P, N)
!      ________________________________________________________
!     |                                                        |
!     |   FIND THE K-TH SMALLEST EIGENVALUE OF A TRIDIAGONAL   |
!     |  MATRIX WHOSE CROSS-DIAGONAL PRODUCTS ARE NONNEGATIVE  |
!     |USING BOTH THE BISECTION METHOD AND A NEWTON-LIKE METHOD|
!     |                                                        |
!     |    INPUT:                                              |
!     |                                                        |
!     |         Y,Z   --ENDS OF AN INTERVAL THAT CONTAINS THE  |
!     |                 DESIRED EIGENVALUE                     |
!     |                                                        |
!     |         K     --INDEX OF DESIRED EIGENVALUE            |
!     |                                                        |
!     |         T     --TOLERANCE (ITERATIONS CONTINUE UNTIL   |
!     |                 THE ERROR IN THE EIGENVALUE .LE. T)    |
!     |                                                        |
!     |         D     --DIAGONAL OF THE COEFFICIENT MATRIX A   |
!     |                                                        |
!     |         P     --CROSS-DIAGONAL PRODUCTS A SUB I+1,I    |
!     |                 TIMES A SUB I,I+1                      |
!     |                                                        |
!     |         N     --MATRIX DIMENSION                       |
!     |                                                        |
!     |    OUTPUT:                                             |
!     |                                                        |
!     |         E     --EIGENVALUE                             |
!     |                                                        |
!     |    BUILTIN FUNCTIONS: ABS,MAX,SIGN,SQRT              |
!     |    PACKAGE SUBROUTINES: CP,EQL,INP                     |
!     |________________________________________________________|
!
      use kind_spec
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer:: K, N
      REAL(rprec):: E, Y, Z, T
      REAL(rprec), DIMENSION(N) :: D, P
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      real(rprec), parameter :: one = 1, zero = 0
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: I, J, M
      REAL(rprec) :: A,B,FL,FR,L,Q,R,S,U,V,
     1   W,D2,D3,D4,P2,P3,P4,D34,D42,D23
      REAL(rprec), DIMENSION(4) :: F, H, X
      REAL(rprec), DIMENSION(4) :: G
      REAL(rprec) :: C, GL, GR
!-----------------------------------------------
      L = Y
      R = Z
      IF ( L .LT. R ) GOTO 10
      L = Z
      R = Y
10    IF ( N .EQ. 1 ) GOTO 210
      S = T + T
      U = ONE
20    U = U/2
      A = ONE + U
      IF (A .GT. ONE) GOTO 20
      U = 5*U
      V = U/2
      CALL CP(L,FL,GL,I,D,P,N)
      CALL CP(R,FR,GR,J,D,P,N)
      IF ( I .GE. K ) GOTO 190
      IF ( J .LT. K ) GOTO 200
C     --------------------------------
C     |*** ISOLATE THE EIGENVALUE ***|
C     --------------------------------
30    E = R - L
      IF ( E .LE. S ) GOTO 180
      IF ( E .LE. U*(ABS(L)+ABS(R)) ) GOTO 180
      IF ( J .EQ. I+1 ) GOTO 70
40    A = .5*(L+R)
      CALL CP(A,B,C,M,D,P,N)
      IF ( K .LE. M ) GOTO 50
      L = A
      I = M
      FL = B
      GL = C
      GOTO 30
50    R = A
      J = M
      FR = B
      GR = C
      GOTO 30
60    E = R - L
      IF ( E .LE. S ) GOTO 180
      IF ( E .LE. U*(ABS(L)+ABS(R)) ) GOTO 180
70    X(1) = L
      F(1) = FL
      G(1) = GL
      X(2) = R
      F(2) = FR
      G(2) = GR
      CALL EQL(X,F,G,H,2)
      IF ( H(1) .EQ. H(2) ) GOTO 160
C     ---------------------
C     |*** SECANT STEP ***|
C     ---------------------
      A = X(1) - H(1)*(X(1)-X(2))/(H(1)-H(2))
      Q = A
      W = max(T,V*(ABS(L)+ABS(R)))
      IF ( ABS(A-L) .LT. W ) A = L + W
      IF ( ABS(A-R) .LT. W ) A = R - W
      CALL CP(A,B,C,J,D,P,N)
      IF ( I .GE. J ) GOTO 80
      R = A
      FR = B
      GR = C
      GOTO 90
80    L = A
      FL = B
      GL = C
90    X(3) = A
      F(3) = B
      G(3) = C
      W = R - L
      IF ( W .LE. S ) GOTO 220
      IF ( W .LE. U*(ABS(L)+ABS(R)) ) GOTO 220
      CALL EQL(X,F,G,H,3)
C     --------------------------------------
C     |*** QUADRATIC INTERPOLATION STEP ***|
C     --------------------------------------
      CALL INP(A,X(1),X(2),X(3),H(1),H(2),H(3),L,R)
      B = L
      IF ( ABS(A-L) .GT. ABS(A-R) ) B = R
C     ------------------------------------
C     |*** APPLY PSEUDO-NEWTON METHOD ***|
C     ------------------------------------
100   Q = A
      W = max(T,V*(ABS(L)+ABS(R)))
      IF ( ABS(A-L) .LT. W ) GOTO 110
      IF ( ABS(A-R) .GT. W ) GOTO 130
110   IF ( A+A .GT. L+R ) GOTO 120
      A = L + W
      GOTO 130
120   A = R - W
130   IF ( A .LE. L ) GOTO 160
      IF ( A .GE. R ) GOTO 160
      E = .5*E
      IF ( E .LT. ABS(B-A) ) GOTO 160
      CALL CP(A,B,C,J,D,P,N)
      IF ( I .GE. J ) GOTO 140
      R = A
      FR = B
      GR = C
      GOTO 150
140   L = A
      FL = B
      GL = C
150   W = R - L
      IF ( W .LE. S ) GOTO 220
      IF ( W .LE. U*(ABS(L)+ABS(R)) ) GOTO 220
      X(4) = A
      F(4) = B
      G(4) = C
      CALL EQL(X,F,G,H,4)
      IF ( X(1) .LT. L ) GOTO 160
      IF ( X(1) .GT. R ) GOTO 160
      B = X(1)
      D4 = X(4) - B
      D3 = X(3) - B
      D2 = X(2) - B
      D34 = X(3) - X(4)
      D42 = X(4) - X(2)
      D23 = X(2) - X(3)
      P2 = D2*(ONE+((D2/D3)*D42+(D2/D4)*D23)/D34)
      P3 = D3*(ONE+((D3/D2)*D34+(D3/D4)*D23)/D42)
      P4 = D4*(ONE+((D4/D2)*D34+(D4/D3)*D42)/D23)
      IF (P2 .NE. ZERO) P2 = (H(2)-H(1))/P2
      IF (P3 .NE. ZERO) P3 = (H(3)-H(1))/P3
      IF (P4 .NE. ZERO) P4 = (H(4)-H(1))/P4
      P2 = P2 + P3 + P4
      IF (P2 .EQ. ZERO) GOTO 160
      A = B - H(1)/P2
      GOTO 100
C     --------------------------
C     |*** BISECTION METHOD ***|
C     --------------------------
160   A = (L+R)/2
      CALL CP(A,B,C,J,D,P,N)
      IF ( I .GE. J ) GOTO 170
      R = A
      FR = B
      GR = C
      GOTO 60
170   L = A
      FL = B
      GL = C
      GOTO 60
180   E = (L+R)/2
      RETURN
190   E = L
      RETURN
200   E = R
      RETURN
210   E = D(1)
      IF ( L .GT. E ) E = L
      IF ( R .LT. E ) E = R
      RETURN
220   E = Q
      RETURN
      END SUBROUTINE STM

      SUBROUTINE INP(A, X, Y, Z, U, V, W, L, R)
      use kind_spec
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(rprec) :: A, X, Y, Z, U, V, W, L, R
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      real(rprec), parameter :: zero = 0, one = 1
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(rprec) :: B, C, P, Q, S, T
!-----------------------------------------------
      S = Z - X
      T = (Y - X)/S
      A = (U - V)/T + (W - V)/(1. - T)
      IF (A .NE. ZERO) THEN
         B = .5_dp*(W - U)/A - .5_dp
         C = U/A
         T = SQRT(ABS(C))
         IF (ABS(B) < SIGN(T,C)) GO TO 60
         T = MAX(T,ABS(B))
         IF (T .EQ. ZERO) GO TO 50
         Q = ONE/T
         P = SQRT((Q*B)**2 - Q*C*Q)
         P = T*P
         IF (ABS(P + B) .LE. ABS(P - B)) THEN
            Q = P - B
         ELSE
            Q = -(B + P)
         ENDIF
         P = C/Q
         Q = X + S*Q
         P = X + S*P
         IF (Q .GE. L) THEN
            IF (Q .LE. R) THEN
               A = Q
               RETURN
            ENDIF
         ENDIF
         A = P
         RETURN
      ENDIF
      IF (U .NE. W) THEN
         A = X + S*U/(U - W)
         RETURN
      ENDIF
   50 CONTINUE
      A = L
      RETURN
   60 CONTINUE
      A = X - S*B
      RETURN

      END SUBROUTINE INP

      SUBROUTINE CP(T, B, V, L, D, P, N)
!------------------------------------------------
!*** EVALUATE CHARACTERISTIC POLYNOMIAL AND ***
!              SIGN ALTERNATIONS
!------------------------------------------------
      use kind_spec
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer :: L, N
      REAL(rprec) ::  T, B
      REAL(rprec) :: V
      REAL(rprec), DIMENSION(N) :: D, P
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      real(rprec), parameter :: zero = 0, one = 1
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: I, J, M
      REAL(rprec) :: A, C, E, F, U, Z
!-----------------------------------------------
      L = 0
      Z = 0
      V = Z
      IF (N .LE. 1) THEN
         B = D(1) - T
         IF (B .LE. Z) L = 1
         RETURN
      ENDIF
      F = 65536
      F = F**4
      E = ONE/F
      U = 16
      M = 0
      I = 1
   20 CONTINUE
      C = ONE
      B = D(I) - T
   30 CONTINUE
      IF (B .LE. Z) GO TO 70
      IF (I .GE. N) GO TO 130
   40 CONTINUE
      J = I
      I = I + 1
      A = (D(I)-T)*B - P(J)*C
      C = B
      B = A
   50 CONTINUE
      A = ABS(B)
      IF (A > F) GO TO 60
      IF (A > E) GO TO 30
      IF (A .EQ. Z) GO TO 70
      C = C*F
      B = B*F
      V = V - U
      GO TO 50
   60 CONTINUE
      C = C*E
      B = B*E
      V = V + U
      GO TO 50
   70 CONTINUE
      L = L + 1
      IF (I .GE. N) GO TO 130
      IF (B < Z) GO TO 90
      IF (P(I) > ZERO) GO TO 90
      I = I + 1
      M = 1
      V = Z
      GO TO 20
   80 CONTINUE
      IF (B .GE. Z) GO TO 120
      IF (I .GE. N) GO TO 130
   90 CONTINUE
      J = I
      I = I + 1
      A = (D(I)-T)*B - P(J)*C
      C = B
      B = A
  100 CONTINUE
      A = ABS(B)
      IF (A > F) GO TO 110
      IF (A > E) GO TO 80
      IF (A .EQ. Z) GO TO 120
      C = C*F
      B = B*F
      V = V - U
      GO TO 100
  110 CONTINUE
      C = C*E
      B = B*E
      V = V + U
      GO TO 100
  120 CONTINUE
      L = L + 1
      IF (I .GE. N) GO TO 130
      IF (B > Z) GO TO 40
      IF (P(I) > ZERO) GO TO 40
      I = I + 1
      M = 1
      V = Z
      GO TO 20
  130 CONTINUE
      IF (M .NE. 1) THEN
         IF (B .NE. ZERO) THEN
            A = ONE/U
            IF (ABS(B) .GE. A) THEN
  140          CONTINUE
               IF (ABS(B) < ONE) RETURN
               B = B*A
               V = V + ONE
               GO TO 140
            ENDIF
            B = B*U
            V = V - ONE
 1003       CONTINUE
            IF (ABS(B) .GE. A) GO TO 1002
            B = B*U
            V = V - ONE
            IF (ABS(B) .GE. A) GO TO 1002
            B = B*U
            V = V - ONE
            IF (ABS(B) .GE. A) GO TO 1002
            B = B*U
            V = V - ONE
            IF (ABS(B) .GE. A) GO TO 1002
            B = B*U
            V = V - ONE
            GO TO 1003
 1002       CONTINUE
            RETURN
         ENDIF
      ENDIF
      V = Z
      B = Z
      RETURN

      END SUBROUTINE CP

      SUBROUTINE EQL(X, F, G, H, N)
      use kind_spec
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer N
      REAL(rprec), DIMENSION(N) :: X, F, H
      REAL(rprec), DIMENSION(N) :: G
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: I1, J2, I, J, K, L, M, NM1
      REAL(rprec) :: R, S, Z, U
!-----------------------------------------------
      Z = 0
      I = 1
      R = X(N)
      S = F(N)
      U = G(N)
      IF (S .EQ. Z) GO TO 30
      I1 = I
      J2 = MAX(N - 1,I1)
      DO I = I1, J2
         IF (F(I) .EQ. Z) CYCLE
         IF (U < G(I)) GO TO 30
         IF (U > G(I)) CYCLE
         IF (ABS(F(I)) .GE. ABS(S)) GO TO 30
      END DO
      GO TO 50
   30 CONTINUE
      M = N + I
      NM1 = N - 1
      DO J = I, NM1
         K = M - J
         L = K - 1
         X(K) = X(L)
         F(K) = F(L)
         G(K) = G(L)
      END DO
      X(I) = R
      F(I) = S
      G(I) = U
   50 CONTINUE
      U = G(N)
      WHERE ((G(:N)-U).LE.(-99._dp) .OR. F(:N).EQ.Z) H(:N) = Z
      WHERE (F(:N).NE.Z .AND. (G(:N)-U)>(-99._dp))
     1    H(:N) = F(:N)*16._dp**(G(:N)-U)

      RETURN
      END SUBROUTINE EQL

      SUBROUTINE TVECT(E, X, L, D, U, N, W)
!      ________________________________________________________
!     |                                                        |
!     |     COMPUTE EIGENVECTOR CORRESPONDING TO GIVEN REAL    |
!     |        EIGENVALUE FOR A REAL TRIDIAGONAL MATRIX        |
!     |                                                        |
!     |    INPUT:                                              |
!     |                                                        |
!     |         E     --EIGENVALUE                             |
!     |                                                        |
!     |         L     --SUBDIAGONAL                            |
!     |                                                        |
!     |         D     --DIAGONAL                               |
!     |                                                        |
!     |         U     --SUPERDIAGONAL                          |
!     |                                                        |
!     |         N     --MATRIX DIMENSION                       |
!     |                                                        |
!     |         W     --WORK ARRAY (LENGTH AT LEAST 4N)        |
!     |                                                        |
!     |    OUTPUT:                                             |
!     |                                                        |
!     |         E     --IMPROVED ESTIMATE FOR EIGENVALUE       |
!     |                                                        |
!     |         X     --EIGENVECTOR                            |
!     |                                                        |
!     |    BUILTIN FUNCTIONS: ABS,SQRT                         |
!     |________________________________________________________|
!
      use kind_spec
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer:: N
      REAL(rprec):: E
      REAL(rprec), DIMENSION(N) :: X, L, D, U
      REAL(rprec), DIMENSION(4*N) :: W
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      real(rprec), parameter :: zero = 0, one = 1
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: G1, J1, J2, J4, J3, F, G, H, I, J, K, M
      REAL(rprec) :: O, P, Q, R, S, T, V, Y, Z
!-----------------------------------------------
      IF (N .LE. 1) THEN
         E = D(1)
         X(1) = ONE
         RETURN
      ENDIF
      M = N - 1
      J = 2
!     ---------------------------------------------------------
!     |*** STORE MATRIX IN W ARRAY AND SUBTRACT EIGENVALUE ***|
!     ---------------------------------------------------------
      X(1:M) = 0
      DO I = 1,M
         W(J) = U(I)
         W(J+1) = D(I) - E
         W(J+2) = L(I)
         J = J + 4
      END DO
      W(J) = 0
      W(J+1) = D(N) - E
      O = 65536
      O = O**(-4)
      T = O/2
      S = T
      T = T/2
      P = S
      S = S + T
      IF (S .GE. O) GO TO 40
      DO WHILE(S + T > S)
         T = T/2
         P = S
         S = S + T
         IF (S .GE. O) GO TO 40
      END DO
   40 CONTINUE
      R = W(3)
      V = ABS(R) + ABS(W(4))
      F = 4
      M = 4*N - 3
      G = -2
!     ---------------------------
!     |*** FACTOR THE MATRIX ***|
!     ---------------------------
      G = G + 4
      G1 = G
      DO G = G1, M, 4
         H = G - 1
         I = G + 2
         J = G + 5
!     --------------------
!     |*** FIND PIVOT ***|
!     --------------------
         Q = W(I)
         Y = ABS(Q)
         Z = ABS(R)
         IF (Z < Y) THEN
!     -------------------
!     |*** SWAP ROWS ***|
!     -------------------
            IF (V < Y) THEN
               V = Y
               F = I
            ENDIF
            T = W(G)
            W(G) = W(J)
            W(J) = T
            T = R/Q
            K = G + 1
            W(K) = Q
            K = J - 1
            S = W(K)
            IF (S .NE. ZERO) THEN
               IF (S .EQ. O) S = P
               W(K) = -S*T
               W(H) = S
               GO TO 100
            ENDIF
            W(K) = S
            W(H) = O
            GO TO 100
         ENDIF
         W(H) = 0
         IF (V < Z) THEN
            V = Z
            F = I
         ENDIF
         IF (R .EQ. ZERO) GO TO 120
         T = Q/R
!     -------------------
!     |*** ELIMINATE ***|
!     -------------------
  100    CONTINUE
         R = W(J) - T*W(G)
         W(J) = R
         W(I) = T
      END DO
      IF (ABS(R) < V) THEN
         V = R
         F = J + 1
!     ---------------------------------------------------
!     |*** COMPUTE INITIAL EIGENVECTOR APPROXIMATION ***|
!     ---------------------------------------------------
      ENDIF
  120 CONTINUE
      J = F/4
      X(J) = ONE
      IF (J .NE. 1) THEN
         K = F - 5
         J = J - 1
         X(J) = (X(J)-W(K-1)*X(J+1))/W(K)
         J1 = J
         IF (J1 - 1 > 0) THEN
            DO J = J1, 2, -1
               K = K - 4
               T = W(K-2)
               IF (T .EQ. O) T = 0
               X(J-1) = (X(J-1)-W(K-1)*X(J)-T*X(J+1))/W(K)
            END DO
         ENDIF
         GO TO 140
      ENDIF
  140 CONTINUE
      IF (V .NE. ZERO) THEN
         S = MAXVAL(ABS(X(:N)))
         S = ONE/S
         X(:N) = S*X(:N)
         R = SUM(X(:N)*X(:N))
         K = 0
         J = 1
         Y = X(1)
!     -----------------------------------------------------
!     |*** APPLY ONE ITERATION OF INVERSE POWER METHOD ***|
!     -----------------------------------------------------
         J2 = J
         J4 = MAX(N - 1,J2)
         DO J = J2, J4
            K = K + 4
            I = J
            S = W(K)
            W(K) = Y
            Y = X(J+1)
            IF (W(K-3) .NE. ZERO) THEN
               T = X(J+1)
               X(J+1) = X(I)
               X(I) = T
            ENDIF
            X(J+1) = X(J+1) - S*X(I)
         END DO
!     ---------------------------
!     |*** BACK SUBSTITUTION ***|
!     ---------------------------
         S = X(J)/W(K+3)
         X(J) = S
         T = ABS(S)
         V = S*Y
         J = J - 1
         K = K - 1
         S = (X(J)-W(K-1)*S)/W(K)
         X(J) = S
         T = MAX(ABS(S),T)
         V = V + S*W(K+1)
         J3 = J
         IF (J3 - 1 > 0) THEN
            DO J = J3, 2, -1
               K = K - 4
               Z = W(K-2)
               IF (Z .EQ. O) Z = 0
               S = (X(J-1)-W(K-1)*S-Z*X(J+1))/W(K)
               X(J-1) = S
               T = MAX(ABS(S),T)
               V = V + S*W(K+1)
            END DO
         ENDIF
         IF (V .NE. ZERO) V = R/V
         T = ONE/T
         S = SUM((X(:N)*V)**2)
         Z = SUM((T*X(:N))**2)
         T = T/SQRT(Z)
         X(:N) = T*X(:N)
!     --------------------------------------------------------------
!     |*** USE RAYLEIGH QUOTIENT TO IMPROVE EIGENVALUE ESTIMATE ***|
!     --------------------------------------------------------------
         IF (R + R .GE. S) E = E + V
         RETURN
      ENDIF
      T = MAXVAL(ABS(X(:N)))
      T = ONE/T
      Z = SUM((T*X(:N))**2)
      T = T/SQRT(Z)
      X(:N) = T*X(:N)

      END SUBROUTINE TVECT


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FFT1D (X,Y,TABLE,M,LL,ISN)
      IMPLICIT NONE
C
C Purpose:  FFT is in place DFT computation using Sande algorithm
C           and Markel pruning modification.
C
      REAL    X(1),Y(1),TABLE(1)
      INTEGER M,LL,ISN
C
C X      : Array of length 2**M used to hold real part of complex input
C Y      : Array of length 2**M used to hold imaginary part of input
C          X&Y are real and complex part of output
C TABLE  : Array of length N/4+1 (N=2**M) contains quarter length
C          cosine table.
C M      : Integer power of two which determines size of fft to be
C          performed. (bit reverse table is set for a max of N=2**12)
C LL     : Integer power of 2 which determines 2**ll actual data pts
C          and thus no. of stages in which no pruning is allowable
C ISN    :-1 for forward fft
C         +1 for reverse fft
C
C Calls   0:
C Called by: FRWFFT , INVFFT
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    C,S,R,FI,T1,T2
      INTEGER L(12),L1,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,IARG
      INTEGER J,J1,J2,J3,J4,J5,J6,J7,J8,J9,J10,J11,JR,JN,K1,K2,K3
      INTEGER N,ND4,ND4P1,ND4P2,ND2P2,LLL,LM,LMM,LO,LI,LMX,LIX,ISCL
C
C L     :
C
      EQUIVALENCE (L12,L(1)) , (L11,L(2)) , (L10,L(3)) , (L9,L(4)) ,
     1            (L8,L(5))  , (L7,L(6))  , (L6,L(7))  , (L5,L(8)) ,
     1            (L4,L(9))  , (L3,L(10)) , (L2,L(11)) , (L1,L(12))
C
C-----------------------------------------------------------------------
      N=2**M
      ND4=N/4
      ND4P1=ND4+1
      ND4P2=ND4P1+1
      ND2P2=ND4+ND4P2
      LLL=2**LL
      DO 50 LO=1,M
         LMX=2**(M-LO)
         LMM=LMX
         LIX=2*LMX
         ISCL=N/LIX
C
C=======TEST FOR PRUNING
C
         IF (LO-M+LL) 10,20,20
  10     LMM=LLL
  20     DO 50 LM=1,LMM
            IARG=(LM-1)*ISCL+1
            IF (IARG.LE.ND4P1) GO TO 30
            K1=ND2P2-IARG
            C=-TABLE(K1)
            K3=IARG-ND4
            S=ISN*TABLE(K3)
            GO TO 40
  30        C=TABLE(IARG)
            K2=ND4P2-IARG
            S=ISN*TABLE(K2)
  40        DO 50 LI=LIX,N,LIX
               J1=LI-LIX+LM
               J2=J1+LMX
               T1=X(J1)-X(J2)
               T2=Y(J1)-Y(J2)
               X(J1)=X(J1)+X(J2)
               Y(J1)=Y(J1)+Y(J2)
               X(J2)=C*T1-S*T2
               Y(J2)=C*T2+S*T1
  50  CONTINUE
C
C========PERFORM BIT REVERSAL
C
      DO 70 J=1,12
         L(J)=1
         IF (J-M) 60,60,70
  60     L(J)=2**(M+1-J)
  70  CONTINUE
      JN=1
      DO 120 J1=1,L1
       DO 120 J2=J1,L2,L1
        DO 120 J3=J2,L3,L2
         DO 120 J4=J3,L4,L3
          DO 120 J5=J4,L5,L4
           DO 120 J6=J5,L6,L5
            DO 120 J7=J6,L7,L6
             DO 120 J8=J7,L8,L7
              DO 120 J9=J8,L9,L8
               DO 120 J10=J9,L10,L9
                DO 120 J11=J10,L11,L10
                 DO 120 JR=J11,L12,L11
                 IF (JN-JR) 80,80,90
  80             R=X(JN)
                 X(JN)=X(JR)
                 X(JR)=R
                 FI=Y(JN)
                 Y(JN)=Y(JR)
                 Y(JR)=FI
  90             IF (ISN) 110,110,100
  100            X(JR)=X(JR)/REAL(N)
                 Y(JR)=Y(JR)/REAL(N)
  110            JN=JN+1
  120 CONTINUE
      RETURN
      END


program GaussSeidel
        implicit none

      ! Diclarations
        character :: FileImport, LINE, NetDataDate,NetOrigName,NetSeason,&
                &NetCaseId,FData, CharNbBus, CharNbBranch
        character(len=106) :: FMT1
        character(len=124) :: FMT2
        character,dimension(500) :: BusName
        character(len=32)::NetDataFileIn, NetDataFileOut, arg, NetFileFormat
        character(len=100) :: OutMessage
        integer,dimension(500) :: NbNode,LFAreaN,LZoneN,Ntype,Ib,Jb,LFAreaB,&
                &LZoneB,Circ,BType,LineRate1,LineRate2,LineRate3,BCntl,BSide
        integer :: N,I,J,Kmax,S,K,M,W,NB,NetYear,ii,jj
        real,dimension(500) :: FV,FDelta,Pd,Qd,Pg,Qg,Vb,Vspec,Qmax,Qmin,&
                &ChargLine,TrRatio,TrPhase,Tapmin,Tapmax,SteSize,Vmin,Vmax
        real::a,b,d,e,NetMVABase
        real,Dimension(500):: P,Q
        complex,dimension(500) :: Ybs
        complex,dimension(500,500) :: Z,Ya,Ys
        complex,Dimension(500)::V
        complex::SS,ST,Va,eps,DVamax

      ! arg represente les arguments transmits à l'application
        NetDataFileOut=""
      if (iargc()/=0 .and. iargc()>0) then
         CALL getarg(1, arg)
         NetDataFileIn=arg
         if (iargc()>1) then
             CALL getarg(2, arg)
             NetDataFileOut=arg
         endif
         if (iargc()>2) then
             CALL getarg(3, arg)
             NetFileFormat=arg
             NetFileFormat=trim(NetFileFormat)
         endif
         DO i = 4, iargc()
            CALL getarg(i, arg)
            selectcase (arg)
                Case ("GS")
                Case ("NR")
                Case ("RL")
                Case ("FD")
            endselect
         enddo
      ! NetDataFile : Nom du fichier de donnees du reseau
        open(unit=100,file=NetDataFileIn,status='old',action='read')
      ! Data.res : Nom du fichier de resultats du reseau
        if (NetDataFileOut=="") Then
            open(unit=200,file='data.html')
        else
            NetDataFileOut=trim(NetDataFileOut) // ".html"
            open(unit=200,file=NetDataFileOut)
        endif
        ! Preparation du fichier à soumettre : RESULTATS et insertion des BALISES HTML necessaire
        write(200,*) "<!DOCTYPE html>"
        write(200,*) ""
        write(200,*) ""
        write(200,*) "<meta charset='utf-8'>"
        write(200,*) "<title>Net Platform Version 1.0 | UTMB, SimulIA Team ENERGARID Lab., 2015</title>"
        write(200,*) "<meta name='description' content='Electrical Network Platform 1.0.'>"
        write(200,*) "<meta name='keywords' content='Electrical, Network, GS, NR, OPF, Load Flow'>"
        write(200,*) "<meta name='author' content='Etudiants Master ETT 2Annee, 2015 | TAMALI Mohammed'>"
        write(200,*) "<meta name='viewport' content='width=device-width, initial-scale=1.0'>"
        write(200,*) "<link rel='stylesheet' href='style.css' type='text/css' />"
        write(200,*) ""
        write(200,*) ""
        write(200,*) "
"
        write(200,*) "
DONNEES DU RESEAU [",trim(NetDataFileIn),"]

"

        if(NetFileFormat=='CDF')then
            call CDFImport(100)
        else
            Call SimulIANetRead(100,200)
        endif

        ! Debut du traitement selon la methode GAUSS-SEIDEL
        K=0
        write(200,*) '
RESULTATS INTERMEDIAIRES

'
        100 write(200,'(A,I4,A)') 'Iteration : ',K,'
'
        ! Boucle principale du calcul des element du vecteur tensions nodales
        do I=1,N
           ! On saute le noeud BILAN numero s
           if (I/=S)then
               ! Calcul de la somme des courant de contributions  SS
               SS=(0.,0.)
               do J=1,N
                  if(I/=J)then
                     SS=SS+Ya(I,J)*V(J)
                  endif
               enddo
               ! Si TYPE du noeud courant I est Producteur (1), on calcul la puissance reactive Q(i)
               if (Ntype(I)==2) then
                  ST=cmplx(0.,0.)
                  do J=1,N
                     ST=ST+Ya(I,J)*V(J)
                  enddo
                  Q(I)=aimag(V(I)*ST)
               endif
               ! On sauvegarde l'ancienne valeur de V(i) dans Va
               Va=V(I)
               ! On calcul la nouvelle valeur de V(i)
               V(I)=(1/Ya(I,I))*(cmplx(P(I),-Q(I))/V(I)-SS)
               ! On compare la difference des deux valeur Va et V(i) à Delta Vmax, si superieur on ecrase Delta Vmax
               if (real(Va-V(I))>real(DVamax) .and. aimag(Va-V(I))>aimag(DVamax)) then
                  DVamax=(Va-V(I))
               endif
           endif
        enddo
        ! Fin de la boucle principale
        ! On imprime les valeurs intermediaires de V
        write(200,*) '
TENSIONS NODALES (TMP)

'
        do M=1,N
            write(200,'(2F12.6,A)') V(M),'
'
        enddo
        if (cabs(DVamax)>cabs(eps)) then
           K=K+1
           if (K<=Kmax) then
              Go to 100
           else
              write(200,*) '
Le calcul a diverge, le maximum des iterations ',&
                    &Kmax,' a ete atteint

'
              GoTo 2
           endif
        else
           ! Calcul de P(s) et Q(s), du noeud BILAN
           ST=cmplx(0.,0.)
           do I=1,N
              ST=ST+Ya(S,I)*V(S)
           enddo
           P(S)=Real(V(S)*ST)
           Q(S)=aimag(V(S)*ST)
           write(200,*) '
PUISSANCE APPARENTE NODALES DU NOEUD BILAN

'
           write(200,'(2F14.6,A)') P(S),Q(S),'
'
           write(200,*) '
RESULTATS FINAUX (en p.u.)

'
           write(200,'(A,I4,A)') "
Pour un nombre d'iterations gal à ",K,"

"
           write(200,*) '
'
           do I=1,N
              write(200,'(2F12.6,A)') V(I),'
'
           enddo
           ! calcul des puissance des pertes par transmission PL et QL
           SS=cmplx(0.,0.)
           ST=cmplx(0.,0.)
           do I=1,N
              SS=SS+P(S)
              ST=ST+Q(S)
           enddo
           write(200,*) '
'
           write(200,*) '
PERTES PAR TRANSMISSION PL et QL (en p.u.)

'
           write(200,'(2F12.6,A)') SS, ST,'
'
        endif
 2      write(200,*) "
"
        write(200,*) ""
      else
         OutMessage="Donner au moins un argument, NOM DU FICHIER\n"
         open(unit=300,file='Error')
         write(300,*) OutMessage
      endif

      CONTAINS

      Subroutine SimulIANetRead(InFile, OutFile)
            implicit none
            integer,intent(In) :: InFile, OutFile
            ! Lecture des nombres de noeuds et de lignes
          ! saisie de la dimension reseau
            Read(InFile,'(2I2)') N,NB
            ! Eciture de N et de Nb dans le fichier à soumettre
            write(OutFile,*)'
le nombre =',N,' le nombre de branches=',NB,'

'
            ! Initialisation des elements de la matrice admittance
            do I=1,N
               do J=1,N
                  Ya(I,J)=cmplx(0.,0.)
               enddo
            enddo
            ! Lecture et ecriture des donnees des lignes
            write(OutFile,*) '
La matrice admittance, elements extra-diagonaux

'
            write(OutFile,*) '  Ni  Nj        Ya[i,j]
'
            do w=1,NB
               Read(InFile,*) I,J,a,b,d,e
               Z(I,J) = cmplx(a,b)
               Ys(I,J)= cmplx(d,e)
               if(real(Z(I,J))>1.0e-6 .and. aimag(Z(I,J))>1.0e-6)then
                  Ya(I,J)=-1/Z(I,J)
               else
                  Ya(I,J)=cmplx(1.0e-6, 1.0e-6)
               endif
               Ya(J,I)=Ya(I,J)
               Z(J,I)=Z(I,J)
               write(OutFile, '(2I4,2F12.6,A)') I,J,Ya(I,J),'
'
            enddo
            ! Calcul les element de diagonale
            write(OutFile,*)'
La matrice admittance, les elements diagonaux

'
            do I=1,N
                Ya(I,I)=(0.,0.)
                 do J=1,N
                   if(Z(I,J)/=0)then
                      Ya(I,I)=Ya(I,I)+(-Ya(I,J)+Ys(I,J)/2)
                   endif
                 enddo
                 write(OutFile, '(2I4,2F12.6,A)') I,I,Ya(I,I),'
'
            enddo
            ! Initialisation de Delta_Vmax
            DVamax=cmplx(-100000, -100000)
            ! Initialisation du vecteur tensions nodales
            do I=1,N
               V(I)=cmplx(1.,0.)
            enddo
            ! Ici commence la saisie des tableaux de planification
            ! Saisie numero nud balancier

            Read(InFile,*),S
            write(OutFile,*) '
Numero du noeud BILAN ',S,'

'
            Ntype(S)=0
            write(OutFile,*) '
TABLEAU DE PLANIFICATION

'
            write(OutFile,*) ' TYPE      P         Q/|V|'
            ! Saisie du vecteur type des nud
            do I = 1,N
               if (I/=S) then
                  Read(InFile,*) Ntype(I)
                  ! Si le nud est de type consommateur : 2 sinon Producteur : 1, 0 pour le noeud Bilan
                  if (Ntype(I) <= 1) then
                      Read(InFile,*) P(I),Q(I)
                      write(OutFile,'(I4,2F12.6,A)') Ntype(I),P(I),Q(I),'
'
                  endif
                  if (Ntype(I) == 2) then
                      Read(InFile,*) a,b,P(I)
                      V(I)=cmplx(a,b)
                      write(OutFile,'(I4,2F12.6,A)') Ntype(I),P(I),cabs(V(I)),'
'
                  endif
               endif
            enddo
            ! Saisie de Epsilon,Kmax
            Read(InFile,*)a,b,Kmax
            eps=cmplx(a,b)
            write(OutFile,*) '
   Epsillon             Kmax

'
            write(OutFile,'(A,2F10.6,A,I10)') '(',eps,')', Kmax
        end subroutine SimulIANetRead

      ! Processus d'importation à partir de fichier IEEE CDF
      subroutine CDFImport(f)
         implicit none
         integer,Intent(In):: f

         !FileImport=trim(f)
         !open(unit=10,file=FileImport,status='old',action='read')
         ! Lecture des informations de la première section (Identification du réseau)
         read(f,'(1X,A8,1X,A19,2X,F6.1,1X,I4,1X,A1,1X,A)') NetDataDate,NetOrigName,&
                &NetMVABase,NetYear, NetSeason, NetCaseId
         ! Lecture de la deuxième section (Pas importante) mention du nombre de neuds dans le réseau.
         read(f, '(A16,1X,A)') FData, CharNbBus
         CharNbBus=trim(CharNbBus)
         ! Lecture de la troisième section, Données des noeuds
         FMT1='(2X,A10,1X,I2,I3,1X,I2,1X,F6.4,F5.2,F8.2,F9.2,F7.2,F8.2,1X,&
                &F7.2,1X,F6.4,F7.2,F7.2,2F8.4,1X,I4,1X,I4)'
         i=0
         loop1: Do
            read(f, '(I4)'), w
            If (w/=-999) then
                i=i+1
                NbNode(i)=w
                read(f, FMT1) BusName(i),LFAreaN(i),LZoneN(i),Ntype(i),&
                        &FV(i),FDelta(i),Pd(i),Qd(i),Pg(i),Qg(i),Vb(i),&
                        &Vspec(i),Qmax(i),Qmin(i),Ybs(i),w
            else
                exit loop1
            endif
         enddo loop1
         ! Après detection de la fin de la section 3, lecture de la section quatrième : Données es lignes
         read(f, '(A19,1X,A)') FData, CharNbBranch
         CharNbBranch=trim(CharNbBranch)
         FMT2='(1X,I2,I2,2X,I1,1X,F10.6,F11.6,F9.5,F6.0,1X,F6.0,1X,F6.0,&
                &1X,I4,1X,I1,2X,F6.4,1X,F7.2,F7.4,F6.4,1X,F6.5,1X,2F7.4,2X,I4)'
         i=0
         loop2: Do
            read(f, '(I4)'), w
            If (w/=-999) then
                i=i+1
                Ib(i)=w
                read(f, '(1X,I4)'),Jb(i)
                ii=Ib(i)
                jj=Jb(i)
                read(f, FMT2) LFAreaB(i),LZoneB(i),Circ(i),BType(i),Z(ii,jj),&
                &Ys(ii,jj),LineRate1(i),LineRate2(i),LineRate3(i),BCntl(i),&
                &BSide(i),TrRatio(i),TrPhase(i),Tapmin(i),Tapmax(i),SteSize(i),Vmin(i),Vmax(i)
            else
                exit loop2
            endif
         enddo loop2
      end subroutine CDFImport
      end program


SUBROUTINE SSPGV_F95( A, B, W, ITYPE, UPLO, Z, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: SPGV_F77 => LA_SPGV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
   INTEGER, INTENT(IN), OPTIONAL :: ITYPE
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(INOUT) :: A(:), B(:)
   REAL(WP), INTENT(OUT) :: W(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_SPGV, LA_SPGVD, LA_HPGV and LA_HPGVD compute all eigenvalues
! and, optionally, all eigenvectors of generalized eigenvalue problems
! of the form A*z = lambda*B*z, A*B*z = lambda*z; and B*A*z = lambda*z,
! where A and B are real symmetric in the cases of LA_SPGV and LA_SPGVD
! and complex Hermitian in the cases of LA_HPGV and LA_HPGVD. In all
! four cases B is positive definite. Matrices A and B are stored in a
! packed format.
!     LA_SPGVD and LA_HPGVD use a divide and conquer algorithm. If
! eigenvectors are desired, they can be much faster than LA_SPGV and
! LA_HPGV for large matrices but use more workspace.
!
! =========
!
!       SUBROUTINE LA_SPGV / LA_SPGVD / LA_HPGV / LA_HPGVD( AP, BP, &
!                         W, ITYPE=itype, UPLO=uplo, Z=z, INFO=info )
!            <type>(<wp>), INTENT(INOUT) :: AP(:), BP(:)
!            REAL(<wp>), INTENT(OUT) :: W(:)
!            INTEGER, INTENT(IN), OPTIONAL :: ITYPE
!            CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!            <type>(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
!            INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!            <type> ::= REAL | COMPLEX
!            <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! AP       (input/output) REAL or COMPLEX array, shape (:) with
!          size(AP) = n*(n + 1)/2, where n is the order of A and B.
!          On entry, the upper or lower triangle of matrix A in packed
! 	   storage. The elements are stored columnwise as follows:
! 	   if UPLO = 'U', AP(i +(j-1)*j/2) = A(i,j) for 1<=i<=j<=n;
! 	   if UPLO = 'L', AP(i +(j-1)*(2*n-j)/2) = A(i,j) for 1<=j<=i<=n.
!          On exit, the contents of AP are destroyed.
! BP       (input/output) REAL or COMPLEX array, shape (:) and
!          size(BP) = size(AP).
!          On entry, the upper or lower triangle of matrix B in packed
! 	   storage. The elements are stored columnwise as follows:
! 	   if UPLO = 'U', BP(i +(j-1)*j/2) = B(i,j) for 1<=i<=j<=n;
! 	   if UPLO = 'L', BP(i +(j-1)*(2*n-j)/2) = B(i,j) for 1<=j<=i<=n.
!          On exit, the triangular factor U or L of the Cholesky
! 	   factorization B = U^H*U or B = L*L^H, in the same storage
! 	   format as B.
! W        (output) REAL array, shape (:) with size(W) = n.
!          The eigenvalues in ascending order.
! ITYPE    Optional (input) INTEGER.
!          Specifies the problem type to be solved:
!             = 1: A*z = lambda*B*z
!             = 2: A*B*z = lambda*z
!             = 3: B*A*z = lambda*z
!          Default value: 1.
! UPLO     Optional (input) CHARACTER(LEN=1).
!             = 'U': Upper triangles of A and B are stored;
!             = 'L': Lower triangles of A and B are stored.
!          Default value: 'U'.
! Z        Optional (output) REAL or COMPLEX square array, shape (:,:)
!          with size(Z,1) = n.
!          The matrix Z of eigenvectors, normalized as follows:
!             if ITYPE = 1 or 2: Z^H * B * Z = I ,
!             if ITYPE = 3: Z^H * B^-1 * Z = I .
! INFO     Optional (output) INTEGER.
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: the algorithm failed to converge or matrix B is not
! 	      positive definite:
!              <= n: if INFO = i, i off-diagonal elements of an
! 	          intermediate tridiagonal form did not converge to
! 		  zero.
!              > n: if INFO = n+i, for 1<=i<=n, then the leading minor
! 	          of order i of B is not positive definite. The
! 		  factorization of B could not be completed and no
!                   eigenvalues or eigenvectors were computed.
!          If INFO is not present and an error occurs, then the program
! 	   is terminated with an error message.
!----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_SPGV'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOBZ, LUPLO
   INTEGER :: LINFO, N, NN, LD, LITYPE, ISTAT, ISTAT1, S1Z, S2Z
!  .. LOCAL ARRAYS ..
   REAL(WP), TARGET :: LLZ(1,1)
   REAL(WP), POINTER :: WORK(:)
   COMPLEX(WP) :: WW
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC SIZE, MAX, PRESENT
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; NN = SIZE(A)
   WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW);  LD = MAX(1,N)
   IF( PRESENT(ITYPE) )THEN; LITYPE = ITYPE; ELSE; LITYPE = 1; END IF
   IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2); LJOBZ = 'V'
   ELSE; S1Z = 1; S2Z = 1; LJOBZ = 'N'; END IF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
!  .. TEST THE ARGUMENTS
   IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1
   ELSE IF( SIZE(B) /= SIZE(A)  )THEN; LINFO = -2
   ELSE IF( SIZE(W) /= N )THEN; LINFO = -3
   ELSE IF( LITYPE < 1 .OR. LITYPE > 3 )THEN; LINFO = -4
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -5
   ELSE IF( PRESENT(Z) .AND. ( S1Z /= LD .OR. S2Z /= N ) )THEN; LINFO = -6
   ELSE IF( N > 0 )THEN
      ALLOCATE(WORK(MAX(1,3*N)), STAT=ISTAT)
      IF( ISTAT == 0 )THEN
         IF( PRESENT(Z) )THEN
           CALL SPGV_F77( LITYPE, LJOBZ, LUPLO, N, A, B, W, Z, S1Z, &
                        WORK, LINFO )
	 ELSE
	   CALL SPGV_F77( LITYPE, LJOBZ, LUPLO, N, A, B, W, LLZ, S1Z, &
                        WORK, LINFO )
	ENDIF
      ELSE; LINFO = -100; ENDIF
      DEALLOCATE(WORK, STAT=ISTAT1)
   ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE SSPGV_F95


*        SUBROUTINE 'DGPFA'
*        SELF-SORTING IN-PLACE GENERALIZED PRIME FACTOR (COMPLEX) FFT
*
*        *** THIS IS THE ALL-FORTRAN VERSION ***
*            -------------------------------
*
*        CALL DGPFA(A,B,TRIGS,INC,JUMP,N,LOT,ISIGN,NPQR)
*
*        A IS FIRST REAL INPUT/OUTPUT VECTOR
*        B IS FIRST IMAGINARY INPUT/OUTPUT VECTOR
*        TRIGS IS A TABLE OF TWIDDLE FACTORS, PRECALCULATED
*              BY CALLING SUBROUTINE 'SETDGPFA'
*        INC IS THE INCREMENT WITHIN EACH DATA VECTOR
*        JUMP IS THE INCREMENT BETWEEN DATA VECTORS
*        N IS THE LENGTH OF THE TRANSFORMS:
*          -----------------------------------
*            N = (2**IP) * (3**IQ) * (5**IR)
*          -----------------------------------
*        LOT IS THE NUMBER OF TRANSFORMS
*        ISIGN = +1 FOR FORWARD TRANSFORM
*              = -1 FOR INVERSE TRANSFORM
*        NPQR = NPQR OBTAINED FROM SETDGPFA
*
*        WRITTEN BY CLIVE TEMPERTON
*        RECHERCHE EN PREVISION NUMERIQUE
*        ATMOSPHERIC ENVIRONMENT SERVICE, CANADA
*
*        MODIFIED FOR VXL PROJECT TO ADD NPQR ARGUMENT
*
*----------------------------------------------------------------------
*
*        DEFINITION OF TRANSFORM
*        -----------------------
*
*        X(J) = SUM(K=0,...,N-1)(C(K)*EXP(ISIGN*2*I*J*K*PI/N))
*
*---------------------------------------------------------------------
*
*        FOR A MATHEMATICAL DEVELOPMENT OF THE ALGORITHM USED,
*        SEE:
*
*        C TEMPERTON : "A GENERALIZED PRIME FACTOR FFT ALGORITHM
*          FOR ANY N = (2**P)(3**Q)(5**R)",
*          SIAM J. SCI. STAT. COMP., MAY 1992.
*
*----------------------------------------------------------------------
*
      SUBROUTINE DGPFA(A,B,TRIGS,INC,JUMP,N,LOT,ISIGN,NPQR)
*
      DOUBLE PRECISION A(*), B(*), TRIGS(*)
      INTEGER INC, JUMP, N, LOT, ISIGN, NPQR(3)
*
      IP = NPQR(1)
      IQ = NPQR(2)
      IR = NPQR(3)
*
*     COMPUTE THE TRANSFORM
*     ---------------------
      I = 1
      IF (IP.GT.0) THEN
         CALL DGPFA2F(A,B,TRIGS,INC,JUMP,N,IP,LOT,ISIGN)
         I = I + 2 * ( 2**IP)
      ENDIF
      IF (IQ.GT.0) THEN
         CALL DGPFA3F(A,B,TRIGS(I),INC,JUMP,N,IQ,LOT,ISIGN)
         I = I + 2 * (3**IQ)
      ENDIF
      IF (IR.GT.0) THEN
         CALL DGPFA5F(A,B,TRIGS(I),INC,JUMP,N,IR,LOT,ISIGN)
      ENDIF
*
      RETURN
      END


program expr_02
implicit none
integer :: x
x = (2+3)*5
if (x /= 25) error stop

x = (2+3)*4
if (x /= 20) error stop

x = (2+3)*(2+3)
if (x /= 25) error stop

x = (2+3)*(2+3)*4*2*(1+2)
if (x /= 600) error stop

x = x / 60
if (x /= 10) error stop

x = x + 1
if (x /= 11) error stop

x = x - 1
if (x /= 10) error stop
end program


! solve the 2d linear advection equation, in conservative form:
!
!   a_t + [f(a)]_x + [g(a)]_y=0
!   f(a) = u*a
!   g(a) = v*a
!   a=a(x,y,t) (user defined)
!   u=constant (user defined)
!   v=constant (user defined)
!
!  using either
!   - dimensionally split 2nd order finite volume predictor-corrector
!   - unsplit with "Corner Transport Upwind" (CTU) method (coming soon)
!  with a choice of gradient limiters
!
! https://github.com/JOThurgood/SimpleCFD/wiki/advect_2d.f90
!

module shared_data

  implicit none

  integer, parameter :: num=selected_real_kind(p=15)
  integer :: nx, ny !number of cells
  integer :: ix,iy
  integer(num) :: step, nsteps
  real(num) :: u, v
  real(num) :: time=0.0_num, t_end, dt
  real(num) :: x_min, x_max
  real(num) :: y_min, y_max
  real(num) :: dx, dy
  real(num), dimension(:), allocatable :: xb, xc
  real(num), dimension(:), allocatable :: yb, yc
  real(num), dimension(:,:), allocatable :: a,a1x,a1y, a1Lx, a1Rx, a1Ly,a1Ry
    !solution and states at half time step indicated by 1
  real(num) :: CFL !cfl modifier

  !keyword codes
  integer :: limiter
  integer, parameter :: lim_unlimited = 1, lim_minmod = 2
  integer :: method
  integer, parameter :: method_split = 1, method_unsplit = 2

  contains

end module shared_data

module setup

  use shared_data

  implicit none

  contains

  subroutine initial_setup
    call control
    call setup_2dfvgrid
    call initial_conditions
  end subroutine initial_setup

  subroutine control
    !user control variables
    u = 1.0_num
    v = 1.0_num
    nx = 64
    ny = 64
    x_min = 0.0_num
    x_max = 1.0_num
    y_min = x_min
    y_max = x_max
    t_end = 1.0_num
    CFL = 0.7_num !cfl multiplier <= 1
    nsteps = -1  !set to -1 to run till t_end
    limiter = lim_minmod
!    limiter = lim_unlimited
    method = method_split
  end subroutine control

  subroutine initial_conditions
    !user set initial profile on a
    a = 0.0_num
!   call x_top_hat
!    call y_top_hat
    call square
!    call gaussian
  end subroutine initial_conditions

  subroutine x_top_hat
    a = 0.0_num
    do ix = 0,nx+1
      if ((xc(ix) .ge. 1.0_num/3.0_num) .and. (xc(ix) .le. 2.0_num/3.0_num)) &
        & a(ix,:) = 1.0_num
    enddo
  end subroutine x_top_hat

  subroutine square
    real(num) :: lo,hi
    lo = 1.0_num/3.0_num
    hi = 2.0_num*lo
    a = 0.0_num
    do iy = 0,ny+1
    do ix = 0,nx+1
      if ((xc(ix) .ge. lo) &
        & .and. (xc(ix) .le. hi) &
        & .and. (yc(iy) .ge. lo) &
        & .and. (yc(iy) .le. hi) ) a(ix,iy) = 1.0_num
    enddo
    enddo
  end subroutine square

  subroutine y_top_hat
    a = 0.0_num
    do iy = 0,ny+1
      if ((yc(iy) .ge. 1.0_num/3.0_num) .and. (yc(iy) .le. 2.0_num/3.0_num)) &
        & a(:,iy) = 1.0_num
    enddo
  end subroutine y_top_hat

  subroutine gaussian
    print *, 'gaussian currently a stub'
  end subroutine gaussian

  subroutine setup_2dfvgrid !setup the grid and allocate other arrays

    allocate(xc(-1:nx+2))  !cell center (cc) - counts from 1 to nx
    allocate(xb(-2:nx+2))  !cell boundary (cb) - counts from 0 to nx
    allocate(yc(-1:ny+2))  !cell center (cc) - counts from 1 to ny
    allocate(yb(-2:ny+2))  !cell boundary (cb) - counts from 0 to ny
                           !all above have two guards  either side

    allocate(a(-1:nx+2,-1:ny+2))   !cc + 2 guards
    allocate(a1x(0:nx,1:ny))  !cb,cc - no guards needed
    allocate(a1Lx(0:nx,1:ny)) !cb,cc
    allocate(a1Rx(0:nx,1:ny)) !cb,cc
    allocate(a1y(1:nx,0:ny))  !cc,cb - no guards needed
    allocate(a1Ly(1:nx,0:ny)) !cc,cb
    allocate(a1Ry(1:nx,0:ny)) !cc,cb

    dx = (x_max - x_min) / REAL(nx,num)
    do ix = -2, nx+2
      xb(ix) = x_min + REAL(ix,num) * dx
      if (ix /= -2) xc(ix) = xb(ix) - dx/2.0_num
    enddo

    dy = (y_max - y_min) / REAL(ny,num)
    do iy = -2, ny+2
      yb(iy) = y_min + REAL(iy,num) * dy
      if (iy /= -2) yc(iy) = yb(iy) - dy/2.0_num
    enddo

  end subroutine setup_2dfvgrid

end module setup

module split_solver

  use shared_data

  implicit none

  private

  public :: solve_split

  contains

  subroutine solve_split

    call set_dt

    if (MOD(step,2) == 1) then !strang splitting
      call x_bcs
      call x_interface_state
      call x_reimann
      call x_update
      call y_bcs
      call y_interface_state
      call y_reimann
      call y_update
    else
      call y_bcs
      call y_interface_state
      call y_reimann
      call y_update
      call x_bcs
      call x_interface_state
      call x_reimann
      call x_update
    endif

    time = time + dt

    !if plotting ghost cells may want to call bcs before plot
    !to update (order here will have them one time before?)
    !no effect on sln / correct for what you intend
  end subroutine solve_split

  subroutine set_dt
    real(num) ::dtx,dty
    dtx = CFL * dx / abs(u)
    dty = CFL * dy / abs(v)
    dt = MIN(dtx,dty)
    if ((step==1) .and. (abs(u-v) .gt. 1e-2_num)) then
      print *,'u not ~= v detected ; even if CFL=1 perfect translation not poss'
      print *,'effective CFL in x drn',dt/dtx * CFL
      print *,'effective CFL in y drn',dt/dty * CFL
    endif
!    if (step==1) print *,'effective CFL in x drn',dt/dtx
!    if (step==1) print *,'effective CFL in y drn',dt/dty
  end subroutine set_dt

  subroutine x_bcs !periodic
    a(-1,:) = a(nx-1,:)
    a(0,:) = a(nx,:)
    a(nx+1,:) = a(1,:)
    a(nx+2,:) = a(2,:)
  end subroutine x_bcs

  subroutine y_bcs !periodic
    a(:,-1) = a(:,ny-1)
    a(:,0) = a(:,ny)
    a(:,ny+1) = a(:,1)
    a(:,ny+2) = a(:,2)
  end subroutine y_bcs

  subroutine x_interface_state
    !be careful with cc vs cb here
    real(num) dadx
    do iy = 1, ny !inefficient, refactor to vector operation
    do ix = 0, nx
      !left state
      if (limiter == lim_minmod) then
        dadx = minmod( ( a(ix,iy)-a(ix-1,iy) ) / dx, ( a(ix+1,iy)-a(ix,iy) ) / dx )
      else
        dadx = ( a(ix+1,iy) - a(ix-1,iy) ) / 2.0_num / dx
      endif
      a1Lx(ix,iy) = a(ix,iy) + 0.5_num * dx * (1.0_num - dt * u / dx) *  dadx
      !right state
      if (limiter == lim_minmod) then
        dadx = minmod( ( a(ix+1,iy)-a(ix,iy) )/dx , ( a(ix+2,iy)-a(ix+1,iy) ) / dx )
      else
        dadx = ( a(ix+2,iy) - a(ix,iy) ) / 2.0_num / dx
      endif

      a1Rx(ix,iy) = a(ix+1,iy) - 0.5_num * dx * (1.0_num + dt * u / dx) *  dadx
    enddo
    enddo
  end subroutine x_interface_state

  subroutine x_reimann
    !worlds simplest reimann problem
    if (u < 0.0_num) then
      a1x = a1Rx
    else if (u > 0.0_num) then
      a1x = a1Lx
    endif
  end subroutine x_reimann

  subroutine x_update
    do ix = 1,nx
      a(ix,1:ny)  = a(ix,1:ny)  - dt / dx * (u*a1x(ix,1:ny)-u*a1x(ix-1,1:ny))
    enddo
  endsubroutine x_update

  subroutine y_interface_state
    !consider a1L as "bottom" and a1R as "top" conceptually
    ! (or most negative -> most positive y)
    !be careful with cc vs cb here
    real(num) dady
    do ix = 1, nx !refactor to vector operation
    do iy = 0, ny
      !left state
      if (limiter == lim_minmod) then
        dady = minmod( ( a(ix,iy)-a(ix,iy-1) ) / dy, ( a(ix,iy+1)-a(ix,iy) ) / dy )
      else
        dady = ( a(ix,iy+1) - a(ix,iy-1) ) / 2.0_num / dy
      endif
      a1Ly(ix,iy) = a(ix,iy) + 0.5_num * dy * (1.0_num - dt * v / dy) *  dady
      !right state
      if (limiter == lim_minmod) then
        dady = minmod( ( a(ix,iy+1)-a(ix,iy) )/dy , ( a(ix,iy+2)-a(ix,iy+1) ) / dy )
      else
        dady = ( a(ix,iy+2) - a(ix,iy) ) / 2.0_num / dy
      endif
      a1Ry(ix,iy) = a(ix,iy+1) - 0.5_num * dy * (1.0_num + dt * v / dy) *  dady
    enddo
    enddo
  end subroutine y_interface_state

  subroutine y_reimann
    if (v < 0.0_num) then
      a1y = a1Ry
    else if (v > 0.0_num) then
      a1y = a1Ly
    endif
  end subroutine y_reimann

  subroutine y_update
    do iy = 1,ny
      a(1:nx,iy)  = a(1:nx,iy)  - dt / dy * (v*a1y(1:nx,iy)-v*a1y(1:nx,iy-1))
    enddo
  endsubroutine y_update

  real(num) function minmod(a,b)  ! refactor - "a" is an unfortunate choice
    real(num), intent(in) :: a, b
    if ( (abs(a) < abs(b)) .and. (a*b > 0) ) then
      minmod = a
    else if ( (abs(a) > abs(b)) .and. (a*b > 0) ) then
      minmod = b
    else
      minmod = 0.0_num
    endif
  end function minmod

end module split_solver

module diagnostics

  use shared_data

  implicit none

  contains

  subroutine do_io

    integer :: out_unit =10

    call execute_command_line("rm -rf xc.dat yc.dat a.dat")
      !dont want to stream to existing files

    open(out_unit, file="xc.dat", access="stream")
    write(out_unit) xc
    close(out_unit)

    open(out_unit, file="yc.dat", access="stream")
    write(out_unit) yc
    close(out_unit)

    open(out_unit, file="a.dat", access="stream")
    write(out_unit) a
    close(out_unit)

    call execute_command_line("python plot_advect_2d.py")

  end subroutine do_io

end module diagnostics

program advection2d !main driver

  use shared_data
  use setup
  use split_solver
  use diagnostics

  implicit none

  call initial_setup

  do
   if ((step >= nsteps .and. nsteps >= 0) .or. (time >= t_end)) exit
    step = step + 1
    if (method == method_split) call solve_split
  enddo

  call do_io

  print *, 'Done in',step,'steps', 'with CFL',CFL

end program advection2d


      SUBROUTINE CONTINUTYn(X, Y, Z, W, C, M,  NTS, CTS)
      USE global
      IMPLICIT NONE
      REAL*8 :: X(2,NXP4), Y(2,NXP4), Z(2,NXP4), W(2,NXP4)
      INTEGER :: IC, NTS, CTS
      REAL*8  :: C, M
!----------------------------------------------------------------------
!     X   = Density of fluid
!     Y   = Velocity of fluid
!     Z   = Pressure of fluid
!     W   = Electric field in system
!     C   = Charge
!     M   = Mass (mu)
!     NTS = (N)ext (T)ime (S)tep
!     CTS = (C)urrent (T)ime (S)tep
!     FD0 = Density derivative (dN/dx)
!     FD1 = Velocity derivative (dV/dx)
!     FD2 = Pressure derivative (dP/dx)
!----------------------------------------------------------------------
!
      CALL FD4n(X(CTS,:), FD0(1,:))  ! density
      CALL FD4n(Y(CTS,:), FD1(1,:))  ! velocity
      CALL FD4n(Z(CTS,:), FD2(1,:))  ! presure
!
      DO 1 IC=3, NXP2
          X(NTS,IC)  = X(NTS,IC) - DT*(X(CTS,IC)*FD1(1,IC) &
     &     + Y(CTS,IC)*FD0(1,IC))
          Y(NTS,IC) = Y(NTS,IC) - DT*(Y(CTS,IC)*FD1(1,IC) &
     &     + FD2(1,IC)/(X(CTS,IC)*M) - W(CTS,IC)*(C/M))
          Z(NTS,IC)  = Z(NTS,IC) - DT*(Y(CTS,IC)*FD2(1,IC) &
     &      + GYM*Z(CTS,IC)*FD1(1,IC) )
    1 CONTINUE
!
      CALL boundary_condition(X(NTS,:))
      CALL boundary_condition(Y(NTS,:))
      CALL boundary_condition(Z(NTS,:))
!
      CALL FILTERn(X(NTS,:))
      CALL FILTERn(Y(NTS,:))
      CALL FILTERn(Z(NTS,:))
!
      RETURN
      END


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine dcvit2                         *
!  *                                                                   *
!  *********************************************************************
!  Double Precision Version 2.11
!  Written by Gordon A. Fenton, TUNS, July 18, 1992
!  Latest Update: Jun 9, 1999
!
!  PURPOSE  computes the initial k1*k2 x k1*k2 covariance matrix (and a 9x9
!           submatrix) between local averages. Used by LAS2G.
!
!
!  This routine forms the covariance matrix Q between local averages arranged
!  on a k1 x k2 grid using a user provided variance function "dvarfn" that
!  returns the variance of a local average (note that this is the point
!  variance sigma^2 times the traditionally "variance" function, as defined
!  by Vanmarcke in "Random Fields", MIT Press, 1984). The grid and element
!  numbering schemes appear as follows (for k1 = k2 = 5)
!
!          | Dx |
!     ---  --------------------------
!      Dy  | 21 | 22 | 23 | 24 | 25 |
!     ---  --------------------------
!          | 16 | 17 | 18 | 19 | 20 |
!          --------------------------           ----------------
!          | 11 | 12 | 13 | 14 | 15 |           |  7 |  8 |  9 |
!          --------------------------           ----------------
!          |  6 |  7 |  8 |  9 | 10 |           |  4 |  5 |  6 |
!          --------------------------           ----------------
!          |  1 |  2 |  3 |  4 |  5 |           |  1 |  2 |  3 |
!          --------------------------           ----------------
!
!                  Q Array                          R Array
!
!  with the k1 x k2 array numbering on the left and a basic 3 x 3 subarray
!  shown on the right. If we call Z_i the local average of a random process
!  over the i'th cell, then for E[Z] = 0, the elements of Q are defined by
!
!           Q(i,j) = E[Z_i*Z_j]
!
!  Note that the elements of R are simply extracted directly from the
!  appropriate elements of Q (for example, R(1,5) = Q(1,7)) if k1 and k2 are
!  greater than 2. Note also that since both Q and R are symmetric, ONLY THE
!  UPPER TRIANGULAR VALUES are stored herein. Finally note that the random
! process is assumed to be quadrant symmetric (that is the covariance
! function is even in each individual lag component) to reduce the total
! number of covariance calculations.
!
!  Arguments to this routine are as follows;
!
!    dvarfn     external double precision function which returns the
!               variance of a local average of size X x Y. This function
!               is referenced using the call "V = dvarfn(X,Y)" (other
!               parameters to the function must be passed via common blocks).
!               On each invocation, this routine calls DVARFN approximately
!               225 times (via DCVAA2).
!
!    Q          double precision array of size at least k1*k2 x k1*k2 which
!               on output will contain the covariance matrix between the local
!               average elements shown above on the left. Note that since Q is
!               symmetric, only the upper triangular values are actually
!               stored (compatible with DCHOL2). (output)
!
!    iq         leading dimension of the array Q as specified in the calling
!               routine. (input)
!
!    R          double precision array of size at least 9 x 9 which on output
!               will contain the covariance matrix between the local average
!               elements shown above on the right. Note that since R is
!               symmetric, only the upper triangular values are actually
!               stored (compatible with DSIFA). (output)
!
!    ir         leading dimension of the array R as specified in the calling
!               routine. (input)
!
!    k1         number of local average cells in the x direction
!               (horizontally). (input)
!
!    k2         number of local average cells in the y direction
!               (vertically). (input)
!
!    Dx         x-dimension of the local average cells. (input)
!
!    Dy         y-dimension of the local average cells. (input)
!
!  Required:
!   1) from libGAFsim: DCVAA2
!
!  REVISION HISTORY:
!  2.1	eliminated unused local variables (Dec 5/96)
!  2.11	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!----------------------------------------------------------------------------
      subroutine dcvit2( dvarfn, Q, iq, R, ir, k1, k2, Dx, Dy )
      implicit real*8 (a-h,o-z)
      dimension Q(iq,*), R(ir,*)
      integer kx(9), ky(9)
      external dvarfn
      data kx/0,1,2,0,1,2,0,1,2/, ky/0,0,0,1,1,1,2,2,2/

!					first form the essential elements of Q
      ii = 0
      do 20 j = 1, k2
         ty = dble(j-1)
         do 10 i = 1, k1
            ii = ii + 1
            tx = dble(i-1)
            Q(1,ii) = dcvaa2( dvarfn, Dx, Dy, tx, ty )
  10     continue
  20  continue
!					now distribute into the upper triangle
      kk = k1*k2
      do 40 j = 2, kk
         mxj = mod(j-1,k1)
         myj = (j-1)/k1
         do 30 i = 2, j
            mxi    = mod(i-1,k1)
            myi    = (i-1)/k1
            m      = 1 + iabs(mxj - mxi) + k1*iabs(myj - myi)
            Q(i,j) = Q(1,m)
  30     continue
  40  continue
!					form R (9 x 9)
      if( k1 .lt. 3 .or. k2 .lt. 3 ) then
!						find essential elements of R
         ii = 0
         do 60 j = 1, 3
            ty = dble(j-1)
            do 50 i = 1, 3
               ii = ii + 1
               tx = dble(i-1)
               R(1,ii) = dcvaa2( dvarfn, Dx, Dy, tx, ty )
  50        continue
  60     continue
!						and distribute into upper tri.
         do 70 j = 2, 9
         do 70 i = 2, j
            m  = 1 + iabs(kx(j)-kx(i)) + 3*iabs(ky(j)-ky(i))
            R(i,j) = R(1,m)
  70     continue
      else
!						or extract elements of R from Q
         do 80 j = 1, 9
         do 80 i = 1, j
            m      = 1 + iabs(kx(j)-kx(i)) + k1*iabs(ky(j)-ky(i))
            R(i,j) = Q(1,m)
  80     continue
      endif

      return
      end


module mjl

    ! Note: j values are integer number of half-quanta, i.e. j = 2 x j.
    ! bigJ values are not multiplied by 2, nor are l or n values.

    use norm
    use wigner
    use bessel
    use constants, only: pi
    contains

    function MJ(y,np,lp,jp,n,l,j,bigJ)
        implicit none
        integer, intent(in) :: np,lp,jp,n,l,j,bigJ
        real(kind=8), intent(in) :: y
        real(kind=8) :: Pi = 3.1415926535897932
        real(kind=8) :: MJ

        MJ = (-1d0)**(0.5d0+j/2d0+dble(bigJ))&
            * SQRT(J2norm(j)*J2norm(jp) &
            * Jnorm(l)*Jnorm(lp)*Jnorm(bigJ)/(4*Pi)) &
              * threej_lookup(2*lp,2*bigJ,2*l,0,0,0) &
              * sixj_lookup(2*lp,jp,1,j,2*l,2*bigJ)  &
              * BesselElement(y,np,lp,n,l,bigJ)

    end function MJ

    function MJLDivQoverall(lp,jp,l,j,bigJ,bigL)
        implicit none
        integer, intent(in) :: lp,jp,l,j,bigJ,bigL
        real(kind=8) :: MJLDivQoverall

        MJLDivQoverall = (-1.0)**(bigL+(j+1)/2)* Qnorm(lp) * q2norm(jp) &
            * q2norm(j)*Qnorm(bigJ)*Qnorm(bigL) &
            * sixj_lookup(2*lp,jp,1,j,2*l,2*bigJ)/SQRT(4d0*Pi)

    end function MJLDivQoverall

    function MJLDivQsummand1(y,np,lp,n,l,bigJ,bigL)
        implicit none
        integer, intent(in) :: np,lp,n,l,bigJ,bigL
        real(kind=8), intent(in) :: y
        real(kind=8) :: MJLDivQsummand1

        MJLDivQsummand1 = -SQRT(l+1d0)*Qnorm(l+1) &
            * sixj_lookup(2*bigL,2,2*bigJ,2*l,2*lp,2*(l+1)) &
            * threej_lookup(2*lp,2*bigL,2*(l+1),0,0,0) &
            * BesselElementminus(y,np,lp,n,l,bigL)

    end function MJLDivQsummand1

    function MJLDivQsummand2(y,np,lp,n,l,bigJ,bigL)
        implicit none
        integer, intent(in) :: np,lp,n,l,bigJ,bigL
        real(kind=8), intent(in) :: y
        real(kind=8) :: MJLDivQsummand2

        if (l.eq.0) then ! O.C.G: avoid Qnorm(-1)
            MJLDivQsummand2 = 0d0
        else
            MJLDivQsummand2 = SQRT(dble(l))*Qnorm(l-1) &
                * sixj_lookup(2*bigL,2,2*bigJ,2*l,2*lp,2*(l-1))  &
                * threej_lookup(2*lp,2*bigL,2*(l-1),0,0,0) &
                * BesselElementplus(y,np,lp,n,l,bigL)
        endif

    end function MJLDivQsummand2

    function MJLDivQ(y,np,lp,jp,n,l,j,bigJ,bigL)
        implicit none
        integer, intent(in) :: np,lp,jp,n,l,j,bigJ,bigL
        real(kind=8), intent(in) :: y
        real(kind=8) :: MJLDivQ

        MJLDivQ = MJLDivQoverall(lp,jp,l,j,bigJ,bigL) &
            * (MJLDivQsummand1(y,np,lp,n,l,bigJ,bigL) &
            + MJLDivQsummand2(y,np,lp,n,l,bigJ,bigL))

    end function MJLDivQ

end module mjl


	FUNCTION PS_RICH  ( datain, nparm, clev, ivcord )
C************************************************************************
C* PS_RICH								*
C*									*
C* This function computes the Richardson number for a layer.		*
C*									*
C*		RICH = BFVQ ** 2 / SHRM ** 2				*
C*									*
C* REAL PS_RICH  ( DATAIN, NPARM, CLEV, IVCORD )			*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARM,*)	REAL		Station data			*
C*	NPARM		INTEGER		Number of data set parameters	*
C*	CLEV		REAL		Vertical level			*
C*	IVCORD		INTEGER 	Vertical coordinate number	*
C*									*
C* Output parameters:							*
C*	PS_RICH		REAL		Richardson number		*
C**									*
C* Log:									*
C* K. Brill/NMC		 7/90						*
C* T. Lee/GSC		 8/97	Changed default depth to RMISSD		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL            datain (*)
C*
	REAL    	stndb (10), stndt (10), stndl (10)
	CHARACTER       cvalue*20
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------------
	PS_RICH = RMISSD
C
C*	Get information over a depth.
C
	dfdpth = RMISSD
	idfcrd = 3
	CALL PC_DPTH  ( datain, nparm, clev, ivcord, dfdpth, idfcrd, 1,
     +			depth, idcord, stndl, stndb, stndt, ier )
C
C*	Check for missing data.
C
	IF  ( ier .ne. 0 )  RETURN
	DO  i = 1, 6
	    IF ( i .ne. 3 ) THEN
		IF  ( ERMISS ( stndt (i) ) .or. ERMISS ( stndb (i) ) )
     +					RETURN
	    END IF
	END DO
	depth = stndt (6) - stndb (6)
	IF  ( depth .eq. 0.0 )  RETURN
C*
	thtop = PR_THTA ( stndt (2), stndt (1) )
	thbot = PR_THTA ( stndb (2), stndb (1) )
        theta = .5 * ( thtop + thbot )
        bvfsqd = ( GRAVTY / theta ) * ( thtop - thbot ) / depth
C*
	CALL PC_GCND ( '$', 1, dir, cvalue, ier )
	utop = stndt (4)
	vtop = stndt (5)
	ubot = stndb (4)
	vbot = stndb (5)
	IF ( ier .ne. 0 ) THEN
	    dudz = ( utop - ubot ) / depth
	    dvdz = ( vtop - vbot ) / depth
	    shrsqd = ( dudz * dudz + dvdz * dvdz )
	  ELSE
	    alpha = ( 270. - dir ) * DTR
	    uutop = utop * COS ( alpha ) + vtop * SIN ( alpha )
	    uubot = ubot * COS ( alpha ) + vbot * SIN ( alpha )
	    dudz = ( uutop - uubot ) / depth
	    shrsqd = dudz * dudz
	END IF
	IF  ( shrsqd .eq. 0.0 )  RETURN
C*
	PS_RICH = bvfsqd / shrsqd
C*
	RETURN
	END


!
!     file thwsssp.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     program to illustrate the use of hwsssp
!
program test_hwsssp

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter     :: M = 18, N = 72
    integer(ip), parameter     :: MP1 = M + 1, NP1 = N + 1
    integer(ip), parameter     :: IDIMF = MP1
    integer(ip)                :: mbdcnd, nbdcnd, i, j, ierror
    real(wp)                   :: f(IDIMF, NP1), sint(IDIMF)
    real(wp), dimension(NP1)   :: bdtf, bdts, bdps, bdpf, sinp
    real(wp)                   :: ts, tf, ps, pf, elmbda
    real(wp)                   :: dtheta, dphi, pertrb
    real(wp)                   :: ZERO = 0.0_wp

    ! Set domain
    ts = ZERO
    tf = HALF_PI
    ps = ZERO
    pf = TWO_PI

    ! Set boundary conditions
    nbdcnd = 0
    mbdcnd = 6

    ! Set helmholtz constant
    elmbda = ZERO

    ! Set mesh sizes
    dtheta = tf/M
    dphi = TWO_PI/N

    ! Generate sines for use in subsequent computations
    do i = 1, MP1
        sint(i) = sin(real(i - 1, kind=wp) * dtheta)
    end do

    do j = 1, NP1
        sinp(j) = sin(real(j - 1, kind=wp) * dphi)
    end do

    ! Compute right hand side of equation and store in f
    block
        real(wp), parameter :: TWO = 2.0_wp
        real(wp), parameter :: SIX = 6.0_wp

        do j = 1, NP1
            f(:MP1, j) = TWO - SIX * (sint(:MP1)*sinp(j))**2
        end do
    end block

    ! Store derivative data at the equator
    bdtf(:NP1) = ZERO

    ! Solve 2D Helmholtz in spherical coordinates on a centered grid
    call hwsssp(ts, tf, M, mbdcnd, bdts, bdtf, ps, pf, N, nbdcnd, &
        bdps, bdpf, elmbda, f, IDIMF, pertrb, ierror)

    ! Compute discretization error.
    ! Since problem is singular, the solution must be normalized.
    block
        real(wp), parameter :: KNOWN_ERROR = 0.338107338525839e-2_wp
        real(wp) :: discretization_error, exact_solution(MP1, NP1)

        do j = 1, NP1
            do i = 1, MP1
                exact_solution(i,j) = (sint(i)*sinp(j))**2 - f(1, 1)
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:MP1,:NP1)))

        call check_output('hwsssp', ierror, KNOWN_ERROR, discretization_error)
    end block

end program test_hwsssp


program Test_Stddev
  implicit none

  real, dimension(8) :: v = (/ 2,4,4,4,5,5,7,9 /)
  integer :: i
  real :: sd

  do i = 1, size(v)
     sd = stat_object(v(i))
  end do

  print *, "std dev = ", sd

contains

  recursive function stat_object(a, cmd) result(stddev)
    real :: stddev
    real, intent(in) :: a
    character(len=*), intent(in), optional :: cmd

    real, save :: summa = 0.0, summa2 = 0.0
    integer, save :: num = 0

    real :: m

    if ( .not. present(cmd) ) then
       num = num + 1
       summa = summa + a
       summa2 = summa2 + a*a
       stddev = stat_object(0.0, "stddev")
    else
       select case(cmd)
       case("stddev")
          stddev = sqrt(stat_object(0.0, "variance"))
       case("variance")
          m = stat_object(0.0, "mean")
          if ( num > 0 ) then
             stddev = summa2/real(num) - m*m
          else
             stddev = 0.0
          end if
       case("count")
          stddev = real(num)
       case("mean")
          if ( num > 0 ) then
             stddev = summa/real(num)
          else
             stddev = 0.0
          end if
       case("reset")
          summa = 0.0
          summa2 = 0.0
          num = 0
       case default
          stddev = 0.0
       end select
    end if

  end function stat_object

end program Test_Stddev