program factorial ! by @urbanjost
use, intrinsic :: iso_fortran_env, only : wp=>real64
integer, parameter :: n(*)=[0,1,5,11,170]
integer            :: j
   do j=1,size(n)
      write(*,'(*(g0,1x))')'factorial of', n(j),' is ', &
       & product([(real(i,kind=wp),i=1,n(j))]),         &
       & ' or ',                                        &
       & gamma(real(n(j)+1,kind=wp))
   enddo
end program factorial
! output:
! factorial of 0  is  1.0000000000000000  or  1.0000000000000000
! factorial of 1  is  1.0000000000000000  or  1.0000000000000000
! factorial of 5  is  120.00000000000000  or  120.00000000000000
! factorial of 11  is  39916800.000000000  or  39916800.000000000
! factorial of 170  is  0.72574156153079940E+307  or  0.72574156153080003E+307


c----------------------------------------------------------------
c----------------------------------------------------------------
c--- The car axis problem of radau
c----------------------------------------------------------------
c----------------------------------------------------------------

c -------- radaudae.f -> radaudae.dll ------
c compile in R with: system("g77 -shared -o radaudae.dll radaudae.f")
c or with system("R CMD SHLIB radaudae.f")

c----------------------------------------------------------------
c Initialiser for parameter common block
c----------------------------------------------------------------
      subroutine initcaraxis(daeparms)

      external daeparms
      integer, parameter :: N = 8
      double precision parms(N)
      common /myparms/parms

      call daeparms(N, parms)
      return
      end

c----------------------------------------------------------------
c rate of change
c----------------------------------------------------------------
      subroutine caraxis(neq, t, y, ydot, out, ip)
      implicit none
      integer          neq, IP(*)
      double precision t, y(neq), ydot(neq), out(*)
      double precision eps, M, k, L, L0, r, w, g
      common /myparms/ eps, M, k, L, L0, r, w, g

      double precision xl, yl, xr, yr, ul, vl, ur, vr, lam1, lam2
      double precision yb, xb, Ll, Lr, dxl, dyl, dxr, dyr
      double precision dul, dvl, dur, dvr, c1, c2

c expand state variables
       xl = y(1)
       yl = y(2)
       xr = y(3)
       yr = y(4)
       ul = y(5)
       vl = y(6)
       ur = y(7)
       vr = y(8)
       lam1 = y(9)
       lam2 = y(10)

       yb = r * sin(w * t)
       xb = sqrt(L * L - yb * yb)
       Ll = sqrt(xl**2 + yl**2)
       Lr = sqrt((xr - xb)**2 + (yr - yb)**2)

       dxl = ul
       dyl = vl
       dxr = ur
       dyr = vr

       dul = (L0-Ll) * xl/Ll      + 2 * lam2 * (xl-xr) + lam1*xb
       dvl = (L0-Ll) * yl/Ll      + 2 * lam2 * (yl-yr) + lam1*yb - k*g
       dur = (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr)
       dvr = (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k*g

       c1  = xb * xl + yb * yl
       c2  = (xl - xr)**2 + (yl - yr)**2 - L * L

c function values in ydot
       ydot(1)  = dxl
       ydot(2)  = dyl
       ydot(3)  = dxr
       ydot(4)  = dyr
       ydot(5)  = dul
       ydot(6)  = dvl
       ydot(7)  = dur
       ydot(8)  = dvr
       ydot(9)  = c1
       ydot(10) = c2
      return
      end


      SUBROUTINE qgaus(func,a,b,ss)
      REAL a,b,ss,func
      EXTERNAL func
      INTEGER j
      REAL dx,xm,xr,w(5),x(5)
      SAVE w,x
      DATA w/.2955242247,.2692667193,.2190863625,.1494513491,
     *.0666713443/
      DATA x/.1488743389,.4333953941,.6794095682,.8650633666,
     *.9739065285/
      xm=0.5*(b+a)
      xr=0.5*(b-a)
      ss=0
      do 11 j=1,5
        dx=xr*x(j)
        ss=ss+w(j)*(func(xm+dx)+func(xm-dx))
11    continue
      ss=xr*ss
      return
      END

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


Subroutine minors(A, n, ans)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A
	Double Precision, Dimension(n, n), Intent(Out) :: ans
	Double Precision, Dimension(n-1, n-1):: tmp
	Integer :: i, j, p, q

	Do i = 1, n
		Do j = 1, n
			tmp = A([(p, p=1,i-1), (p, p=i+1,n)], [(p, p=1,j-1), (p, p=j+1,n)])
			Call det(tmp, n-1, ans(i, j))
		End Do
	End Do

End Subroutine minors


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine tridiagonal(a,b,n,m,lda)
!
!     solves a tridiagonal system of equations a*x=b with
!     n equations. The off-diagonals are in symmetric positions
!     about the main diagonal and m entries away; the matrix does
!     not have to be symmetric
!
!     the first line contains the elements a(1,1) and a(1,1+m)
!     the last line contains the elements a(n,n-m),a(n,n)
!
!     storage:
!       left diagonal in a(*,1)
!       main diagonal in a(*,2)
!       right diagonal in a(*,3)
!
!     INPUT:
!
!     a                  tridiagonal matrix
!     b                  right hand side
!     n                  number of rows and columns of a
!     m                  shift of the off-diagonals compared
!                        to the main diagonal
!     lda                leading dimension of a
!
!     OUTPUT
!
!     b                  solution
!
      implicit none
!
      integer k,n,m,lda
!
      real*8 a(lda,3),b(n),y
!
      intent(in) n,m,lda
!
      intent(inout) a,b
!
!     Gaussian elimination: all values below the
!     diagonal are set to zero, the diagonal values set to 1
!
!     only the unknown values a(*,3) and b(*) are calculated
!
      do k=1,m
         a(k,3)=a(k,3)/a(k,2)
         b(k)=b(k)/a(k,2)
      enddo
!
      do k=m+1,n-m
         y=1.d0/(a(k-m,3)*a(k,1)-a(k,2))
         a(k,3)=-a(k,3)*y
         b(k)=(b(k-m)*a(k,1)-b(k))*y
      enddo
!
      do k=n-m+1,n
         a(k,2)=a(k-m,3)*a(k,1)-a(k,2)
         b(k)=(b(k-m)*a(k,1)-b(k))/a(k,2)
      enddo
!
!     back substitution
!
      do k=n-m,1,-1
         b(k)=b(k)-a(k,3)*b(k+m)
      enddo
!
      return
      end


      double precision function psi(blockno,xc,yc,t)
      implicit none

      double precision xc, yc, t
      integer blockno
      double precision pi, alpha
      double precision revs_per_s
      integer*8 cont, get_context

      double precision xc1, yc1, zc1, pi2
      integer example

      common /compi/ pi
      common /toruscomm/ alpha
      common /excomm_example/ example

      cont = get_context()

c     # (xc,yc) in each block is in [0,1]x[0,1].  This call maps
c     # maps that point to subregion of this unit domain, according
c     # to what brick the point occupies.  For example, in a 2x2 brick
c     # arrangement, the point (0.5,0.5) in brick 0 gets mapped to (0.25
c     #(0.25,0.25).  The same point in brick 2 gets mapped to
c     # (0.25,0.75).

      call fclaw2d_map_brick2c(cont,
     &      blockno,xc,yc,xc1,yc1,zc1)

      revs_per_s = 0.5d0

      pi2 = 2*pi

      if (example .eq. 0) then
c        # Rigid body rotation
         psi = (pi2*revs_per_s)*alpha*
     &         (pi2*yc1 + alpha*sin(pi2*yc1))
      elseif (example .eq. 1) then
c        # Twisted torus stream function (to be used with usual torus map)
         psi = (pi2*revs_per_s)*alpha*
     &         (pi2*(xc1+yc1) + alpha*sin(pi2*(xc1+yc1)))
      endif

c      psi = psi

      end

      subroutine get_vel_psi_comp(blockno,xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(2),xd2(2), ds, vn, psi,t
      integer blockno

      vn = (psi(blockno,xd1(1),xd1(2),t) -
     &      psi(blockno,xd2(1),xd2(2),t))/ds

      end


module perfect_numbers
  implicit none

contains

  character(len=9) function classify(num)
    integer, intent(in) :: num
    integer :: rest
    integer :: i
    integer :: aliquot_sum
    classify = "ERROR"
    ! reject negative numbers
    if (num<=0)then
      return
    endif
    if (num==1)then
      ! Edge case (no factors other than itself) is classified correctly
      classify = "deficient"
      return
    endif
    aliquot_sum = 1
    ! get_divisors
    do i=2,num/2
      rest = mod(num,i)
      if (rest==0)then
        ! is divisor
        !write(*,*) 'DIV', num, i
        aliquot_sum = aliquot_sum+i
      endif
    enddo
    !write(*,*) 'aliquot_sum', num, aliquot_sum

    if (aliquot_sum==num) then
      classify = "perfect"
    else if (aliquot_sum>num) then
      classify = "abundant"
    else if (aliquot_sum<num) then
      classify = "deficient"
    end if

  end function

end module


*DECK DBSKIN
      SUBROUTINE DBSKIN (X, N, KODE, M, Y, NZ, IERR)
C***BEGIN PROLOGUE  DBSKIN
C***PURPOSE  Compute repeated integrals of the K-zero Bessel function.
C***LIBRARY   SLATEC
C***CATEGORY  C10F
C***TYPE      DOUBLE PRECISION (BSKIN-S, DBSKIN-D)
C***KEYWORDS  BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL,
C             INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         The following definitions are used in DBSKIN:
C
C     Definition 1
C         KI(0,X) = K-zero Bessel function.
C
C     Definition 2
C         KI(N,X) = Bickley Function
C                 =  integral from X to infinity of KI(N-1,t)dt
C                     for X .ge. 0 and N = 1,2,...
C  _____________________________________________________________________
C    DBSKIN computes a sequence of Bickley functions (repeated integrals
C    of the K0 Bessel function); i.e. for fixed X and N and for K=1,...,
C    DBSKIN computes the sequence
C
C                     Y(K) =         KI(N+K-1,X) for KODE=1
C          or
C                     Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2,
C
C         for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously).
C
C      INPUT      X is DOUBLE PRECISION
C        X      - Argument, X .ge. 0.0D0
C        N      - Order of first member of the sequence N .ge. 0
C        KODE   - Selection parameter
C             KODE = 1 returns Y(K)=        KI(N+K-1,X), K=1,M
C                  = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M
C        M      - Number of members in the sequence, M.ge.1
C
C       OUTPUT     Y is a DOUBLE PRECISION VECTOR
C         Y      - A vector of dimension at least M containing the
C                  sequence selected by KODE.
C         NZ     - Underflow flag
C                  NZ = 0 means computation completed
C                     = 1 means an exponential underflow occurred on
C                         KODE=1.  Y(K)=0.0D0, K=1,...,M is returned
C                         KODE=1 AND Y(K)=0.0E0, K=1,...,M IS RETURNED
C         IERR   - Error flag
C                    IERR=0, Normal return, computation completed
C                    IERR=1, Input error,   no computation
C                    IERR=2, Error,         no computation
C                            Algorithm termination condition not met
C
C         The nominal computational accuracy is the maximum of unit
C         roundoff (=D1MACH(4)) and 1.0D-18 since critical constants
C         are given to only 18 digits.
C
C         BSKIN is the single precision version of DBSKIN.
C
C *Long Description:
C
C         Numerical recurrence on
C
C      (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X)
C
C         is stable where recurrence is carried forward or backward
C         away from INT(X+0.5).  The power series for indices 0,1 and 2
C         on 0.le.X.le.2 starts a stable recurrence for indices
C         greater than 2.  If N is sufficiently large (N.gt.NLIM), the
C         uniform asymptotic expansion for N to INFINITY is more
C         economical.  On X.gt.2 the recursion is started by evaluating
C         the uniform expansion for the three members whose indices are
C         closest to INT(X+0.5) within the set N,...,N+M-1.  Forward
C         recurrence, backward recurrence or both complete the
C         sequence depending on the relation of INT(X+0.5) to the
C         indices N,...,N+M-1.
C
C***REFERENCES  D. E. Amos, Uniform asymptotic expansions for
C                 exponential integrals E(N,X) and Bickley functions
C                 KI(N,X), ACM Transactions on Mathematical Software,
C                 1983.
C               D. E. Amos, A portable Fortran subroutine for the
C                 Bickley functions KI(N,X), Algorithm 609, ACM
C                 Transactions on Mathematical Software, 1983.
C***ROUTINES CALLED  D1MACH, DBKIAS, DBKISR, DEXINT, DGAMRN, I1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891009  Removed unreferenced statement label.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBSKIN
      INTEGER I, ICASE, IERR, IL, I1M, K, KK, KODE, KTRMS, M,
     * M3, N, NE, NFLG, NL, NLIM, NN, NP, NS, NT, NZ
      INTEGER I1MACH
      DOUBLE PRECISION A, ENLIM, EXI, FN, GR, H, HN, HRTPI, SS, TOL,
     * T1, T2, W, X, XLIM, XNLIM, XP, Y, YS, YSS
      DOUBLE PRECISION DGAMRN, D1MACH
      DIMENSION EXI(102), A(50), YS(3), YSS(3), H(31), Y(*)
      SAVE A, HRTPI
C-----------------------------------------------------------------------
C             COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS
C-----------------------------------------------------------------------
      DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), A(8), A(9), A(10),
     * A(11), A(12), A(13), A(14), A(15), A(16), A(17), A(18), A(19),
     * A(20), A(21), A(22), A(23), A(24) /1.00000000000000000D+00,
     * 5.00000000000000000D-01,3.75000000000000000D-01,
     * 3.12500000000000000D-01,2.73437500000000000D-01,
     * 2.46093750000000000D-01,2.25585937500000000D-01,
     * 2.09472656250000000D-01,1.96380615234375000D-01,
     * 1.85470581054687500D-01,1.76197052001953125D-01,
     * 1.68188095092773438D-01,1.61180257797241211D-01,
     * 1.54981017112731934D-01,1.49445980787277222D-01,
     * 1.44464448094367981D-01,1.39949934091418982D-01,
     * 1.35833759559318423D-01,1.32060599571559578D-01,
     * 1.28585320635465905D-01,1.25370687619579257D-01,
     * 1.22385671247684513D-01,1.19604178719328047D-01,
     * 1.17004087877603524D-01/
      DATA A(25), A(26), A(27), A(28), A(29), A(30), A(31), A(32),
     * A(33), A(34), A(35), A(36), A(37), A(38), A(39), A(40), A(41),
     * A(42), A(43), A(44), A(45), A(46), A(47), A(48)
     * /1.14566502713486784D-01,1.12275172659217048D-01,
     * 1.10116034723462874D-01,1.08076848895250599D-01,
     * 1.06146905164978267D-01,1.04316786110409676D-01,
     * 1.02578173008569515D-01,1.00923686347140974D-01,
     * 9.93467537479668965D-02,9.78414999033007314D-02,
     * 9.64026543164874854D-02,9.50254735405376642D-02,
     * 9.37056752969190855D-02,9.24393823875012600D-02,
     * 9.12230747245078224D-02,9.00535481254756708D-02,
     * 8.89278787739072249D-02,8.78433924473961612D-02,
     * 8.67976377754033498D-02,8.57883629175498224D-02,
     * 8.48134951571231199D-02,8.38711229887106408D-02,
     * 8.29594803475290034D-02,8.20769326842574183D-02/
      DATA A(49), A(50) /8.12219646354630702D-02,8.03931690779583449D-02
     * /
C-----------------------------------------------------------------------
C             SQRT(PI)/2
C-----------------------------------------------------------------------
      DATA HRTPI /8.86226925452758014D-01/
C
C***FIRST EXECUTABLE STATEMENT  DBSKIN
      IERR = 0
      NZ=0
      IF (X.LT.0.0D0) IERR=1
      IF (N.LT.0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (M.LT.1) IERR=1
      IF (X.EQ.0.0D0 .AND. N.EQ.0) IERR=1
      IF (IERR.NE.0) RETURN
      IF (X.EQ.0.0D0) GO TO 300
      I1M = -I1MACH(15)
      T1 = 2.3026D0*D1MACH(5)*I1M
      XLIM = T1 - 3.228086D0
      T2 = T1 + (N+M-1)
      IF (T2.GT.1000.0D0) XLIM = T1 - 0.5D0*(LOG(T2)-0.451583D0)
      IF (X.GT.XLIM .AND. KODE.EQ.1) GO TO 320
      TOL = MAX(D1MACH(4),1.0D-18)
      I1M = I1MACH(14)
C-----------------------------------------------------------------------
C     LN(NLIM) = 0.125*LN(EPS),   NLIM = 2*KTRMS+N
C-----------------------------------------------------------------------
      XNLIM = 0.287823D0*(I1M-1)*D1MACH(5)
      ENLIM = EXP(XNLIM)
      NLIM = INT(ENLIM) + 2
      NLIM = MIN(100,NLIM)
      NLIM = MAX(20,NLIM)
      M3 = MIN(M,3)
      NL = N + M - 1
      IF (X.GT.2.0D0) GO TO 130
      IF (N.GT.NLIM) GO TO 280
C-----------------------------------------------------------------------
C     COMPUTATION BY SERIES FOR 0.LE.X.LE.2
C-----------------------------------------------------------------------
      NFLG = 0
      NN = N
      IF (NL.LE.2) GO TO 60
      M3 = 3
      NN = 0
      NFLG = 1
   60 CONTINUE
      XP = 1.0D0
      IF (KODE.EQ.2) XP = EXP(X)
      DO 80 I=1,M3
        CALL DBKISR(X, NN, W, IERR)
      IF(IERR.NE.0) RETURN
        W = W*XP
        IF (NN.LT.N) GO TO 70
        KK = NN - N + 1
        Y(KK) = W
   70   CONTINUE
        YS(I) = W
        NN = NN + 1
   80 CONTINUE
      IF (NFLG.EQ.0) RETURN
      NS = NN
      XP = 1.0D0
   90 CONTINUE
C-----------------------------------------------------------------------
C     FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2
C-----------------------------------------------------------------------
      FN = NS - 1
      IL = NL - NS + 1
      IF (IL.LE.0) RETURN
      DO 110 I=1,IL
        T1 = YS(2)
        T2 = YS(3)
        YS(3) = (X*(YS(1)-YS(3))+(FN-1.0D0)*YS(2))/FN
        YS(2) = T2
        YS(1) = T1
        FN = FN + 1.0D0
        IF (NS.LT.N) GO TO 100
        KK = NS - N + 1
        Y(KK) = YS(3)*XP
  100   CONTINUE
        NS = NS + 1
  110 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     COMPUTATION BY ASYMPTOTIC EXPANSION FOR X.GT.2
C-----------------------------------------------------------------------
  130 CONTINUE
      W = X + 0.5D0
      NT = INT(W)
      IF (NL.GT.NT) GO TO 270
C-----------------------------------------------------------------------
C     CASE NL.LE.NT, ICASE=0
C-----------------------------------------------------------------------
      ICASE = 0
      NN = NL
      NFLG = MIN(M-M3,1)
  140 CONTINUE
      KK = (NLIM-NN)/2
      KTRMS = MAX(0,KK)
      NS = NN + 1
      NP = NN - M3 + 1
      XP = 1.0D0
      IF (KODE.EQ.1) XP = EXP(-X)
      DO 150 I=1,M3
        KK = I
        CALL DBKIAS(X, NP, KTRMS, A, W, KK, NE, GR, H, IERR)
      IF(IERR.NE.0) RETURN
        YS(I) = W
        NP = NP + 1
  150 CONTINUE
C-----------------------------------------------------------------------
C     SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD
C-----------------------------------------------------------------------
      IF (KTRMS.EQ.0) GO TO 160
      NE = KTRMS + KTRMS + 1
      NP = NN - M3 + 2
      CALL DEXINT(X, NP, 2, NE, TOL, EXI, NZ, IERR)
      IF (NZ.NE.0) GO TO 320
  160 CONTINUE
      DO 190 I=1,M3
        SS = 0.0D0
        IF (KTRMS.EQ.0) GO TO 180
        KK = I + KTRMS + KTRMS - 2
        IL = KTRMS
        DO 170 K=1,KTRMS
          SS = SS + A(IL)*EXI(KK)
          KK = KK - 2
          IL = IL - 1
  170   CONTINUE
  180   CONTINUE
        YS(I) = YS(I) + SS
  190 CONTINUE
      IF (ICASE.EQ.1) GO TO 200
      IF (NFLG.NE.0) GO TO 220
  200 CONTINUE
      DO 210 I=1,M3
        Y(I) = YS(I)*XP
  210 CONTINUE
      IF (ICASE.EQ.1 .AND. NFLG.EQ.1) GO TO 90
      RETURN
  220 CONTINUE
C-----------------------------------------------------------------------
C     BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2
C-----------------------------------------------------------------------
      KK = NN - N + 1
      K = M3
      DO 230 I=1,M3
        Y(KK) = YS(K)*XP
        YSS(I) = YS(I)
        KK = KK - 1
        K = K - 1
  230 CONTINUE
      IL = KK
      IF (IL.LE.0) GO TO 250
      FN = NN - 3
      DO 240 I=1,IL
        T1 = YS(2)
        T2 = YS(1)
        YS(1) = YS(2) + ((FN+2.0D0)*YS(3)-(FN+1.0D0)*YS(1))/X
        YS(2) = T2
        YS(3) = T1
        Y(KK) = YS(1)*XP
        KK = KK - 1
        FN = FN - 1.0D0
  240 CONTINUE
  250 CONTINUE
      IF (ICASE.NE.2) RETURN
      DO 260 I=1,M3
        YS(I) = YSS(I)
  260 CONTINUE
      GO TO 90
  270 CONTINUE
      IF (N.LT.NT) GO TO 290
C-----------------------------------------------------------------------
C     ICASE=1, NT.LE.N.LE.NL WITH FORWARD RECURSION
C-----------------------------------------------------------------------
  280 CONTINUE
      NN = N + M3 - 1
      NFLG = MIN(M-M3,1)
      ICASE = 1
      GO TO 140
C-----------------------------------------------------------------------
C     ICASE=2, N.LT.NT.LT.NL WITH BOTH FORWARD AND BACKWARD RECURSION
C-----------------------------------------------------------------------
  290 CONTINUE
      NN = NT + 1
      NFLG = MIN(M-M3,1)
      ICASE = 2
      GO TO 140
C-----------------------------------------------------------------------
C     X=0 CASE
C-----------------------------------------------------------------------
  300 CONTINUE
      FN = N
      HN = 0.5D0*FN
      GR = DGAMRN(HN)
      Y(1) = HRTPI*GR
      IF (M.EQ.1) RETURN
      Y(2) = HRTPI/(HN*GR)
      IF (M.EQ.2) RETURN
      DO 310 K=3,M
        Y(K) = FN*Y(K-2)/(FN+1.0D0)
        FN = FN + 1.0D0
  310 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     UNDERFLOW ON KODE=1, X.GT.XLIM
C-----------------------------------------------------------------------
  320 CONTINUE
      NZ=M
      DO 330 I=1,M
        Y(I) = 0.0D0
  330 CONTINUE
      RETURN
      END


      	Program integrate
      	Implicit none
c declarations
      	Real*8 trapez, simpson, quad, r1, r2, r3
      	Real*8 theo, vmin, vmax
      	Integer i,j, id(8)
	data id/2, 10, 20, 40, 80, 160, 320, 640/
c
c theoretical result, integration range
      	theo = 0.632120558829
c	theo = dexp(1.0D0)
c	theo = theo - 1.d0/theo
      	vmin=0.0
      	vmax=1.0
c     	Open(6, File='integ.dat', Status='Unknown')
c calculate integral using both methods for steps = 3..501
        Do 50 j=1, 8
	  i = id(j) + 1
          r1=trapez(i, vmin, vmax)
          r1=abs(r1-theo)
          r2=simpson(i,vmin, vmax)
          r2=abs(r2-theo)
          r3=quad(i,vmin, vmax)
          r3=abs(r3-theo)
C         write(6,100) i, log10(r1), log10(r2), log10(r3)
          write(6,100) i, r1, r2, r3
 50   Continue
 	Close(6)
      	Stop 'data saved in integ.dat'
C100     format(1x,i7,1x,3f12.5)
100     format(1x,i7,1x,3e13.4)
      	End
c
c the function we want to integrate
      	Function f(x)
      	Implicit none
      	Real*8 f, x
          f=dexp(-x)
       	Return
      	End
c
c trapezoid rule
      	Function trapez(i, min, max)
      	Implicit none
      	Integer i, n
      	Real*8 f, interval, min, max, trapez, x
      	trapez=0
      	interval = ((max-min) / (i-1))
c sum the midpoints
      	Do 21 n=2, (i-1)
          x = interval * (n-1) + min
          trapez = trapez + f(x)*interval
 21   	Continue
c add the endpoints
      	trapez = trapez+0.5*(f(min)+f(max))*interval
        Return
      	End
c
c Simpson's rule
      	Function simpson(i, min, max)
      	Implicit none
      	Integer i, n
      	Real*8 f, interval, min, max, simpson, x
      	simpson=0
      	interval = ((max-min) / (i-1))
c loop for odd points
      	Do 31 n=2, (i-1), 2
          x = interval * (n-1) + min
          simpson = simpson + 4*f(x)
 31   	Continue
c loop for even points
      	Do 32 n=3, (i-1), 2
          x = interval * (n-1) + min
          simpson = simpson + 2*f(x)
 32   	Continue
c add the endpoints
      	simpson = simpson+f(min)+f(max)
      	simpson=simpson*interval/3
        Return
      	End
c
c Gauss' rule
      	Function quad(i, min, max)
      	Implicit none
      	Real*8 w(1000), x(1000)
      	Real*8 f, min, max, quad
      	Integer i, job, n
      	quad=0
      	job=0
      	call gauss(i, job, min, max, x, w)
      	Do 41 n=1, i
          quad=quad+f(x(n))*w(n)
 41   	Continue
      	Return
      	End
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  gauss.f: Points and weights for Gaussian quadrature                 c
c								       c
c  taken from: "Projects in Computational Physics" by Landau and Paez  c
c	       copyrighted by John Wiley and Sons, New York            c
c                                                                      c
c  written by: Oregon State University Nuclear Theory Group            c
c	       Guangliang He & Rubin H. Landau                         c
c  supported by: US National Science Foundation, Northwest Alliance    c
c                for Computational Science and Engineering (NACSE),    c
c                US Department of Energy 	                       c
c								       c
c  comment: error message occurs if subroutine called without a main   c
c  comment: this file has to reside in the same directory as integ.c   c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     rescale rescales the gauss-legendre grid points and weights
c
c     npts     number of points
c     job = 0  rescalling uniformly between (a,b)
c           1  for integral (0,b) with 50% points inside (0, ab/(a+b))
c           2  for integral (a,inf) with 50% inside (a,b+2a)
c     x, w     output grid points and weights.
c
      subroutine gauss(npts,job,a,b,x,w)
      integer npts,job,m,i,j
      real*8 x(npts),w(npts),a,b,xi
      real*8 t,t1,pp,p1,p2,p3,aj
      real*8 eps,pi,zero,two,one,half,quarter
      parameter (pi = 3.14159265358979323846264338328, eps = 3.0E-14)
      parameter (zero=0.0d0,one=1.0d0,two=2.0d0)
      parameter (half=0.5d0,quarter=0.25d0)
c
c *** FIRST EXECTUABLE *************************************************
c

      m=(npts+1)/2
      do 1020 i=1,m
         t=cos(pi*(i-quarter)/(npts+half))
 1000    continue
         p1=one
         p2=zero
         aj=zero
         do 1010 j=1,npts
            p3=p2
            p2=p1
            aj=aj+one
            p1=((two*aj-one)*t*p2-(aj-one)*p3)/aj
 1010    continue
         pp=npts*(t*p1-p2)/(t*t-one)
         t1=t
         t=t1-p1/pp
c
         if(abs(t-t1).gt.eps) goto 1000
c
         x(i)=-t
         x(npts+1-i)=t
         w(i)=two/((one-t*t)*pp*pp)
         w(npts+1-i)=w(i)
 1020 continue
c
c rescale the grid points
      if (job.eq.0) then
c     scale to (a,b) uniformly
         do 1030 i=1,npts
            x(i)=x(i)*(b-a)/two+(b+a)/two
            w(i)=w(i)*(b-a)/two
 1030    continue
      elseif (job.eq.1) then
c scale to (0,b) with 50% points inside (0,ab/(a+b))
         do 1040 i=1,npts
            xi=x(i)
            x(i)=a*b*(one+xi)/(b+a-(b-a)*xi)
            w(i)=w(i)*two*a*b*b/((b+a-(b-a)*xi)*(b+a-(b-a)*xi))
 1040    continue
      elseif (job.eq.2) then
c scale to (a,inf) with 50% points inside (a,b+2a)
         do 1050 i=1,npts
            xi=x(i)
            x(i)=(b*xi+b+a+a)/(one-xi)
            w(i)=w(i)*two*(a+b)/((one-xi)*(one-xi))
 1050    continue
      else
         pause 'Wrong value of job'
      endif
c
      return
      end


	FUNCTION PC_MHGT  ( tb, tt, tdb, tdt, pb, pt, hb )
C************************************************************************
C* PC_MHGT								*
C*									*
C* This function computes the moist hydrostatic height.			*
C*									*
C* REAL PC_MHGT  ( TB, TT, TDB, TDT, PB, PT, HB )			*
C*									*
C* Input parameters:							*
C*	TB		REAL		Bottom temperature		*
C*	TT		REAL		Top temperature			*
C*	TDB		REAL		Bottom dewpoint 		*
C*	TDT		REAL		Top dewpoint 			*
C*	PB		REAL		Bottom pressure			*
C*	PT		REAL		Top pressure			*
C*	HB		REAL		Bottom height			*
C*									*
C* Output parameters:							*
C*	PC_MHGT		REAL		Moist hydrostatic height	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	11/84						*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C* T. Piper/GSC		11/98	Updated prolog				*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ( .not. ERMISS (tb) ) .and. ( .not. ERMISS (tt) ) .and.
     +	      ( .not. ERMISS (pb) ) .and. ( .not. ERMISS (pt) ) .and.
     +	      ( .not. ERMISS (hb) ) .and. ( pt .ne. 0.) )  THEN
	    tvb = PR_TVRK ( tb, tdb, pb )
	    tvt = PR_TVRK ( tt, tdt, pt )
	    tav = ( tvb + tvt ) / 2.0
	    PC_MHGT = hb + RKAP * tav * ALOG ( pb / pt )
	  ELSE
	    PC_MHGT = RMISSD
	END IF
C*
	RETURN
	END


program unity
     real, parameter :: pi = 3.141592653589793
     complex, parameter :: i = (0, 1)
     complex, dimension(0:7-1) :: unit_circle
     integer :: n, j

     do n = 2, 7
          !!!! KEY STEP, does all the calculations in one statement !!!!
        unit_circle(0:n-1) = exp(2*i*pi/n * (/ (j, j=0, n-1) /) )

        write(*,"(i1,a)", advance="no") n, ": "
        write(*,"(sp,2f7.4,a)", advance="no") (unit_circle(j), "j  ", j = 0, n-1)
        write(*,*)
     end do
 end program unity


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file igrades.f
c
c     this file includes documentation and code for
c     subroutine igrades         i
c
c ... files which must be loaded with igradec.f
c
c     sphcom.f, hrfft.f, shses.f,vhaes.f
c
c     subroutine igrades(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,
c    +                   wshses,lshses,work,lwork,ierror)
c
c     let br,bi,cr,ci be the vector spherical harmonic coefficients
c     precomputed by vhaes for a vector field (v,w).  let (v',w') be
c     the irrotational component of (v,w) (i.e., (v',w') is generated
c     by assuming cr,ci are zero and synthesizing br,bi with vhses).
c     then subroutine igrades computes a scalar field sf such that
c
c            gradient(sf) = (v',w').
c
c     i.e.,
c
C*PL*ERROR* Comment line too long
c            v'(i,j) = d(sf(i,j))/dtheta          (colatitudinal component of
c                                                 the gradient)
c     and
c
C*PL*ERROR* Comment line too long
c            w'(i,j) = 1/sint*d(sf(i,j))/dlambda  (east longitudinal component
c                                                 of the gradient)
c
c     at colatitude
c
c            theta(i) = (i-1)*pi/(nlat-1)
c
c     and longitude
c
c            lambda(j) = (j-1)*2*pi/nlon
c
C*PL*ERROR* Comment line too long
c     where sint = sin(theta(i)).  required associated legendre polynomials
C*PL*ERROR* Comment line too long
c     are stored rather than recomputed as they are in subroutine igradec.
c
c     note:  for an irrotational vector field (v,w), subroutine igrades
c     computes a scalar field whose gradient is (v,w).  in ay case,
c     subroutine igrades "inverts" the gradient subroutine grades.
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the scalar field sf is
c            computed on the full or half sphere as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in (v,w) about the equator.  in this case sf
c            is neither symmetric nor antisymmetric about the equator.
c            sf is computed on the entire sphere.  i.e., in the array
c            sf(i,j) for i=1,...,nlat and  j=1,...,nlon
c
c      = 1
c
c            w is antisymmetric and v is symmetric about the equator.
c            in this case sf is antisymmetyric about the equator and
c            is computed for the northern hemisphere only.  i.e.,
c            if nlat is odd sf is computed in the array sf(i,j) for
c            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
c            sf is computed in the array sf(i,j) for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c      = 2
c
c            w is symmetric and v is antisymmetric about the equator.
c            in this case sf is symmetyric about the equator and
c            is computed for the northern hemisphere only.  i.e.,
c            if nlat is odd sf is computed in the array sf(i,j) for
c            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
c            sf is computed in the array sf(i,j) for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c
c     nt     nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields.
C*PL*ERROR* Comment line too long
c            the arrays br,bi, and sf can be three dimensional corresponding
c            to an indexed multiple vector field (v,w).  in this case,
c            multiple scalar synthesis will be performed to compute each
C*PL*ERROR* Comment line too long
c            scalar field.  the third index for br,bi, and sf is the synthesis
c            index which assumes the values k = 1,...,nt.  for a single
c            synthesis set nt = 1.  the description of the remaining
C*PL*ERROR* Comment line too long
c            parameters is simplified by assuming that nt=1 or that br,bi,
c            and sf are two dimensional arrays.
c
c     isf    the first dimension of the array sf as it appears in
c            the program that calls igrades. if isym = 0 then isf
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then isf must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then isf must be at least (nlat+1)/2.
c
c     jsf    the second dimension of the array sf as it appears in
c            the program that calls igrades. jsf must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c            that contain vector spherical harmonic coefficients
c            of the vector field (v,w) as computed by subroutine vhaes.
c     ***    br,bi must be computed by vhaes prior to calling igrades.
c
C*PL*ERROR* Comment line too long
c     mdb    the first dimension of the arrays br and bi as it appears in
c            the program that calls igrades (and vhaes). mdb must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
C*PL*ERROR* Comment line too long
c     ndb    the second dimension of the arrays br and bi as it appears in
c            the program that calls igrades (and vhaes). ndb must be at
c            least nlat.
c
c
c  wshses    an array which must be initialized by subroutine igradesi
c            (or equivalently by subroutine shsesi).  once initialized,
c            wshses can be used repeatedly by igrades as long as nlon
c            and nlat remain unchanged.  wshses must not be altered
c            between calls of igrades.
c
c
c  lshses    the dimension of the array wshses as it appears in the
c            program that calls igrades. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd.
c
c
c            then lshses must be greater than or equal to
c
c               (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls igrades. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            if isym = 0 lwork must be greater than or equal to
c
c               nlat*((nt+1)*nlon+2*nt*l1+1)
c
c            if isym > 0 lwork must be greater than or equal to
c
c               (nt+1)*l2*nlon+nlat*(2*nt*l1+1)
c
c
c
c     **************************************************************
c
c     output parameters
c
c
C*PL*ERROR* Comment line too long
c     sf    a two or three dimensional array (see input parameter nt) that
c           contain a scalar field whose gradient is the irrotational
c           component of the vector field (v,w).  the vector spherical
c           harmonic coefficients br,bi were precomputed by subroutine
c           vhaes.  sf(i,j) is given at the gaussian colatitude theta(i)
c           and longitude lambda(j) = (j-1)*2*pi/nlon.  the index ranges
c           are defined at input parameter isym.
c
c
c  ierror   = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of isf
c           = 6  error in the specification of jsf
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lshses
c           = 10 error in the specification of lwork
c
c **********************************************************************
c
      SUBROUTINE DIGRADES(NLAT,NLON,ISYM,NT,SF,ISF,JSF,BR,BI,MDB,NDB,
     +                   WSHSES,LSHSES,WORK,LWORK,IERROR)
      DOUBLE PRECISION SF
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION WSHSES
      DOUBLE PRECISION WORK
      DIMENSION SF(ISF,JSF,NT)
      DIMENSION BR(MDB,NDB,NT),BI(MDB,NDB,NT)
      DIMENSION WSHSES(LSHSES),WORK(LWORK)
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.ISF.LT.NLAT) .OR.
     +    (ISYM.NE.0.AND.ISF.LT.IMID)) RETURN
      IERROR = 6
      IF (JSF.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+2)/2)
      IF (MDB.LT.MIN0(NLAT, (NLON+1)/2)) RETURN
      IERROR = 8
      IF (NDB.LT.NLAT) RETURN
      IERROR = 9
c
c     verify saved work space length
c
      IMID = (NLAT+1)/2
      LPIMN = (IMID*MMAX* (NLAT+NLAT-MMAX+1))/2
      IF (LSHSES.LT.LPIMN+NLON+15) RETURN
      IERROR = 10
c
c     set minimum and verify unsaved work space
c
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
c
c     set first dimension for a,b (as requried by shses)
c
      MAB = MIN0(NLAT,NLON/2+1)
      MN = MAB*NLAT*NT
      LWKMIN = NLN + LS*NLON + 2*MN + NLAT
      IF (LWORK.LT.LWKMIN) RETURN
      IERROR = 0
c
c     set work space pointers
c
      IA = 1
      IB = IA + MN
      IS = IB + MN
      IWK = IS + NLAT
      LIWK = LWORK - 2*MN - NLAT
      CALL DIGRDES1(NLAT,NLON,ISYM,NT,SF,ISF,JSF,WORK(IA),WORK(IB),MAB,
     +             WORK(IS),MDB,NDB,BR,BI,WSHSES,LSHSES,WORK(IWK),LIWK,
     +             IERROR)
      RETURN
      END

      SUBROUTINE DIGRDES1(NLAT,NLON,ISYM,NT,SF,ISF,JSF,A,B,MAB,SQNN,MDB,
     +                   NDB,BR,BI,WSHSES,LSHSES,WK,LWK,IERROR)
      DOUBLE PRECISION SF
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION SQNN
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION WSHSES
      DOUBLE PRECISION WK
      DOUBLE PRECISION FN
      DIMENSION SF(ISF,JSF,NT)
      DIMENSION BR(MDB,NDB,NT),BI(MDB,NDB,NT),SQNN(NLAT)
      DIMENSION A(MAB,NLAT,NT),B(MAB,NLAT,NT)
      DIMENSION WSHSES(LSHSES),WK(LWK)
c
c     preset coefficient multiplyers in vector
c
      DO 1 N = 2,NLAT
          FN = DBLE(N-1)
          SQNN(N) = 1.0D0/SQRT(FN* (FN+1.D0))
    1 CONTINUE
c
c     set upper limit for vector m subscript
c
      MMAX = MIN0(NLAT, (NLON+1)/2)
c
c     compute multiple scalar field coefficients
c
      DO 2 K = 1,NT
c
c     preset to 0.0
c
          DO 3 N = 1,NLAT
              DO 4 M = 1,MAB
                  A(M,N,K) = 0.0D0
                  B(M,N,K) = 0.0D0
    4         CONTINUE
    3     CONTINUE
c
c     compute m=0 coefficients
c
          DO 5 N = 2,NLAT
              A(1,N,K) = BR(1,N,K)*SQNN(N)
              B(1,N,K) = BI(1,N,K)*SQNN(N)
    5     CONTINUE
c
c     compute m>0 coefficients
c
          DO 6 M = 2,MMAX
              DO 7 N = M,NLAT
                  A(M,N,K) = SQNN(N)*BR(M,N,K)
                  B(M,N,K) = SQNN(N)*BI(M,N,K)
    7         CONTINUE
    6     CONTINUE
    2 CONTINUE
c
c     scalar sythesize a,b into sf
c
      CALL DSHSES(NLAT,NLON,ISYM,NT,SF,ISF,JSF,A,B,MAB,NLAT,WSHSES,
     +           LSHSES,WK,LWK,IERROR)
      RETURN
      END


SUBROUTINE fluxsum(g)

!-------------------------------------------------------------
!
!  Compose the cell center scalar flux solution for each
!   node and group given the individual moments
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: g
INTEGER :: i, j, k, l
REAL*8 :: x, y, px, py

! Start by looping over all nodes
DO j = 1, ny
   ! x and y have values of 0.0 because want cell-center
   ! polynomials defined for each cell i,j individually with origin at center
   y = 0.0
   DO i = 1, nx
      x = 0.0
      DO l = 0, lambda
         ! Use subroutine p to get the value of the Legendre polynomial
         CALL p(l,y,py)
         DO k = 0, lambda
            CALL p(k,x,px)
            ! Compute sum
            phisum(i,j,g) = phisum(i,j,g) + (2.0*k+1.0)*(2.0*l+1.0)*px*py*f(i,j,k,l,g)
         END DO
      END DO
   END DO
END DO

RETURN
END SUBROUTINE fluxsum


module logspace

  use types, only: dp

  implicit none

contains

  impure elemental function log1p(x) result (y)
    real(dp), intent(in) :: x
    real(dp) :: y
    real(dp), volatile :: u, v

    u = 1.0d0 + x
    if (u == 0) then
       y = log(u)
    else
       v = u - 1.0d0
       y = log(u) - (v - x) / u    ! cancels errors with IEEE arithmetic
    end if
  end function log1p

  function logadd(x, y) result (sum)
    real(dp), intent(in) :: x, y
    real(dp) :: sum

    real(dp), parameter :: LOG2 = log(2.0_dp)
    real(dp) :: x_minus_y

    if (x == y) then
       sum = x + LOG2
    else
       x_minus_y = x - y
       if (x_minus_y > 0) then
          sum = x + log1p(exp(-x_minus_y))
       else if (x_minus_y <= 0) then
          sum = y + log1p(exp(x_minus_y))
       else
          sum = x_minus_y
       end if
    end if
  end function logadd

end module logspace


************************************************************************
* This file contains routines to calculate A Posteriori errors.
************************************************************************

************************************************************************
* Calculate A Posteriori H1-error
*
* This routine calculates an approximation to the H1-error using the
* solution of a calculation.
*
* In:
*   DU     - array [1..NVT] of double
*            Solution vector in the vertices of the grid
*   NVT    - Number of vertices in the grid
*   TRIA   - Current triangulation
*
* Out:
*   ERRH1  - array [1..NVT] of double
*            An approximation to the H1-error in every vertex of the
*            triagulation
************************************************************************

      SUBROUTINE ERPCH1(DU,NVT,TRIA,ERRH1)

      IMPLICIT NONE

      INCLUDE 'stria.inc'

      INCLUDE 'cmem.inc'

      INTEGER NVT
      DOUBLE PRECISION DU(NVT)
      INTEGER TRIA(SZTRIA)
      DOUBLE PRECISION ERRH1(*)

C     local variables

      INTEGER LGR1X,LGR1Y,LGR2X,LGR2Y,I

      EXTERNAL E011

C     Allocate auxiliary vectors for gradient information

      CALL ZNEW (NVT,1,LGR1X,'DGR1X ')
      CALL ZNEW (NVT,1,LGR1Y,'DGR1Y ')
      CALL ZNEW (NVT,1,LGR2X,'DGR2X ')
      CALL ZNEW (NVT,1,LGR2Y,'DGR2Y ')

C     The H1-error is defined cellwise as
C
C         | grad(u) - grad(u_h) |_T
C
C     Ok, we don't have the u... instead, we replace grad(u)
C     with grad_2(u_h) with grad_2 being a higher order
C     gradient reconstruction method -- the ZZ-technique.
C     grad(u) we calculate as usual by the first order method.
C
C     Calculate the gradient with standard gradient evaluation

      CALL XGRDR3(TRIA,DU,DWORK(L(LGR1X)),DWORK(L(LGR1Y)),NVT,
     *            E011,.FALSE.)

C     Calculate the gradient with higher-order ZZ-technique

      CALL XGRDR3(TRIA,DU,DWORK(L(LGR2X)),DWORK(L(LGR2Y)),NVT,
     *            E011,.FALSE.)

C     Subtract the solutions

      CALL LLC1 (DWORK(L(LGR1X)),DWORK(L(LGR2X)),NVT,1D0,-1D0)
      CALL LLC1 (DWORK(L(LGR1Y)),DWORK(L(LGR2Y)),NVT,1D0,-1D0)

C     Build the l2-norm in every vertex; this is the approximation
C     to the error

      DO I=0,NVT-1
        ERRH1 (1+I) = SQRT(DWORK(L(LGR1X)+I)**2 + DWORK(L(LGR1Y)+I)**2)
      END DO

C     Release auxiliary vectors

      CALL ZDISP (0,LGR2Y,'DGR2Y ')
      CALL ZDISP (0,LGR2X,'DGR2X ')
      CALL ZDISP (0,LGR1Y,'DGR1Y ')
      CALL ZDISP (0,LGR1X,'DGR1X ')

      END

************************************************************************
* Calculate A Posteriori H1-error from velocity vector
*
* This routine calculates an approximation to the H1-error using the
* solution of a calculation. The solution is assumed to be a 2D
* velocity vector, discretized with Q1~.
*
* In:
*   DU1    - array [1..NU] of double
*            X-velocity
*   DU2    - array [1..NU] of double
*            Y-velocity
*   NU     - Number of velocity components in each velocity
*   TRIA   - Current triangulation
*
* Out:
*   ERRH1  - array [1..NVT] of double
*            An approximation to the H1-error in every vertex of the
*            triagulation
************************************************************************

      SUBROUTINE ERPVH1(DU1,DU2,NU,TRIA,NVT,ERRH1,
     *                  IASMBL,DASMBL,IGEOM,DGEOM)

      IMPLICIT NONE

      INCLUDE 'cmem.inc'

      INCLUDE 'stria.inc'

      INCLUDE 'sassembly.inc'

      INTEGER NU,NVT
      DOUBLE PRECISION DU1(NU),DU2(NU)
      INTEGER TRIA(SZTRIA)
      DOUBLE PRECISION ERRH1(NVT)
      INTEGER IASMBL(*),IGEOM(*)
      DOUBLE PRECISION DASMBL(*),DGEOM(*)

C     local variables

      INTEGER LH1,LH2,LAUX,I
      INTEGER KCORVG,KXNPR
      DOUBLE PRECISION RE
      EXTERNAL UE

C     Allocate auxiliary vectors to calculate the solution in the
C     vertices

      CALL ZNEW (NVT,1,LAUX,'DAUX  ')

C     Interpolate the solution to the vertices.
C     This returns handles LH1, LH2.

      LH1=0
      LH2=0
      CALL XINTUV (DU1,DU2,TRIA,LH1,LH2)

C     Implement boundary conditions, since the interpolation
C     does not correctly handle boundaries:

      KCORVG = L(TRIA(OLCORVG))
      KXNPR  = L(TRIA(OLXNPR))
      RE = DASMBL(ORE)
      CALL BDRCOR (DWORK(L(LH1)),DWORK(L(LH2)),
     *             TRIA,DWORK(KCORVG),
     *             KWORK(KXNPR),UE,1D0,RE,
     *             IASMBL,DASMBL,IGEOM,DGEOM)

C     Calculate the error of each component

      CALL ERPCH1(DWORK(L(LH1)),NVT,TRIA,ERRH1)
      CALL LCP1 (ERRH1,DWORK(L(LH1)),NVT)
      CALL ERPCH1(DWORK(L(LH2)),NVT,TRIA,ERRH1)

C     And add them together using a norm

      DO I=1,NVT
        ERRH1(I) = SQRT(ERRH1(I)**2+DWORK(L(LH1)+I-1)**2)
      END DO

C     Release memory

      CALL ZDISP (0,LAUX,'DAUX  ')
      CALL ZDISP (0,LH2,'DH2   ')
      CALL ZDISP (0,LH1,'DH1   ')

      END

************************************************************************
* Calculate A Posteriori H1-error from velocity vector
*
* This routine calculates an approximation to the H1-error using the
* solution of a calculation. The solution is assumed to be a 2D
* velocity vector, discretized with Q1.
*
* In:
*   DU1    - array [1..NVT] of double
*            X-velocity
*   DU2    - array [1..NVT] of double
*            Y-velocity
*   NVT    - Number of velocity components in each velocity
*            = number of vertices in the triangulation
*   TRIA   - Current triangulation
*
* Out:
*   ERRH1  - array [1..NVT] of double
*            An approximation to the H1-error in every vertex of the
*            triagulation
************************************************************************

      SUBROUTINE ERPQH1(DU1,DU2,NVT,TRIA,ERRH1)

      IMPLICIT NONE

      INCLUDE 'cmem.inc'

      INCLUDE 'stria.inc'

      INCLUDE 'sassembly.inc'

      INTEGER NVT
      DOUBLE PRECISION DU1(NVT),DU2(NVT)
      INTEGER TRIA(SZTRIA)
      DOUBLE PRECISION ERRH1(NVT)

C     local variables

      INTEGER LAUX,I

C     Allocate auxiliary vectors to calculate the solution in the
C     vertices

      CALL ZNEW (NVT,1,LAUX,'DAUX  ')

C     Calculate the error of each component

      CALL ERPCH1(DU1,NVT,TRIA,ERRH1)
      CALL ERPCH1(DU2,NVT,TRIA,DWORK(L(LAUX)))

C     And add them together using a norm

      DO I=1,NVT
        ERRH1(I) = SQRT(ERRH1(I)**2+DWORK(L(LAUX)+I-1)**2)
      END DO

C     Release memory

      CALL ZDISP (0,LAUX,'DAUX  ')

      END


SUBROUTINE productcross(r1,r2 , cp)

! ----------------------------------------------------------------------
! SUBROUTINE: productcross.f90
! ----------------------------------------------------------------------
! Purpose:
!  Cross product between two vectors
! ----------------------------------------------------------------------
! Input arguments:
! - r1 : first vector   [x1 y1 z1]'  (meters)
! - r2 : second vector  [x2 y2 z2]'  (meters)
!
! Output arguments:
! - cp : Cross product of r1,r2 vectors  [x3 y3 z3]'  (meters)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia         24 November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: r1, r2
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(3) :: cp
! ---------------------------------------------------------------------------

      cp(1) = r1(2) * r2(3) - r1(3) * r2(2)

      cp(2) = r1(3) * r2(1) - r1(1) * r2(3)

      cp(3) = r1(1) * r2(2) - r1(2) * r2(1)

END


: quadArc ( xstart xend xpin ypin r )
  DUP NEGATE dx ! 0  dy ! ( xstart xend xpin ypin r )
  2 SWAP 2* - ( xstart xend xpin ypin err )
  BEGIN
	dx @ 0<
  WHILE
	( xstart xend xpin ypin err )
	DUP dy @ <= IF DUP 1+ dy @ 1+ DUP dy ! 2* +
				   dx @ DUP 7 PICK >= SWAP 6 PICK <= AND
				   IF 2 PICK #Ysteps step THEN
				ELSE DUP
				THEN
	( xstart xend xpin ypin err err* )
	SWAP dx @ > OVER dy @ > OR IF 1+ dx @ 1+ DUP dx ! 2* +
								  dx @ DUP 6 PICK >= SWAP 5 PICK <= AND
								  IF 2 PICK #Xsteps step THEN
							   THEN
	( xstart xend  xpin ypin err* )
  REPEAT
  2DROP 2DROP DROP
;

: quadrantBresenham ( xstart xend ystart yend r CW QUAD -- ) \ Bresenham's circle Algorithm
  \ cw 1|0
  \ (x,y)
  \ (y,-x) FIRST-QUAD CW
  \ (-x,y) FIRST-QUAD CCW
  \ (x,y) SECOND-QUAD CW
  \ (-y,-x) SECOND-QUAD CCW
  \ (-y,x) THIRD-QUAD CW
  \ (x,-y) THIRD-QUAD CCW
  \ (y,x) FOURTH-QUAD CW
  \ (-x,-y) FOURTH-QUAD CCW

  ( xstart xend r CW QUAD -- )
  CASE
	1 OF Xm.Dpin ioc! Ym.Dpin ios!
		 0<> ( CW ) IF >R >R >R 2DROP R> R> R>
					   #Ysteps #Xsteps TO #Ysteps TO #Xsteps
					   Ym.Spin Xm.Spin ROT quadArc
					   #Ysteps #Xsteps TO #Ysteps TO #Xsteps
					   ( xstart xend xpin ypin r )
					ELSE ( CCW ) NIP NIP
						 Xm.Spin Ym.Spin ROT quadArc
						 ( xstart xend xpin ypin r )
					THEN
	  ENDOF
	2 OF 0<> ( CW ) IF NIP NIP
					   Xm.Dpin ios! Ym.Dpin ios!
					   Xm.Spin Ym.Spin ROT quadArc
					   ( xstart xend xpin ypin r )
					ELSE ( CCW ) >R >R >R 2DROP R> R> R>
						 Xm.Dpin ioc! Ym.Dpin ioc!
						 #Ysteps #Xsteps TO #Ysteps TO #Xsteps
						 Ym.Spin Xm.Spin ROT quadArc
						 #Ysteps #Xsteps TO #Ysteps TO #Xsteps
						 ( xstart xend xpin ypin r )
					THEN
	  ENDOF

	3 OF Xm.Dpin ios! Ym.Dpin ioc!
		 0<> ( CW ) IF >R >R >R 2DROP R> R> R>
					   #Ysteps #Xsteps TO #Ysteps TO #Xsteps
					   Ym.Spin Xm.Spin ROT quadArc
					   #Ysteps #Xsteps TO #Ysteps TO #Xsteps
					   ( xstart xend xpin ypin r )
					ELSE ( CCW ) NIP NIP
						 Xm.Spin Ym.Spin ROT quadArc
						 ( xstart xend xpin ypin r )
					THEN
	  ENDOF
	( default case: 4 )
	>R 0<> ( CW ) IF  >R >R >R 2DROP R> R> R>
					  Xm.Dpin ioc! Ym.Dpin ioc!
					  Xm.Spin Ym.Spin ROT quadArc
					  ( xstart xend xpin ypin r )
				  ELSE ( CCW ) NIP NIP
					   Xm.Dpin ios! Ym.Dpin ios!
					   #Ysteps #Xsteps TO #Ysteps TO #Xsteps
					   Ym.Spin Xm.Spin ROT quadArc
					   #Ysteps #Xsteps TO #Ysteps TO #Xsteps
					   ( xstart xend xpin ypin r )
				  THEN
	R>
  ENDCASE
;


module asym
use leastsquare
use openm
implicit none

contains

function getrealasym(fn,n,q)
!fit first,x, vs second,y, column in file fn with: y(x)=-a/x^2+b
!Let's say n_tot is the number of points in file fn.
!Fit to the last min(n,q*n_tot) points
!Return a and b as [a,b] = getrealasym(:)
implicit none
character(len=800),intent(in) :: fn
integer,intent(in) :: n
real(kind=16),intent(in) :: q

real(kind=16) :: getrealasym(2)

real(kind=16),allocatable :: x(:),y(:),k(:,:),f(:)
integer :: i,m,ntot

ntot=filelen(fn)
m=min(real(n,kind=16),ntot*q)
write(*,*) "Number of Matsubara points used for finding asymptotic:",m
call openf(fn,x,y)
allocate(f(m))
f=x(ntot-m+1:ntot)
deallocate(x)
allocate(x(m))
x=f
f=y(ntot-m+1:ntot)
deallocate(y)
allocate(y(m))
y=f
deallocate(f)
allocate(k(m,2))
do i=1,m
   k(i,1)=-1q0/(x(i)**2)
   k(i,2)=1q0
enddo
call ls(k,y,0,128,f) !min |k*[a b]-y|^2 wrt [a b]
getrealasym=f
deallocate(k,x,y,f)
end function

real(kind=16) function getsweightm(fn,n,q) !  find b in Im[G(i*w_n)] \approx -s/w_n
!fit first,x, vs third,y, column in file fn with: y(x)=-a/x
!Let's say n_tot is the number of points in file fn.
!Fit to the last min(n,q*n_tot) points
implicit none
character(len=800),intent(in) :: fn
integer,intent(in) :: n
real(kind=16),intent(in) :: q

real(kind=16),allocatable :: x(:),y(:),k(:,:),f(:)
integer :: i,m,ntot

ntot=filelen(fn)
m=min(real(n,kind=16),ntot*q)
write(*,*) "Number of Matsubara points used for finding asymptotic:",m
call openf(fn,x,f,y)
deallocate(f)
allocate(f(m))
f=x(ntot-m+1:ntot)
deallocate(x)
allocate(x(m))
x=f
f=y(ntot-m+1:ntot)
deallocate(y)
allocate(y(m))
y=f
deallocate(f)
allocate(k(m,1))
do i=1,m
   k(i,1)=-1q0/x(i)
enddo
allocate(f(1))
call ls(k,y,0,128,f) !min |k*a-y|^2 wrt f
getsweightm=f(1)
deallocate(f,k,x,y)
end function

end module


! Tests for correct parsing of complicated initialization
      MODULE funcon
      IMPLICIT NONE
      REAL(8),DIMENSION(3,3),PARAMETER :: &
         imat= reshape((/1.d0,0.d0,0.d0, &
                         0.d0,1.d0,0.d0, &
                         0.d0,0.d0,1.d0/),(/3,3/))
      REAL(8),DIMENSION(6,6),PARAMETER :: &
         imat6= reshape((/1.d0,0.d0,0.d0,0.d0,0.d0,0.d0, &
                          0.d0,1.d0,0.d0,0.d0,0.d0,0.d0, &
		 	  0.d0,0.d0,1.d0,0.d0,0.d0,0.d0, &
                          0.d0,0.d0,0.d0,1.d0,0.d0,0.d0, &
			  0.d0,0.d0,0.d0,0.d0,1.d0,0.d0, &
                          0.d0,0.d0,0.d0,0.d0,0.d0,1.d0/),(/6,6/))

      END MODULE funcon


module fibonacci
contains
    recursive function fibR(n) result(fib)
        integer, intent(in) :: n
        integer             :: fib

        select case (n)
            case (:0);      fib = 0
            case (1);       fib = 1
            case default;   fib = fibR(n-1) + fibR(n-2)
        end select
    end function fibR


integer :: j, k, jj(5)
real :: x(10), xx(10,10), yy(10,10)

! C.4.6    Examples of FORALL statements
! Example 1:

     FORALL (J=1:M, K=1:N) xx(K, J) = yy(J, K)
     FORALL (K=1:N) xx(K, 1:M) = yy(1:M, K)

! These statements both copy columns 1 through N of array Y into rows 1
! through N of array X. They are equivalent to

     xx(1:N, 1:M) = TRANSPOSE (yy(1:M, 1:N) )

! Example 2:
! The following FORALL statement computes five partial sums of subarrays of J.

     jj = (/ 1, 2, 3, 4, 5 /)

     FORALL (K = 1:5) jj(K) = SUM (jj(1:K) )

! SUM is allowed in a FORALL because intrinsic functions are pure (12.7). After
! execution of the FORALL statement, J = (/ 1, 3, 6, 10, 15 /).

!     Example 3:

     FORALL (I = 2:N-1) X(I) = (X(I-1) + 2*X(I) + X(I+1) ) / 4

!     has the same effect as

     X(2:N-1) = (X(1:N-2) + 2*X(2:N-1) + X(3:N) ) / 4

end


program main

  use BoxLib
  use parallel
  use bl_random_module
  use iso_c_binding

  implicit none

  integer :: i
  double precision :: ra, rb, r(2)
  integer :: ia, ib, ir(2)
  type(bl_rng_engine) :: eng1, eng2, eng1_r, eng2_r
  type(bl_rng_uniform_real) :: ur, ur_r
  type(bl_rng_normal) :: nm, nm_r
  type(bl_rng_poisson) :: ps, ps_r
  type(bl_rng_binomial) :: bi, bi_r

  call boxlib_initialize()

  call bl_rng_build_engine(eng1, 42)
  call bl_rng_build_engine(eng2, 0)

  ! uniform real distribution: [0.0d0, 1.0d0)
  call bl_rng_build_distro(ur, 0.0d0, 1.0d0)

  ! normal distribution with mean=0.d0, stddev=1.0d0
  call bl_rng_build_distro(nm, 0.0d0, 1.0d0)

  ! poisson distribution with mean=100.d0
  call bl_rng_build_distro(ps, 100.0d0)

  ! binomial distribution with t=160 (number of trials), p=0.6d0
  call bl_rng_build_distro(bi, 160, 0.6d0)

  if (parallel_myproc() .eq. 0) then
     print *, 'uniform real, normal, poisson, binomial'
  end if
  do i = 1, 10
     r(1)  = bl_rng_get(ur, eng1)
     r(2)  = bl_rng_get(nm, eng2)
     ir(1) = bl_rng_get(ps, eng2)
     ir(2) = bl_rng_get(bi, eng2)

     if (parallel_myproc() .eq. 0) &
          print *, r(1), r(2), ir(1), ir(2)
  end do

  call bl_rng_save_engine   (eng1  , "eng1")
  call bl_rng_restore_engine(eng1_r, "eng1")

  call bl_rng_save_engine   (eng2  , "eng2")
  call bl_rng_restore_engine(eng2_r, "eng2")

  call bl_rng_save_distro   (nm  , "normal")
  call bl_rng_restore_distro(nm_r, "normal")

  call bl_rng_save_distro   (ur  , "uniform")
  call bl_rng_restore_distro(ur_r, "uniform")

  call bl_rng_save_distro   (ps  , "poisson")
  call bl_rng_restore_distro(ps_r, "poisson")

  call bl_rng_save_distro   (bi  , "binomial")
  call bl_rng_restore_distro(bi_r, "binomial")

  if (parallel_myproc() .eq. 0) then
     print *, 'uniform real: original, restart, difference'
  end if
  do i = 1, 10
     ra = bl_rng_get(ur  , eng2)
     rb = bl_rng_get(ur_r, eng2_r)
     if (parallel_myproc() .eq. 0) then
        print *, ra, rb, ra-rb
     else if (ra .ne. rb) then
        print *, "uniform real error!!! ", ra, rb
     end if
  end do

  if (parallel_myproc() .eq. 0) then
     print *, 'normal: original, restart, difference'
  end if
  do i = 1, 10
     ra = bl_rng_get(nm  , eng2)
     rb = bl_rng_get(nm_r, eng2_r)
     if (parallel_myproc() .eq. 0) then
        print *, ra, rb, ra-rb
     else if (ra .ne. rb) then
        print *, "normal error!!! ", ra, rb
     end if
  end do

  if (parallel_myproc() .eq. 0) then
     print *, 'poisson: original, restart, difference'
  end if
  do i = 1, 10
     ia = bl_rng_get(ps  , eng1)
     ib = bl_rng_get(ps_r, eng1_r)
     if (parallel_myproc() .eq. 0) then
        print *, ia, ib, ia-ib
     else if (ia .ne. ib) then
        print *, "poisson error!!! ", ia, ib
     end if
  end do

  if (parallel_myproc() .eq. 0) then
     print *, 'binomial: original, restart, difference'
  end if
  do i = 1, 10
     ia = bl_rng_get(bi  , eng2)
     ib = bl_rng_get(bi_r, eng2_r)
     if (parallel_myproc() .eq. 0) then
        print *, ia, ib, ia-ib
     else if (ia .ne. ib) then
        print *, "binomial error!!! ", ia, ib
     end if
  end do

  if (parallel_myproc() .eq. 0) then
     print *, 'rank, uniform real, normal, poisson, binomial'
  end if
  do i = 0, parallel_nprocs()
     if (i .eq. parallel_myproc()) then
        print *, parallel_myproc(), bl_rng_get(ur,eng1), bl_rng_get(nm,eng2), &
             bl_rng_get(ps,eng2), bl_rng_get(bi,eng1)
        call flush(6)
     end if
     call parallel_barrier()
  end do

  if (parallel_myproc() .eq. 0) then
     print *, "we now change the change Poisson mean from 100.d0 to 30000.54d0"
     call bl_rng_destroy_distro(ps)
     call bl_rng_build_distro(ps, 30000.54d0)
     print *, "Poisson old and new"
     do i = 1, 5
        print *, bl_rng_get(ps_r, eng1), bl_rng_get(ps, eng2)
     end do
  end if

  if (parallel_myproc() .eq. 0) then
     print *, "we now change the change Binomial mean from 160, 0.6d0 to 1000, 0.3d0"
     call bl_rng_destroy_distro(bi)
     call bl_rng_build_distro(bi, 1000, 0.3d0)
     print *, "Binomial old and new"
     do i = 1, 5
        print *, bl_rng_get(bi_r, eng1), bl_rng_get(bi, eng2)
     end do
  end if

  call bl_rng_destroy_distro(ur)
  call bl_rng_destroy_distro(nm)
  call bl_rng_destroy_distro(ps)
  call bl_rng_destroy_distro(bi)
  call bl_rng_destroy_distro(ur_r)
  call bl_rng_destroy_distro(nm_r)
  call bl_rng_destroy_distro(ps_r)
  call bl_rng_destroy_distro(bi_r)

  call bl_rng_destroy_engine(eng1)
  call bl_rng_destroy_engine(eng2)
  call bl_rng_destroy_engine(eng1_r)
  call bl_rng_destroy_engine(eng2_r)

  call boxlib_finalize()

end program main


C******************************************************************************
C FILE: ser_mm.f
C DESCRIPTION:
C   Serial Matrix Multiply - Fortran version.
C AUTHOR: unknown
C LAST REVISED:  04/15/05 Blaise Barney
C******************************************************************************

      program mm

      parameter (NRA = 62)
      parameter (NCA = 15)
      parameter (NCB = 7)

      integer 	i, j, k
      real*8	a(NRA,NCA), b(NCA,NCB), c(NRA,NCB)

      print *,'Starting serial matrix multiple example...'
      write(*,100) NRA,NCA,NCA,NCB,NRA,NCB
 100  format(' Using matrix sizes a(',I2,',',I2,'),b(',I2,',',I1,
     & '),c(',I2,',',I1,')')

C     Initialize A and B
      print *,'Initializing matrices...'
      do 30 i=1, NRA
        do 30 j=1, NCA
        a(i,j) = (i-1)+(j-1)
 30   continue
      do 40 i=1, NCA
        do 40 j=1, NCB
	b(i,j) = (i-1)*(j-1)
 40   continue

C     Do matrix multiply
      print *,'Performing matrix multiply...'
       do 50 k=1, NCB
         do 50 i=1, NRA
         c(i,k) = 0.0
           do 50 j=1, NCA
           c(i,k) = c(i,k) + a(i,j) * b(j,k)
  50       continue

C     Print results
      print*, 'Here is the result matrix: '
      do 90 i=1, NRA
         do 80 j = 1, NCB
         write(*,70)c(i,j)
  70     format(2x,f8.2,$)
  80     continue
      print *, ' '
  90  continue
      print *, 'Done.'
      print *, ' '

      end


! We can rename the return variable... yippee
!function circle_area2(r) result (area)
!  implicit none
!  real :: r
!  real :: area
!  real, parameter :: pi = 3.14159
!
!  area = pi * r**2
!end function circle_area2

program funtest
  implicit none

  real :: res = 0
  res = circleArea(2.0)
  print*, res

end program funtest

function circleArea(r)
  ! ye gads, really?
  implicit none
  ! 'parameter' denotes a constant
  real, parameter :: pi = 3.14159
  real :: r ! This is the argument... really?
  real :: circleArea ! This is the function return... REALLY?

  circleArea = pi * r**2
end function circleArea


MODULE vector_matrix_utilities
use num_types
use utilities
use numerical_utilities

implicit none
private
public matrix_inverse, determinant, cross_product, volume, norm, reduce_C_in_ABC, &
     orthogonality_defect, minkowski_conditions_check, norm_real_vector, &
     norms_real_vector_list, determinant_real, determinant_integer,&
     minkowski_reduce_basis, find_value_in_array

INTERFACE determinant
   module procedure determinant_real, determinant_integer
END INTERFACE

INTERFACE norm
   module procedure norm_real_vector, norms_real_vector_list
END INTERFACE norm

INTERFACE find_value_in_array
  module procedure find_lvalue_in_larray1
  module procedure find_intvalue_in_intarray3
  module procedure find_sintvalue_in_sintarray3
  module procedure find_intvalue_in_intarray4
  module procedure find_sintvalue_in_sintarray4
END INTERFACE find_value_in_array

CONTAINS

  !!This function checks the minkowski conditions for a 3D
  !!lattice basis.
  !!<parameter name="basis" regular="true"></parameter>
  !!<parameter name="eps" regular="true"></parameter>
  function minkowski_conditions_check(basis,eps)
    logical  :: minkowski_conditions_check
    ! real(dp), dimension(3,3), intent(IN) :: basis
    real(dp), intent(IN) :: basis(3,3)
    real(dp), intent(IN) :: eps
    real(dp), dimension(3) :: b1, b2, b3

    b1 = basis(:,1)
    b2 = basis(:,2)
    b3 = basis(:,3)

    minkowski_conditions_check = .true.
    if (norm(b1) > norm(b2)+eps) then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 1 failed: b1 > b2"
    endif
    if (norm(b2) > norm(b3)+eps)        then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 2 failed: b2 > b3"
    endif
    if (norm(b2) > norm(b1+b2)+eps)     then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 3 failed: b2 > b1+b2"
    endif
    if (norm(b2) > norm(b1-b2)+eps)     then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 4 failed: b2 > b1-b2"
    endif
    if (norm(b3) > norm(b1+b3)+eps)     then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 5 failed: b3 > b1+b3"
    endif
    if (norm(b3) > norm(b3-b1)+eps)     then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 6 failed: b3 > b3-b1"
    endif
    if (norm(b3) > norm(b2+b3)+eps)     then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 7 failed: b3 > b2+b3"
    endif
    if (norm(b3) > norm(b3-b2)+eps)     then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 8 failed: b3 > b3-b2"
    endif
    if (norm(b3) > norm(b1+b2+b3)+eps)  then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 9 failed: b3 > b1+b2+b3"
    endif
    if (norm(b3) > norm(b1-b2+b3)+eps)  then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 10 failed: b3 > b1-b2+b3"
    endif
    if (norm(b3) > norm(b1+b2-b3)+eps)  then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 11 failed: b3 > b1+b2-b3"
    endif
    if (norm(b3) > norm(b1-b2-b3)+eps)  then
       minkowski_conditions_check = .false.
       write(*,*) "Minkowski_condition 12 failed: b3 > b1-b2-b3"
    endif
  endfunction minkowski_conditions_check

  !!This routine takes three vectors, A,B,C, defining a
  !!lattice, and reduces the last one so that it is as close as
  !!possible to the origin while remaining in an affine plane, which
  !!is parallel to the A-B plane but which passes through the end of
  !!the C vector. See Lecture notes in computer science, ISSN
  !!0302-974, ANTS - VI : algorithmic number theory, 2004, vol. 3076,
  !!pp. 338-357 ISBN 3-540-22156-5
  !!<parameter name="A" regular="true"></parameter>
  !!<parameter name="B" regular="true"></parameter>
  !!<parameter name="C" regular="true"></parameter>
  !!<parameter name="eps" regular="true"></parameter>
  subroutine reduce_C_in_ABC(A,B,C,eps)
    real(dp), intent(inout) :: A(3), B(3), C(3)
    real(dp), intent(in) :: eps
    real(dp), dimension(3) :: T  ! projection of C into the A-B plane
    real(dp), dimension(3,3) :: ABC, ABCinv, oldABC ! Matrices of ABC basis vectors and inverse
    real(dp), dimension(3)   :: cpdAB ! unit vector perpendicular to the A-B plane
    real(dp) :: dist(4) ! the distances from T to enclosing lattice
                        ! points of A,B (4 corners of the ppiped)
    integer LC(3) ! lattice coordinates of C, in the affine plane, using the A,B basis vectors
    integer idx(1) ! index of the smallest distance from T to a lattice point in A,B
    logical err
    real(dp) :: corners(4,3)  ! Array to store 4 corners of the unit cell (in lattice coordinates)
    integer i ! loop counter

    ABC = reshape((/A,B,C/),(/3,3/))
    oldABC = ABC

    ! Use Gaussian reduction to reduce the A,B 2D basis so that it is
    ! itself Minkowski reduced. If this is done, then the closest
    ! lattice point (in A,B plane) to the projection of C (into the
    ! A,B plane) is guaranteed to be one of the corners of the unit
    ! cell enclosing the projection of C
    call gaussian_reduce_two_vectors(A,B,eps)

    ! First thing to do is find the (real, not lattice) point in the affine plane A,B + C that is
    ! nearest the origin. Call this T.
    cpdAB = cross_product(A,B)/norm(cross_product(A,B))
    T = C - cpdAB*dot_product(C,cpdAB)

    if(.not. equal(dot_product(T,cross_product(A,B)),0._dp,eps)) then
       print *,dot_product(T,cross_product(A,B))
       stop "Projection of C into A,B plane failed"
    endif

    ! Now find the four points of the A,B lattice, in the affine plane, that enclose the point T
    ABC = reshape((/A,B,C/),(/3,3/))

    call matrix_inverse(ABC,ABCinv,err)
    if(err)stop "A,B,C vectors in reduce_C_in_ABC are co-planar"
    LC = floor(matmul(ABCinv,T) + eps)

!    dist(1) = norm(T-matmul(ABC,LC))
!    dist(2) = norm(T-matmul(ABC,(/LC(1)+1,LC(2),LC(3)/)))
!    dist(3) = norm(T-matmul(ABC,(/LC(1),LC(2)+1,LC(3)/)))
!    dist(4) = norm(T-matmul(ABC,(/LC(1)+1,LC(2)+1,LC(3)/)))
!
! GLWH July 10 2015. This stupid do loop business is needed to circumvent a compiler bug in ifort
    ! -O3 version  14.0.2 20140121. Old code is above.

    ! Compute the distance from T to each of the four corners of the cell and pick
    ! the one that is the closest.
    corners(1,:) =(/0,0,0/)
    corners(2,:) =(/1,0,0/)
    corners(3,:) =(/0,1,0/)
    corners(4,:) =(/1,1,0/)
    do i = 1,4
       dist(i) = norm(T-matmul(ABC,LC+corners(i,:)))
    enddo
    idx = minloc(dist)

    select case(idx(1))
    case(1)
       C = C - matmul(ABC,LC+corners(1,:))
    case(2)
       C = C - matmul(ABC,LC+corners(2,:))
    case(3)
       C = C - matmul(ABC,LC+corners(3,:))
    case(4)
       C = C - matmul(ABC,LC+corners(4,:))
    case default
       print *, "Case failed in reduce_C_in_ABC"
       write(*,'("Lattice coordinates in the A,B plane: ",2(i2,1x))') LC
       stop
    end select

    ABC = reshape((/A,B,C/),(/3,3/))
    call matrix_inverse(ABC,ABCinv,err)
    if(any(abs(matmul(ABCinv,oldABC)-nint(matmul(ABCinv,oldABC)))>eps)) stop "Lattice was not preserved &
         & in reduce_A_in_ABC"

    if(err)stop "A,B,C vectors in reduce_C_in_ABC are co-planar (after Minkowski)"

  endsubroutine reduce_C_in_ABC

  !!This routine takes two vectors (in three-space) and
  !!reduces them to form a shortest set (Minkowski reduced). The idea
  !!is to subtract multiples of U from V so that the new V is as close
  !!to the origin as any lattice point along the line that passes
  !!through U in the direction of V. The process is repeated until the
  !!new vector isn't shorter than the other. It's pretty obvious if
  !!you do an example by hand. Also see 3.1 of Lecture notes in
  !!computer science, ISSN 0302-974, ANTS - VI: algorithmic number
  !!theory, 2004, vol. 3076, pp. 338-357 ISBN 3-540-22156-5. Fixes
  !!made Apr 2012 GLWH (not sure if they made a practical difference
  !!though)
  !!<parameter name="U" regular="true"></parameter>
  !!<parameter name="V" regular="True"></parameter>
  !!<parameter name="eps" regular="true"></parameter>
  subroutine gaussian_reduce_two_vectors(U,V,eps)
    real(dp) :: U(3), V(3), R(3)
    real(dp), intent(in) :: eps

    real(dp) temp(3)
    integer it

    it = 0
    if (norm(U) > norm(V) - eps) then
       ! Make sure that the {U,V} are listed in ascending order; ||U||<||V||
       temp = U; U = V; V = temp ! Keep V as the longest vector
    end if
    do; it = it + 1
       if (it > 10) stop "gaussian_reduce_two_vectors failed to converge in 10 iterations"
       R = V-nint(dot_product(U,V)/dot_product(U,U))*U !Shorten V as much as possible
       V = U ! Swap U and V (so U remains the shortest)
       U = R
       if (norm(U) >= norm(V) - eps) exit
    end do
    ! Make sure that the {U,V} are listed in ascending order on exit; ||U||<||V||
    temp = U; U = V; V = temp

  endsubroutine gaussian_reduce_two_vectors

  !!
  !!<parameter name="IN" regular="true"></parameter>
  !!<parameter name="OUT" regular="true"></parameter>
  !!<parameter name="eps" regular="true"></parameter>
  !!<parameter name="aeps_" regular="true"></parameter>
  SUBROUTINE minkowski_reduce_basis(IN, OUT, eps, aeps_)
    real(dp), intent(in) :: IN(3,3)
    real(dp), intent(out) :: OUT(3,3)
    real(dp), intent(in) :: eps
    real(dp), optional, intent(in) :: aeps_
    real(dp)             :: norms(3), temp(3,3), aeps
    integer              :: i, idx(1), it, limit

    if (present(aeps_)) then; aeps = aeps_; else; aeps = 5e-5_dp; endif
    limit = 10
    if (equal(determinant(IN),0._dp,eps, atolerance_=aeps)) stop "Input basis for 'minkowski_reduce_basis' was not linearly independent"
    OUT = IN

    ! print*,"in mink routine"
    ! Keep applying the greedy algorithm until the vectors come out already sorted
    do it = 1, limit
       ! Sort the three vectors into ascending order
       temp = OUT
       norms = norm(temp)
       do i = 3,1,-1
          idx = maxloc(norms)
          temp(:,i) = OUT(:,idx(1))
          norms(idx(1)) = 0
       enddo
       OUT = temp ! Copy the sorted vectors back to OUT
       !   write(*,'(f7.3)') orthogonality_defect(OUT)
       call reduce_C_in_ABC(OUT(:,1),OUT(:,2),OUT(:,3),eps)
       !   write(*,'(f7.3)') orthogonality_defect(OUT)
       if (norm(OUT(:,3))>=norm(OUT(:,2))-eps) exit

    end do
    ! print *,"mink past first loop"
    !if (it>limit+1) stop "Too many iterations in 'minkowski_reduce_basis'"
    if (.not. minkowski_conditions_check(OUT,eps)) then
       write(*,'("ERROR in minkowski_reduce_basis: Minkowski conditions not met.")')
       write(*,'("Number of iterations:",i3)') limit
       stop
    end if

    ! we want to make sure that the det is positive.
    ! NOTE: This *destroys* the mathematical picture of a "greedy reduced basis" (Minkowski), but
    !       from a physical point of view we don't care ;-)
    !       Either way, the basis is as orthogonal as possible.
    if (determinant(OUT)<0) then
       temp(:,1) = OUT(:,2)
       OUT(:,2) = OUT(:,3)
       OUT(:,3) = temp(:,1)
    endif

  END SUBROUTINE minkowski_reduce_basis

  !!This function calculates the "orthogonality defect" of
  !!the given basis of a 3D lattice.
  !!<parameter name="basis" regular="true"></parameter>
  function orthogonality_defect(basis)
    real(dp), intent(in) :: basis(3,3)
    real(dp) :: orthogonality_defect
    real(dp) :: od
    integer j
    od = 1._dp
    do j=1,3
       od = od*norm(basis(:,j))
    enddo
    od = od/abs(determinant(basis))
    orthogonality_defect = od
  endfunction orthogonality_defect

  !!Given the matrix a, finds its inverse b
  !!<parameter name="a" regular="true"></parameter>
  !!<parameter name="b" regular="true"></parameter>
  !!<parameter name="err_" regular="true"></parameter>
  !!<parameter name="eps_" regular="true"></parameter>
  subroutine matrix_inverse(a, b, err_, eps_)
    real(dp), intent(in):: a(3,3)
    real(dp),intent(out):: b(3,3)
    real(dp) :: c,avec(9)
    real(dp)           :: eps

    logical,  optional :: err_
    real(dp), optional :: eps_

    if(present(err_)) err_ = .false.
    if(present(eps_)) then; eps=eps_; else; eps=10d-14; endif

    c=a(1,3)*(-a(2,2)*a(3,1)+a(2,1)*a(3,2))+ &
         a(1,2)*(a(2,3)*a(3,1)-a(2,1)*a(3,3))+ &
         a(1,1)*(-a(2,3)*a(3,2)+a(2,2)*a(3,3))
    avec=(/-a(2,3)*a(3,2)+a(2,2)*a(3,3),a(1,3)*a(3,2)-a(1,2)*a(3,3), &
         -a(1,3)*a(2,2)+a(1,2)*a(2,3),a(2,3)*a(3,1)-a(2,1)*a(3,3), &
         -a(1,3)*a(3,1)+a(1,1)*a(3,3),a(1,3)*a(2,1)-a(1,1)*a(2,3), &
         -a(2,2)*a(3,1)+a(2,1)*a(3,2),a(1,2)*a(3,1)-a(1,1)*a(3,2), &
         -a(1,2)*a(2,1)+a(1,1)*a(2,2)/)
    if(abs(c) < eps) then; if(present(err_)) err_ = .true.
    else; b=1/c*transpose(reshape(avec,(/3,3/))); endif
    ! transpose due to column major storage
  end subroutine matrix_inverse

  !!Given vectors a and b, c = a x b
  !!<parameter name="a" regular="true"></parameter>
  !!<parameter name="b" regular="true"></parameter>
  function cross_product(a,b)
    real(dp) :: a(3), b(3), cross_product(3)

    cross_product = (/a(2)*b(3) - a(3)*b(2), &
         a(3)*b(1) - a(1)*b(3), &
         a(1)*b(2) - a(2)*b(1)/)
  end function cross_product

  !!This routine takes the norm of a vector
  !!<parameter name="vector" regular="true"></parameter>
  pure function norm_real_vector(vector)
    real(dp) :: norm_real_vector
    real(dp), intent(in):: vector(:)

    norm_real_vector = sqrt(dot_product(vector,vector))
  end function norm_real_vector

  !!This routine takes the norms of vectors in a list
  !!<parameter name="vector_list" regular="true"></parameter>
  pure function norms_real_vector_list(vector_list)
    real(dp), intent(in)               :: vector_list(:,:)
    real(dp) :: norms_real_vector_list(size(vector_list,2))
    integer :: i

    do i = 1, size(vector_list,2)
       norms_real_vector_list(i) = sqrt(dot_product(vector_list(:,i),vector_list(:,i)))
    end do
  end function norms_real_vector_list

  !!This routine finds the determinant of 2x2 or 3x3 matrices
  !!<parameter name="a" regular="true"></parameter>
  function determinant_real(a)
    real(dp) :: determinant_real,a(:,:)

    integer :: n
    n=size(a,dim=1)
    if (n==2) then
       determinant_real=-a(1,2)*a(2,1)+a(1,1)*a(2,2)
    else if (n==3) then
       determinant_real=a(1,3)*(-a(2,2)*a(3,1)+a(2,1)*a(3,2))+ &
            a(1,2)*(a(2,3)*a(3,1)-a(2,1)*a(3,3))+ &
            a(1,1)*(-a(2,3)*a(3,2)+a(2,2)*a(3,3))
    else
       stop "DETERMINANT ERROR: Matrix dimension exceeds 3."
    end if
  end function determinant_real

  !!This routine finds the determinant of 2x2 or 3x3 matrices
  !!<parameter name="a" regular="true"></parameter>
  function determinant_integer(a)
    integer :: determinant_integer,a(:,:)
    integer :: n
    n=size(a,dim=1)
    if (n==2) then
       determinant_integer=-a(1,2)*a(2,1)+a(1,1)*a(2,2)
    else if (n==3) then
       determinant_integer=a(1,3)*(-a(2,2)*a(3,1)+a(2,1)*a(3,2))+ &
            a(1,2)*(a(2,3)*a(3,1)-a(2,1)*a(3,3))+ &
            a(1,1)*(-a(2,3)*a(3,2)+a(2,2)*a(3,3))
    else
       stop "DETERMINANT ERROR: Matrix dimension exceeds 3."
    end if
  end function determinant_integer

  !!This function takes three vectors and returns a "signed"
  !!volume of the parallelpiped that they form.
  !!<parameter name="a1" regular="true"></parameter>
  !!<parameter name="a2" regular="true"></parameter>
  !!<parameter name="a3" regular="true"></parameter>
  function volume(a1, a2, a3)
    real(dp) :: volume
    real(dp) :: a1(3), a2(3), a3(3)

    volume = dot_product(a1, cross_product(a2,a3))
  end function volume

  !!Find a int value inside a 3-dim array
  !!<parameter name="array" regular="true"></parameter>
  !!<parameter name="vals" regular="true"></parameter>
  !!<parameter name="loc" regular="true">intent(out), { #found_value }</parameter>
  !!<parameter name="nfound" regular="true">number of val occurrences in array</parameter>
  subroutine find_lvalue_in_larray1(array,vals,loc,nfound)
    logical, intent(in)     :: array(:)
    logical, intent(in)     :: vals(:)
    integer, intent(out)    :: loc(:)
    integer, intent(out)    :: nfound

    integer, parameter :: dim=1
    integer :: count, l

    count = 0
    do l=1,size(array,1)
       if (any(array(l).eqv.vals(:))) then
          count = count+1
          loc(count) = l
       endif
    enddo

    nfound=count

  end subroutine find_lvalue_in_larray1

  !!Find a int value inside a 3-dim array
  !!<parameter name="array" regular="true"></parameter>
  !!<parameter name="vals" regular="true"></parameter>
  !!<parameter name="loc">intent(out), { #coordinate, #found_value }</parameter>
  !!<parameter name="nfound" regular="true">number of val occurrences in array</parameter>
  subroutine find_intvalue_in_intarray3(array,vals,loc,nfound)
    integer, intent(in)     :: array(:,:,:)
    integer, intent(in)     :: vals(:)
    integer, pointer        :: loc(:,:)
    integer, intent(out)    :: nfound

    integer, parameter :: dim=3

    integer :: j,k,l
    integer :: count

    count = 0
    do j=1,size(array,3)
       do k=1,size(array,2)
          do l=1,size(array,1)
             if (any(array(l,k,j)==vals(:))) then
                count = count+1
                loc(:dim,count) = (/l,k,j/)
             endif
          enddo
       enddo
    enddo

    nfound=count

  end subroutine find_intvalue_in_intarray3

  !!Find a int value inside a 3-dim array, si version
  !!<parameter name="array" regular="true"></parameter>
  !!<parameter name="vals" regular="true"></parameter>
  !!<parameter name="loc">intent(out), { #coordinate, #found_value }</parameter>
  !!<parameter name="nfound" regular="true">number of val occurrences in array</parameter>
  subroutine find_sintvalue_in_sintarray3(array,vals,loc,nfound)
    integer(si), intent(in)     :: array(:,:,:)
    integer(si), intent(in)     :: vals(:)
    integer, pointer        :: loc(:,:)
    integer, intent(out)    :: nfound

    integer, parameter :: dim=3

    integer :: j,k,l
    integer :: count

    count = 0
    do j=1,size(array,3)
       do k=1,size(array,2)
          do l=1,size(array,1)
             if (any(array(l,k,j)==vals(:))) then
                count = count+1
                loc(:dim,count) = (/l,k,j/)
             endif
          enddo
       enddo
    enddo

    nfound=count

  end subroutine find_sintvalue_in_sintarray3

  !!Find a int value inside a 4-dim array
  !!<parameter name="array" regular="true"></parameter>
  !!<parameter name="vals" regular="true"></parameter>
  !!<parameter name="loc">intent(out), { #coordinate, #found_value }</parameter>
  !!<parameter name="nfound" regular="true">number of val occurrences in array</parameter>
  subroutine find_intvalue_in_intarray4(array,vals,loc,nfound)
    integer, intent(in)     :: array(:,:,:,:)
    integer, intent(in)     :: vals(:)
    integer, pointer        :: loc(:,:) ! intent(out), { #coordinate, #found_value }
    integer, intent(out)    :: nfound   ! number of val occurrences in array

    integer, parameter :: dim=4

    integer :: i,j,k,l
    integer :: count

    count = 0
    do i=1,size(array,4)
       do j=1,size(array,3)
          do k=1,size(array,2)
             do l=1,size(array,1)
                if (any(array(l,k,j,i)==vals(:))) then
                   count = count+1
                   loc(:dim,count) = (/l,k,j,i/)
                endif
             enddo
          enddo
       enddo
    enddo

    nfound=count

  end subroutine find_intvalue_in_intarray4

  !!Find a int value inside a 4-dim array, si version
  !!<parameter name="array" regular="true"></parameter>
  !!<parameter name="vals" regular="true"></parameter>
  !!<parameter name="loc">intent(out), { #coordinate, #found_value }</parameter>
  !!<parameter name="nfound" regular="true">number of val occurrences in array</parameter>
  subroutine find_sintvalue_in_sintarray4(array,vals,loc,nfound)
    integer(si), intent(in)     :: array(:,:,:,:)
    integer(si), intent(in)     :: vals(:)
    integer, pointer        :: loc(:,:)
    integer, intent(out)    :: nfound

    integer, parameter :: dim=4

    integer :: i,j,k,l
    integer :: count

    count = 0
    do i=1,size(array,4)
       do j=1,size(array,3)
          do k=1,size(array,2)
             do l=1,size(array,1)
                if (any(array(l,k,j,i)==vals(:))) then
                   count = count+1
                   loc(:dim,count) = (/l,k,j,i/)
                endif
             enddo
          enddo
       enddo
    enddo

    nfound=count

  end subroutine find_sintvalue_in_sintarray4

END MODULE


!4. Write a program that asks the user for a number n and prints the sum of the numbers 1 to n

    program Exercises
    implicit none
    integer :: n
    integer :: sum
    integer :: i

    print *, 'Please enter a number, n:'
    read *, n

    sum = 0
    do i=1,n
        sum = sum + i
    end do

    print '(A, I0)', 'The sum of the numbers from 1 to n is: ', sum

    end program Exercises