module declarations

  implicit none

  integer, parameter :: layerwise_input_length = 10000
  ! Resolution
  integer :: nx ! number of x grid points
  integer :: ny ! number of y grid points
  integer :: layers ! number of active layers in the model
  integer :: OL ! size of halo region
  ! Layer thickness (h)
  double precision, dimension(:,:,:), allocatable :: h
  ! Velocity component (u)
  double precision, dimension(:,:,:), allocatable :: u
  ! Velocity component (v)
  double precision, dimension(:,:,:), allocatable :: v
  ! Free surface (eta)
  double precision, dimension(:,:),   allocatable :: eta
  ! Bathymetry
  character(60) :: depthFile
  double precision, dimension(:,:),   allocatable :: depth
  double precision :: H0 ! default depth in no file specified
  ! Grid
  double precision :: dx, dy
  double precision, dimension(:,:),   allocatable :: wetmask
  double precision, dimension(:,:),   allocatable :: hfacW
  double precision, dimension(:,:),   allocatable :: hfacE
  double precision, dimension(:,:),   allocatable :: hfacS
  double precision, dimension(:,:),   allocatable :: hfacN

  ! Coriolis parameter at u and v grid-points respectively
  double precision, dimension(:,:),   allocatable :: fu
  double precision, dimension(:,:),   allocatable :: fv
  ! File names to read them from
  character(60) :: fUfile, fVfile
  character(60) :: wetMaskFile
  ! Numerics
  double precision :: dt ! delta_t in seconds
  double precision :: au ! viscosity
  double precision :: ar ! linear drag between layers
  double precision :: botDrag ! linear bottom drag
  double precision :: kh(layerwise_input_length) ! horizontal thickness diffusivity
  double precision :: kv ! vertical thickness diffusivity
  double precision :: slip ! tangential momentum boundary condition
  double precision :: hmin ! minimum layer thickness
  integer          :: niter0 ! timestep to start from
  integer          :: nTimeSteps ! timesteps to simulate
  double precision :: dumpFreq ! time period between snapshot outputs
  double precision :: avFreq ! time period between averaged outputs
  double precision :: checkpointFreq ! time period between checkpoint outputs
  double precision :: diagFreq ! time period between diagnostic outputs
  double precision, dimension(:), allocatable :: zeros
  integer          :: maxits ! maximum iterations for pressure solver
  double precision :: eps ! tolerance for pressure solver
  double precision :: freesurfFac ! controls rigid lid or free surface
  double precision :: thickness_error ! max error between layer thickness
  ! and depth before a warning is printed
  integer          :: debug_level ! how much output should there be?
  integer          :: hAdvecScheme ! selects thickness advection scheme
  integer          :: TS_algorithm ! selects timestepping algorithm
  integer          :: AB_order ! used to construct tendency arrays

  ! Model
  ! shortcut for flat initial conditions
  double precision :: hmean(layerwise_input_length)
  ! Switch for using n + 1/2 layer physics, or using n layer physics
  logical :: RedGrav
  ! Physics
  double precision :: g_vec(layerwise_input_length) ! gravity between layers
  double precision :: rho0 ! background density
  ! Wind
  double precision, dimension(:,:,:),   allocatable :: base_wind_x
  double precision, dimension(:,:,:),   allocatable :: base_wind_y
  logical          :: DumpWind
  character(60)    :: wind_mag_time_series_file
  double precision :: wind_depth ! depth over which the wind forcing is spread
  double precision, dimension(:),     allocatable :: wind_mag_time_series
  integer          :: wind_n_records
  double precision :: wind_period
  logical          :: wind_loop_fields
  logical          :: wind_interpolate

  ! Sponge regions
  double precision, dimension(:,:,:), allocatable :: spongeHTimeScale
  double precision, dimension(:,:,:), allocatable :: spongeUTimeScale
  double precision, dimension(:,:,:), allocatable :: spongeVTimeScale
  double precision, dimension(:,:,:), allocatable :: spongeH
  double precision, dimension(:,:,:), allocatable :: spongeU
  double precision, dimension(:,:,:), allocatable :: spongeV
  character(60) :: spongeHTimeScaleFile
  character(60) :: spongeUTimeScaleFile
  character(60) :: spongeVTimeScaleFile
  character(60) :: spongeHfile
  character(60) :: spongeUfile
  character(60) :: spongeVfile
  ! Main input files
  character(60) :: initUfile, initVfile, initHfile, initEtaFile
  character(60) :: zonalWindFile, meridionalWindFile
  logical       :: RelativeWind
  double precision :: Cd

  integer*8 :: start_time

  ! External pressure solver variables
  integer :: nProcX, nProcY

  integer :: ierr
  integer :: num_procs, myid

  integer, dimension(:),   allocatable :: xlower, xupper
  integer, dimension(:),   allocatable :: ylower, yupper
  integer, dimension(:,:), allocatable :: ilower, iupper
  integer, dimension(:,:), allocatable :: jlower, jupper
  integer*8 :: hypre_grid
  integer   :: i, j, k
  integer   :: offsets(2,5)

  contains

end module declarations


C---------------------------------------
C ANALYSIS PROGRAM FOR A THREE BAR TRUSS
C WITH STRESS, DISPACEMENT AND FREQUENCY
C---------------------------------------
C

      SUBROUTINE runbar3truss(PVEC,M0,A1,A2,A3,E,EL,RHO,
     *                        S1,S2,S3,U,V,FF,OBJ)
C
      IMPLICIT None

      Integer mxndv, mxcon
      PARAMETER (MXNDV = 150, MXCON = 400)

      Double Precision px, py, Pvec, m0
      Double Precision a1,a2,a3
      Double Precision E, EL, RHO

      Double Precision force1,force2,force3
      Double Precision S1, S2, S3
      Double Precision U, V, FF
      Double Precision obj

      Dimension Pvec(2)

      COMMON /Forces/ FORCE1, FORCE2, FORCE3

Cf2py intent(in) pvec
Cf2py intent(in) mo
Cf2py intent(in) a1
Cf2py intent(in) a2
Cf2py intent(in) a3
Cf2py intent(in) e
Cf2py intent(in) el
Cf2py intent(in) rho
Cf2py intent(out) s1
Cf2py intent(out) s2
Cf2py intent(out) s3
Cf2py intent(out) u
Cf2py intent(out) v
Cf2py intent(out) ff
Cf2py intent(out) obj

      Double Precision DOBJ(3)
      Double Precision GSTRES(3,3), GDIS(3,2), GRADFF(3)
      Double Precision SOM, SOM2, OMEGA, CON, BTM

      Double Precision EE

      Integer I

      Double Precision Q
      Double Precision PI, ABOT, ABOT2

      Double Precision FFI, FF2, ZZZ

C
C   BAR FORCES ( F1, F2, F3 )
C   BAR STRESSES ( S1,S2,S3)
C   FREQUENCY FF
C   NODAL DISPLACEMENTS ( U,V)
C   LOADS PX,PY
C   LENGTH PARAMETER EL
C
C   CALCULATION OF STRESSES
C   THE PARAMETERS ARE AS SPECIFIED

      PX = PVEC(1)
      PY = PVEC(2)

      Q = DSQRT(2.0D0)
      PI = 3.1415926535D0
      ABOT = A1 * A2 +  A2 * A3  + Q * A1 * A3
      ABOT2 = ABOT * ABOT
C
      S1 =( A3 * PY -  ( A3 + Q * A2  ) * PX ) / ABOT
      S2 = - ( ( A3 - A1 )* PX -  ( A1 + A3  )* PY ) / ABOT
      S3 =  (  ( A1 + Q * A2 ) * PX + A1 * PY ) / ABOT

C calculate forces

      force1 = a1*S1
      force2 = a2*S2
      force3 = a3*S3

      V = EL*S2/E
      U = (EL/E)* ( - 2* S1 + S2 )
      FFI =   (1/ (2 * Q) ) *(  (A1 + A3 + Q * A2) -
     $     DSQRT (  (A1 - A3 )* ( A1 - A3 ) + 2 * A2*A2  ) )
      FF2= FFI* ( (1000* E ) /(EL * M0 ) )
      FF = DSQRT (FF2)/(2*PI)
C
C  GRADIENT OF WEIGHT

      OBJ =  RHO*(A1*EL*Q  + A2*EL + A3*EL*Q)
C
      DOBJ(1) = RHO*EL*Q
      DOBJ(2) = RHO*EL
      DOBJ(3) = RHO*EL*Q
C
C STRESS GRADIENTS GSTRESS(3X3)
C THIS IS A 3X3 MATRIX ROWS ARE WITH RESPECT TO AREAS
C
C COLUMNS WITH RESPECT TO STRESS VARIABLES
C
      ZZZ = (PX*(A2 + Q*A3)*(A3+Q*A2)
     $      - PY*(A3*(A2 + Q*A3))  )

      GSTRES(1,1) = (   PX* (A2 + Q *A3)* (A3+Q*A2)
     $      - PY* ( A3 * ( A2 + Q * A3) )  ) /ABOT2

      GSTRES(2,1) = (   PX*  A3 *  (A3-A1)
     $      + PY*(- A3 * ( A1 + A3) )   )/ABOT2

      GSTRES(3,1) = ( PX*  A2 *(A1+ Q*A2)
     $      + PY*( A1*A2  )   )/ABOT2

      GSTRES(1,2) = ( PX*   Q*A3 *(A3+Q*A2)
     $      - PY*( A3 *  Q * A3)    )/ABOT2

      GSTRES(2,2) = ( PX*(A3 + A1 )*(A3-A1)
     $      - PY*( A1 + A3 )* (A1 + A3  )   )/ABOT2

      GSTRES(3,2) = ( PX*(-Q*A1)*(A1+ Q*A2)
     $      + PY*(- A1*Q* A1  )   )/ABOT2

      GSTRES(1,3) = (PX* (- A2 * ( Q*A2 +A3))
     $      + PY* A3 * A2   )/ABOT2

      GSTRES(2,3) = ( PX*(A1 )*(A3-A1)
     $      - PY*( A1  )* (A1 + A3  )   )/ABOT2

      GSTRES(3,3) = ( PX*(- A1 - Q*A2 )*(A2+ Q*A1)
     $      - PY*( A1 * ( A2 + Q*A1  ) ) )/ABOT2

C
C DISPLACEMENT GRADIENT
C
C THE TWO DISPLACEMENT GRADIENTS ARE ( GDIS (2X2) )
C
C COLUMNS FOR U AND V , ROWS FOR A1, A2, A3
C
       DO 30 I = 1,3
          GDIS(I,1)  =  (EL/E)* GSTRES (I,2)
          GDIS(I,2)  =  (EL/E)* (-2.d0* GSTRES(I,1) + GSTRES(I,2) )
30    CONTINUE

C
C FREQUENCY GRADIENTS (3X1) GRADF
C

      SOM = 2.d0*PI*FF
      EE = E*1000.d0
      SOM2 = SOM*SOM
      OMEGA = ( EL*M0)*SOM2/EE
      CON =DSQRT ( EE / ( EL* M0 ) )* ( 1 / (8.d0*Q*PI*DSQRT (OMEGA ) ))
      BTM = DSQRT ( ( A1 - A3 )* ( A1 - A3 ) + 2.d0* A2*A2 )
C
      GRADFF(1) = CON* (1 - ( A1 - A3 )/BTM )
      GRADFF(2) = CON* ( Q - 2*A2/BTM )
      GRADFF(3) = CON * ( 1 + (A1 - A3 )/ BTM )

      RETURN
      END


      double precision function Li2(x)
      implicit none
C     returns Li_2(x) for real x, minf < x < 1
      double precision x
      double complex wgplg

      if (x .gt. 1d0) then
        write(6,*) 'x>1 in Li2 function, src/Lib/Li2.f'
        stop
      endif

      Li2 = dble(wgplg(1,1,x))
      end


      subroutine implicit(y,t0,h,N)

*  ____________________________________________________________________
* |                                                                    |
* |...  ITERATION SCHEME FOR BACKWARD EULER APPROXIMATION OF           |
* |...  AN INITIAL VECTOR VALUED PROBLEM ITERATION SCHEME IS BASED     |
* |...  ON ON A QUASI-NEWTON METHOD IN AN 1984 IMSL SUBROUTINE.        |
* |...  REFERENCE IS THE MINIPACK PACKAGE BASED ON POWELL'S HYBRID     |
* |...  HYBRID ALGORITHM WHICH USES A FINITE DIFFERENCE APPROXIMATION  |
* |...  TO THE JACOBIAN AND TAKES PERCAUTIONS TO AVOID LARGE STEP SIZES|
* |...  OR INCREASING RESIDUALS.                                       |
* |                                                                    |
* |           x(*) : INITIAL STARTING VECTOR FOR QUASI NEWTON METHOD   |
* |                                                                    |
* |...  THE CLOSER THE GUESS,THE FASTER IT CONVERGES.                  |
* |                                                                    |
* |                                     Modified by .................  |
* |                                                 Waeil M. Ashmawi   |
* |                                                 NC State University|
* |                                                 April 07, 1998     |
* |____________________________________________________________________|
*

      parameter (nss = 24)
	  integer n2, N
      dimension x(N), y(N), wk(N*(3*N+15)/2), par(N+1)
      external fcn

*
* ======================== S T A R T   C O D E ========================
*
      write(*,*) 'in implicit'
      n2=N+1
      do i = 1, N
         x(i)   = 1.0*y(i)
         par(i) = y(i)
c		 write(*,*) 'x,y',x(i),y(i)
      end do
      par(n2) = h
      nsig    = 3
      itmax   = 200
      do i=1,n2
	    write(*,*) 'par in implicit',par(i)
	  enddo

      call zspow(fcn,nsig,N,itmax,par,x,fnorm,wk,ier)

      if (ier .eq. 131) then
	     write(*,*) 'implicit.f ier=131'
         stop
      endif

      do i = 1, N
         y(i) = x(i)
      end do
c      WRITE(27,22)
22    FORMAT('IMPLICIT SCHEME')

*
* ========================== E N D   C O D E ==========================
*

      return
      end


C     *****************************************************************
C     *****************************************************************

      subroutine extrapolation(nind,x,l,u,m,lambda,rho,equatn,linear,g,
     +xp,fp,gp,d,alpha,amax,rbdnnz,rbdind,rbdtype,fmin,beta,etaext,
     +maxextrap,extinfo,inform)

C     SCALAR ARGUMENTS
      integer extinfo,inform,m,maxextrap,nind,rbdnnz
      double precision alpha,amax,beta,etaext,fmin,fp

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      character rbdtype(nind)
      integer rbdind(nind)
      double precision d(nind),g(*),gp(*),l(nind),lambda(m),rho(m),
     +        u(nind),x(*),xp(*)

C     Performs extrapolation.
C
C     extinfo:
C
C     0: Success
C     2: Unbounded objective function?
C     4: beta-condition holds. No extrapolation is done
C     6: Maximum number of extrapolations reached
C     7: Similar consecutive projected points
C     8: Not-well-defined objective function
C     9: Functional value increases

      include "dim.par"
      include "counters.inc"
      include "machconst.inc"
      include "outtyp.inc"

C     LOCAL SCALARS
      logical projected,samep
      integer extrap,i
      double precision atmp,fbext,ftmp,gptd,gtd

C     LOCAL ARRAYS
      double precision xbext(nmax),xtmp(nmax)

      extinfo = 0

      extrap  = 0

C     Compute directional derivative

      gtd = 0.0d0
      do i = 1,nind
          gtd = gtd + g(i) * d(i)
      end do

      call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
      if ( inform .lt. 0 ) return

      gptd = 0.0d0
      do i = 1,nind
          gptd = gptd + gp(i) * d(i)
      end do

C     Beta condition holds. No extrapolation is done.

      if ( gptd .ge. beta * gtd ) then

          if ( iprintinn .ge. 6 ) then
C              write(*, 110)
              write(10,110)
          end if

          extinfo = 4

          return

      end if

C     Beta condition does not holds. We will extrapolate.

      if ( iprintinn .ge. 6 ) then
C          write(* ,120)
          write(10,120)
      end if

C     Save f and x before extrapolation to return in case of a
C     not-well-defined objective function at an extrapolated point

      fbext = fp

      do i = 1,nind
          xbext(i) = xp(i)
      end do

 1010 continue

C     Test f going to -inf

      if ( fp .le. fmin ) then

C         Finish the extrapolation with the current point

          if ( extrap .ne. 0 ) then
              call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
              if ( inform .lt. 0 ) return
          end if

          extinfo = 2

          if ( iprintinn .ge. 6 ) then
C              write(*, 910)
              write(10,910)
          end if

          return

      end if

C     Test if the maximum number of extrapolations was exceeded

      if ( extrap .ge. maxextrap ) then

C         Finish the extrapolation with the current point

          if ( extrap .ne. 0 ) then
              call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
              if ( inform .lt. 0 ) return
          end if

          extinfo = 6

          if ( iprintinn .ge. 6 ) then
C              write(*, 930)
              write(10,930)
          end if

          return

      end if

C     Chose new step

      extrap = extrap + 1

      if ( alpha .lt. amax .and. etaext * alpha .gt. amax ) then
          atmp = amax
      else
          atmp = etaext * alpha
      end if

C     Compute new trial point

      do i = 1,nind
          xtmp(i) = x(i) + atmp * d(i)
      end do

      if ( atmp .eq. amax ) then
          do i = 1,rbdnnz
              if ( rbdtype(i) .eq. 'L' ) then
                  xtmp(rbdind(i)) = l(rbdind(i))
              else if ( rbdtype(i) .eq. 'U' ) then
                  xtmp(rbdind(i)) = u(rbdind(i))
              end if
          end do
      end if

C     Project

      if ( atmp .gt. amax ) then

          projected = .false.
          do i = 1,nind
              if ( xtmp(i) .lt. l(i) .or. xtmp(i) .gt. u(i) ) then
                  projected = .true.
                  xtmp(i) = max( l(i), min( xtmp(i), u(i) ) )
              end if
          end do

      end if

C     Test if this is not the same point as the previous one. This test
C     is performed only when xtmp is in fact a projected point.

      if ( projected ) then

          samep = .true.
          do i = 1,nind
              if ( xtmp(i) .gt.
     +             xp(i) + macheps23 * max( 1.0d0, abs( xp(i) ) ) .or.
     +             xtmp(i) .lt.
     +             xp(i) - macheps23 * max( 1.0d0, abs( xp(i) ) ) ) then
                  samep = .false.
              end if
          end do

          if ( samep ) then

C             Finish the extrapolation with the current point

              call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
              if ( inform .lt. 0 ) return

              extinfo = 7

              if ( iprintinn .ge. 6 ) then
C                  write(*, 940)
                  write(10,940)
              end if

              return

          end if

      end if

C     Evaluate function

      call csetp(nind,xtmp)

      call calcal(nind,xtmp,m,lambda,rho,equatn,linear,ftmp,inform)

C     If the objective function is not well defined in an extrapolated
C     point, we discard all the extrapolated points and return to a
C     safe region (to the last point before the extrapolation)

      if ( inform .lt. 0 ) then

          fp = fbext

          do i = 1,nind
              xp(i) = xbext(i)
          end do

          call csetp(nind,xp)

          call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
          if ( inform .lt. 0 ) return

          extinfo = 8

          if ( iprintinn .ge. 6 ) then
C              write(*, 950)
              write(10,950)
          end if

          return

      end if

C     Print information of this iteration

      if ( iprintinn .ge. 6 ) then
C          write(*, 100) atmp,ftmp,fcnt
          write(10,100) atmp,ftmp,fcnt
      end if

C     If the functional value decreases then set the current point and
C     continue the extrapolation

      if ( ftmp .lt. fp ) then

          alpha = atmp

          fp = ftmp

          do i = 1,nind
              xp(i) = xtmp(i)
          end do

          go to 1010

      end if

C     If the functional value does not decrease then discard the last
C     trial and finish the extrapolation with the previous point

      call csetp(nind,xp)

      call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
      if ( inform .lt. 0 ) return

      extinfo = 9

      if ( iprintinn .ge. 6 ) then
C          write(*, 960)
          write(10,960)
      end if

C     NON-EXECUTABLE STATEMENTS

 100  format(  5X,'Alpha = ',1P,D7.1,' F = ',1P,D24.16,' FE = ',I7)
 110  format(  5X,'Beta condition also holds. ',
     +            'No extrapolation is done.')
 120  format(  5X,'Beta condition does not hold. We will extrapolate.')

 910  format(  5X,'Flag of Extrapolation: Unbounded objective ',
     +            'function?')
 930  format(  5X,'Flag of Extrapolation: Maximum of consecutive ',
     +            'extrapolations reached.')
 940  format(  5X,'Flag of Extrapolation: Very similar consecutive ',
     +            'projected points.')
 950  format(  5X,'Flag of Extrapolation: Not-well-defined objective ',
     +            'function in an extrapolated point.')
 960  format(  5X,'Flag of Extrapolation: Functional value increased ',
     +            'when extrapolating.')

      end


!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!

!>
!!##NAME
!!    M_random(3f) - [M_random::INTRO] Routines for generating random numbers and strings
!!##SYNOPSIS
!!
!!   See the routines:
!!
!!    use M_random, only : init_random_seed_by_system_clock, init_random_seed_by_dat, init_random_seed
!!    use M_random, only : random_string, random_hex, random_int
!!    use M_random, only : random_kiss64
!!    use M_random, only : mtprng_state, mtprng_init_array, mtprng_rand64, mtprng_rand_real1
!!    use M_random, only : mtprng_int, mtprng_int_by_array
!!    use M_random, only : mtprng_rand64, mtprng_rand, mtprng_rand_range
!!    use M_random, only : mtprng_rand_real3, mtprng_rand_real2, mtprng_rand_real1
!!    use M_random, only : scramble
!!
!!##QUOTE
!!
!!   The generation of random numbers is too important to be left to chance -- Robert R. Coveyou
!!
!!##DESCRIPTION
!!
!!    The M_random(3fm) module contains routines to support random number generation. This includes
!!    supplements for the Fortran intrinsic random_seed(3f).
!!
!!   SUPPLEMENTING INTRINSIC RANDOM_SEED
!!    o init_random_seed_by_system_clock(3f): initialize random_number(3f) to return a single value with system clock
!!    o init_random_seed_by_dat(3f): initialize random_number(3f) to return a single value using date_and_time(3f)
!!    o init_random_seed(3f): initialize random_number(3f) to return a single value with single integer seed like srand(3c)
!!
!!    o random_string(3f): create random string composed of provided characters of specified length
!!    o random_hex(3f): create random hexadecimal string of specified length
!!    o random_int(3f): return integer uniformly distributed in specified range
!!
!!   MISCELLANEOUS
!!    o random_kiss64(3f): A 64-bit KISS random number generator by George Margaglia.
!!    o scramble(3f): generate an integer array of specified size populated with a random permutation of 1 to size(array)
!!
!!   MERSENNE TWISTER ALGORITHM
!!    o mtprng_int(3f): Initializes the Mersenne Twister random number generator with
!!    o mtprng_int_by_array(3f): Initialize with an array of seeds
!!
!!    o mtprng_rand64(3f): Obtain the next 64-bit integer in the pseudo-random sequence in the range 0 to 2^32-1
!!    o mtprng_rand(3f): Obtain the next 32-bit integer in the pseudo-random sequence in the range 0 to 2^31-1
!!    o mtprng_rand_range(3f): Obtain a pseudo-random integer in the range [lo,hi]
!!
!!    o mtprng_rand_real3(3f): Obtain a pseudo-random real number .gt. 0 and .lt. 1.
!!    o mtprng_rand_real2(3f): Obtain a pseudo-random real number .ge. 0.0 and .lt. 1.0
!!    o mtprng_rand_real1(3f): Obtain a pseudo-random real number .ge. 0 and .le.= 1.
module M_random
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64  !  1 2 4 8
use,intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
private                                           ! Everything is private unless explicitly made public private
public init_random_seed_by_system_clock
public init_random_seed_by_dat
public init_random_seed

public random_string
public random_hex
public random_int

public random_kiss64
public scramble

public :: mtprng_state, mtprng_init, mtprng_init_by_array, mtprng_rand64, mtprng_rand
public :: mtprng_rand_range, mtprng_rand_real1, mtprng_rand_real2, mtprng_rand_real3

!==================================================================================================================================!
! Kind types for IEEE 754/IEC 60559 single- and double-precision reals
integer, parameter :: IEEE32 = selected_real_kind(  6,  37 )
integer, parameter :: IEEE64 = selected_real_kind( 15, 307 )
! Constants
integer(INT32), parameter :: N = 624_INT32
integer(INT32), parameter :: M = 397_INT32
! types
type mtprng_state
   integer(INT32)                   :: mti = -1
   integer(INT64), dimension(0:N-1) :: mt
end type
!==================================================================================================================================!
contains
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    random_string(3f) - [M_random] create random string composed of
!!                        provided characters of specified length
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    function random_string(chars,length) result(out)
!!
!!     character(len=*),intent(in)     :: chars
!!     integer,intent(in)              :: length
!!     character(len=:),allocatable    :: out
!!
!!##DESCRIPTION
!!    Given a set of characters and a length, generate a random string of
!!    the specified length composed of the given set of characters.
!!
!!##OPTIONS
!!    chars   list of characters to generate random string with
!!    length  number of characters to place in output string
!!
!!##RESULT
!!    out     string of LENGTH characters randomly filled with characters
!!            from CHARS
!!
!!##EXAMPLE
!!
!!    Sample program:
!!
!!     program demo_random_string
!!     use M_random, only : random_string, init_random_seed_by_dat
!!        character(len=64) :: hexstring
!!        ! use date and time to create a seed for calling random_seed(3f)
!!        call init_random_seed_by_dat()
!!        hexstring=random_string('0123456789abcdef',len(hexstring))
!!        ! write random hexadecimal value for use
!!        ! as something like an X11 authorization key
!!        write(*,'(a)')hexstring
!!     end program demo_random_string
!!
!!    Results
!!
!!     2363a3589736e23be0137ec7ebc9d74297a963f27958a176daea3dd850ed8487
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT License
function random_string(chars,length) result(out)

! ident_1="@(#)M_random::random_string(3f): create random string composed of provided characters of specified length"

character(len=*),intent(in)     :: chars
integer,intent(in)              :: length
character(len=:),allocatable    :: out
   real                         :: x
   integer                      :: ilen   ! length of list of characters
   integer                      :: which
   integer                      :: i
   ilen=len(chars)
   out=''
   if(ilen.gt.0)then
      do i=1,length
         call random_number(x)
         which=nint(real(ilen-1)*x)+1
         out=out//chars(which:which)
      enddo
   endif
end function random_string
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    random_hex(3f) - [M_random] create a string representing a random
!!                     hexadecimal value of specified length
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    function random_hex(chars,length) result(out)
!!
!!     character(len=*),intent(in)     :: chars
!!     integer,intent(in)              :: length
!!     character(len=:),allocatable    :: out
!!
!!##DESCRIPTION
!!    Generate a random string representing a hexadecimal value of a given length
!!
!!##OPTIONS
!!    length  number of characters to place in output string
!!
!!##RESULT
!!    out     string of LENGTH characters randomly filled with characters
!!            representing a hexadecimal value
!!
!!##EXAMPLE
!!
!!    Sample program:
!!
!!     program demo_random_hex
!!     use M_random, only : random_hex, init_random_seed_by_dat
!!        character(len=64) :: hexstring
!!        ! use date and time to create a seed for calling random_seed(3f)
!!        call init_random_seed_by_dat()
!!        ! write random hexadecimal value for use
!!        ! as something like an X11 authorization key
!!        hexstring=random_hex(len(hexstring))
!!        write(*,'(a)')hexstring
!!     end program demo_random_hex
!!
!!    Results
!!
!!     2363a3589736e23be0137ec7ebc9d74297a963f27958a176daea3dd850ed8487
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    MIT License
function random_hex(length) result(out)

! ident_2="@(#)M_random::random_hex(3f): create random hexadecimal string of specified length"

integer,intent(in)              :: length
character(len=:),allocatable    :: out
   out=random_string('0123456789abcdef',length)
end function random_hex
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    random_int(3f) - [M_random] return an integer between low and high value inclusive
!!    (LICENSE:MIT)
!!##SYNOPSIS
!!
!!   function random_int(first,last) result(rand_int)
!!
!!    integer,intent(in) :: first,last
!!    integer            :: rand_int
!!
!!##DESCRIPTION
!!    Return an integer uniformly distributed from the set {first,,first+1,...,last-1,last}.
!!##OPTIONS
!!    first       lowest value of range of integer values to randomly return
!!    last        highest value of range of integer values to randomly return
!!##RETURNS
!!    rand_int    a random integer value between FIRST LAST inclusive
!!##EXAMPLE
!!
!!   Sample program
!!
!!    program demo_random_int
!!    use M_random, only : random_int
!!    write(*,'(*(i0:,1x))')(random_int(1,10),i=1,20)
!!    write(*,'(*(i0:,1x))')(random_int(-5,5),i=1,20)
!!    end program demo_random_int
!!
!!   Sample output
!!
!!    1 3  8 1 2  6  8 7  4  10  7  3  8  3  10 1  5  2 9  8
!!    4 5 -3 5 2 -5 -4 4 -5  -3 -2 -2 -2 -1  -2 4 -2 -2 4 -4
!!
!!##AUTHOR
!!    John S. Urban
!!##LICENSE
!!    MIT License
function random_int(first,last) result(rand_int)
use,intrinsic :: iso_fortran_env, only : dp=>real64
implicit none
integer,intent(in)   :: first,last ! lowest and highest integer in range of integers to get
integer, allocatable :: seed(:)
integer              :: n
integer              :: rand_int
real(kind=dp)        :: rand_val
logical,save         :: called=.false.
   if(.not.called)then
   ! initialize seed
      call random_seed(size = n)
      allocate(seed(n))
      call random_seed(get=seed)
      called=.true.
   endif

   ! To have a discrete uniform distribution on the integers {first, first+1,
   ! ..., last-1, last} carve the continuous distribution up into last+1-first
   ! equal sized chunks, mapping each chunk to an integer. One way is:
   !
   ! get real number from 0 up to but not including 1 (ie. [0,1)).
   call random_number(rand_val)
   ! use random value to choose an integer from first to last
   rand_int = first + floor((last-first+1)*rand_val)
end function random_int
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    scramble(3f) - [M_random] generate an integer array of specified size populated with a random permutation of 1 to size(array)
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    function scramble( number_of_values )
!!    integer,intent(in) :: number_of_values
!!
!!##DESCRIPTION
!!    Return an integer array of the size specified populated with the
!!    numbers 1 to "number_of_values" in random order.
!!
!!    A simple way to randomly scramble a list of any type is to create
!!    a random permutation of all the index values of the array and then
!!    access the original list elements using that list of indices. The
!!    list itself can be re-ordered very succinctly using array syntax.
!!    Given a list size ..
!!
!!    1. create an INTEGER array of the specified size N
!!    2. populate it with the values from 1 to N
!!    3. randomly switch values in the array to randomize it
!!    4. return the newly created array for use as indices
!!
!!    The resulting random permutation of the indices can then be used to
!!    access essentially any type of list in random order.
!!
!!##OPTIONS
!!    number_of_values  size of integer array to create
!!
!!##RETURNS
!!    scramble    Integer array filled with integers 1 to NUMBER_OF_VALUES in random order
!!
!!##EXAMPLE
!!
!!   Sample program
!!
!!     program demo_scramble
!!     use M_random, only : scramble
!!     implicit none
!!     character(len=*),parameter :: list(*)=[character(len=5) :: &
!!     & 'one','two','three','four','five',&
!!     & 'six','seven','eight','nine','ten']
!!     integer                    :: i
!!     integer                    :: n=size(list)
!!     character(len=len(list))   :: newlist(size(list))
!!     do i = 1,8
!!        ! use random values as indices to randomize array
!!        newlist=list(scramble(n))
!!        write(*,'(*(a,1x))') newlist
!!     enddo
!!     end program demo_scramble
!!
!!   Example output
!!
!!    ten   six   eight one   four  nine  two   five  three seven
!!    three five  ten   nine  one   four  six   seven two   eight
!!    four  eight ten   two   seven nine  six   three one   five
!!    three one   nine  seven ten   five  two   six   eight four
!!    two   seven nine  one   four  three eight ten   five  six
!!    three one   nine  six   ten   five  eight two   four  seven
!!    four  five  six   eight one   ten   three nine  seven two
!!    three nine  four  two   one   seven ten   five  six   eight
!!##AUTHOR
!!    John S. Urban
!!##LICENSE
!!    MIT License
function scramble( number_of_values ) result(array)

! ident_3="@(#)M_random::scramble(3f): return integer array of random values 1 to N."

integer,intent(in)    :: number_of_values
integer,allocatable   :: array(:)
integer               :: i, j, k, m, n
integer               :: temp
real                  :: u

   array=[(i,i=1,number_of_values)] ! make the array and populate it with 1 thru number_of_values

! The intrinsic RANDOM_NUMBER(3f) returns a real number (or an array
! of such) from the uniform distribution over the interval [0,1). (ie.
! it includes 0 but not 1.).
!
! To have a discrete uniform distribution on
! the integers {n, n+1, ..., m-1, m} carve the continuous distribution
! up into m+1-n equal sized chunks, mapping each chunk to an integer.
!
! One way is:
!   call random_number(u)
!   j = n + FLOOR((m+1-n)*u)  ! choose one from m-n+1 integers

   n=1
   m=number_of_values
   do k=1,2
      do i=1,m
         call random_number(u)
         j = n + FLOOR((m+1-n)*u)
         ! switch values
         temp=array(j)
         array(j)=array(i)
         array(i)=temp
      enddo
   enddo

end function scramble
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!       random_kiss64 - [M_random] A 64-bit KISS random number generator by George Margaglia.
!!##SYNOPSIS
!!
!!    function random_kiss64()
!!    integer, parameter         :: i8b = selected_int_kind(18)  ! eight-byte integer
!!    integer(i8b)               :: random_kiss64
!!
!!##DESCRIPTION
!!    A simple random number generator that returns a random 64-bit INTEGER. The same
!!    sequence is returned.
!!##EXAMPLE
!!
!!
!!   Sample usage:
!!
!!     program demo_random_kiss64
!!     use M_random, only : random_kiss64
!!     implicit none
!!     integer, parameter    :: i8b = selected_int_kind(18)  ! eight-byte integer
!!     integer(i8b)          :: i, t
!!
!!        write(*,*)'HUGE=',huge(0_i8b)
!!
!!        do i = 1, 100000000
!!           t = random_kiss64()
!!           if(mod(i,1000000_i8b+1_i8b)==1000000_i8b)write(*,*)i,' T=',T
!!        enddo
!!
!!        if (t .eq. 1666297717051644203_i8b) then
!!           print *, "100 million calls to KISS() OK"
!!        else
!!           print *, "Fail"
!!        endif
!!     end program demo_random_kiss64
function random_kiss64()

! ident_4="@(#)M_random::random_kiss64(3f): A 64-bit KISS random number generator by George Margaglia."

! From: FortranWiki.org
! Originally posted to comp.lang.fortran in the message 64-bit KISS RNGs.
! No license was specified.
!
! Revised on April 14, 2010 21:40:44 by Jason Blevins (75.178.9.182)
! This version was modified by Jason Blevins to use "implicit none"
! and to portably declare the 64-bit/eight-byte integer type.
!-----------------------------------------------------------------------------------------------------------------------------------
   integer, parameter         :: i8b = selected_int_kind(18)  ! eight-byte integer
   integer(i8b), save         :: x, y, z, c
   integer(i8b)               :: t, k, m, s, random_kiss64
   data x, y, z, c &
      / 1234567890987654321_i8b, &
      362436362436362436_i8b, &
      1066149217761810_i8b, &
      123456123456123456_i8b /
!-----------------------------------------------------------------------------------------------------------------------------------
   m(x,k) = ieor(x, ishft(x,k))  ! statement function
   s(x) = ishft(x, -63)          ! statement function
!-----------------------------------------------------------------------------------------------------------------------------------
   t = ishft(x, 58) + c
   if (s(x) .eq. s(t)) then
      c = ishft(x, -6) + s(x)
   else
      c = ishft(x, -6) + 1 - s(x + t)
   endif
   x = t + x
   y = m(m(m(y,13_i8b),-17_i8b), 43_i8b)
   z = 6906969069_i8b * z + 1234567
   random_kiss64 = x + y + z
end function random_kiss64
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    init_random_seed_by_system_clock(3f) - [M_random] seed random_number(3f) with system clock value
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    subroutine init_random_seed_by_system_clock()
!!
!!##DESCRIPTION
!!    A simple wrapper around random_seed(3f) that uses the system clock to initialize the seed so you can
!!    easily call random_number(3f) with varying pseudo-random real number sequences
!!
!!##EXAMPLE
!!
!!    Sample program:
!!
!!     program demo_init_random_seed_by_system_clock
!!     use M_random, only : init_random_seed_by_system_clock
!!     integer :: i
!!     real    :: x
!!        call init_random_seed_by_system_clock()
!!        do i=1,10
!!           ! generate real pseudo-random numbers from 0 to <1.0
!!           call random_number(x)
!!           write(*,*)i,x
!!        enddo
!!     end program demo_init_random_seed_by_system_clock
!!
!!    Results
!!
!!     >   1  0.661672294
!!     >   2  0.274969578
!!     >   3  0.683666587
!!     >   4   7.35652447E-02
!!     >   5  0.457893968
!!     >   6  0.826303899
!!     >   7  0.727411628
!!     >   8  0.542535722
!!     >   9  0.983459771
!!     >  10  0.527638793
!!##AUTHOR
!!    John S. Urban
!!##LICENSE
!!    MIT License
subroutine init_random_seed_by_system_clock()

! ident_5="@(#)M_random::init_random_seed_by_system_clock(3f): initialize random_number(3f) to return a single value with system clock"

   integer :: i, n, clock
   integer, dimension(:), allocatable :: seed
   call random_seed(size = n)
   allocate(seed(n))
   call system_clock(count=clock)
   seed = clock + 37 * (/ (i - 1, i = 1, n) /)
!   write(*,*)seed
!   write(*,*)(/ (i - 1, i = 1, n) /)
   call random_seed(put = seed)

   deallocate(seed)
end subroutine init_random_seed_by_system_clock
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    init_random_seed_by_dat(3f) - [M_random] seed random_number(3f) with values from date_and_time(3f)
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    subroutine init_random_seed_by_dat()
!!
!!##DESCRIPTION
!!    A simple wrapper around random_seed(3f) that uses the date_and_time(3f)
!!    intrinsic to initialize the seed so you can easily call
!!    random_number(3f) with varying pseudo-random real number sequences
!!
!!##EXAMPLE
!!
!!    Sample program:
!!
!!     program demo_init_random_seed_by_dat
!!     use M_random, only : init_random_seed_by_dat
!!     integer :: i
!!     real    :: x
!!        call init_random_seed_by_dat()
!!        do i=1,10
!!           ! generate real pseudo-random numbers from 0 to <1.0
!!           call random_number(x)
!!           write(*,*)i,x
!!        enddo
!!     end program demo_init_random_seed_by_dat
!!
!!    Results
!!
!!      >     1  0.644704163
!!      >     2  0.244343698
!!      >     3  0.516471267
!!      >     4  0.296542704
!!      >     5  0.681771278
!!      >     6  0.449223280
!!      >     7  0.915870190
!!      >     8  0.466257989
!!      >     9  0.912388682
!!      >    10  0.597788215
!!
!!##AUTHOR
!!    John S. Urban
!!##LICENSE
!!    MIT License
subroutine init_random_seed_by_dat()

! ident_6="@(#)M_random::init_random_seed_by_dat(3f): initialize random_number(3f) to return a single value using date_and_time(3f)"

! Initially based on a post on comp.lang.fortran.
  integer :: ival(8)
  integer :: n, v(3), i
  integer, allocatable :: seed(:)
  call date_and_time(values=ival)
  v(1) = ival(8) + 2048*ival(7)
  v(2) = ival(6) + 64*ival(5)                     ! skip value(4) because it is the timezone, which is typically constant
  v(3) = ival(3) + 32*ival(2) + 32*8*ival(1)
  call random_seed(size=n)
  allocate(seed(n))
  call random_seed()                              ! give the seed an implementation-dependent kick
  call random_seed(get=seed)
  do i=1, n
     seed(i) = seed(i) + v(mod(i-1, 3) + 1)
  enddo
  call random_seed(put=seed)
  deallocate(seed)
end subroutine init_random_seed_by_dat
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    init_random_seed(3f) - [M_random] seed random_number(3f) with single value like srand(3c) usage
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    subroutine init_random_seed(mine)
!!
!!     integer,intent(in) :: mine
!!
!!##DESCRIPTION
!!    A simple wrapper around random_seed(3f) that uses the single given
!!    integer to initialize the seed so you can easily call random_number(3f)
!!    with varying pseudo-random real number sequences simply, much like
!!    srand(3c) and rand(3c).
!!
!!##EXAMPLE
!!
!!    Sample program:
!!
!!     program demo_init_random_seed
!!     use M_random, only : init_random_seed
!!     integer :: iseed
!!     integer :: i
!!     real    :: x
!!        iseed=218595421
!!        call init_random_seed(iseed)
!!        do i=1,10
!!           ! generate real pseudo-random numbers from 0 to <1.0
!!           call random_number(x)
!!           write(*,*)i,x
!!        enddo
!!     end program demo_init_random_seed
!!
!!    Results
!!
!!      >     1  0.989341617
!!      >     2  0.296594143
!!      >     3  0.805420995
!!      >     4   4.00894880E-03
!!      >     5   5.73359132E-02
!!      >     6  0.805290103
!!      >     7  0.944527864
!!      >     8  0.789443851
!!      >     9  0.327288270
!!      >    10  0.710926533
!!
!!##AUTHOR
!!    John S. Urban
!!##LICENSE
!!    MIT License
subroutine init_random_seed(mine)

! ident_7="@(#)M_random::init_random_seed(3f): initialize random_number(3f) to return a single value with single integer seed like srand(3c)"

! to make this start with a single number like srand(3c) take the seed and
! use the value to fill the seed array, adding 37 to each subsequent value
! till the array is filled.
integer,intent(in) :: mine
   integer         :: i, n
   integer, dimension(:), allocatable :: seed
   call random_seed(size = n)
   allocate(seed(n))
   seed = mine + 37 * (/ (i - 1, i = 1, n) /)
  !write(*,*)seed
  !write(*,*)(/ (i - 1, i = 1, n) /)
   call random_seed(put = seed)
   deallocate(seed)
end subroutine init_random_seed
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!  An implementation of the Mersenne Twister algorithm for generating pseudo-random sequences.
! This notice applies specifically to the MTPRNG_* routines ....

! From the Algorithmic Conjurings of Scott Robert Ladd comes...
!
!  mtprng.f90 (a Fortran 95 module)
!
!  An implementation of the Mersenne Twister algorithm for generating
!  pseudo-random sequences.
!
!  History
!  -------
!   1.0.0   Initial release
!
!   1.1.0   6 February 2002
!           Updated to support algorithm revisions posted
!           by Matsumoto and Nishimura on 26 January 2002
!
!   1.5.0   12 December 2003
!           Added to hypatia project
!           Minor style changes
!           Tightened code
!           Now state based; no static variables
!           Removed mtprng_rand_real53
!
!   2.0.0   4 January 2004
!           Corrected erroneous unsigned bit manipulations
!           Doubled resolution by using 64-bit math
!           Added mtprng_rand64
!
!    2.0.1  26 April 2018
!           Added IMPLICIT NONE,
!           defined kinds internally to remove need for
!           separate module STDTYPES. Included this
!           module into existing module M_RANDOM.
!
!  ORIGINAL ALGORITHM COPYRIGHT
!  ============================
!  Copyright (C) 1997,2002 Makoto Matsumoto and Takuji Nishimura.
!  Any feedback is very welcome. For any question, comments, see
!  http://www.math.keio.ac.jp/matumoto/emt.html or email
!  matumoto@math.keio.ac.jp
!---------------------------------------------------------------------
!
!  COPYRIGHT NOTICE, DISCLAIMER, and LICENSE:
!
!  This notice applies *only* to this specific expression of this
!  algorithm, and does not imply ownership or invention of the
!  implemented algorithm.
!
!  If you modify this file, you may insert additional notices
!  immediately following this sentence.
!
!  Copyright 2001, 2002, 2004 Scott Robert Ladd.
!  All rights reserved, except as noted herein.
!
!  This computer program source file is supplied "AS IS". Scott Robert
!  Ladd (hereinafter referred to as "Author") disclaims all warranties,
!  expressed or implied, including, without limitation, the warranties
!  of merchantability and of fitness for any purpose. The Author
!  assumes no liability for direct, indirect, incidental, special,
!  exemplary, or consequential damages, which may result from the use
!  of this software, even if advised of the possibility of such damage.
!
!  The Author hereby grants anyone permission to use, copy, modify, and
!  distribute this source code, or portions hereof, for any purpose,
!  without fee, subject to the following restrictions:
!
!      1. The origin of this source code must not be misrepresented.
!
!      2. Altered versions must be plainly marked as such and must not
!         be misrepresented as being the original source.
!
!      3. This Copyright notice may not be removed or altered from any
!         source or altered source distribution.
!
!  The Author specifically permits (without fee) and encourages the use
!  of this source code for entertainment, education, or decoration. If
!  you use this source code in a product, acknowledgment is not required
!  but would be appreciated.
!
!  Acknowledgement:
!      This license is based on the wonderful simple license that
!      accompanies libpng.
!
!-----------------------------------------------------------------------
!
!  For more information on this software package, please visit
!  Scott's web site, Coyote Gulch Productions, at:
!
!      http://www.coyotegulch.com
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    mtprng_init(3f) - [M_random:MERSENNE TWISTER] Initialize the Mersenne Twister random number generator with "seed"
!!    (LICENSE:CUSTOM OPEN)
!!
!!##SYNOPSIS
!!
!!    subroutine mtprng_init(seed, state)
!!    integer(INT32),     intent(in)  :: seed
!!    type(mtprng_state), intent(out) :: state
!!
!!##DESCRIPTION
!!    Initializes the Mersenne Twister random number generator with "seed"
!!
!!##OPTIONS
!!    seed   A seed value is used to start a specific sequence of pseudo-random numbers
!!    state  generator state initialized by mtprng_init(3f) or mtprng_init_array(3f)
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_mtprng_init
!!    use M_random, only : mtprng_state, mtprng_init, mtprng_rand64
!!    use, intrinsic :: iso_fortran_env, only : int32, int64
!!    implicit none
!!    integer(INT32) :: seed
!!    type(mtprng_state) :: state
!!       GET_SEED: block
!!       integer :: count
!!       integer :: count_rate
!!          call system_clock(count, count_rate)
!!          seed=count
!!       endblock GET_SEED
!!      call mtprng_init(seed, state)
!!      ! returns a INT64 integer with a range in 0 .. 2^32-1
!!      write(*,*) mtprng_rand64(state)
!!    end program demo_mtprng_init
!!
!!   Sample Results:
!!
!!      867010878
subroutine mtprng_init(seed, state)

! ident_8="@(#)M_random::mtprng_int(3f): Initializes the Mersenne Twister random number generator with seed"

! arguments
integer(INT32),     intent(in)  :: seed
type(mtprng_state), intent(out) :: state
   ! working storage
   integer :: i
   ! save seed
   state%mt(0) = seed

   ! Set the seed using values suggested by Matsumoto & Nishimura, using
   !   a generator by Knuth. See original source for details.
   do i = 1, N - 1
      state%mt(i) = iand(4294967295_INT64,1812433253_INT64 * ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64)) + i)
   enddo

   state%mti = N

end subroutine mtprng_init
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    mtprng_init_by_array(3f) - [M_random:MERSENNE TWISTER] Initialize the Mersenne Twister random number generator with "seed" array
!!    (LICENSE:CUSTOM OPEN)
!!
!!##SYNOPSIS
!!
!!    subroutine mtprng_init_by_array(init_key, state)
!!    integer(INT32), dimension(:), intent(in) :: init_key
!!    type(mtprng_state), intent(out) :: state
!!
!!##DESCRIPTION
!!    Initialize the Mersenne Twister random number generator with "seed" array
!!
!!##OPTIONS
!!    state  generator state initialized by mtprng_init(3f) or mtprng_init_array(3f)
!!##RETURNS
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_mtprng_init_by_array
!!    use M_random, only : mtprng_state, mtprng_init_by_array
!!    use M_random, only : mtprng_rand64, mtprng_rand_real1
!!    use, intrinsic :: iso_fortran_env, only : int32, int64
!!    implicit none
!!    integer(INT32)     :: init_key(3)
!!    type(mtprng_state) :: state
!!      GET_SEED: block
!!      integer :: count
!!      integer :: count_rate
!!         call system_clock(count, count_rate)
!!         init_key(1) = 11*count
!!         init_key(2) = 37*count
!!         init_key(3) = 97*count
!!      endblock GET_SEED
!!      call mtprng_init_by_array(init_key, state )
!!      ! returns a INT64 integer with a range in 0 .. 2^32-1
!!      write(*,*) mtprng_rand64(state)
!!      ! returns a IEEE64 real, may be used as double precision
!!      write(*,*) mtprng_rand_real1(state)
!!    end program demo_mtprng_init_by_array
subroutine mtprng_init_by_array(init_key, state)

! ident_9="@(#)M_random::mtprng_int_by_array(3f): Initialize with an array of seeds"

! arguments
integer(INT32),intent(in)       :: init_key(:)
type(mtprng_state), intent(out) :: state

   ! working storage
   integer :: key_length
   integer :: i
   integer :: j
   integer :: k

   call mtprng_init(19650218_INT32,state)

   i = 1
   j = 0
   key_length = size(init_key)

   do k = max(N,key_length), 0, -1
      state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1664525_INT64))) + init_key(j) + j

      i = i + 1
      j = j + 1

      if (i >= N) then
         state%mt(0) = state%mt(N-1)
         i = 1
      endif

      if (j >= key_length) j = 0
   enddo

   do k = N-1, 0, -1
      state%mt(i) = ieor(state%mt(i),(ieor(state%mt(i-1),ishft(state%mt(i-1),-30_INT64) * 1566083941_INT64))) - i

      i = i + 1

      if (i>=N) then
         state%mt(0) = state%mt(N-1)
         i = 1
      endif
   enddo

   state%mt(0) = 1073741824_INT64 ! 0x40000000, assuring non-zero initial array

end subroutine mtprng_init_by_array
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    mtprng_rand64(3f) - [M_random:MERSENNE TWISTER] Obtain the next 64-bit integer in the pseudo-random sequence
!!    (LICENSE:CUSTOM OPEN)
!!
!!##SYNOPSIS
!!
!!    function mtprng_rand64(state) result(r)
!!    type(mtprng_state), intent(inout) :: state
!!    integer(INT64) :: r
!!
!!##DESCRIPTION
!!    Obtain the next 64-bit integer in the pseudo-random sequence in the range 0 to 2^32-1.
!!    Note that the range is considerably below the value of HUGE(0_int64).
!!
!!##OPTIONS
!!    state  generator state initialized by mtprng_init(3f) or mtprng_init_array(3f)
!!
!!##RETURNS
!!    r      next pseudo-random value in the range 0 to 2^32-1
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_mtprng_rand64
!!    use M_random, only : mtprng_state, mtprng_init, mtprng_rand64
!!    use, intrinsic :: iso_fortran_env, only : int32, int64
!!    implicit none
!!    integer(INT32) :: seed
!!    type(mtprng_state) :: state
!!      GET_SEED: block
!!      integer :: count
!!      integer :: count_rate
!!         call system_clock(count, count_rate)
!!      seed = count
!!      endblock GET_SEED
!!      call mtprng_init(seed, state)
!!      write(*,*) mtprng_rand64(state)
!!    end program demo_mtprng_rand64
function mtprng_rand64(state) result(r)

! ident_10="@(#)M_random::mtprng_rand64(3f): Obtain the next 64-bit integer in the pseudo-random sequence"

! arguments
type(mtprng_state), intent(inout) :: state
!return type
integer(INT64) :: r

   ! internal constants
   integer(INT64), dimension(0:1), parameter :: mag01 = (/ 0_INT64, -1727483681_INT64 /)

   ! Period parameters
   integer(INT64), parameter :: UPPER_MASK =  2147483648_INT64
   integer(INT64), parameter :: LOWER_MASK =  2147483647_INT64

   ! Tempering parameters
   integer(INT64), parameter :: TEMPERING_B = -1658038656_INT64
   integer(INT64), parameter :: TEMPERING_C =  -272236544_INT64

   ! Note: variable names match those in original example
   integer(INT32) :: kk

   ! Generate N words at a time
   if (state%mti >= N) then
      ! The value -1 acts as a flag saying that the seed has not been set.
      if (state%mti == -1) call mtprng_init(4357_INT32,state)

      ! Fill the mt array
      do kk = 0, N - M - 1
         r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK))
         state%mt(kk) = ieor(ieor(state%mt(kk + M),ishft(r,-1_INT64)),mag01(iand(r,1_INT64)))
      enddo

      do kk = N - M, N - 2
         r = ior(iand(state%mt(kk),UPPER_MASK),iand(state%mt(kk+1),LOWER_MASK))
         state%mt(kk) = ieor(ieor(state%mt(kk + (M - N)),ishft(r,-1_INT64)),mag01(iand(r,1_INT64)))
      enddo

      r = ior(iand(state%mt(N-1),UPPER_MASK),iand(state%mt(0),LOWER_MASK))
      state%mt(N-1) = ieor(ieor(state%mt(M-1),ishft(r,-1)),mag01(iand(r,1_INT64)))

      ! Start using the array from first element
      state%mti = 0
   endif

   ! Here is where we actually calculate the number with a series of
   !   transformations
   r = state%mt(state%mti)
   state%mti = state%mti + 1

 !-------------------------
 !*!r = ieor(r,ishft(r,-11))
   r = ieor(r,ishft(iand(4294967295_INT64,r),-11)) ! Added a 32-bit mask to first r shift
 !-------------------------

   r = iand(4294967295_INT64,ieor(r,iand(ishft(r, 7),TEMPERING_B)))
   r = iand(4294967295_INT64,ieor(r,iand(ishft(r,15),TEMPERING_C)))
   r = ieor(r,ishft(r,-18))

end function mtprng_rand64
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    mtprng_rand(3f) - [M_random:MERSENNE TWISTER] Obtain the next 32-bit integer in the pseudo-random sequence
!!    (LICENSE:CUSTOM OPEN)
!!
!!##SYNOPSIS
!!
!!    function mtprng_rand(state) result(r)
!!    type(mtprng_state), intent(inout) :: state
!!    integer(INT32) :: r
!!
!!##DESCRIPTION
!!    Obtain the next 32-bit integer in the pseudo-random sequence
!!
!!##OPTIONS
!!    state  generator state initialized by mtprng_init(3f) or mtprng_init_array(3f)
!!
!!##RETURNS
!!    r      The next 32-bit integer in the pseudo-random sequence
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_mtprng_rand
!!    use M_random, only : mtprng_state, mtprng_init, mtprng_rand
!!    use, intrinsic :: iso_fortran_env, only : int32
!!    implicit none
!!    integer(INT32) :: seed
!!    type(mtprng_state) :: state
!!      GET_SEED: block
!!      integer :: count
!!      integer :: count_rate
!!         call system_clock(count, count_rate)
!!         seed = count
!!      endblock GET_SEED
!!      call mtprng_init(seed, state)
!!      ! returns a INT32 integer with a range in 0 .. 2^31-1
!!      write(*,*) mtprng_rand(state)
!!    end program demo_mtprng_rand
function mtprng_rand(state) result(r)

! ident_11="@(#)M_random::mtprng_rand(3f): Obtain the next 32-bit integer in the pseudo-random sequence"

! arguments
type(mtprng_state), intent(inout) :: state
!return type
integer(INT32) :: r

   ! working storage
   integer(INT64) :: x

   ! done
   x = mtprng_rand64(state)

   if (x > 2147483647_INT64) then
      r = x - 4294967296_INT64
   else
      r = x
   endif

end function mtprng_rand
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    mtprng_rand_range(3f) - [M_random:MERSENNE TWISTER] Obtain a pseudo-random integer in the range [lo,hi]
!!    (LICENSE:CUSTOM OPEN)
!!##SYNOPSIS
!!
!!    function mtprng_rand_range(state, lo, hi) result(r)
!!    type(mtprng_state), intent(inout) :: state
!!    integer, intent(in) :: lo
!!    integer, intent(in) :: hi
!!    integer(INT32) :: r
!!
!!##DESCRIPTION
!!    Obtain a pseudo-random integer in the range [lo,hi]
!!
!!##OPTIONS
!!    state  generator state initialized by mtprng_init(3f) or mtprng_init_array(3f)
!!    lo     lowest value in desired range of values to return
!!    hi     highest value in desired range of values to return
!!
!!##RETURNS
!!    r      returned pseudo-random value in range from LO to HI
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_mtprng_rand_range
!!    use M_random, only : mtprng_state, mtprng_init, mtprng_rand_range
!!    use, intrinsic :: iso_fortran_env, only : int32
!!    implicit none
!!    integer(INT32) :: seed
!!    type(mtprng_state) :: state
!!      GET_SEED: block
!!      integer :: count
!!         integer :: count_rate
!!         call system_clock(count, count_rate)
!!         seed = count
!!      endblock GET_SEED
!!      call mtprng_init(seed, state)
!!      write(*,*) mtprng_rand_range(state,20,30)
!!    end program demo_mtprng_rand_range
function mtprng_rand_range(state, lo, hi) result(r)

! ident_12="@(#)M_random::mtprng_rand_range(3f): Obtain a pseudo-random integer in the range [lo,hi]"

! arguments
type(mtprng_state), intent(inout) :: state
integer, intent(in) :: lo
integer, intent(in) :: hi
! return type
integer(INT32) :: r

   ! Use real value to calculate range
   r = lo + floor((hi - lo + 1.0_IEEE64) * mtprng_rand_real2(state))

end function mtprng_rand_range
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    mtprng_rand_real1(3f) - [M_random:MERSENNE TWISTER] Obtain a pseudo-random real number in the range [0.0,1.0]
!!    (LICENSE:CUSTOM OPEN)
!!
!!##SYNOPSIS
!!
!!    function mtprng_rand_real1(state) result(r)
!!    type(mtprng_state), intent(inout) :: state
!!    real(IEEE64) :: r
!!##DESCRIPTION
!!    Obtain a pseudo-random real number in the range [0,1], i.e., a number
!!    greater than or equal to 0 and less than or equal to 1.
!!##OPTIONS
!!    state  generator state initialized by mtprng_init(3f) or mtprng_init_array(3f)
!!##RETURNS
!!     r      ...
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_mtprng_real1
!!    use M_random, only : mtprng_init
!!    use M_random, only : mtprng_state
!!    use M_random, only : mtprng_rand_real1
!!    use, intrinsic :: iso_fortran_env, only : int32
!!    implicit none
!!    integer(INT32) :: seed
!!    type(mtprng_state) :: state
!!      GET_SEED: block
!!      integer :: count
!!      integer :: count_rate
!!         call system_clock(count, count_rate)
!!         seed = count
!!      endblock GET_SEED
!!      call mtprng_init(seed, state)
!!      write(*,*) mtprng_rand_real1(state)
!!    end program demo_mtprng_real1
function mtprng_rand_real1(state) result(r)

! ident_13="@(#)M_random::mtprng_rand_real1(3f): Obtain a pseudo-random real number .ge. 0 and .le.= 1."

! arguments
type(mtprng_state), intent(inout) :: state
! return type
real(IEEE64) :: r

   ! Local constant; precalculated to avoid division below
   real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967295.0_IEEE64

   ! compute
   r = real(mtprng_rand64(state),IEEE64) * factor

end function mtprng_rand_real1
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    mtprng_rand_real2(3f) - [M_random:MERSENNE TWISTER] Obtain a pseudo-random real number in the range [0,<1)
!!    (LICENSE:CUSTOM OPEN)
!!
!!##SYNOPSIS
!!
!!##DESCRIPTION
!!    Obtain a pseudo-random real number in the range [0,1), i.e., a number
!!    greater than or equal to 0 and less than 1.
!!##OPTIONS
!!    state  generator state initialized by mtprng_init(3f) or mtprng_init_array(3f)
!!##RETURNS
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_mtprng_real2
!!    use M_random, only : mtprng_state, mtprng_init, mtprng_rand_real2
!!    use, intrinsic :: iso_fortran_env, only : int32
!!    implicit none
!!    integer(INT32)     :: seed
!!    type(mtprng_state) :: state
!!      GET_SEED: block
!!      integer :: count
!!      integer :: count_rate
!!         call system_clock(count, count_rate)
!!         seed = count
!!      endblock GET_SEED
!!      call mtprng_init(seed, state)
!!      ! returns a IEEE64 real, may be used as double precision
!!      write(*,*) mtprng_rand_real2(state)
!!    end program demo_mtprng_real2
function mtprng_rand_real2(state) result(r)
! ident_14="@(#)M_random::mtprng_rand_real2(3f): Obtain a pseudo-random real number .ge. 0.0 and .lt. 1.0"

type(mtprng_state), intent(inout) :: state                                   ! arguments
real(IEEE64)                      :: r                                       ! return type
   real(IEEE64), parameter        :: factor=1.0_IEEE64 / 4294967296.0_IEEE64 ! Local constant; precalculated to avoid division below

   r = real(mtprng_rand64(state),IEEE64) * factor                            ! compute

end function mtprng_rand_real2
!==================================================================================================================================!
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!==================================================================================================================================!
!>
!!##NAME
!!    mtprng_rand_real3(3f) - [M_random:MERSENNE TWISTER] Obtain a pseudo-random real number in the range (0< XXX <1)
!!    (LICENSE:CUSTOM OPEN)
!!
!!##SYNOPSIS
!!
!!     function mtprng_rand_real3(state) result(r)
!!     type(mtprng_state), intent(inout) :: state
!!     real(IEEE64) :: r
!!
!!##DESCRIPTION
!!    Obtain a pseudo-random real number in the range (0,1), i.e., a number
!!    greater than 0 and less than 1.
!!
!!##OPTIONS
!!    state  generator state initialized by mtprng_init(3f) or mtprng_init_array(3f)
!!##RETURNS
!!    r      a pseudo-random real number greater than 0 and less than 1.
!!##EXAMPLE
!!
!!   Sample program:
!!
!!     program demo_mtprng_real3
!!     use M_random, only : mtprng_state, mtprng_init, mtprng_rand_real3
!!     use, intrinsic :: iso_fortran_env, only : int32
!!     implicit none
!!     integer(INT32) :: seed
!!     type(mtprng_state) :: state
!!       GET_SEED: block
!!       integer :: count
!!       integer :: count_rate
!!          call system_clock(count, count_rate)
!!          seed = count
!!       endblock GET_SEED
!!       call mtprng_init(seed, state)
!!       write(*,*) mtprng_rand_real3(state)
!!     end program demo_mtprng_real3
function mtprng_rand_real3(state) result(r)

! ident_15="@(#)M_random::mtprng_rand_real3(3f): Obtain a pseudo-random real number .gt. 0 and .lt. 1."

! arguments
type(mtprng_state), intent(inout) :: state
! return type
real(IEEE64) :: r

   ! Local constant; precalculated to avoid division below
   real(IEEE64), parameter :: factor = 1.0_IEEE64 / 4294967296.0_IEEE64

   r = (real(mtprng_rand64(state),IEEE64) + 0.5_IEEE64) * factor

end function mtprng_rand_real3
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
end module M_random
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================


C/MEMBR ADD NAME=WDOTCR,SSI=0
c     Copyright INRIA
      double precision function wdotcr(n,xr,xi,incx,yr,yi,incy)
      double precision xr(*),xi(*),yr(*),yi(*),s
      s = 0.0d+0
      if (n .le. 0) go to 20
      ix = 1
      iy = 1
      if (incx.lt.0) ix = (-n+1)*incx + 1
      if (incy.lt.0) iy = (-n+1)*incy + 1
      do 10 i = 1, n
         s = s + xr(ix)*yr(iy) + xi(ix)*yi(iy)
         ix = ix + incx
         iy = iy + incy
   10 continue
   20 wdotcr = s
      return
      end


      include 'VICMAIN_FOR'
      subroutine main44
      implicit none

      integer maxsamps, maxbands
      parameter (maxsamps=10000)
      parameter (maxbands=20)

      integer     nlo,nso,nli,nsi,slo,sso,iunit,ounit,stat,sb,nb,nbi,i
      integer     icount,idef,line,band,goodvalue(maxsamps)
      integer*2   bufin(maxsamps,maxbands),bufout(maxsamps)
      integer*2   avgout(maxsamps),tout(maxsamps)
      real*8      avgbuf(maxsamps),residual(maxsamps,maxbands)
      real*8      mina(maxsamps), maxa(maxsamps), amean(maxsamps)
      real*8      emissivity(maxsamps)
      real        c1,c2,pi,fact,a,b,c
      real        wave(maxbands),weight(maxbands)
      character*8 format

C     Echo the version when the program runs and abort with an
C     Error message if a vicar routine fails
      call ifmessage ('AMER Version 21-Jan-96')
      call xveaction ('sa', ' ')

C     Open input data set
      call xvunit(iunit,'inp',1,stat,' ')
      call xvopen(iunit,stat,'u_format','half',' ')

C     Get data format and check that its in halfword
      call xvget(iunit,stat,'format',format,' ')
      if(format.ne.'HALF') then
         call mabend('betae expects halfword radiance data input')
      end if

C     Get the size of the ouput
      call xvsize(slo,sso,nlo,nso,nli,nsi)
      call xvbands(sb,nb,nbi)

C     Check the number of samples requested does not exceed the
C     number available, if there it does - abort
      if (slo+nlo.gt.nli+1) then
        call mabend('Error: requested lines exceed those available')
      endif

C     Check the number of samples requested does not exceed the
C     number available, if there it does - abort
      if (sso+nso.gt.nsi+1) then
        call mabend('Error: requested samples exceed those available')
      endif

C     Check there are less than maxbands and less than maxsamps
C     samples, if not - abort
      if(nsi.gt.maxsamps) then
      	call mabend('sorry image larger than max # samples')
      end if
      if(nbi.gt.maxbands) then
      	call mabend('sorry image larger than max # bands')
      end if

C     Get the wavelength vals and make sure there are as many
C     values as there are bands
      call xvparm('wave',wave,icount,idef,maxbands)
      if(icount.ne.nbi) then
      	call mabend('sorry # of wave vals must equal # input bands')
      end if

C     Open output data set, make it one band larger than the input
      call xvunit(ounit,'out',1,stat,' ')
      call xvopen(ounit,stat,'op','write','u_format','half',
     &            'u_nl',nlo,'u_ns',nso,'u_nb',nb+1,'u_org','bil',' ')

C     Set the constants
      c1 = 3.74151e-16    !in w/m2
      c2 = 0.0143879
      pi = 3.1416
      fact = 1.0e-6
C
      print *, ''
      print *, 'This program requires your data to be'
      print *, 'atmospherically corrected and in'
      print *, 'mw/m*m/um/sr'
      print *, ''
C
C     Convert wavelength to metres and calculate the band weights
      do i = 1,nb
        wave(i) = wave(i)*fact
        a = a + (wave(i)*log(c1))
        b = b + (5.0*wave(i)*log(wave(i)))
        c = c + (log(pi)*wave(i))
      enddo
c
      a = a/nb
      b = b/nb
      c = c/nb
      print *,'Wavelengths and weights are:'
      do i = 1,nb
        weight(i) = (wave(i)*(log(c1)))
     1              - (5.0*wave(i)*(log(wave(i))))
     2              - (wave(i)*(log(pi))) - a + b + c
        weight(i) = - weight(i)
      print*, wave(i)/fact, '   ', weight(i)
      enddo
      print *, ''

C     For each line first calculate:
C       the wavelength weighted mean,
C       the alpha residual,
C       the alpha mean,
C       the average-MMD emissivity
C       the average-MMD temperature
C       the emissivities from the average-MMD temperature

      do  line = slo,slo+nlo-1

C         Zero the arrays used in summations
          call zia(avgbuf,2*nso)
          call zia(mina,2*nso)
          call zia(maxa,2*nso)
          call zia(goodvalue,nso)

C         Calculate the wavelength weighted log sum
      	  do band = 1,nb
            call xvread(iunit,bufin(1,band),stat,'line',line,
     1        'band',band,'samp',sso,'nsamps',nso,' ')
            call arsum(wave(band), bufin(1,band), avgbuf,
     1        goodvalue, nso)
          end do

C         Calculate the wavelength weighted log mean
          call armean(avgbuf, goodvalue, avgout, nso, nb)

C         Calculate the alpha residual and stats for the variance
     	  do band = 1,nb
            call ar(wave(band), weight(band), bufin(1,band), avgbuf,
     1        residual(1,band), nso)
            call arstats(residual(1,band),nso,fact,mina,maxa,band)
          end do

C         Calculate the alpha mean from the variance
          call am(mina,maxa,amean,nso,nb,fact)

C         Calculate the Average-MMD emissivity from the alpha mean,
C         Note only need one channel since all temperatures are same
C         because using weins approximation.
          call ae(wave(1),residual(1,1),amean,nso,nb,fact,
     1        emissivity)

C         Calculate the Average-MMD temperature. Note only need
C         one channel since all temperatures are same
C         because using weins approximation.
          call atemp(bufin(1,1),emissivity,wave(1),nso,nb,c1,c2,pi,
     1        tout)

C         Calculate the emissivity from the temperature and write out
C         the emissivity
          do band = 1,nb
            call getemis(bufin(1,band),tout,wave(band),nso,c1,c2,pi,
     1        bufout)
            call xvwrit(ounit,bufout,stat,'nsamps',nso,' ')
          end do

C         Write out the temperature
          call xvwrit(ounit,tout,stat,'nsamps',nso,' ')

      end do

C     Close data sets
      call xvclose(iunit,stat,' ')
      call xvclose(ounit,stat,' ')
C
      return
      end

C     Subroutine to calculate the wavelength weighted log sum for all bands
      subroutine arsum(wave, bufin, avgbuf, goodvalue, nso)
      implicit none

      real wave
      real*8 avgbuf(nso), avg
      integer*2 bufin(nso)
      integer goodvalue(nso), nso, sample

C     Calculate the wavelength weighted sum
      do sample = 1,nso
C       Zero avg
        avg = 0.0d0
C       Convert the input into w/m*m*m/sr
        avg = dble(bufin(sample) * 1.0e+3)
C       Wavelength weight the radiance
        if(avg.gt.0.0)then
          avg = dlog(avg)*dble(wave)
          avgbuf(sample) = avgbuf(sample)+avg
          goodvalue(sample)=goodvalue(sample)+1
        endif
      end do
      return
      end

C     Subroutine to calculate the wavelength weighted log
C     mean (1 value per pixel)
      subroutine armean(avgbuf, goodvalue, avgout, nso, nb)
      implicit none

      real*8 avgbuf(nso)
      integer goodvalue(nso)
      integer*2 avgout(nso)
      integer nso, nb, sample

C     Calc the mean
      do sample = 1,nso
        if(goodvalue(sample).eq.nb) then
          avgbuf(sample)=(avgbuf(sample)/dble(goodvalue(sample)))
        else
          avgbuf(sample)=0
        endif
C       Create a halfword version for output
        avgout(sample)=avgbuf(sample)*1.0e+7
      end do
      return
      end

C     Subroutine to calculate the alpha residual
      subroutine ar(wave, weight, bufin, avgbuf, residual, nso)
      implicit none

      real wave, weight
      real*8 avgbuf(nso), rad, residual(nso)
      integer*2 bufin(nso)
      integer nso, sample

C     Calculate the alpha residual
      do sample = 1,nso
C       Convert the input into w/m*m*m/sr
        rad =dble(bufin(sample))*1.0e+3
C        print *,  rad, wave, avgbuf(sample), weight
C     Calculate the alpha residual
        residual(sample)=
     1     dble(wave)*dlog(rad)-avgbuf(sample)+dble(weight)
C      print *, residual(sample)
      end do

      return
      end

C     Subroutine to calculate the stats for getting the mmd
      subroutine arstats(residual, nso, fact, mina, maxa, pass)
      implicit none

      real*8 residual(nso), mina(nso), maxa(nso)
      real fact
      integer nso, sample, pass

C     If its the first pass, set all the values
      if (pass .EQ. 1) then
        do sample =1,nso
          mina(sample)=residual(sample)
          maxa(sample)=residual(sample)
        enddo
      endif

C     Calculate the max and min
      do sample = 1,nso
        if (mina(sample) .GT. residual(sample))
     1    mina(sample) = residual(sample)
        if (maxa(sample) .LT. residual(sample))
     1    maxa(sample) = residual(sample)
      end do

      return
      end

C     Subroutine to calculate the Average-MMD emissivity mean
C     The MMD is divided by fact since this form was used in
C     calculating the empirical calibration curve
      subroutine am(mina,maxa,amean,nso,nb,fact)
      implicit none

      integer nso, nb, sample
      real*8 mina(nso), maxa(nso), amean(nso)
      real mmd, fact

C     Calculate the variance and derived alpha mean
      do sample = 1,nso
        mmd = maxa(sample)-mina(sample)
C     Linear approx - not used.
C        amean(sample) = -0.50317 * (mmd/fact) - 0.23615
C        print *, amean(sample)
C     Power approx
        amean(sample) = -0.790683 * ((mmd/fact)**0.723098)
C        print *, amean(sample)

      end do

      return
      end

C     Subroutine to calculate the Average-MMD emissivity
C     The residual is divided by fact since this form was used in
C     calculating the amean from the empirical calibration curve

      subroutine ae(wave,residual,amean,nso,nb,fact,emissivity)
      implicit none

      integer nso, nb, sample
      real*8 residual(nso), amean(nso), emissivity(nso), w
      real fact, wave

C     Calculate the emissivity
C     Convert the wavelength and residual to microns for Pete's method
      w=dble(wave/fact)
      do sample = 1, nso
        emissivity(sample) =
     1    dexp(((residual(sample)/dble(fact)) + amean(sample)) / w)

      enddo

      return
      end

C     Subroutine to calculate the sum of the Average-MMD derived temperatures
C     Note if weins approximation is used then all temps are the same.
      subroutine atemp(bufin,emissivity,wave,nso,nb,c1,c2,pi,tout)
      implicit none

      integer nso, nb, sample
      integer*2 bufin(nso), tout(nso)
      real*8 emissivity(nso)
      real temp, c1, c2, pi, wave, rad

C     Calculate the temperature
      do sample = 1, nso
C       Convert the input into w/m*m*m/sr
        rad = float(bufin(sample)) * 1.0e+3

C       Calculate the temperature with the Wein approximation
        temp = (c2/(wave*log(((emissivity(sample)*c1)/
     1    (rad*wave**5.0*pi))))) - 273.15
        tout(sample)=ifix(temp*100)

      enddo

      return
      end

C     Subroutine to calculate the emissivity from a temperature and radiance
      subroutine getemis(bufin,tout,wave,nso,c1,c2,pi,bufout)
      implicit none

      integer nso, sample
      integer*2 tout(nso), bufin(nso)
      integer*2 bufout(nso)
      real wave, c1, c2, pi, r, e, t

C     Calculate the radiance for each wavelength then calculate the
C     emissivity
        do sample = 1, nso
          t = (tout(sample)/100.0) + 273.15
          r = c1 / (wave**5.0 * pi * (exp(c2/(wave*t))-1.0))
          e =  float(bufin(sample))*1.0e3 / r
C          print *, r, bufin(sample)*1.0e3
          bufout(sample) = e * 1.0e4

      enddo

      return
      end


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!>  This module contains subroutines used in 3d eigen analysis for
!!  elements 341, 351, 361
module m_eigen_LIB_3d1mass
contains

  !----------------------------------------------------------------------*
  subroutine MASS_C3D8(XX,YY,ZZ,EE,PP,RHO,SS,fstrEIG)
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 8-NODE SOLID ELEMENT
    !
    use hecmw
    use m_fstr
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal)   :: XX(*), YY(*), ZZ(*), SS(*), EE, PP, RHO
    integer(kind=kint) :: IFLG
    ! LOCAL VARIABLES
    integer(kind=kint), parameter :: NN = 8, NDOF = 3, ISIZE = (NN*NDOF)*(NN*NDOF + 1)/2
    integer(kind=kint), parameter :: NG = 2
    !parameter(NN=8, NDOF=3, ISIZE=(NN*NDOF)*(NN*NDOF + 1)/2, NG=2)
    real(kind=kreal)   :: D(6, 6), B(6, NDOF*NN), DB(6, NDOF*NN)
    real(kind=kreal)   :: H(NN), HR(NN), HS(NN), HT(NN)
    real(kind=kreal)   :: RI, SI, TI, RP, SP, TP, RM, SM, TM
    real(kind=kreal)   :: XJ11, XJ21, XJ31, XJ12, XJ22, XJ32, XJ13, XJ23, XJ33, DET, WG, DUM
    real(kind=kreal)   :: XJI11, XJI21, XJI31, XJI12, XJI22, XJI32, XJI13, XJI23, XJI33
    integer(kind=kint) :: I, J, L, LX, LY, LZ, NUM, J2, K1
    real(kind=kreal)   :: DNDX, DNDY, DNDZ
    real(kind=kreal)   :: DRDX, DRDY, DRDZ
    real(kind=kreal)   :: DSDX, DSDY, DSDZ
    real(kind=kreal)   :: DTDX, DTDY, DTDZ
    !**FOR CORRECTION
    real(kind=kreal)   :: C(6, 9), DC(6, 9), CC(9, 9), V(9, 24), CCV(9, 24)
    !*EHM CONSISTENT MASS MATRIX 17Apr04
    real(kind=kreal)   :: totdiag, totmass
    integer(kind=kint) :: ind1, ind2
    real(kind=kreal)   :: ej2, ej, sstest(NN*NDOF, NN*NDOF)
    type(fstr_eigen)   :: fstrEIG

    !print *,'RHO:',RHO
    !pause

    totdiag = 0.0
    totmass = 0.0
    ! ZERO CLEAR MATRIX S()
    do I=1,ISIZE
      SS(I)=0.0
    enddo
    ! LOOP FOR INTEGRATION POINTS
    do LX=1,NG
      RI=XG(NG,LX)
      do LY=1,NG
        SI=XG(NG,LY)
        do LZ=1,NG
          TI=XG(NG,LZ)
          RP=1.0+RI
          SP=1.0+SI
          TP=1.0+TI
          RM=1.0-RI
          SM=1.0-SI
          TM=1.0-TI
          !  INTERPOLATION FUNCTION
          H(1)=0.125*RM*SM*TM
          H(2)=0.125*RP*SM*TM
          H(3)=0.125*RP*SP*TM
          H(4)=0.125*RM*SP*TM
          H(5)=0.125*RM*SM*TP
          H(6)=0.125*RP*SM*TP
          H(7)=0.125*RP*SP*TP
          H(8)=0.125*RM*SP*TP
          !  DERIVATIVE OF INTERPOLATION FUNCTION
          !  FOR R-COORDINATE
          HR(1)=-.125*SM*TM
          HR(2)= .125*SM*TM
          HR(3)= .125*SP*TM
          HR(4)=-.125*SP*TM
          HR(5)=-.125*SM*TP
          HR(6)= .125*SM*TP
          HR(7)= .125*SP*TP
          HR(8)=-.125*SP*TP
          !  FOR S-COORDINATE
          HS(1)=-.125*RM*TM
          HS(2)=-.125*RP*TM
          HS(3)= .125*RP*TM
          HS(4)= .125*RM*TM
          HS(5)=-.125*RM*TP
          HS(6)=-.125*RP*TP
          HS(7)= .125*RP*TP
          HS(8)= .125*RM*TP
          !  FOR T-COORDINATE
          HT(1)=-.125*RM*SM
          HT(2)=-.125*RP*SM
          HT(3)=-.125*RP*SP
          HT(4)=-.125*RM*SP
          HT(5)= .125*RM*SM
          HT(6)= .125*RP*SM
          HT(7)= .125*RP*SP
          HT(8)= .125*RM*SP
          !  JACOBI MATRIX
          XJ11=0.0
          XJ21=0.0
          XJ31=0.0
          XJ12=0.0
          XJ22=0.0
          XJ32=0.0
          XJ13=0.0
          XJ23=0.0
          XJ33=0.0
          do I=1,NN
            XJ11=XJ11+HR(I)*XX(I)
            XJ21=XJ21+HS(I)*XX(I)
            XJ31=XJ31+HT(I)*XX(I)
            XJ12=XJ12+HR(I)*YY(I)
            XJ22=XJ22+HS(I)*YY(I)
            XJ32=XJ32+HT(I)*YY(I)
            XJ13=XJ13+HR(I)*ZZ(I)
            XJ23=XJ23+HS(I)*ZZ(I)
            XJ33=XJ33+HT(I)*ZZ(I)
          enddo
          !DETERMINANT OF JACOBIAN
          DET=XJ11*XJ22*XJ33     &
            +XJ12*XJ23*XJ31     &
            +XJ13*XJ21*XJ32     &
            -XJ13*XJ22*XJ31     &
            -XJ12*XJ21*XJ33     &
            -XJ11*XJ23*XJ32
          ! INVERSION OF JACOBIAN
          DUM=1.0/DET
          XJI11=DUM*( XJ22*XJ33-XJ23*XJ32)
          XJI21=DUM*(-XJ21*XJ33+XJ23*XJ31)
          XJI31=DUM*( XJ21*XJ32-XJ22*XJ31)
          XJI12=DUM*(-XJ12*XJ33+XJ13*XJ32)
          XJI22=DUM*( XJ11*XJ33-XJ13*XJ31)
          XJI32=DUM*(-XJ11*XJ32+XJ12*XJ31)
          XJI13=DUM*( XJ12*XJ23-XJ13*XJ22)
          XJI23=DUM*(-XJ11*XJ23+XJ13*XJ21)
          XJI33=DUM*( XJ11*XJ22-XJ12*XJ21)
          !  WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,LX)*WGT(NG,LY)*WGT(NG,LZ)*DET
          ind1 = 1
          do J=1,NN*NDOF
            ind2 = 1
            do J2=1,J
              NUM=(J-1)*J/2+J2
              !DEBUG
              !               IF(fstrEIG%mastyp.EQ.2) THEN
              !                IF(MOD(j,ndof).EQ.MOD(j2,ndof)) THEN
              !                 SS(NUM)=SS(NUM)+H(ind2)*H(ind1)*WG*RHO
              !!*EHM CONSISTENT MASS MATRIX 22 Apr 2004: Uncomment for debug
              !!                 sstest(j,j2) = SS(NUM)
              !                 ENDIF
              !               ELSE IF(fstrEIG%mastyp.EQ.1) THEN
              if(j.EQ.j2) then
                SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
                totdiag=totdiag+H(ind1)*H(ind2)*WG*RHO
              endif
              if(mod(j2,ndof).EQ.mod(j,ndof)) then
                totmass=totmass+H(ind1)*H(ind2)*WG*RHO
              endif
              !               ENDIF
              if(mod(J2,NDOF).EQ.0) ind2 = ind2 + 1
            enddo
            if(mod(J,NDOF).EQ.0) ind1 = ind1 + 1
          enddo

          !*EHM CONSISTENT MASS MATRIX 15 Apr 2004
        end do
      end do
    end do

    !DEBUG
    !      IF(fstrEIG%mastyp.EQ.1) THEN
    do j = 1,nn*ndof
      num = j*(j+1)/2
      ss(num) = ss(num)*(2*totmass-totdiag)/(totdiag)
    end do
    if(2*totmass-totdiag .LT. 0) then
      write(*,*) "Mass error 361!"
      call hecmw_abort( hecmw_comm_get_comm())
    endif
    !      ENDIF
    !DEBUG

    !*EHM DEBUG CONSISTENT MASS MATRIX 18Apr04: Uncomment for debug
    !	OPEN(55,FILE="sstest.dat",STATUS="UNKNOWN",ACCESS="APPEND")
    !        WRITE(55,*)'*--------------------------------------------*'
    !	DO j=1,NN*NDOF
    !	 WRITE(55,10) (sstest(j,j2),j2=1,NN*NDOF)
    !	END DO
    ! 10     FORMAT(24F7.5)
    !        CLOSE(55)
    !	!PAUSE 'Check SSTEST'
    return
  end subroutine MASS_C3D8
  !----------------------------------------------------------------------*
  subroutine MASS_C3D6(XX,YY,ZZ,EE,PP,RHO,SS,fstrEIG)
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 6-NODE SOLID ELEMENT
    !
    use hecmw
    use m_fstr
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) :: XX(*), YY(*), ZZ(*), SS(*), EE, PP, RHO
    ! LOCAL VARIABLES
    integer(kind=kint), parameter :: NN = 6, NDOF = 3, ISIZE = (NN*NDOF)*(NN*NDOF + 1)/2
    integer(kind=kint), parameter :: NG = 2
    !parameter(NN=6, NDOF=3, ISIZE=(NN*NDOF)*(NN*NDOF + 1)/2, NG=2)
    real(kind=kreal)   :: D(6, 6), B(6, NDOF*NN), DB(6, NDOF*NN)
    real(kind=kreal)   :: H(NN), HL1(NN), HL2(NN), HL3(NN), HZ(NN)
    real(kind=kreal)   :: XJ11, XJ21, XJ31, XJ12, XJ22, XJ32, XJ13, XJ23, XJ33, DET, WG, DUM
    real(kind=kreal)   :: XJI11, XJI21, XJI31, XJI12, XJI22, XJI32, XJI13, XJI23, XJI33
    integer(kind=kint) :: I, J, L, L1, L2, LZ, NUM, J2
    real(kind=kreal)   :: X1, X2, X3, XL1, XL2, ZI
    real(kind=kreal)   :: DNDX, DNDY, DNDZ
    !*EHM CONSISTENT MASS MATRIX 18 Apr 2004
    real(kind=kreal)   :: totdiag, totmass
    integer(kind=kint) :: ind1, ind2
    type(fstr_eigen)   :: fstrEIG

    totdiag = 0.0
    totmass = 0.0
    ! ZERO CLEAR MATRIX S()
    do I=1,ISIZE
      SS(I)=0.0
    enddo
    ! LOOP FOR INTEGRATION POINTS
    do LZ=1,NG
      ZI=XG(NG,LZ)
      do L2=1,NG
        XL2=XG(NG,L2)
        X2 =(XL2+1.0)*0.5
        do L1=1,NG
          XL1=XG(NG,L1)
          X1=0.5*(1.0-X2)*(XL1+1.0)
          !  INTERPOLATION FUNCTION
          X3=1.0-X1-X2
          H(1)=X1*(1.0-ZI)*0.5
          H(2)=X2*(1.0-ZI)*0.5
          H(3)=X3*(1.0-ZI)*0.5
          H(4)=X1*(1.0+ZI)*0.5
          H(5)=X2*(1.0+ZI)*0.5
          H(6)=X3*(1.0+ZI)*0.5
          !  DERIVATIVE OF INTERPOLATION FUNCTION
          !  FOR L1-COORDINATE
          HL1(1)=(1.0-ZI)*0.5
          HL1(2)=0.0
          HL1(3)=0.0
          HL1(4)=(1.0+ZI)*0.5
          HL1(5)=0.0
          HL1(6)=0.0
          !  FOR L2-COORDINATE
          HL2(1)=0.0
          HL2(2)=(1.0-ZI)*0.5
          HL2(3)=0.0
          HL2(4)=0.0
          HL2(5)=(1.0+ZI)*0.5
          HL2(6)=0.0
          !  FOR L3-COORDINATE
          HL3(1)=0.0
          HL3(2)=0.0
          HL3(3)=(1.0-ZI)*0.5
          HL3(4)=0.0
          HL3(5)=0.0
          HL3(6)=(1.0+ZI)*0.5
          !  FOR Z-COORDINATE
          HZ(1)=-X1*0.5
          HZ(2)=-X2*0.5
          HZ(3)=-X3*0.5
          HZ(4)= X1*0.5
          HZ(5)= X2*0.5
          HZ(6)= X3*0.5
          !  JACOBI MATRIX
          XJ11=0.0
          XJ21=0.0
          XJ31=0.0
          XJ12=0.0
          XJ22=0.0
          XJ32=0.0
          XJ13=0.0
          XJ23=0.0
          XJ33=0.0
          do I=1,NN
            XJ11=XJ11+(HL1(I)-HL3(I))*XX(I)
            XJ21=XJ21+(HL2(I)-HL3(I))*XX(I)
            XJ31=XJ31+HZ(I)*XX(I)
            XJ12=XJ12+(HL1(I)-HL3(I))*YY(I)
            XJ22=XJ22+(HL2(I)-HL3(I))*YY(I)
            XJ32=XJ32+HZ(I)*YY(I)
            XJ13=XJ13+(HL1(I)-HL3(I))*ZZ(I)
            XJ23=XJ23+(HL2(I)-HL3(I))*ZZ(I)
            XJ33=XJ33+HZ(I)*ZZ(I)
          enddo
          !DETERMINANT OF JACOBIAN
          DET=XJ11*XJ22*XJ33     &
            +XJ12*XJ23*XJ31     &
            +XJ13*XJ21*XJ32     &
            -XJ13*XJ22*XJ31     &
            -XJ12*XJ21*XJ33     &
            -XJ11*XJ23*XJ32
          ! INVERSION OF JACOBIAN
          DUM=1.0/DET
          XJI11=DUM*( XJ22*XJ33-XJ23*XJ32)
          XJI21=DUM*(-XJ21*XJ33+XJ23*XJ31)
          XJI31=DUM*( XJ21*XJ32-XJ22*XJ31)
          XJI12=DUM*(-XJ12*XJ33+XJ13*XJ32)
          XJI22=DUM*( XJ11*XJ33-XJ13*XJ31)
          XJI32=DUM*(-XJ11*XJ32+XJ12*XJ31)
          XJI13=DUM*( XJ12*XJ23-XJ13*XJ22)
          XJI23=DUM*(-XJ11*XJ23+XJ13*XJ21)
          XJI33=DUM*( XJ11*XJ22-XJ12*XJ21)
          !  WEIGHT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,L1)*WGT(NG,L2)*WGT(NG,LZ)*DET*(1.0-X2)*0.25
          ind1 = 1
          do J=1,NN*NDOF
            ind2 = 1
            do J2=1,J
              NUM=(J-1)*J/2+J2
              !DEBUG
              !               IF(fstrEIG%mastyp.EQ.2) THEN
              !                IF(MOD(j,NDOF).EQ.MOD(j2,NDOF)) THEN
              !                 SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
              !                ENDIF
              !               ELSE IF(fstrEIG%mastyp.EQ.1) THEN
              if(j.EQ.j2) then
                SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
                totdiag=totdiag+H(ind1)*H(ind2)*WG*RHO
              endif
              if(mod(j2,ndof).EQ.mod(j,ndof)) then
                totmass=totmass+H(ind1)*H(ind2)*WG*RHO
              endif
              !               ENDIF
              if(mod(j2,NDOF).EQ.0) ind2 = ind2+1
            enddo
            if(mod(j,NDOF).EQ.0) ind1 = ind1+1
          enddo
        enddo
      enddo
    enddo

    !DEBUG
    !      IF(fstrEIG%mastyp.EQ.1) THEN
    do j = 1,nn*ndof
      num = j*(j+1)/2
      ss(num) = ss(num)*(2*totmass-totdiag)/(totdiag)
    end do
    if(2*totmass-totdiag .LT. 0) stop "Mass error 351!"
    !      ENDIF

    return
  end subroutine MASS_C3D6
  !----------------------------------------------------------------------*
  subroutine MASS_C3D4(XX,YY,ZZ,EE,PP,RHO,SS,fstrEIG)
    !----------------------------------------------------------------------*
    !
    ! CALCULATION 3D 4-NODE SOLID ELEMENT
    !
    use hecmw
    use m_fstr
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*), YY(*), ZZ(*), SS(*), EE, PP, RHO
    ! LOCAL VARIABLES
    integer(kind=kint), parameter :: NN = 4, NDOF = 3, ISIZE = (NN*NDOF)*(NN*NDOF + 1)/2
    integer(kind=kint), parameter :: NG = 2
    !parameter(NN=4,NDOF=3,ISIZE=(NN*NDOF)*(NN*NDOF+1)/2,NG=2)
    real(kind=kreal)   :: D(6, 6), B(6, NDOF*NN), DB(6, NDOF*NN)
    real(kind=kreal)   :: H(NN), HL1(NN), HL2(NN), HL3(NN), HL4(NN)
    real(kind=kreal)   :: XJ11, XJ21, XJ31, XJ12, XJ22, XJ32, XJ13, XJ23, XJ33, DET, WG, DUM
    real(kind=kreal)   :: XJI11, XJI21, XJI31, XJI12, XJI22, XJI32, XJI13, XJI23, XJI33
    integer(kind=kint) :: I, J, L, L1, L2, L3, NUM, J2
    real(kind=kreal)   :: XL1, XL2, XL3
    real(kind=kreal)   :: X1, X2, X3, X4
    real(kind=kreal)   :: DNDX, DNDY, DNDZ
    !*EHM CONSISTENT MASS MATRIX 18 Apr 2004
    real(kind=kreal)   :: totdiag, totmass
    integer(kind=kint) :: ind1, ind2
    type(fstr_eigen)   :: fstrEIG

    totdiag = 0.0
    totmass = 0.0
    ! ZERO CLEAR MATRIX S()
    do I=1,ISIZE
      SS(I)=0.0
    enddo
    totdiag = 0.
    totmass = 0.
    ! LOOP FOR INTEGRATION POINTS
    do L3=1,NG
      XL3=XG(NG,L3)
      X3 =(XL3+1.0)*0.5
      do L2=1,NG
        XL2=XG(NG,L2)
        X2 =(1.0-X3)*(XL2+1.0)*0.5
        do L1=1,NG
          XL1=XG(NG,L1)
          X1=(1.0-X2-X3)*(XL1+1.0)*0.5
          !  INTERPOLATION FUNCTION
          X4=1.0-X1-X2-X3
          H(1)=X1
          H(2)=X2
          H(3)=X3
          H(4)=X4
          ! DERIVATIVE OF INTERPOLATION FUNCTION
          ! FOR L1-COORDINATE
          HL1(1)= 1.0
          HL1(2)= 0.0
          HL1(3)= 0.0
          HL1(4)= 0.0
          !  FOR L2-COORDINATE
          HL2(1)= 0.0
          HL2(2)= 1.0
          HL2(3)= 0.0
          HL2(4)= 0.0
          !  FOR L3-COORDINATE
          HL3(1)= 0.0
          HL3(2)= 0.0
          HL3(3)= 1.0
          HL3(4)= 0.0
          !  FOR L4-COORDINATE
          HL4(1)= 0.0
          HL4(2)= 0.0
          HL4(3)= 0.0
          HL4(4)= 1.0
          !  JACOBI MATRIX
          XJ11=0.0
          XJ21=0.0
          XJ31=0.0
          XJ12=0.0
          XJ22=0.0
          XJ32=0.0
          XJ13=0.0
          XJ23=0.0
          XJ33=0.0
          do I=1,NN
            XJ11=XJ11+(HL1(I)-HL4(I))*XX(I)
            XJ21=XJ21+(HL2(I)-HL4(I))*XX(I)
            XJ31=XJ31+(HL3(I)-HL4(I))*XX(I)
            XJ12=XJ12+(HL1(I)-HL4(I))*YY(I)
            XJ22=XJ22+(HL2(I)-HL4(I))*YY(I)
            XJ32=XJ32+(HL3(I)-HL4(I))*YY(I)
            XJ13=XJ13+(HL1(I)-HL4(I))*ZZ(I)
            XJ23=XJ23+(HL2(I)-HL4(I))*ZZ(I)
            XJ33=XJ33+(HL3(I)-HL4(I))*ZZ(I)
          enddo
          !DETERMINANT OF JACOBIAN
          DET=XJ11*XJ22*XJ33     &
            +XJ12*XJ23*XJ31   &
            +XJ13*XJ21*XJ32   &
            -XJ13*XJ22*XJ31   &
            -XJ12*XJ21*XJ33   &
            -XJ11*XJ23*XJ32
          ! INVERSION OF JACOBIAN
          DUM=1.0/DET
          XJI11=DUM*( XJ22*XJ33-XJ23*XJ32)
          XJI21=DUM*(-XJ21*XJ33+XJ23*XJ31)
          XJI31=DUM*( XJ21*XJ32-XJ22*XJ31)
          XJI12=DUM*(-XJ12*XJ33+XJ13*XJ32)
          XJI22=DUM*( XJ11*XJ33-XJ13*XJ31)
          XJI32=DUM*(-XJ11*XJ32+XJ12*XJ31)
          XJI13=DUM*( XJ12*XJ23-XJ13*XJ22)
          XJI23=DUM*(-XJ11*XJ23+XJ13*XJ21)
          XJI33=DUM*( XJ11*XJ22-XJ12*XJ21)
          DET=-DET
          !  WEIGT VALUE AT GAUSSIAN POINT
          WG=WGT(NG,L1)*WGT(NG,L2)*WGT(NG,L3)*DET*(1.0-X3)*(1.0-X2-X3)*0.125
          ind1 = 1
          do J=1,NN*NDOF
            ind2 = 1
            do J2=1,J
              NUM=(J-1)*J/2+J2
              !DEBUG
              !               IF(fstrEIG%mastyp.EQ.2) THEN
              !                IF(MOD(j,NDOF).EQ.MOD(j2,NDOF))THEN
              !                 SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
              !                ENDIF
              !               ELSE IF(fstrEIG%mastyp.EQ.1) THEN
              if(j.EQ.j2) then
                SS(NUM)=SS(NUM)+H(ind1)*H(ind2)*WG*RHO
                totdiag=totdiag+H(ind1)*H(ind2)*WG*RHO
              endif
              if(mod(j2,ndof).EQ.mod(j,ndof)) then
                totmass=totmass+H(ind1)*H(ind2)*WG*RHO
              endif
              !               ENDIF
              if(mod(j2,NDOF).EQ.0) ind2 = ind2 + 1
            enddo
            if(mod(j,NDOF).EQ.0) ind1 = ind1 + 1
          enddo
        enddo
      enddo
    enddo
    !DEBUG
    !      IF(fstrEIG%mastyp.EQ.1) THEN
    do j = 1,nn*ndof
      num = j*(j+1)/2
      ss(num) = ss(num)*(2*totmass-totdiag)/(totdiag)
    end do
    if(2*totmass-totdiag .LT. 0) stop "Mass error 341!"
    !      ENDIF
    return
  end subroutine MASS_C3D4
  !--------------------------------------------------------------------*

end module m_eigen_LIB_3d1mass