      subroutine stream_func_wave_finite(nfx,xp,tp,n_four_modes,
     $     zz,yy,wavenum,grav,etai,phi_s)

! A subroutine to compute the dimensional elevation and surface
! potential  at a set of points (xp) on the free-surface at time tp,
! based on the input stream function theory solution which has been
! computed by the subroutine stream_func_coeffs.  The solution is
! uniform in y.

      IMPLICIT NONE
      INTEGER nfx, n_four_modes
C      REAL*8 xp(*), tp, zz(*), yy(*), etai(*), phi_s(*), wavenum,
C     $     grav
C Test GD
      REAL*8 xp(nfx), tp, zz(2*n_four_modes+10), yy(2*n_four_modes+10),
     $     etai(nfx), phi_s(nfx), wavenum, grav
C Harry's definition
C      REAL*8 xp(2,*), tp, zz(*), yy(*), etai(*), phi_s(*), wavenum,
C     $     grav
C Local variables
      INTEGER j, k, m
      real*8 SLOPE,U,W,E,S,B,C,ufactor,t,elx,uxx,d, omega_t, kinv, kx,
     $     ph, pfactor, km, sinhzh
      kinv=1.D00/wavenum
      ufactor=sqrt(grav*kinv)
      pfactor=ufactor*kinv
      omega_t=wavenum*ufactor*zz(4)*tp
      DO j=1,nfx
         kx=wavenum*xp(j)-omega_t
C         kx=wavenum*xp(1,j)-omega_t
         km=DBLE(n_four_modes)
         etai(j)=0.5d0*(yy(n_four_modes))*cos(km*kx)
         slope=-0.5d0*km*yy(n_four_modes)*sin(km*kx)
         DO  m=1,n_four_modes-1
            km=DBLE(m)
! Non-dimensional eta
            etai(j)=etai(j)+yy(m)*cos(km*kx)
            slope=slope-km*yy(m)*sin(km*kx)
         ENDDO
         ph=0.D00
         w=0.d00
!     This orginal version had a bug and used the dimensional xp instead
!     of the non-dimensional one. So I've gone back to this form which should
!     be correct for either  U_E or U_S versions. HBB - corrected 18/03/2019.
         ph=(zz(4)-zz(7))*xp(j)*wavenum
C Here phi, is computed on the free-surface etai.  To get values
C at another level of z, replace etai with z in the following two loops.
         DO m=1,n_four_modes
            km=DBLE(m)
            e=EXP(km*(zz(1)+etai(j)))
            b=zz(n_four_modes+m+10)*0.5d0*(e+1.d0/e)/COSH(km*zz(1))
            sinhzh=km*zz(n_four_modes+m+10)*0.5d0
     &                              *(e-1.d0/e)/COSH(km*zz(1))
            ph=ph+b*SIN(km*kx)
            w=w+sinhzh*SIN(km*kx)
         ENDDO
! Dimensionalize
         etai(j)=kinv*etai(j)
         phi_s(j)=ph*pfactor
!	Next line ADDED: APEK 01-07-2008, ! phi_s=uE*x+ph, uE=c-ubar,
!     phi_s(j)=phi_s(j) + xp(j)*(zz(5)*sqrt(grav/wavenum))
!     HBB - corrected 18/03/2019.
         w=w*ufactor
!hbb temporary output for checking the GOperator
!         write(26,*)phi_s(j),w
      END DO

      return
      end subroutine stream_func_wave_finite

      subroutine stream_func_wave_deep(nfx,xp,tp,n_four_modes,
     $     zz,yy,wavenum,grav,etai,phi_s)

C A subroutine to compute the dimensional elevation and velocity at
C a set of points (xp) on the free-surface at time tp, based on the
C input stream function theory solution which has been computed by
C the subroutine stream_func_coeffs.  The solution is uniform in
C y.

      IMPLICIT NONE
      INTEGER nfx, n_four_modes
      REAL*8 xp(*), tp, zz(*), yy(*), etai(*), phi_s(*), wavenum,
     $     grav
C Local variables
      INTEGER j, k, m
      real*8 SLOPE,U,W,E,S,B,C,ufactor,t,elx,uxx,d, omega_t, kinv, kx,
     $     ph, pfactor, km

      kinv=1.D00/wavenum
      ufactor=sqrt(grav*kinv)
      pfactor=ufactor*kinv
      omega_t=wavenum*ufactor*zz(4)*tp
      DO j=1,nfx
         kx=wavenum*xp(j)-omega_t
         km=DBLE(n_four_modes)
         etai(j)=0.5d0*yy(n_four_modes)*cos(km*kx)
         slope=-0.5d0*km*yy(n_four_modes)*sin(km*kx)
         DO  m=1,n_four_modes-1
            km=DBLE(m)
            etai(j)=etai(j)+yy(m)*cos(km*kx)
            slope=slope-km*yy(m)*sin(km*kx)
         ENDDO
         ph=0.D00
!     This orginal version had a bug and used the dimensional xp instead
!     of the non-dimensional one. So I've gone back to this form which should
!     be correct for either  U_E or U_S versions. HBB - corrected 18/03/2019.
         ph=(zz(4)-zz(7))*xp(j)*wavenum
!         ph=-zz(7)*xp(j)*wavenum
C Here phi is computed on the free-surface etai.  To get values
C at another level of z, replace etai with z in the following two loops.
         DO m=1,n_four_modes
            km=DBLE(m)
            ph=ph+zz(n_four_modes+m+10)*EXP(km*etai(j))*SIN(km*kx)
         ENDDO
         etai(j)=kinv*etai(j)
         phi_s(j)=ph*pfactor
!	Next line ADDED: APEK 01-07-2008, ! phi_s=uE*x+ph, uE=c-ubar,
!     phi_s(j)=phi_s(j) + xp(j)*(zz(5)*sqrt(grav/wavenum))
!     See note above, HBB 18/03/2019.

      END DO

      return
      end subroutine stream_func_wave_deep

	  subroutine weights (z,x,n,nd,m,c)
C---
C--- Input Parameters
C--- z location where approximations are to be accurate,
C--- x(0:nd) grid point locations, found in x(0:n)
C--- n one less than total number of grid points; n must
C--- not exceed the parameter nd below,
C--- nd dimension of x- and c-arrays in calling program
C--- x(0:nd) and c(0:nd,0:m), respectively,
C--- m highest derivative for which weights are sought,
C--- Output Parameter
C--- c(0:nd,0:m) weights at grid locations x(0:n) for derivatives
C--- of order 0:m, found in c(0:n,0:m)
C---
	  implicit real*8 (a-h,o-z)
	  dimension x(0:nd),c(0:nd,0:m)
	  c1 = 1.0d0
	  c4 = x(0)-z
	  do 10 k=0,m
		do 10 j=0,n
   10			c(j,k) = 0.0d0
		c(0,0) = 1.0d0
		do 50 i=1,n
			mn = min(i,m)
			c2 = 1.0d0
			c5 = c4
			c4 = x(i)-z
			do 40 j=0,i-1
				c3 = x(i)-x(j)
				c2 = c2*c3
				if (j.eq.i-1) then
					do 20 k=mn,1,-1
   20						c(i,k) = c1*(k*c(i-1,k-1)-c5*c(i-1,k))/c2
					c(i,0) = -c1*c5*c(i-1,0)/c2
				endif
				do 30 k=mn,1,-1
   30					c(j,k) = (c4*c(j,k)-k*c(j,k-1))/c3
   40			c(j,0) = c4*c(j,0)/c3
   50		c1 = c2
	  return
	  end subroutine weights


program Manipulacija_so_vektor_FORTRAN90

    !stefannajdovski 22.06.2021
    !Se kompajlova so f90 gcc kompajler
    !BANG:
    !Terminal/Konsol Programa vo FORTRAN 90
    !Cel na programata e presemtka na
    !dolzina na vektor

real x1,y1,x2,y2    !Fortran 77 nema operacii so vektori i arrays taka da reeeeee
real dolzina
write(*,*) "Dolzina na vektor"
write(*,*) "(x1,y1):"
read(*,*) x1,y1
write(*,*) "(x2,y2)"
read(*,*) x2,y2
dolzina = sqrt((y2-y1)**2+(y2-y1)**2)
write(*,*) "Dolzina", dolzina

end program ! is this jojo ahmmm ASM reference?


      subroutine compute_ddltheta(ctfm,ctfmp,n_alpha,n_metthetatheta,n_m
     &etxx,x,Nx,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_alpha(Nx)
      real*8 n_metthetatheta(Nx)
      real*8 n_metxx(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = -0.1250000000000000D0 / ctfmp(i) ** 2 * (n_alpha(i - 1) - 0.1
     #D1 * n_alpha(i + 1)) / hx ** 2 / n_metxx(i) * (-0.1D1 * n_mettheta
     #theta(i - 1) + n_metthetatheta(i + 1)) - 0.5000000000000000D0 * (n
     #_alpha(i - 1) - 0.1D1 * n_alpha(i + 1)) / hx / ctfmp(i) / ctfm(i)
     #/ n_metxx(i) * n_metthetatheta(i)
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END


**********************************************************************
*  FILE SPLINE - LAST CHANGE: 06/06/88 (AMS)                         *
*--------------------------------------------------------------------*
*                                                                    *
*      THIS FILE CONTAINS ROUTINES TO COMPUTE CUBIC SPLINES. THE     *
*  ROUTINES ARE BASED ON:                                            *
*                                                                    *
*  FORSYTHE, G. E., M. A. MALCOLN AND C. B. MOLER (1977):            *
*  "COMPUTER METHODS FOR MATHEMATICAL COMPUTATIONS", PrentiCe-Hall.  *
*                                                                    *
**********************************************************************

      subroutine SPLINE ( b, c, d, n, x, y )

      integer  n
      real     b(n), c(n), d(n), x(n), y(n)

**********************************************************************
*   FIRST VERSION: 02/13/86 (AMS)   CURRENT VERSION: 02/13/86 (AMS)  *
*--------------------------------------------------------------------*
*                                                                    *
*     THIS ROUTINE COMPUTES THE COEFFICIENTS  B(I), C(I), D(I),      *
*   I = 1, ..., N FOR A CUBIC INTERPOLATING SPLINE.                  *
*                                                                    *
*    S(X) = Y(I) + B(I) * ( X - X(I) ) + C(I) * ( X - X(I) )**2      *
*                + D(I) * ( X - X(I) )**3                            *
*                                                                    *
*--------------------------------------------------------------------*
*                                                                    *
*   ON INPUT                                                         *
*   --------                                                         *
*   N   ---   NUMBER OF DATA POINTS OR KNOTS ( N .GE. 2 )            *
*   X   ---   THE ABSCISSAS OF THE KNOTS IN STRICTLY INCREASING      *
*             ORDER                                                  *
*   Y   ---   THE ORDINATES OF THE KNOTS                             *
*                                                                    *
*   ON OUTPUT                                                        *
*   ---------                                                        *
*   B, C, D   ---   ARRAYS OF SPLINE COEFFICIENTS AS DEFINED ABOVE.  *
*                                                                    *
*--------------------------------------------------------------------*
*                                                                    *
*   INTERPRETAION:                                                   *
*   -------------                                                    *
*                                                                    *
*   Y(I)   ---   S    ( X(I) )                                       *
*   B(I)   ---   S'   ( X(I) )                                       *
*   C(I)   ---   S''  ( X(I) ) / 2                                   *
*   D(I)   ---   S''' ( X(I) ) / 6  ( DERIVATIVE FROM THE RIGHT )    *
*                                                                    *
*   WHERE ' DENOTES DIFFERENTIATION. THE ACCOMPANYING SUBPROGRAM     *
*   FUNCTION  SEVAL  CAN BE USED TO EVALUATE THE SPLINE.             *
*                                                                    *
**********************************************************************
*
      integer  nm1, ib, i
      real     t
*
      nm1 = n - 1
      if ( n .lt. 2 )  return
      if ( n .lt. 3 )  go to 50
*
*     SET UP TRIDIAGONAL SYSTEM
*     -------------------------
*
*     B = DIAGONAL, D = DIAGONAL, C = RIGHT HAND SIDE
*     -----------------------------------------------
      d(1) = x(2) - x(1)
      c(2) = ( y(2) - y(1) ) / d(1)
      do 10 i = 2, nm1
         d(i)   = x(i+1) - x(i)
         b(i)   = 2.0 * ( d(i-1) + d(i) )
         c(i+1) = ( y(i+1) - y(i) ) / d(i)
         c(i)   = c(i+1) - c(i)
 10   continue
*
*     END CONDITIONS. THIRD DERIVATIVES AT  X(1)  AND  X(N)
*     OBTAINED FROM DIVIDED DIFFERENCES
*     -----------------------------------------------------
      b(1) = - d(1)
      b(n) = - d(n-1)
      c(1) = 0.0
      c(n) = 0.0
      if ( n .eq. 3 )  go to 15
      c(1) = c(3)   / ( x(4) - x(2)   )
     1     - c(2)   / ( x(3)   - x(1)   )
      c(n) = c(n-1) / ( x(n) - x(n-2) )
     1     - c(n-2) / ( x(n-1) - x(n-3) )
      c(1) = c(1) * d(1)**2 / ( x(4) - x(1) )
      c(n) = -c(n) * d(n-1)**2 / ( x(n) - x(n-3) )
*
*     FORWARD ELIMINATION
*     -------------------
 15   do 20 i = 2, n
          t    = d(i-1) / b(i-1)
          b(i) = b(i)  -  t * d(i-1)
          c(i) = c(i)  -  t * c(i-1)
 20   continue
*
*     BACK SUBSTITUTION
*     -----------------
      c(n) = c(n) / b(n)
      do 30 ib = 1, nm1
         i = n - ib
         c(i) = ( c(i) - d(i) * c(i+1) ) / b(i)
 30   continue
*
*     C(I) NOW CONTAINS SIGMA(I)
*     --------------------------
*
*     COMPUTE POLYNOMIAL COEFFICIENTS
*     -------------------------------
      b(n) = ( y(n) - y(nm1) ) / d(nm1)
     1     + d(nm1) * ( c(nm1) + 2.0 * c(n) )
      do 40 i = 1, nm1
         b(i) = ( y(i+1) - y(i) ) / d(i)
     1        - d(i) * ( c(i+1) + 2.0 * c(i) )
         d(i) = ( c(i+1) - c(i) ) / d(i)
         c(i) = 3.0 * c(i)
 40   continue
      c(n) = 3.0 * c(n)
      d(n) = d(n-1)
*
      return
*
 50   b(1) = ( y(2) - y(1) ) / ( x(2) - x(1) )
      c(1) = 0.0
      d(1) = 0.0
      b(2) = b(1)
      c(2) = 0.0
      d(2) = 0.0
*
      return
      end

*............................................................................

      real function SEVAL ( u, x, y, n, b, c, d )

      integer  n
      real     u, x(n), y(n), b(n), c(n), d(n)

**********************************************************************
*   FIRST VERSION: 02/13/86 (AMS)   CURRENT VERSION: 02/13/86 (AMS)  *
*--------------------------------------------------------------------*
*                                                                    *
*       THIS ROUTINE  RETURNS THE CUBIC SPLINE FUNCTION              *
*                                                                    *
*    SEVAL = Y(I) + B(I) * ( U - X(I) ) + C(I) * ( U - X(I) )**2     *
*                 + D(I) * ( U - X(I) )**3                           *
*                                                                    *
*    WHERE  X(I) .LT. U .LT. X(I+1), USING HORNER'S RULE.            *
*       IF U .LT. X(1) THEN I=1 IS USED, IF U .GE. X(N) THEN I=N     *
*    IS USED.                                                        *
*                                                                    *
*--------------------------------------------------------------------*
*                                                                    *
*   ON INPUT                                                         *
*   --------                                                         *
*   N        ---   NUMBER OF DATA POINTS OR KNOTS ( N .GE. 2 )       *
*   U        ---   ABSCISSA AT WHICH THE SPLINE IS TO BE EVALUATED   *
*   X, Y     ---   THE ARRAYS OF ABSCISSAS AND ORDINATES.            *
*   B, C, D  ---   ARRAYS OF SPLINE COEFFICIENTS AS DEFINED ABOVE.   *
*                                                                    *
*      IF  U  IS NOT IN THE SAME INTERVAL AS THE PREVIOUS CALL,      *
*   THEN A BINARY SEARCH IS PERFORMED TO DETERMINE THE PROPER        *
*   INTERVAL.                                                        *
*                                                                    *
**********************************************************************

      save i
      integer  i, j, k
      real     dx

      data i / 1 /

      if ( i .ge. n      ) i = 1
      if ( u .lt. x(i)   ) go to 10
      if ( u .le. x(i+1) ) go to 30

*     BINARY SEARCH
*     -------------
 10   i = 1
      j = n + 1
 20   k = ( i + j ) / 2
      if ( u .lt. x(k) )  j = k
      if ( u .ge. x(k) )  i = k
      if ( j .gt. i+1  )  go to 20

*     EVALUATE SPLINE
*     ---------------
 30   dx    = u - x(i)
      seval = y(i)
     1      + dx * ( b(i) + dx * ( c(i) + dx * d(i) ) )

      return
      end

*............................................................................

      subroutine SEVAL1 ( s, sp, spp, u, x, y, n, b, c, d )

      integer  n
      real     s, sp, spp, u, x(n), y(n), b(n), c(n), d(n)

**********************************************************************
*   FIRST VERSION: 02/17/87 (AMS)   CURRENT VERSION: 02/17/87 (AMS)  *
*--------------------------------------------------------------------*
*                                                                    *
*       THIS ROUTINE  RETURNS THE CUBIC SPLINE FUNCTION              *
*                                                                    *
*    S(U)  = Y(I) + B(I) * ( U - X(I) ) + C(I) * ( U - X(I) )**2     *
*                 + D(I) * ( U - X(I) )**3                           *
*                                                                    *
*    AND ITS RESPECTIVE FIRST AND SECOND DERIVATIVES:                *
*                                                                    *
*                 SP = S'(U)    AND    SPP = S''(U)                  *
*                                                                    *
*    WHERE  X(I) .LT. U .LT. X(I+1), USING HORNER'S RULE.            *
*       IF U .LT. X(1) THEN I=1 IS USED, IF U .GE. X(N) THEN I=N     *
*    IS USED.                                                        *
*                                                                    *
*--------------------------------------------------------------------*
*                                                                    *
*   ON INPUT                                                         *
*   --------                                                         *
*   N        ---   NUMBER OF DATA POINTS OR KNOTS ( N .GE. 2 )       *
*   U        ---   ABSCISSA AT WHICH THE SPLINE IS TO BE EVALUATED   *
*   X, Y     ---   THE ARRAYS OF ABSCISSAS AND ORDINATES.            *
*   B, C, D  ---   ARRAYS OF SPLINE COEFFICIENTS AS DEFINED ABOVE.   *
*                                                                    *
*      IF  U  IS NOT IN THE SAME INTERVAL AS THE PREVIOUS CALL,      *
*   THEN A BINARY SEARCH IS PERFORMED TO DETERMINE THE PROPER        *
*   INTERVAL.                                                        *
*                                                                    *
**********************************************************************

      save     i
      integer  i, j, k
      real     dx

      data i / 1 /

      if ( i .ge. n      ) i = 1
      if ( u .lt. x(i)   ) go to 10
      if ( u .le. x(i+1) ) go to 30

*     BINARY SEARCH
*     -------------
 10   i = 1
      j = n + 1
 20   k = ( i + j ) / 2
      if ( u .lt. x(k) )  j = k
      if ( u .ge. x(k) )  i = k
      if ( j .gt. i+1  )  go to 20

*     EVALUATE SPLINE
*     ---------------
 30   dx = u - x(i)
      s   = y(i) + dx * ( b(i) + dx * ( c(i) + dx * d(i) ) )
      sp  = b(i) + dx * ( 2.0 * c(i) + 3.0 * d(i) * dx )
      spp = 2.0 * c(i) + 6.0 * d(i) * dx

      return
      end

*............................................................................

      subroutine BICSPL ( a1, x1, y1, nx1, ny1,
     1                    a2, x2, y2, nx2, ny2,
     2                    b, c, d )

*
*                           A2 contains input array; A1 receives output
*                             dim ( A2 ):   max(NX1,NX2) x max(NY1,NY2)
*                             dim ( A1 ):   max(NX1,NX2) x max(NY1,NY2)

      real   a1(*), a2(*)

      real   x1(nx1), x2(nx2), y1(ny1), y2(ny2)
*
*                                  these vectors must have dimension
*                                   >= max ( nx2, ny2 )
      real   b(*), c(*), d(*)

**********************************************************************
*   FIRST VERSION: 06/06/88         CURRENT VERSION: 06/06/88        *
*--------------------------------------------------------------------*
*                                                                    *
*     THIS ROUTINE COMPUTES INTRPOLATES THE BI-DIMENSIONAL FIELD  A2 *
*   GIVEN ON A GRID  X2 x Y2  TO A FIELD  A1  DEFINED ON A GRID      *
*   X1 x Y1.                                                         *
*                                                                    *
*         A1, A2 should not share storage.   No attempt is made to   *
*   save storage.  A2 is overwritten.                                *
*                                                                    *
**********************************************************************

*     X-INTERPOLATION
*     ---------------
      do 10 j = 1, ny2
         l1j = ( j - 1 ) * nx2 + 1
         call spline ( b, c, d, nx2, x2, a2(l1j) )
         do 20 i = 1, nx1
            lij = ( j - 1 ) * nx1 + i
            a1(lij) = seval ( x1(i), x2, a2(l1j), nx2, b, c, d )
 20      continue
 10   continue

*     TRANSPOSITION
*     -------------
      do 30 i = 1, nx1
         do 30 j = 1, ny2
            lij = ( j - 1 ) * nx1 + i
            lji = ( i - 1 ) * ny2 + j
            a2(lji) = a1(lij)
 30   continue

*     Y-INTERPOLATION
*     ---------------
      do 40 i = 1, nx1
         l1i = ( i - 1 ) * ny2 + 1
         call SPLINE ( b, c, d, ny2, y2, a2(l1i) )
         do 50 j = 1, ny1
            lij = ( j - 1 ) * nx1 + i
            a1(lij) = seval ( y1(j), y2, a2(l1i), ny2, b, c, d )
 50      continue
 40   continue

      return
      end


 ! This test code demonstrates that the scope of the implied do loop variable is
 ! not local to the implied do loop, but instead is the scope of the statement
 ! in which the implied do loop is present.

 ! If "implicit none" is used, then the declaration of "j" is required.
   implicit none

 ! This is only required because of a bug in gFortran (should not be required).
   integer j

 ! Implied do loop for the direct data initialization in a type statement
 ! real, dimension (3) :: a = (/(j,j=1,3)/)
   real, dimension (3) :: b = (/(j**2+j,j=1,3)/)

 ! This next implied do loop demonstrates that we need to have OFP communicate
 ! the implied do loop variable (not fixed in OFP).
   integer, parameter :: i = 1
   real, dimension (3) :: c = (/(j**2+i,j=1,3)/)
end


!
! Copyright 2003-2010 Henk Krus, Cyclone Fluid Dynamics BV
! All Rights Reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
! http://www.dolfyn.net/license.html
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an
! "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
! either express or implied. See the License for the specific
! language governing permissions and limitations under the License.
!
subroutine cross_product(a,b,c)
!
!  classic cross product: a x b = c
!
   real, dimension(3), intent(IN)  :: a, b
   real, dimension(3), intent(OUT) :: c

   c(1) = a(2)*b(3) - a(3)*b(2)
   c(2) = a(3)*b(1) - a(1)*b(3)
   c(3) = a(1)*b(2) - a(2)*b(1)

end subroutine cross_product
!========================================================================
subroutine normalise(a)
!
!  normalise a vector to length 1
!
   real, dimension(3), intent(INOUT) :: a
   real :: rlength

   rlength = 1.0/sqrt( dot_product(a,a) )

   a(1) = a(1)*rlength
   a(2) = a(2)*rlength
   a(3) = a(3)*rlength

end subroutine normalise
!========================================================================
real function vector_length(a)

   real, dimension(3), intent(IN) :: a

   vector_length = sqrt( dot_product(a,a) )

end function vector_length
!========================================================================
real function vector_cosangle(a,b)
!
!  the cosine of the angle between two vectors in the form of cos(angle)
!
   real, dimension(3), intent(IN) :: a, b

   vector_cosangle = dot_product(a,b)
   vector_cosangle = vector_cosangle/(vector_length(a)*vector_length(b))

end function vector_cosangle
!========================================================================
real function det33v(a,b,c)
!
!  determinant of a 3 by 3 matrix
!
   real, dimension(3), intent(IN) :: a, b, c

   det33v = ( a(2)*b(3) - b(2)*a(3) )*c(1) &
          + ( b(1)*a(3) - a(1)*b(3) )*c(2) &
          + ( a(1)*b(2) - a(2)*b(1) )*c(3)

end function det33v
!========================================================================
real function det33m(a)
!
!  same as the previous function, different form: classic determinant
!  of a 3 by 3 matrix
!
   real, dimension(3,3), intent(IN) :: a

   det33m = a(1,1)*a(2,2)*a(3,3) - a(1,1)*a(2,3)*a(3,2) &
          - a(1,2)*a(2,1)*a(3,3) + a(1,2)*a(2,3)*a(3,1) &
          + a(1,3)*a(2,1)*a(3,2) - a(1,3)*a(2,2)*a(3,1)

end function det33m
!========================================================================
real function det44m(a)
!
!  determinant of a 4 by 4 matrix
!
   real, dimension(4,4), intent(IN) :: a
   real, dimension(3,3) :: b

   det44m = 0.0

   b(1,1) = a(2,2)
   b(1,2) = a(2,3)
   b(1,3) = a(2,4)
   b(2,1) = a(3,2)
   b(2,2) = a(3,3)
   b(2,3) = a(3,4)
   b(3,1) = a(4,2)
   b(3,2) = a(4,3)
   b(3,3) = a(4,4)

   det44m = det44m + a(1,1)*det33m(b)

   b(1,1) = a(2,1)
   b(1,2) = a(2,3)
   b(1,3) = a(2,4)
   b(2,1) = a(3,1)
   b(2,2) = a(3,3)
   b(2,3) = a(3,4)
   b(3,1) = a(4,1)
   b(3,2) = a(4,3)
   b(3,3) = a(4,4)

   det44m = det44m - a(1,2)*det33m(b)

   b(1,1) = a(2,1)
   b(1,2) = a(2,2)
   b(1,3) = a(2,4)
   b(2,1) = a(3,1)
   b(2,2) = a(3,2)
   b(2,3) = a(3,4)
   b(3,1) = a(4,1)
   b(3,2) = a(4,2)
   b(3,3) = a(4,4)

   det44m = det44m + a(1,3)*det33m(b)

   b(1,1) = a(2,1)
   b(1,2) = a(2,2)
   b(1,3) = a(2,3)
   b(2,1) = a(3,1)
   b(2,2) = a(3,2)
   b(2,3) = a(3,4)
   b(3,1) = a(4,1)
   b(3,2) = a(4,2)
   b(3,3) = a(4,3)

   det44m = det44m - a(1,4)*det33m(b)

end function det44m
!========================================================================
integer function lens(string)

   character(len=*) string

   do i=len(string),1,-1
     if( string(i:i) .ne. ' ')goto 10
   end do
   i = 0
10 continue

   lens = i

end function lens
!========================================================================
subroutine openfile(iunit,casename,extension,reqform,reqacc,status,idebug)

  character(len=*)   casename
  character(len=*)   extension
  character(len=*)   reqform
  character(len=*)   reqacc
  character(len=*)   status
  character(len=128) filename
  character(len=11)  form

  logical exists

  filename = casename(1:lens(casename))//extension(1:lens(extension))
  length   = lens(filename)

  if( idebug > 2 )write(*,*) 'Opening ',filename(1:length),' l=',length

  if( status(1:3) == 'OLD' )then
    inquire(file=filename(1:length),exist=exists,form=form)
    if( .not. exists )then
      write(*,*) '*** Error: File ',filename(1:length),' does not exist'
      stop
    endif
  endif

  !write(*,*)'open:',iunit,filename(1:length),' ',reqacc

  if( reqacc == 'APPEND' )then
    open(iunit,file=filename(1:length),form=reqform, &
               access='SEQUENTIAL',position='APPEND',status=status)
  elseif( reqacc  == 'STREAM' .and.                  &
          reqform == 'UNFORMATTED_BIG_ENDIAN' )then
      open(iunit,file=filename(1:length),form='UNFORMATTED', &
                 convert='BIG_ENDIAN',                       &
		 access=reqacc,status='REPLACE')
  else
    if( reqform == 'UNFORMATTED_BIG_ENDIAN' )then
      open(iunit,file=filename(1:length),form='UNFORMATTED', &
                 convert='BIG_ENDIAN',                       &
		 access=reqacc,status=status)
    else
      open(iunit,file=filename(1:length),form=reqform, &
                 access=reqacc,status=status)
    endif
  endif

  if( idebug >= 2 ) write(*,*) 'File ',filename(1:length),' opened'

end subroutine openfile
!========================================================================
subroutine feelfile(iunit,iform,casename,extension,reqform,reqacc,status,idebug)

   character(len=*)  casename
   character(len=*)  extension
   character(len=*)  reqform
   character(len=*)  reqacc
   character(len=*)  status
   character(len=48) filename

   character(len=12) string

   filename = casename(1:lens(casename))//extension(1:lens(extension))
   length   = lens(filename)

   if( idebug > 2 )write(*,*) 'Probing ',filename(1:length)

   call openfile(iunit,casename,extension(1:lens(extension)), &
                 'FORMATTED','SEQUENTIAL','OLD',idebug)

   read(iunit,'(a12)',err=2) string(1:12)

   if( string(1:12) == 'dolfyn asc g' )then
     write(*,*) filename(1:length),' ascii'
     iform = 1
   else
     write(*,*) filename(1:length),' binary'
     iform = 0
   endif
   close(iunit)

 2 continue
   if( idebug >= 2 ) write(*,*) 'File ',filename(1:length),' probed'

end subroutine feelfile
!========================================================================
subroutine uppercase(string)

  character(len=*) :: string

  ial = ichar('a')
  izl = ichar('z')
  iau = ichar('A')

  ioffset = iau - ial

  do i=1,len(string)
    if( ichar(string(i:i)) >= ial .and. ichar(string(i:i)) <= izl )then
      string(i:i) = char(ichar(string(i:i))+ioffset)
    endif
  end do

end subroutine uppercase
!========================================================================
subroutine lowercase(string)

  character(len=*) :: string

  ial = ichar('a')
  izl = ichar('z')
  iau = ichar('A')
  izu = ichar('Z')

  ioffset = ial - iau

  do i=1,len(string)
    if( ichar(string(i:i)) >= iau .and. ichar(string(i:i)) <= izu )then
      string(i:i) = char(ichar(string(i:i))+ioffset)
    endif
  end do

end subroutine lowercase
!========================================================================
real function random_valentclare()
!========================================================================
! random number generator
! org. f77 code by: Dick Valent and Fred Clare addapted from
! "Random Number Generators: Good Ones are Hard to Find"
! by Steven Park, Keith Miller, Communications of the ACM, October, 1988.
!========================================================================

   integer, parameter :: MPLIER =  16807, MODLUS = 2147483647, &
                         MOBYMP = 127773, MOMDMP = 2836

   integer :: hvlue, lvlue, testv, nextn = 0

   integer :: jseed = 123456789, ifirst = 0
   save       jseed, ifirst, nextnumber, nextn

   if( ifirst == 0 )then
     nextnumber = jseed
     ifirst = 1
   endif

   hvlue = nextnumber / mobymp
   lvlue = mod(nextn, mobymp)
   testv = mplier*lvlue - momdmp*hvlue
   if( testv > 0 )then
     nextn = testv
   else
     nextn = testv + modlus
   endif
   random_valentclare = real(nextn)/real(modlus)

   return

   entry RandomSeed(iseed)

   jseed  = iseed
   ifirst = 0

   random_valentclare = 0.0

   return

end function random_valentclare
subroutine CheckMassFlux

   use constants
   use geometry
   use variables

   write(*,*)'Checking mass fluxes'

   ierr = 0
   do ip=1,Ncel
     cmf = 0.0
     cmfmax = 1.e-12
     do j=1,NFaces(ip)
       k   = CFace(ip,j)
       tmp = MassFlux( k )
       if( tmp /= 0.0 )then
         cmfmax = max( cmfmax , abs(tmp) )
       endif
       if( ip == Face(k)%cell1 )then
         cmf = cmf + tmp
       else
         cmf = cmf - tmp
       endif
     end do

     if( abs(cmf) >= cmfmax )then
       ierr = ierr + 1
       if( ierr <= 10 )then
         write(*,*) '*** Check mass flux in cell =',ip,cmf,cmfmax
         write(*,*) 'volume:',Cell(ip)%vol
         cmf  = 0.0
         do j=1,NFaces(ip)
           k = CFace(ip,j)
           tmp = MassFlux( k )
           if( ip == Face(k)%cell1 )then
             cmf = cmf + tmp
             write(*,*) 'face ',k,' + ',tmp,' = ',cmf
           else
             cmf = cmf - tmp
             write(*,*) 'face ',k,' - ',tmp,' = ',cmf
           endif
         end do
       else if( ierr == 2 )then
         write(*,*)' (no more shown)'
       endif
     endif

   end do
   if( ierr > 0 )write(*,*)'Check :',ierr

end subroutine CheckMassFlux
subroutine TrackMemory(istat,i,string)
!========================================================================

   use constants, only: memory, debug, IOdbg

   integer, intent(in) :: i, istat
   character(len=*), intent(in) :: string

   memory = memory + i

   change = 0.001*float(i)
   words  = 0.000001*float(memory)
   if( istat == 0 .and. debug > -1 )then

     write(IOdbg,'(1x,A,f8.3,A,f10.3,A,A)') &
       'MEMORY ',words,' MWords, change ',change,' kWords => ',string

   else
     if( istat /= 0 ) write(*,'(1x,A,A,A,i12,i12)') &
       '*** WARNING: ',string,', memory: ',words,' MW, status ',istat
   endif

end subroutine TrackMemory
subroutine CleanUp

   use constants
   use geometry
   use variables
   use scalars
   use particles
!   use searched

   if( allocated( U        ) ) deallocate ( U        )
   if( allocated( V        ) ) deallocate ( V        )
   if( allocated( W        ) ) deallocate ( W        )
   if( allocated( P        ) ) deallocate ( P        )
   if( allocated( PP       ) ) deallocate ( PP       )
   if( allocated( TE       ) ) deallocate ( TE       )
   if( allocated( ED       ) ) deallocate ( ED       )
   if( allocated( T        ) ) deallocate ( T        )

   if( allocated( Uold     ) ) deallocate ( Uold     )
   if( allocated( Vold     ) ) deallocate ( Vold     )
   if( allocated( Wold     ) ) deallocate ( Wold     )
   if( allocated( TEold    ) ) deallocate ( TEold    )
   if( allocated( EDold    ) ) deallocate ( EDold    )
   if( allocated( Told     ) ) deallocate ( Told     )

   if( allocated( Uold2    ) ) deallocate ( Uold2    )
   if( allocated( Vold2    ) ) deallocate ( Vold2    )
   if( allocated( Wold2    ) ) deallocate ( Wold2    )
   if( allocated( TEold2   ) ) deallocate ( TEold2   )
   if( allocated( EDold2   ) ) deallocate ( EDold2   )
   if( allocated( Told2    ) ) deallocate ( Told2    )

   if( allocated( Variable ) ) deallocate ( Variable )
   if( allocated( Solver   ) ) deallocate ( Solver   )
   if( allocated( Gamma    ) ) deallocate ( Gamma    )
   if( allocated( Scheme   ) ) deallocate ( Scheme   )
   if( allocated( PostC    ) ) deallocate ( PostC    )
   if( allocated( PostV    ) ) deallocate ( PostV    )
   if( allocated( Solve    ) ) deallocate ( Solve    )
   if( allocated( Store    ) ) deallocate ( Store    )

   if( allocated(UseSlopeLimiter)) deallocate ( UseSlopeLimiter )
   if( allocated(URFSlopeLimiter)) deallocate ( URFSlopeLimiter )
   if( allocated(LimiterSlope   )) deallocate ( LimiterSlope    )

   if( allocated( GradVar  ) ) deallocate ( GradVar  )
   if( allocated( nGradVar ) ) deallocate ( nGradVar )

   if( allocated( TurbP    ) ) deallocate ( TurbP    )
   if( allocated( DEN      ) ) deallocate ( DEN      )
   if( allocated( CP       ) ) deallocate ( CP       )
   if( allocated( VisEff   ) ) deallocate ( VisEff   )
   if( allocated( dUdX     ) ) deallocate ( dUdX     )
   if( allocated( dVdX     ) ) deallocate ( dVdX     )
   if( allocated( dWdX     ) ) deallocate ( dWdX     )
   if( allocated( dPdX     ) ) deallocate ( dPdX     )
   if( allocated( MassFlux ) ) deallocate ( MassFlux )
   if( allocated( dPhidXo  ) ) deallocate ( dPhidXo  )
   if( allocated( DXdebug  ) ) deallocate ( DXdebug  )
   if( allocated( DXgrad   ) ) deallocate ( DXgrad   )

   if( allocated( Cell     ) ) deallocate ( Cell     )
   if( allocated( NFaces   ) ) deallocate ( NFaces   )
   if( allocated( CFace    ) ) deallocate ( CFace    )
   if( allocated( Face     ) ) deallocate ( Face     )
   if( allocated( RFace    ) ) deallocate ( RFace    )
   if( allocated( Bnd      ) ) deallocate ( Bnd      )
   if( allocated( Reg      ) ) deallocate ( Reg      )
   if( allocated( Vert     ) ) deallocate ( Vert     )

   if( allocated( iFaces%i ) ) deallocate ( iFaces%i    )
   if( allocated( iFaces%list))deallocate ( iFaces%list )
   if( allocated( iNodes%i ) ) deallocate ( iNodes%i    )
   if( allocated( iNodes%list))deallocate ( iNodes%list )
   if( allocated( NNodes   ) ) deallocate ( NNodes      )

   if( allocated( Ar       ) ) deallocate ( Ar       )
   if( allocated( Au       ) ) deallocate ( Au       )
   if( allocated( Av       ) ) deallocate ( Av       )
   if( allocated( Aw       ) ) deallocate ( Aw       )
   if( allocated( Su       ) ) deallocate ( Su       )
   if( allocated( Sv       ) ) deallocate ( Sv       )
   if( allocated( Sw       ) ) deallocate ( Sw       )
   if( allocated( Res      ) ) deallocate ( Res      )
   if( allocated( Residual ) ) deallocate ( Residual )
   if( allocated( ResiNorm ) ) deallocate ( ResiNorm )
   if( allocated( Acoo     ) ) deallocate ( Acoo     )
   if( allocated( Arow     ) ) deallocate ( Arow     )
   if( allocated( Acol     ) ) deallocate ( Acol     )
   if( allocated( Acsr     ) ) deallocate ( Acsr     )
   if( allocated( Arwc     ) ) deallocate ( Arwc     )
   if( allocated( Aclc     ) ) deallocate ( Aclc     )

   if( allocated( Work     ) ) deallocate ( Work     )
   if( allocated( RHS      ) ) deallocate ( RHS      )
   if( allocated( SOL      ) ) deallocate ( SOL      )

   !
   ! scalars
   !
   if( allocated( Scalar   ) ) deallocate ( Scalar   )
   if( allocated( SC       ) ) deallocate ( SC       )
   if( allocated( SCold    ) ) deallocate ( SCold    )
   if( allocated( SCold2   ) ) deallocate ( SCold2   )
   if( allocated( ScReg    ) ) deallocate ( ScReg    )
   if( allocated( ScProp   ) ) deallocate ( ScProp   )
   if( allocated( VarS     ) ) deallocate ( VarS     )
   if( allocated( SolveScalar   ) ) deallocate ( SolveScalar )
   if( allocated( StoreScalar   ) ) deallocate ( StoreScalar )

   if( allocated( LimitLowScalar ) ) deallocate ( LimitLowScalar )
   if( allocated( LimitUpScalar  ) ) deallocate ( LimitUpScalar )
   if( allocated( LowerLimitSC   ) ) deallocate ( LowerLimitSC )
   if( allocated( UpperLimitSC   ) ) deallocate ( UpperLimitSC )

   !
   ! particles
   !
   if( UseParticles )then
     write(*,*)'Deallocate particle data'
     do ipart=1,Npart
       call ParticleClearTrack(ipart)
     end do
     do ipart=1,Npart
       if( associated( Tracks(ipart)%head ) ) deallocate ( Tracks(ipart)%head )
       if( associated( Tracks(ipart)%last ) ) deallocate ( Tracks(ipart)%last )
     end do

     if( allocated( Tracks   ) ) deallocate ( Tracks   )
     if( allocated( Particle ) ) deallocate ( Particle )

    !call CollectCells(-1)   ! <=== VISUAL FORTRAN WIL DIT NIET
     call CollectCells(-1,0,0,0)

   endif
   if( allocated( Sensor     ) ) deallocate ( Sensor )
   write(*,*)'Arrays cleaned up'

end subroutine CleanUp
subroutine A33xB3(A,RHS_A)

   real, dimension(3,3) :: A
   real, dimension(2,2) :: B
   real, dimension(3)   :: X
   real, dimension(3)   :: RHS_A
   real, dimension(2)   :: RHS_B

   logical :: UseX, UseY, UseZ

   UseX = .false.
   UseY = .false.
   UseZ = .false.

   X = 0.0

   irang = 0
   if( A(1,1) /= 0.0 )then  ! altijd >= 0
     UseX = .true.
     irang = irang + 1
   else
     X(1) = 0.0
   endif
   if( A(2,2) /= 0.0 )then  ! altijd >= 0
     UseY = .true.
     irang = irang + 1
   else
     X(2) = 0.0
   endif
   if( A(3,3) /= 0.0 )then  ! altijd >= 0
     UseZ = .true.
     irang = irang + 1
   else
     X(3) = 0.0
   endif

   if( irang <= 1 )then
     !
     ! too simple, do nothing
     !

     X = 0.0

   else if( irang == 2 )then
     !
     ! only two components can be calculated
     ! assume the third to be zero
     !
     if( UseX .and. UseY )then
       B(1,1) = A(1,1)
       B(1,2) = A(1,2)
       B(2,1) = A(2,1)
       B(2,2) = A(2,2)

       RHS_B(1) = RHS_A(1)
       RHS_B(2) = RHS_A(2)
     else if( UseX .and. UseZ )then
       B(1,1) = A(1,1)
       B(1,2) = A(1,3)
       B(2,1) = A(3,1)
       B(2,2) = A(3,3)

       RHS_B(1) = RHS_A(1)
       RHS_B(2) = RHS_A(3)
     else if( UseY .and. UseZ )then
       B(1,1) = A(2,2)
       B(1,2) = A(2,3)
       B(2,1) = A(3,2)
       B(2,2) = A(3,3)

       RHS_B(1) = RHS_A(2)
       RHS_B(2) = RHS_A(3)
     endif
     !
     ! B inverteren
     !
     if( B(1,1) /= 0.0 )then
       p1 = - B(2,1)/B(1,1)
       B(2,1) = B(2,1) + p1 * B(1,1)
       B(2,2) = B(2,2) + p1 * B(1,2)

       RHS_B(2) = RHS_B(2) + p1 * RHS_B(1)

     else
       write(*,1) 1
     endif
     if( B(2,2) /= 0.0 )then
       p2 = - B(1,2)/B(2,2)
       B(1,1) = B(1,1) + p2 * B(2,1)
       B(1,2) = B(1,2) + p2 * B(2,2)

       RHS_B(1) = RHS_B(1) + p2 * RHS_B(2)

     else
       write(*,1) 2
     endif
     !
     ! normeren
     !
     if( B(1,1) /= 0.0 )then
       p3 = 1.0/B(1,1)
       B(1,1) = p3 * B(1,1)
       B(1,2) = p3 * B(1,2)

       RHS_B(1) = p3 * RHS_B(1)

     else
       write(*,1) 3
     endif
     if( B(2,2) /= 0.0 )then
       p4 = 1.0/B(2,2)
       B(2,1) = p4 * B(2,1)
       B(2,2) = p4 * B(2,2)

       RHS_B(2) = p4 * RHS_B(2)

     else
       write(*,1) 4
     endif
     !
     ! de gradient
     !
     if( UseX .and. UseY )then
       X(1) = RHS_B(1)
       X(2) = RHS_B(2)
       X(3) = 0.0
     else if( UseX .and. UseZ )then
       X(1) = RHS_B(1)
       X(2) = 0.0
       X(3) = RHS_B(2)
     else if( UseY .and. UseZ )then
       X(1) = 0.0
       X(2) = RHS_B(1)
       X(3) = RHS_B(2)
     endif

   else if( irang == 3 )then
     !
     ! the case were all three components
     ! can be calculated
     !
     if( A(1,1) /= 0.0 )then
       p1 = - A(2,1)/A(1,1)
       A(2,1) = A(2,1) + p1 * A(1,1)
       A(2,2) = A(2,2) + p1 * A(1,2)
       A(2,3) = A(2,3) + p1 * A(1,3)
       RHS_A(2) = RHS_A(2) + p1 * RHS_A(1)

       p2 = - A(3,1)/A(1,1)
       A(3,1) = A(3,1) + p2 * A(1,1)
       A(3,2) = A(3,2) + p2 * A(1,2)
       A(3,3) = A(3,3) + p2 * A(1,3)
       RHS_A(3) = RHS_A(3) + p2 * RHS_A(1)
     else
       write(*,1) 5
     endif
     if( A(2,2) /= 0.0 )then
       p3 = - A(1,2)/A(2,2)
       A(1,1) = A(1,1) + p3 * A(2,1)
       A(1,2) = A(1,2) + p3 * A(2,2)
       A(1,3) = A(1,3) + p3 * A(2,3)
       RHS_A(1) = RHS_A(1) + p3 * RHS_A(2)

       p4 = - A(3,2)/A(2,2)
       A(3,1) = A(3,1) + p4 * A(2,1)
       A(3,2) = A(3,2) + p4 * A(2,2)
       A(3,3) = A(3,3) + p4 * A(2,3)
       RHS_A(3) = RHS_A(3) + p4 * RHS_A(2)
     else
       write(*,1) 6
     endif

     if( A(3,3) /= 0.0 )then
       p5 = - A(1,3)/A(3,3)
       A(1,1) = A(1,1) + p5 * A(3,1)
       A(1,2) = A(1,2) + p5 * A(3,2)
       A(1,3) = A(1,3) + p5 * A(3,3)
       RHS_A(1) = RHS_A(1) + p5 * RHS_A(3)

       p6 = - A(2,3)/A(3,3)
       A(2,1) = A(2,1) + p6 * A(3,1)
       A(2,2) = A(2,2) + p6 * A(3,2)
       A(2,3) = A(2,3) + p6 * A(3,3)
       RHS_A(2) = RHS_A(2) + p6 * RHS_A(3)
     else
       write(*,1) 7
     endif
     !
     ! normeren
     !
     if( A(1,1) /= 0.0 )then
       p7 = 1.0/A(1,1)
       A(1,1) = p7 * A(1,1)
       A(1,2) = p7 * A(1,2)
       A(1,3) = p7 * A(1,3)
       RHS_A(1) = p7 * RHS_A(1)
     else
       write(*,1) 8
     endif
     if( A(2,2) /= 0.0 )then
       p8 = 1.0/A(2,2)
       A(2,1) = p8 * A(2,1)
       A(2,2) = p8 * A(2,2)
       A(2,3) = p8 * A(2,3)
       RHS_A(2) = p8 * RHS_A(2)
     else
       write(*,1) 8
     endif
     if( A(3,3) /= 0.0 )then
       p9 = 1.0/A(3,3)
       A(3,1) = p9 * A(3,1)
       A(3,2) = p9 * A(3,2)
       A(3,3) = p9 * A(3,3)
       RHS_A(3) = p9 * RHS_A(3)
     else
       write(*,1) 9
     endif
     !
     ! de gradient
     !
     X(1) = RHS_A(1)
     X(2) = RHS_A(2)
     X(3) = RHS_A(3)

   else
     write(*,*)'+ internal error A33xB3 catch 22:',irang
   endif

   RHS_A(1) = X(1)
   RHS_A(2) = X(2)
   RHS_A(3) = X(3)

 1 format('+ internal error: A33xB3 ',i2)

end subroutine A33xB3


    program demo_sign
    implicit none
       print *, sign( -12,  1 )
       print *, sign( -12,  0 )
       print *, sign( -12, -1 )

       print *, sign( -12.0, [1.0, 0.0, -1.0] )

       print *,'can I distinguish 0 from -0? ',sign(1.0,-0.0).ne.sign(1.0,0.0)
    end program demo_sign


! sample compile command to generate *.o object file:
!      gfortran -fopenmp -c Fig_11.6_hist.f90

program main
   use omp_lib
   implicit none

   integer, parameter :: num_trials = 1000000	 ! number of x values
   integer, parameter :: num_bins = 100		   ! number of bins in histogram
   real*8, save :: xlow = 0.0;		   ! low end of x range
   real*8, save :: xhi = 10.0;		   ! high end of x range

   real*8 :: x
   integer*8 :: hist(num_bins)   ! the histogram
   integer*8 :: ival, i
   real*8 :: bin_width    ! the width of each bin in the hi, stogram
   real*8 :: sumh, sumhsq, ave, std_dev
   integer(kind=omp_lock_kind) :: hist_lcks(num_bins)   ! array of locks, one per bucket

   interface
      function drandom() result(val)
         real*8 :: val
      end function
      subroutine seed(low_in, hi_in)
         real*8, intent(in) :: low_in, hi_in
      end subroutine
   end interface

   call seed(xlow, xhi)     ! seed random generator over range of x
   bin_width = (xhi - xlow) / dble(num_bins)

   ! initialize the histogram and the array of locks
   !$omp parallel do schedule(static)
      do i = 1, num_bins
         hist(i) = 0
         call omp_init_lock(hist_lcks(i))
      enddo
   !$omp end parallel do
   ! test uniform pseudorandom sequence by assigning values
   ! to the right histogram bin
   !$omp parallel do schedule(static) private(x,ival)
      do i = 1, num_trials
         x = drandom()
         ival = int8((x - xlow)/bin_width)
         ! protect histogram bins. Low overhead due to uncontended locks
         call omp_set_lock(hist_lcks(ival))
         hist(ival) = hist(ival) + 1
         call omp_unset_lock(hist_lcks(ival))
      enddo
   !$omp end parallel do

   sumh = 0.0
   sumhsq = 0.0
   ! compute statistics (ave, std_dev) and destroy locks
   !$omp parallel do schedule(static) reduction(+:sumh,sumhsq)
      do i = 1, num_bins
         sumh  = sumh + hist(i)
         sumhsq = sumhsq + hist(i)*hist(i)
         call omp_destroy_lock(hist_lcks(i))
      enddo
   !$omp end parallel do

   ave = sumh / dble(num_bins)
   std_dev = sqrt(sumhsq /(dble(num_bins) - ave * ave))
end program main


evapoTranspirationPriestlyTaylor = MAX((Alpha * hslope * (netRadiationEquivalentEvaporation) / (hslope + psychrometricConstant)), 0)


module nanoparticle_models
use math
implicit none
contains
    !Sphere CS NP
    double precision function cs_sphere_core_a_fraction(x, p, Np)
        double precision, intent(in) :: x
        double precision, dimension(Np), intent(in) :: p
        integer, intent(in) :: Np

        double precision :: x0
        double precision :: density, core_radius, shell_thickness

        double precision :: particle_size, xshift

        x0 = p(1)
        density = p(2)
        core_radius = p(3)
        shell_thickness = p(4)

        particle_size = core_radius + shell_thickness
        xshift = x - particle_size - x0

        if (xshift < -core_radius) then
            cs_sphere_core_a_fraction = 0d0
        else if (xshift  < core_radius) then
            cs_sphere_core_a_fraction = ((core_radius/particle_size)**2 -&
                                         (xshift/particle_size)**2)
        else
            cs_sphere_core_a_fraction = 0d0
        end if
    end function cs_sphere_core_a_fraction

    double precision function cs_sphere_shell_a_fraction(x, p, Np)
        double precision, intent(in) :: x
        double precision, dimension(Np), intent(in) :: p
        integer, intent(in) :: Np

        double precision :: x0
        double precision :: density, core_radius, shell_thickness

        double precision :: particle_size, xshift

        x0 = p(1)
        density = p(2)
        core_radius = p(3)
        shell_thickness = p(4)

        particle_size = core_radius + shell_thickness
        xshift = x - particle_size - x0

        if (xshift < -particle_size) then
            cs_sphere_shell_a_fraction = 0d0
        else if (xshift < -core_radius) then
            cs_sphere_shell_a_fraction =&
                                (1d0- (xshift/particle_size)**2 )
        else if (xshift  < core_radius) then
            cs_sphere_shell_a_fraction =&
                                (1d0 - (core_radius/particle_size)**2)
        else if (xshift < particle_size) then
            cs_sphere_shell_a_fraction =&
                                (1d0- (xshift/particle_size)**2 )
        else
            cs_sphere_shell_a_fraction = 0d0
        end if
    end function cs_sphere_shell_a_fraction

    subroutine sld_coreshell_sphere(x, x0,&
                                    density, core_radius, shell_thickness,&
                                    sig_radius, sig_x0,&
                                    sld_core, sld_shell, sld_matrix,&
                                    Nx, sld)
    double precision, intent(in), dimension(Nx) :: x
    double precision, intent(in) :: x0, density, core_radius, shell_thickness
    double precision, intent(in) :: sig_radius, sig_x0
    complex*16, intent(in) :: sld_core, sld_shell, sld_matrix
    integer, intent(in) :: Nx
    complex*16, intent(out), dimension(Nx) :: sld

    integer, parameter :: Np=4
    double precision, dimension(Nx) :: area_core, area_shell
    double precision, dimension(Np) :: p
    double precision :: Rmin, Rmax
    double precision :: x0min, x0max

    integer :: ix

    p = (/x0, density, core_radius, shell_thickness/)
    call get_cutoff_gaussian(x0, sig_x0, x0min, x0max)
    call get_cutoff_lognormal(core_radius, sig_radius, Rmin, Rmax)

    !$omp parallel
    !$omp do
    do ix=1, Nx
        call integrate_two_size_distributions(x(ix), p, Np, &
                        1, x0min, x0max, sig_x0, &
                        3, Rmin, Rmax, sig_radius, &
                        cs_sphere_core_a_fraction, gaussian, lognormal, area_core(ix))
        call integrate_two_size_distributions(x(ix), p, Np, &
                        1, x0min, x0max, sig_x0, &
                        3, Rmin, Rmax, sig_radius, &
                        cs_sphere_shell_a_fraction, gaussian, lognormal, area_shell(ix))
    end do
    !$omp end do
    !$omp end parallel

    sld = sld_core*area_core*density + sld_shell*area_shell*density +&
          sld_matrix*(1d0 - area_core*density - area_shell*density)
    end subroutine sld_coreshell_sphere

    subroutine sld_immersed_coreshell_sphere(x, x0,&
                                    density, core_radius, shell_thickness,&
                                    immersion_depth,&
                                    sig_radius,&
                                    sld_core, sld_shell, sld_matrix,&
                                    Nx, sld)
    double precision, intent(in), dimension(Nx) :: x
    double precision, intent(in) :: x0, density, core_radius, shell_thickness
    double precision, intent(in) :: immersion_depth
    double precision, intent(in) :: sig_radius
    complex*16, intent(in) :: sld_core, sld_shell, sld_matrix
    integer, intent(in) :: Nx
    complex*16, intent(out), dimension(Nx) :: sld

    integer, parameter :: Np=4
    double precision, dimension(Nx) :: area_core, area_shell, sld_immersion
    double precision, dimension(Np) :: p
    double precision :: Rmin, Rmax
    double precision :: x0min, x0max

    integer :: ix

    p = (/x0, density, core_radius, shell_thickness/)
    call get_cutoff_lognormal(core_radius, sig_radius, Rmin, Rmax)

    !$omp parallel
    !$omp do
    do ix=1, Nx
        call integrate_size_distribution(x(ix), p, Np, &
                        3, Rmin, Rmax, sig_radius, &
                        cs_sphere_core_a_fraction, lognormal, area_core(ix))
        call integrate_size_distribution(x(ix), p, Np, &
                        3, Rmin, Rmax, sig_radius, &
                        cs_sphere_shell_a_fraction, lognormal, area_shell(ix))

        if (x(ix) < immersion_depth) then
            sld_immersion(ix) = sld_matrix
        else
            sld_immersion(ix) = 0d0
        end if
    end do
    !$omp end do
    !$omp end parallel

    sld = sld_core*area_core*density + sld_shell*area_shell*density +&
          sld_immersion*(1d0 - area_core*density - area_shell*density)
    end subroutine sld_immersed_coreshell_sphere

    subroutine sld_multi_immersed_coreshell_sphere(x, x0, density,&
                                    core_radius, shell_thickness,&
                                    immersion_depth,&
                                    sig_radius,&
                                    sld_core, sld_shell, sld_matrix,&
                                    N, Nx, sld)
    double precision, intent(in), dimension(Nx) :: x
    double precision, intent(in), dimension(N) :: x0, density
    double precision, intent(in) :: core_radius, shell_thickness
    double precision, intent(in) :: immersion_depth
    double precision, intent(in) :: sig_radius
    complex*16, intent(in) :: sld_core, sld_shell, sld_matrix
    integer, intent(in) :: N, Nx
    complex*16, intent(out), dimension(Nx) :: sld

    integer, parameter :: Np=4
    double precision, dimension(Nx) :: area_core, area_shell, sld_immersion
    double precision, dimension(Np) :: p, parallel_p
    double precision :: Rmin, Rmax
    double precision :: x0min, x0max
    double precision :: particle_radius, parallel_areaC, parallel_areaS
    integer :: ix, i

    call get_cutoff_lognormal(core_radius, sig_radius, Rmin, Rmax)
    p = (/0d0, 0d0, core_radius, shell_thickness/)
    particle_radius = core_radius + shell_thickness
    area_core = 0d0
    area_shell = 0d0
    sld_immersion = 0d0

    do ix=1, Nx
        do i=1, N
            parallel_p = p
            parallel_p(1) = x0(i) + (i-1)*2d0*sqrt(6d0)/3d0*particle_radius
            parallel_p(2) = density(i)
            parallel_areaC = 0d0
            parallel_areaS = 0d0
            call integrate_size_distribution(x(ix), parallel_p, Np, &
                            3, Rmin, Rmax, sig_radius, &
                            cs_sphere_core_a_fraction, lognormal, parallel_areaC)
            call integrate_size_distribution(x(ix), parallel_p, Np, &
                            3, Rmin, Rmax, sig_radius, &
                            cs_sphere_shell_a_fraction, lognormal, parallel_areaS)

            area_core(ix) = area_core(ix) + parallel_areaC*density(i)
            area_shell(ix) = area_shell(ix) + parallel_areaS*density(i)
        end do

        if (x(ix) < immersion_depth) then
            sld_immersion(ix) = sld_matrix
        else
            sld_immersion(ix) = 0d0
        end if
        ! print *, ix, area_core(ix), area_shell(ix), sld_immersion(ix)
    end do

    sld = sld_core*area_core + sld_shell*area_shell +&
          sld_immersion*(1d0 - area_core - area_shell)
    end subroutine sld_multi_immersed_coreshell_sphere
!    !$omp parallel private(parallel_p, parallel_areaC, parallel_areaS)
!    !$omp do
!    !$omp end do
!    !$omp end parallel

    ! Cube CS NP
    double precision function cs_cube_core_a_fraction(x, p, Np)
        double precision, intent(in) :: x
        double precision, dimension(Np), intent(in) :: p
        integer, intent(in) :: Np

        double precision :: x0
        double precision ::density, core_edge_length, shell_thickness

        double precision :: particle_size, xshift

        x0 = p(1)
        density = p(2)
        core_edge_length = p(3)
        shell_thickness = p(4)

        particle_size = core_edge_length + 2*shell_thickness
        xshift = x - x0

        if (xshift < shell_thickness) then
            cs_cube_core_a_fraction = 0d0
        else if (xshift  < core_edge_length+shell_thickness) then
            cs_cube_core_a_fraction =&
                                 ((core_edge_length/particle_size)**2)*density
        else
            cs_cube_core_a_fraction = 0d0
        end if
    end function cs_cube_core_a_fraction

    double precision function cs_cube_shell_a_fraction(x, p, Np)
        double precision, intent(in) :: x
        double precision, dimension(Np), intent(in) :: p
        integer, intent(in) :: Np

        double precision :: x0
        double precision :: density, core_edge_length, shell_thickness

        double precision :: particle_size, xshift

        x0 = p(1)
        density = p(2)
        core_edge_length = p(3)
        shell_thickness = p(4)

        particle_size = core_edge_length + 2*shell_thickness
        xshift = x - x0

        if (xshift < 0d0) then
            cs_cube_shell_a_fraction = 0d0
        else if (xshift < shell_thickness) then
            cs_cube_shell_a_fraction = density
        else if (xshift  < shell_thickness+core_edge_length) then
            cs_cube_shell_a_fraction =&
                            (1d0 - (core_edge_length/particle_size)**2)*density
        else if (xshift < particle_size) then
            cs_cube_shell_a_fraction = density
        else
            cs_cube_shell_a_fraction = 0d0
        end if
    end function cs_cube_shell_a_fraction

    subroutine sld_coreshell_cube(x, x0,&
                                    density, core_edgelength, shell_thickness,&
                                    sig_edgelength, sig_x0,&
                                    sld_core, sld_shell, sld_matrix,&
                                    Nx, sld)
    double precision, intent(in), dimension(Nx) :: x
    double precision, intent(in) :: x0, density, core_edgelength, shell_thickness
    double precision, intent(in) :: sig_edgelength, sig_x0
    complex*16, intent(in) :: sld_core, sld_shell, sld_matrix
    integer, intent(in) :: Nx
    complex*16, intent(out), dimension(Nx) :: sld

    integer, parameter :: Np=4
    double precision, dimension(Nx) :: area_core, area_shell
    double precision, dimension(Np) :: p
    double precision :: edgemin, edgemax
    double precision :: x0min, x0max

    integer :: ix

    p = (/x0, density, core_edgelength, shell_thickness/)
    call get_cutoff_gaussian(x0, sig_x0, x0min, x0max)
    call get_cutoff_lognormal(core_edgelength, sig_edgelength, edgemin, edgemax)

    !$omp parallel
    !$omp do
    do ix=1, Nx
        call integrate_two_size_distributions(x(ix), p, Np, &
                        1, x0min, x0max, sig_x0, &
                        3, edgemin, edgemax, sig_edgelength, &
                        cs_cube_core_a_fraction, gaussian, lognormal, area_core(ix))
        call integrate_two_size_distributions(x(ix), p, Np, &
                        1, x0min, x0max, sig_x0, &
                        3, edgemin, edgemax, sig_edgelength, &
                        cs_cube_shell_a_fraction, gaussian, lognormal, area_shell(ix))
    end do
    !$omp end do
    !$omp end parallel

    sld = sld_core*area_core + sld_shell*area_shell +&
          sld_matrix*(1d0 - area_core - area_shell)
    end subroutine sld_coreshell_cube

    subroutine sld_colloidal_coreshell_cubes_45deg_period(x, x0,&
                                a, d,&
                                sld_core, sld_shell, sld_matrix,&
                                N_periods, Nx, sld)

    double precision, intent(in), dimension(Nx) :: x
    double precision, intent(in) :: x0
    double precision, intent(in) :: a, d
    complex*16, intent(in) :: sld_core, sld_shell, sld_matrix
    integer, intent(in) :: N_periods, Nx
    complex*16, intent(out), dimension(Nx) :: sld

    double precision, dimension(Nx) :: area_core, area_shell
    integer :: ix, iper
    double precision :: z
    double precision :: A_ref,sq2d, sq2a, sq2a2, diagonal_center, diagonal_length
    double precision :: half_cube_diagonal
    !a: core edge length
    !d: shell thickness

    sq2a = sq2*a
    sq2a2 = sq2*a**2
    sq2d = sq2*d
    half_cube_diagonal = 5d-1*sq2a
    diagonal_center = half_cube_diagonal + sq2d
    diagonal_length = sq2*(a+2d0*d)
    area_shell = 0d0
    area_core = 0d0
    A_ref = 1d0/(2d0*(a+2*d)**2)

!    !$omp parallel
!    !$omp do
    do ix=1, Nx
        z = x(ix) - x0
        ! bottom cube layer
        if (z < 0 .or. z > (N_periods+1)*diagonal_length) continue

        if (z < sq2d) then
            continue
        else if (z < diagonal_center) then
            area_core(ix) = area_core(ix) + 2d0*a*(z - sq2d)*A_ref
        else
            continue
        end if
        z = z - diagonal_center
        do iper=0, N_periods-1
            ! outer 4 cubes area fraction:
            if (z < 0d0) then
                continue
            else if (z < half_cube_diagonal) then
                area_core(ix) = area_core(ix) + (sq2a2 - 2d0*a*z) * A_ref
            else if (z < diagonal_center+sq2d) then
                continue
            else if (z <= diagonal_length) then
                area_core(ix) = area_core(ix) + 2d0*a*(z - (diagonal_center+sq2d))*A_ref
            else
                continue
            end if

            ! center cube area fraction:
            if (z < sq2d) then
                continue
            else if (z < diagonal_center) then
                area_core(ix) = area_core(ix) + 2d0*a*(z - sq2d)*A_ref
            else if (z < diagonal_length - sq2d) then
                area_core(ix) = area_core(ix) + (sq2a2 - 2d0*a*(z - diagonal_center))*A_ref
            else
                continue
            end if
            z = z - diagonal_length
        end do
!         top cube layer
        if (z < 0d0) then
            continue
        else if (z < half_cube_diagonal) then
            area_core(ix) = area_core(ix) + (sq2a2 - 2d0*a*z)*A_ref
        else
            continue
        end if
    end do
!    !$omp end do
!    !$omp end parallel

    sld = sld_core*area_core + sld_shell*area_shell + sld_matrix*(1d0 - area_core - area_shell)
    end subroutine sld_colloidal_coreshell_cubes_45deg_period

end module nanoparticle_models


      subroutine gauinv(p,xp,ierr)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c Computes the inverse of the standard normal cumulative distribution
c function with a numerical approximation from : Statistical Computing,
c by W.J. Kennedy, Jr. and James E. Gentle, 1980, p. 95.
c
c
c
c INPUT/OUTPUT:
c
c   p    = double precision cumulative probability value: dble(psingle)
c   xp   = G^-1 (p) in single precision
c   ierr = 1 - then error situation (p out of range), 0 - OK
c
c
c-----------------------------------------------------------------------
      real*8 p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,y,pp,lim,p
      save   p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,lim
c
c Coefficients of approximation:
c
      data lim/1.0e-10/
      data p0/-0.322232431088/,p1/-1.0/,p2/-0.342242088547/,
     +     p3/-0.0204231210245/,p4/-0.0000453642210148/
      data q0/0.0993484626060/,q1/0.588581570495/,q2/0.531103462366/,
     +     q3/0.103537752850/,q4/0.0038560700634/
c
c Check for an error situation:
c
      ierr = 1
      if(p.lt.lim) then
            xp = -1.0e10
            return
      end if
      if(p.gt.(1.0-lim)) then
            xp =  1.0e10
            return
      end if
      ierr = 0
c
c Get k for an error situation:
c
      pp   = p
      if(p.gt.0.5) pp = 1 - pp
      xp   = 0.0
      if(p.eq.0.5) return
c
c Approximate the function:
c
      y  = dsqrt(dlog(1.0/(pp*pp)))
      xp = real( y + ((((y*p4+p3)*y+p2)*y+p1)*y+p0) /
     +               ((((y*q4+q3)*y+q2)*y+q1)*y+q0) )
      if(real(p).eq.real(pp)) xp = -xp
c
c Return with G^-1(p):
c
      return
      end


      subroutine trbak3(nm, n, nv, a, m, z)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: nm
      integer , intent(in) :: n
      integer , intent(in) :: nv
      integer , intent(in) :: m
      real(double) , intent(in) :: a(nv)
      real(double) , intent(inout) :: z(nm,m)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: i, j, k, l, ik, iz
      real(double) :: h, s
!-----------------------------------------------
!
!
!     this subroutine is a translation of the algol procedure trbak3,
!     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
!
!     this subroutine forms the eigenvectors of a real symmetric
!     matrix by back transforming those of the corresponding
!     symmetric tridiagonal matrix determined by  tred3.
!
!     on input
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement.
!
!        n is the order of the matrix.
!
!        nv must be set to the dimension of the array parameter a
!          as declared in the calling program dimension statement.
!
!        a contains information about the orthogonal transformations
!          used in the reduction by  tred3  in its first
!          n*(n+1)/2 positions.
!
!        m is the number of eigenvectors to be back transformed.
!
!        z contains the eigenvectors to be back transformed
!          in its first m columns.
!
!     on output
!
!        z contains the transformed eigenvectors
!          in its first m columns.
!
!     note that trbak3 preserves vector euclidean norms.
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
!     ------------------------------------------------------------------
!
      if (m /= 0) then
         if (n /= 1) then
!
            do i = 2, n
               l = i - 1
               iz = (i*l)/2
               ik = iz + i
               h = a(ik)
               if (h == 0.0D0) cycle
!
               do j = 1, m
                  ik = iz
!
                  s = sum(a(ik+1:l+ik)*z(:l,j))
!     .......... double division avoids possible underflow ..........
                  s = (s/h)/h
                  ik = iz
!
                  z(:l,j) = z(:l,j) - s*a(ik+1:l+ik)
!
               end do
!
            end do
!
         endif
      endif
      return
      end subroutine trbak3


!> Numerical storage size parameters for real and integer values
module kind_parameter
    implicit none
    public

    !> Single precision real numbers, 6 digits, range 10⁻³⁷ to 10³⁷-1; 32 bits
    integer, parameter :: sp = selected_real_kind(6, 37)
    !> Double precision real numbers, 15 digits, range 10⁻³⁰⁷ to 10³⁰⁷-1; 64 bits
    integer, parameter :: dp = selected_real_kind(15, 307)
    !> Quadruple precision real numbers, 33 digits, range 10⁻⁴⁹³¹ to 10⁴⁹³¹-1; 128 bits
    integer, parameter :: qp = selected_real_kind(33, 4931)

    !> Char length for integers, range -2⁷ to 2⁷-1; 8 bits
    integer, parameter :: i1 = selected_int_kind(2)
    !> Short length for integers, range -2¹⁵ to 2¹⁵-1; 16 bits
    integer, parameter :: i2 = selected_int_kind(4)
    !> Length of default integers, range -2³¹ to 2³¹-1; 32 bits
    integer, parameter :: i4 = selected_int_kind(9)
    !> Long length for integers, range -2⁶³ to 2⁶³-1; 64 bits
    integer, parameter :: i8 = selected_int_kind(18)

 end module kind_parameter


subroutine sub
real::a2(10,20)
a2 = reshape((/((real(i),i=1,10),j=1,20)/),(/10,20/))
end


!=== === +++ === === +++ === === +++ === ===
! File:   Generate_random_numbers_module.f90
! Author: John R. Brandon
! eMail:  jbrandon at gmail
! Date :  Apr 2015
! Developed under OS:  Mac OS 10.9.5 (x86_64-apple-darwin10.8.0 (64-bit))
! Language : Fortran 90/95
! Originally compiled using: GCC GNU gfortran v 4.2 (free open source Fortran 90/95 compiler) -- https://gcc.gnu.org/
! IDE: Netbeans 8.0.2
!====== +++ === === +++ === === +++ === ===
! Purpose : Create the seed vector to initialize the random number generator (RNG).
!  This code takes values from an input file (e.g. input.par) and creates the seed vector accordingly.
!  For example, if the input file specifies a certain value for seed (iseed), that will be used. Otherwise,
!   the system clock will be used to create the seed vector.
!  The RNG is initialized by calling the intrinsic random_seed() routine and passing it the seed vector.
!====== +++ === === +++ === === +++ === ===

MODULE Generate_random_numbers_module

    use Declare_variables_module ! contains variables read from input file re: how to seed RNG

    implicit none

    contains
!#######################################################
    subroutine set_random_seed()
        implicit none ! this is not necessary to include in procedure, because 'implicit none' is declared at the module level
        integer(kind = 4), allocatable :: seed(:) ! This is a general routine, so leaving variable declarations here for portability
        integer(kind = 4) :: seed_n               ! Length of the seed vector
        integer(kind = 4) :: init_seed            ! Value underlying creation of seed vector values
        integer(kind = 4) :: ii                   ! Counter
        call random_seed(size = seed_n) ! Call the intrinsic random_seed subroutine and return length of seed vector (might be compiler dependent)
        allocate(seed(seed_n)) ! Dimension the seed vector accordingly (using allocate to dynamically dimension vector)

!        print *, "seed(seed_n): ", seed ! in gfortran 4.2 compiler on Mac OS X 10.9, seed is vector of length eight (zeros at this stage)
!        print *, "seed_n: ", seed_n

        if(cseed.eq."Y") then      ! User wants to specify the seed for the RNG, e.g. so results are reproducible
            init_seed = iseed      ! User defined seed from input file
        else if(cseed.eq."N") then ! User wants a random seed for RNG instead
            call system_clock(count = init_seed)   ! Seed is set using CPU time
        else
            stop "ERROR: Program stopped running, cseed in input file needs to = Y or N"
        end if

!         print *, "init_seed: ", init_seed
         do ii = 1, seed_n
             seed(ii) = init_seed + 37*(ii-1) ! Recommended function for setting seeds of RNG because 37 is prime number and RNG likes primes
!             print *, "ii / seed(ii): ", ii, seed(ii)
         enddo

         call random_seed(put = seed) ! pass the seed vector to initialize the random number generator

    end subroutine set_random_seed

END MODULE Generate_random_numbers_module


program arr_construct
  integer:: K
  real ::a(4) = (/ 2, (K,K=1,3,1) /)
  print *,a
end program arr_construct


      PROGRAM LA_CHPEV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_HPEV, LA_HPEVD
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, INFO, N
      REAL(WP), ALLOCATABLE :: W(:)
!  .. "Local Arrays" ..
      COMPLEX(WP), ALLOCATABLE :: A(:), AA(:), Z(:,:)
!  .. "Intrinsic Functions" ..
      INTRINSIC  AIMAG, INT
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_HPEV Example Program Results'
      N = 5
      ALLOCATE( A(N*(N+1)/2), AA(N*(N+1)/2), W(N), Z(N,N) )

      OPEN(UNIT=21,FILE='hpev.ma',STATUS='UNKNOWN')
      DO I=1,N*(N+1)/2
         READ(21,*) A(I)
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A : '
      DO I=1,N*(N+1)/2
         WRITE(*,"((I3,1X,'+',1X,I3,'i',1X))") INT(A(I)),INT(AIMAG(A(I)))
      ENDDO

      WRITE(*,*) "CALL LA_HPEV( A, W) "
      CALL LA_HPEV( A, W )

      WRITE(*,*) 'W on exit : '
      DO I=1,N
      WRITE(*,"(5(E14.6))") W(I)
      ENDDO
      WRITE(*,*)
      WRITE(*,*) ' * EXAMPLE 2 * '

      OPEN(UNIT=21,FILE='hpev.mat',STATUS='UNKNOWN')
      DO I=1,N*(N+1)/2
         READ(21,*) A(I)
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A : '
      DO I=1,N*(N+1)/2
         WRITE(*,"((I3,1X,'+',1X,I3,'i',1X))") INT(A(I)),INT(AIMAG(A(I)))
      ENDDO

      WRITE(*,*) "CALL LA_HPEVD( A, W, 'L', Z, INFO )"
      CALL LA_HPEVD( A, W, 'L', Z, INFO )

      WRITE(*,*)'Z on exit: '
      DO I=1,N; WRITE(*,*) Z(I,:);
      ENDDO

      WRITE(*,*) ' INFO = ', INFO

      END PROGRAM LA_CHPEV_EXAMPLE


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MQuickSort

    use MArrayStack
    use MSort

    implicit none
    private

    type, extends(TSort), public :: TQuickSort
    contains
        procedure, nopass :: sort => sortOriginal

        procedure, nopass :: sortOriginal
        procedure, nopass :: sortStackBased
    end type

contains
    subroutine sortOriginal(array)
        integer, dimension(:), intent(in out) :: array

        call sortOriginalProc(array, 1, size(array))
    end subroutine

    recursive subroutine sortOriginalProc(array, left, right)
        integer, dimension(:), intent(in out) :: array
        integer, intent(in) :: left
        integer, intent(in) :: right

        integer pivot

        if (right > left) then
            pivot = partition(array, left, right)

            call sortOriginalProc(array, left, pivot - 1)
            call sortOriginalProc(array, pivot + 1, right)
        end if
    end subroutine

    subroutine sortStackBased(array)
        integer, dimension(:), intent(in out) :: array

        type(TArrayStack) :: stack
        integer index
        integer left
        integer right

        call stack%init()

        left  = 1
        right = size(array)

        do
            do while (right > left)
                index = partition(array, left, right)

                if (index - left > right - index) then
                    call stack%push(left)
                    call stack%push(index - 1)

                    left = index + 1
                else
                    call stack%push(index + 1)
                    call stack%push(right)

                    right = index - 1
                end if
            end do

            ! stack is empty
            if (stack%peek() == 0) then
                exit
            end if

            right = stack%pop()
            left  = stack%pop()
        end do

        call stack%destroy()
    end subroutine

    function partition(array, left, right) result(pivot)
        integer, dimension(:), intent(in out) :: array
        integer, intent(in) :: left
        integer, intent(in) :: right

        integer pivot
        integer jndex
        integer value
        integer buffer

        value = array(right)
        pivot = left - 1
        jndex = right

        do
            pivot = pivot + 1
            jndex = jndex - 1

            do while (array(pivot) < value)
                pivot = pivot + 1
            end do

            do while (array(jndex) > value)
                jndex = jndex - 1
            end do

            if (pivot >= jndex) then
                exit
            end if

            buffer       = array(pivot)
            array(pivot) = array(jndex)
            array(jndex) = buffer
        end do

        buffer       = array(pivot)
        array(pivot) = array(right)
        array(right) = buffer
    end function
end module


module modf
implicit none

contains

FUNCTION gsumf(x) RESULT(y)
    implicit none
    INTEGER , DIMENSION(: ), INTENT(IN) :: x
    INTEGER:: y
    INTEGER:: i
    INTEGER:: i_cyml0
    y = 0
    DO i_cyml0 = 1, SIZE(x)
        i = x(i_cyml0)
        y = y + i
    END DO
END FUNCTION gsumf

end module modf


      subroutine torus_setprob()
      implicit none

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta
      common /torus_comm/ alpha, beta

      integer example
      common /example_comm/ example

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      integer color_equation
      common /eqn_comm/ color_equation

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

      open(10,file='setprob.data')
      read(10,*) example
      read(10,*) alpha
      read(10,*) beta
      read(10,*) revs_per_s
      read(10,*) color_equation
      close(10)

      end


!
!     (c) 2020-2021 Sourcery, Inc.
!     This software was developed for the U.S. Nuclear Regulatory Commission (US NRC) under contract # 31310020D0006:
!     "Technical Assistance in Support of NRC Nuclear Regulatory Research for Materials, Waste, and Reactor Programs"
!
module calc_K

implicit none

    contains

    !Function to calculate K(t)
    elemental function Ki_t(a, b, stress)

        use constants_h, only: Pi

        !Variables
        real :: Ki_t
        real, intent(in) :: a, b, stress

        !Calculate Ki_t
        Ki_t = stress*sqrt(Pi*a)*   &
            (1.122-0.231*(a/b)+10.55*(a/b)**2-21.71*(a/b)**3+30.382*(a/b)**4)

    end function Ki_t

end module calc_K


! Program to generate a lattice of spin-1/2 particles and study its
! Ferromagnetic properties
! Author: Anantha Rao (Reg no: 20181044)

program ising_3d
    implicit none

    integer:: i,j,k,L,p,a,b,c,d,f,g,niter,time,mm,nn,oo,N, T_temp, T_factor, n_equil, n_stat
    real*8:: r,E,M,mag,Ei,Ef,dE,u,h, av_M, av_E, av_e_n, av_m_n, av_E2, av_M2, chi, cv, av_m4

    real*8:: T, binder_cum, J_ising=1.0 !assigning value to relevant parameters: k_B, J_ising

    integer, dimension(:,:,:), allocatable :: spin
    integer:: seed

    seed=44859

    print*, "Welcome to this program! This program simulates a 3D ising model with all spins iniitally in the random state"
    print*, "Enter the number of lattice points in one dimension for (LxLxL)"
    read*,L
    print*, "Enter the number of iterations"
    read*, niter

    allocate(spin(L,L,L))
    E=0.0d0 ! Instantaneous Energy of the lattice
    M=0.0d0 ! Instantaneous magnetization of the lattice
    N = L*L*L ! Total number of spins in lattice

    n_equil = 10000 ! At each step, we collect data after n_equil steps ie the equilibration time
    n_stat = 10 ! Collect statistical data every n_stat steps

    ! Initialize your lattice
    open(unit=71, file="initial_ising_3D.dat")
    p=0
    do i=1,L
        do j=1,L
            do k=1,L
             call RANDOM_NUMBER(r)
                ! spin(k,j,i) = -1
                if (r < 0.5) then
                    spin(i,j,k) = -1
                else
                    spin(i,j,k)=1
                end if
            ! Write down this configuration
            write(71,*) float(i), float(j), float(k), float(p), float(spin(i,j,k))
            end do
        end do
    end do

    close(71)

    ! Calculate Initial magnetization and energy
    do i=1,L
        do j=1,L
            do k=1,L
            a=i+1; b=i-1; c=j+1; d=j-1; f=k+1; g=k-1 !identifying the 6 neighbors of spin(j,i)

            ! Setting PBCs (Periodic Boundary conditions)
            if (i==L)a=1
            if (i==1)b=L
            if (j==L)c=1
            if (j==1)d=L
            if (k==L)f=1
            if (k==1)g=L

            E = E - J_ising*float((spin(i,j,k))*(spin(a,j,k)+spin(b,j,k)+spin(i,c,k)+spin(i,d,k)+spin(i,j,f)+spin(i,j,g)))
            M = M + spin(i,j,k)
            end do
        end do
    end do

    ! Calculate instantaneous magnetization per spin
    mag = M/float(N)
    E=E*0.5d0
    print*, "Initial energy E, E per spin is: ",E, E/float(N)
    print*, "Initial magentization M, M per spin is: ", M,M/float(N)

    ! INITIALIZATION COMPLETE
    ! -----------------------------
    ! EVOLVE TO REACH EQUILIBRIUM

    open(unit=10, file="ising_L7_3d_data_new.dat")

    do T_temp=470,380,-2 !TEMPERATURE LOOP
        T = dfloat(T_temp)/100.0d0  !FIX T

        av_m = 0.0d0 ; av_e_N = 0.0d0 ! AVG. E, M, of ENTIRE LATTICE
        av_m2 = 0.0d0 ; av_e2 = 0.0d0 ! <E2>, <M2> of ENTIRE LATTICE
        av_m4 = 0.0d0 ! <M4> for calculating Binder's cumulant

    do time=i,niter ! Loop over number of MCS
        do mm=1,L
            do nn=1,L
                do oo=1,L
                ! Choosing a lattice site (i,j,k)
                call random_number(r); i=int(r*float(L))+1
                call random_number(r); j=int(r*float(L))+1
                call random_number(r); k=int(r*float(L))+1

                a=i+1;b=i-1;c=j+1;d=j-1;f=k+1;g=k-1 !identify the neighbors of spin(j,i)

                if(i==L)a=1; if(i==1)b=L; if(j==L)c=1; if(j==1)d=L; if(k==L)f=1; if(k==1)g=L !PBC

                ! BEFORE TRIAL FLIP
                Ei = -J_ising*float((spin(i,j,k))*(spin(a,j,k)+spin(b,j,k)+spin(i,c,k)+spin(i,d,k)+spin(i,j,f)+spin(i,j,g)))

                !TRIAL FLIP
                spin(i,j,k) =-spin(i,j,k)

                ! AFTER TRIAL FLIP
                Ef = -J_ising*float((spin(i,j,k))*(spin(a,j,k)+spin(b,j,k)+spin(i,c,k)+spin(i,d,k)+spin(i,j,f)+spin(i,j,g)))
                dE = Ef-Ei

                ! METROPOLIS ALGORITHM
                if(dE <=0.0) then
                    E=E+dE
                    M=M+(2.0*float(spin(i,j,k)))
                else
                    u=exp(-dE/(T))
                    call random_number(h)
                    if (h<u) then
                        E=E+dE
                        M=M+(2.0*float(spin(i,j,k))) ! Instantaneous mag. Of entire lattice
                    else
                        spin(i,j,k) = -spin(i,j,k) ! Trial flip not accepted; E & M not updated
                    end if
                end if
                end do
            end do
            end do

        ! -----------------------------------------------------------
        ! AFTER REACHING EQUILIBRIUM, COLLECT STATISTICAL DATA

        if (time .gt. n_equil) then
        !    if (mod(time, n_stat) .eq. 0) then

            mag = abs(M/(dfloat(N)))  ! N=L*L*L : instantaneous magnetization per spin
            av_m = av_m+mag           ;   av_e = av_e+E/dfloat(N) ! PER SPIN
            av_m_n = av_m_n+ abs(M)   ;   av_e_n = av_e_n+E ! AV. E, M of ENTIRE LATTICE
            av_m2 = av_m2+(M*M)       ;   av_e2 = av_e2+(E*E) ! AVG. E2, M2 of ENTIRE LATTICE
            av_m4 = av_m4+(M*M*M*M)

        ! end if
        end if
        end do  ! do time = 1:niter ! loop over no of MCS

        av_m  = av_m/dfloat(niter - n_equil)  ; av_e = av_e/dfloat(niter - n_equil)
        av_e2 = av_e2/dfloat(niter - n_equil) ; av_e_n = av_e_n/dfloat(niter- n_equil)
        av_m2 = av_m2/dfloat(niter - n_equil) ; av_m_n = av_m_n/dfloat(niter - n_equil)
        av_m4 = av_m4/dfloat(niter - n_equil)

        binder_cum = 1 - (av_m4/(3*(av_m2*av_m2)))

        cv = (av_e2 - av_e_n*av_e_n)/(T*T)
        chi = (av_m2 - av_m_n*av_m_n)/(T)

        write(10,*) T, av_M, av_E, cv, chi, binder_cum ! Writing down E and M with number of iterations
        end do ! do T_temp = 47:38
    close(10)
    deallocate(spin)

end program ising_3d


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

!> diffusion for FVM
module modDiffusion
  private

  ! constants
  integer,parameter::DIMS=3 !< dimensions

  !> generic finding diffusion
  interface findDiff
    module procedure::findDiffPolyVect
    module procedure::findDiffPolyScal
  end interface
  public::findDiff

contains

  !> find diffusion due to gradient of vector s on polyFvGrid
  !> \f[ \int_A D_i \nabla \mathbf{s} \cdot \hat{n} dA \f]
  subroutine findDiffPolyVect(grid,s,gradS,d,diff)
    use modPolyFvGrid
    class(polyFvGrid),intent(inout)::grid !< the grid
    double precision,intent(in)::s(:,:) !< state variables
    double precision,intent(in)::gradS(:,:,:) !< gradient of s
    double precision,intent(in)::d(:,:) !< diffusivities
    double precision,allocatable,intent(inout)::diff(:,:) !< diffusion output
    double precision::sf(DIMS),dPF,Afs,flow(size(s,1)),fPF,dF(size(s,1)),gradSF(DIMS,size(s,1))

    call grid%up()
    if(.not.(allocated(diff)))then
      allocate(diff(size(s,1),grid%nC))
    end if
    diff(:,:)=0d0
    !$omp parallel do default(shared)&
    !$omp& private(m,n,fPF,dF,gradSF,sf,dPF,Afs,flow,j)
    do i=1,grid%nP
      m=grid%iEP(1,i)
      n=grid%iEP(2,i)
      if(n<=grid%nC)then
        fPF=norm2(grid%pP(:,i)-grid%p(:,n))&
        &   /(norm2(grid%pP(:,i)-grid%p(:,m))+norm2(grid%pP(:,i)-grid%p(:,n)))
        dF(:)=fPF*d(:,m)+(1d0-fPF)*d(:,n)
        gradSF(:,:)=fPF*gradS(:,:,m)+(1d0-fPF)*gradS(:,:,n)
      else
        dF(:)=d(:,m)
        gradSF(:,:)=gradS(:,:,m)
      end if
      sf(:)=grid%p(:,n)-grid%p(:,m)
      dPF=norm2(sf)
      sf(:)=sf(:)/dPF
      Afs=grid%aP(i)/dot_product(sf,grid%normP(:,i))
      if(m<=grid%nC.and.n<=grid%nC)then ! internal pairs
        flow(:)=dF(:)*Afs*((s(:,n)-s(:,m))/dPF&
        &                  -matmul(transpose(gradSF(:,:)),&
        &                          sf-grid%normP(:,i)*dot_product(sf,grid%normP(:,i))))
        do j=1,size(flow)
          !$omp atomic
          diff(j,m)=diff(j,m)+flow(j)
          !$omp atomic
          diff(j,n)=diff(j,n)-flow(j)
        end do
      else ! boundary pairs
        flow(:)=dF(:)*Afs*(s(:,n)-s(:,m))/(2d0*dPF)
        do j=1,size(flow)
          !$omp atomic
          diff(j,m)=diff(j,m)+flow(j)
        end do
      end if
    end do
    !$omp end parallel do
  end subroutine

  !> find diffusion due to gradient of scalar s on polyFvGrid
  !> \f[ \int_A D \nabla \mathbf{s} \cdot \hat{n} dA \f]
  subroutine findDiffPolyScal(grid,s,gradS,d,diff)
    use modPolyFvGrid
    class(polyFvGrid),intent(inout)::grid !< the grid
    double precision,intent(in)::s(:) !< state variable
    double precision,allocatable::gradS(:,:) !< gradient of s
    double precision,intent(in)::d(:) !< diffusivity
    double precision,allocatable,intent(inout)::diff(:) !< diffusion output
    double precision::sf(DIMS),dPF,Afs,flow,fPF,dF,gradSF(DIMS)

    call grid%up()
    if(.not.(allocated(diff)))then
      allocate(diff(grid%nC))
    end if
    diff(:)=0d0
    !$omp parallel do default(shared)&
    !$omp& private(m,n,fPF,dF,gradSF,sf,dPF,Afs,flow)
    do i=1,grid%nP
      m=grid%iEP(1,i)
      n=grid%iEP(2,i)
      if(n<=grid%nC)then
        fPF=norm2(grid%pP(:,i)-grid%p(:,n))&
        &   /(norm2(grid%pP(:,i)-grid%p(:,m))+norm2(grid%pP(:,i)-grid%p(:,n)))
        dF=fPF*d(m)+(1d0-fPF)*d(n)
        gradSF(:)=fPF*gradS(:,m)+(1d0-fPF)*gradS(:,n)
      else
        dF=d(m)
        gradSF(:)=gradS(:,m)
      end if
      sf(:)=grid%p(:,n)-grid%p(:,m)
      dPF=norm2(sf)
      sf(:)=sf(:)/dPF
      Afs=grid%aP(i)/dot_product(sf,grid%normP(:,i))
      if(m<=grid%nC.and.n<=grid%nC)then ! internal pairs
        flow=dF*Afs*((s(n)-s(m))/dPF&
        &            -dot_product(gradSF(:),sf-grid%normP(:,i)*dot_product(sf,grid%normP(:,i))))
        !$omp atomic
        diff(m)=diff(m)+flow
        !$omp atomic
        diff(n)=diff(n)-flow
      else ! boundary pairs
        flow=dF*Afs*(s(n)-s(m))/(2d0*dPF)
        !$omp atomic
        diff(m)=diff(m)+flow
      end if
    end do
    !$omp end parallel do
  end subroutine

end module


	  function glat(hlat)
c------convert geographic latitude to geocentric latitude-------------
c	 hlat (input) = geographic latitude in radians (north positive)
c	 glat (output)= geocentric latitude in radians (north positive)
c---------------------------------------------------------------------
	data halfpi /1.570796/
	if(halfpi - abs(hlat).ge.0.05) then
	  glat = atan(0.993277*sin(hlat)/cos(hlat))
	else
c------special formula near pole
	  glat = hlat/0.993277 - sign(0.010632, hlat)
	end if

	return
	end


C       SAMPLE MAIN PROGRAM FOR POLYNOMIAL REGRESSION - POLRG
        IMPLICIT DOUBLE PRECISION (A - H)
        IMPLICIT DOUBLE PRECISION (O - Z)
C  THE FOLLOWING ROUTINES ARE USED: GDATA,ORDER,MINV,MULTR
C       AND AN OPTIONAL PLOTTING SUBROUTINE COULD BE ADDED
C
C       THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
C       PRODUCT OF N*(M+1) WHERE N IS THE NUMBER OF OBSERVATIONS AND
C       M IS THE HIGHEST DEGREE POLYNOMIAL SPECIFIED.
        DIMENSION X(75)
C       THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
C       PRODUCT OF M*M.
        DIMENSION DI(16)
C       THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO
C       (M+2)*(M+1)/2.
        DIMENSION D(15)
C       THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO M.
        DIMENSION B(4),SB(4),T(4),E(4)
C       THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO
C       (M+1).
        DIMENSION XBAR(5),STD(5),COE(5),SUMSQ(5),ISAVE(5)
C       THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 10.
        DIMENSION ANS(10)
C       THE FOLLOWING DIMENSION WILL BE USED IF THE PLOT OF OBSERVED
C       DATA AND ESTIMATES IS DESIRED.  THE SIZE OF THE DIMENSION, IN
C       THIS CASE, MUST BE GREATER THAN OR EQUAL TO N*3. OTHERWISE,
C       THE SIZE OF THE DIMENSION MAY BE SET TO 1.
        DIMENSION P(1)
        COMMON IOUT,IN
C
C       OUTPUT CHANNEL = IOUT, INPUT CHANNEL = IN
1       FORMAT(A4,A2,I5,I2,I1)
2       FORMAT(2F6.0)
3       FORMAT(//27H POLYNOMIAL REGRESSION.....,A4,A2)
4       FORMAT(/23H NUMBER OF OBSERVATION,I4/' HIGHEST DEGREE',I4)
5       FORMAT(/32H POLYNOMIAL REGRESSION OF DEGREE,I3)
6       FORMAT(/12H   INTERCEPT,F15.5)
7       FORMAT(/26H   REGRESSION COEFFICIENTS/(6F12.5))
C	RULER FOR COLUMNS 1-72
CCCCCCCCCC..........//////////..........//////////..........//////////ZZ
8         FORMAT(/8X,24HANALYSIS OF VARIANCE FOR,I4,19H  DEGREE POLYNOMI
     1AL/)
9         FORMAT(/' SOURCE OF VARIATION  DEGREE'6X'SUM OF'8X'MEAN'
     110X'F    IMPROVEMENT'/24X'OF'8X'SQUARES'7X'SQUARE'6X
     2'VALUE  IN TERMS OF'/21X'FREEDOM'39X'SUM OF SQUARES')
10      FORMAT(/' DUE TO REGRESSION',I6,4X,4F13.5)
11      FORMAT(' DEVIATION ABOUT'/8X'REGRESSION',I6,4X,2F13.5)
12      FORMAT(' TOTAL',12X,I6,4X,F13.5///)
13      FORMAT(/17H  NO IMPROVEMENT )
14      FORMAT(//27X,18HTABLE OF RESIDUALS//16H OBSERVATION NO.,5X
     1,7HX VALUE,7X,7HY VALUE,7X,10HY ESTIMATE,7X,8HRESIDUAL/)
15      FORMAT(/,3X,I6,F18.5,F14.5,F17.5,F15.5)
C		LOGICAL DEVICE FOR READ, WRITE (LUN's)
        IN=1
        IOUT=2
C	CALL OPNFIL (IN,IOUT)
	OPEN (1,FILE='POLRG.DAT')
 	OPEN (2,FILE='POLRG.OUT')
C       READ PARAMETER CARD
100     READ(IN,1) PR,PR1,N,M
C       PR=PROBLEM NUMBER (MAY BE ALPHAMERIC)
C       PR1=PROBLEM NUMBER (CONTINUED)
C       N=NUMBER OF OBSERVATIONS
C       M=HIGHEST DEGREE POLYNOMIAL SPECIFIED
C       NPLOT=OPTION CODE FOR PLOTTING
C               0 IF PLOT IS NOT DESIRED
C               1 IF PLOT IS DESIRED
        IF(N.EQ.0) STOP
C       PRINT PROBLEM NUMBER AND N.

        WRITE(IOUT,3) PR,PR1
        WRITE(IOUT,4) N,M
C       READ INPUT DATA
        L=N*M
        DO 110 I=1,N
        J=L+I
C       X(I) IS THE INDEPENDENT VARIABLE, AND X(J) IS THE DEPENDENT
C       VARIABLE.
        READ(IN,2) X(I),X(J)
	WRITE (IOUT,2) X(I),X(J)
  110   CONTINUE
        CALL GDATA(N,M,X,XBAR,STD,D,SUMSQ)
	WRITE (IOUT,21)
21	FORMAT (' GDATA - OK')
        MM=M+1
        SUM=0.0
        NT=N-1
        DO 200 I=1,M
        ISAVE(I)=I
C       FORM SUBSET OF CORRELATION COEFFICIENT MATRIX
        CALL ORDER(M,D,MM,I,ISAVE,DI,E)
	WRITE (IOUT,22)
22	FORMAT (' ORDER - OK')
C       INVERT THE SUBMATRIX OF CORRELATION COEFFICIENTS
        CALL MINV(DI,I,DET,B,T)
	WRITE (IOUT,23)
23	FORMAT (' MINV - OK')
        CALL MULTR(N,I,XBAR,STD,SUMSQ,DI,E,ISAVE,B,SB,T,ANS)
C       PRINT THE RESULT OF CALCULATION
        WRITE(IOUT,5) I
        IF(ANS(7)) 140,130,130
130     SUMIP=ANS(4)-SUM
        IF(SUMIP) 140,140,150
140     WRITE(IOUT,13)
        GO TO 210
150     WRITE(IOUT,6) ANS(1)
        WRITE(IOUT,7) (B(J),J=1,I)
        WRITE(IOUT,8) I
        WRITE(IOUT,9)
        SUM=ANS(4)
        WRITE(IOUT,10) I,ANS(4),ANS(6),ANS(10),SUMIP
        NI=ANS(8)
        WRITE(IOUT,11) NI,ANS(7),ANS(9)
        WRITE(IOUT,12) NT,SUMSQ(MM)
C       SAVE COEFFICIENTS FOR CALCULATION OF Y ESTIMATES
        COE(1)=ANS(1)
        DO 160 J=1,I
160     COE(J+1)=B(J)
        LA=I
200     CONTINUE
C       TEST WHETHER PLOT IS DESIRED
210     GO TO 100
C210     IF(NPLOT) 100,100,220
CC       CALCULATE ESTIMATES
C220     NP3=N+N
C        DO 230 I=1,N
C        NP3=NP3+1
C        P(NP3)=COE(1)
C        L=I
C        DO 230 J=1,LA
C        P(NP3)=P(NP3)+X(L)*COE(J+1)
C230     L=L+N
CC       COPY OBSERVED DATA
C        N2=N
C        L=N*M
C        DO 240 I=1,N
C        P(I)=X(I)
C        N2=N2+1
C        L=L+1
C240     P(N2)=X(L)
CC       PRINT TABLE OF RESIDUALS
C        WRITE(IOUT,3) PR,PR1
C        WRITE(IOUT,5) LA
C        WRITE(IOUT,14)
C        NP2=N
C        NP3=N+N
C        DO 250 I=1,N
C        NP2=NP2+1
C        NP3=NP3+1
C        RESID=P(NP2)-P(NP3)
C250     WRITE(IOUT,15) I,P(I),P(NP2),P(NP3),RESID
CC		PUT CALL TO PLOT HERE
C        GO TO 100
        END


!----------------------------------------------- Program Descriptions -----------------------------------------------

! This program define many physical constants used by other modules
! Date composed by Jingxiang Guo : 11/27/2019

module constants
    ! import the precision (machine dependent) defined for each data type.
	use system,only: dp,sp
	implicit none
	! Global Variables:

	real(dp),parameter,public :: pi = 3.14159265358979323d0
	real(dp),parameter,public :: Bohr = 0.529177d0
	real(dp),parameter,public :: Mole = 6.02214179E+23
	real(dp),parameter,public :: water_molar_mass = 18.01528 ! g/mol

	! TIP4P:
	real(dp),parameter,public :: OM = 0.1577d0 ! Angstrom
	real(dp),parameter,public :: boltzman = 1.38064852E-23 !
	real(dp),parameter,public :: gas_constant = 8.3144598
	integer,dimension(1),public :: seed=(/197394210/)

	! Global varialbes:

contains

end module