      SUBROUTINE THIRMOF(N,MH,XX,XMEAN,CC,CN,C)
C
      INCLUDE 'timsac_f.h'
C
cc	PROGRAM THIRMO
C     PROGRAM 74.6.1.
C-----------------------------------------------------------------------
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C         TOKYO
C     ** DATE OF THE LATEST REVISION: MARCH 25, 1977
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C        "TIMSAC-74 A TIME SERIES ANALYSIS AND CONTROL PROGRAM PACKAGE(2
C        BY H. AKAIKE, E. ARAHATA AND T. OZAKI, COMPUTER SCIENCE MONOGRA
C        NO.6 MARCH 1976, THE INSTITUTE OF STATISTICAL MATHEMATICS
C-----------------------------------------------------------------------
C     THIS PROGRAM COMPUTES THE THIRD ORDER MOMENTS.
C     THE OUTPUT OF THIS PROGRAM M,MH,CC(I) AND C(I,J) ARE USED AS THE I
C     TO THE PROGRAM BISPEC (BI-SPECTRUM COMPUTATION).
C     THIS PROGRAM REQUIRES THE FOLLOWING INPUTS;
C     N: DATA LENGTH
C     MH: MAXIMUM LAG
C     DFORM: DATA FORMAT STATEMENT INFORMATION
C     X(I),I=1,N: ORIGINAL DATA
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: THIRMOF
C
cxx      IMPLICIT REAL*8(A-H,O-Z)
cc      REAL*4 X,XMEAN
cc      DIMENSION X(2000),X1(2000),CC(51),C(51,51)
cc      DIMENSION CN(51),ITAB(7),CPR(7),IIND(7)
cc      DIMENSION DFORM(20)
cxx      DIMENSION X(N),X1(N),CC(MH+1),CN(MH+1),C(MH+1,MH+1)
cxx      DIMENSION XX(N)
      INTEGER :: N, MH
      REAL(8) :: XX(N), XMEAN, CC(MH+1), CN(MH+1), C(MH+1,MH+1)
      REAL(8) :: X(N), X1(N), CST0, CST1, AN, BN, SUM, T1, T2, CX0
cc	DATA IIND / 7*4HJ=   /
C
C     INPUT / OUTPUT DATA FILE OPEN
cc      CHARACTER(100) DFNAM
cc      CALL SETWND
cc      DFNAM='thirmo.out'
cc      CALL FLOPN3(DFNAM,NFL)
cc      IF (NFL.EQ.0) GO TO 999
C
cc      READ(5,1) N,MH
      L1=MH+1
C     INPUT FORMAT SPECIFICATION
cc      READ(5,4) (DFORM(I),I=1,20)
cc    4 FORMAT(20A4)
C     ORIGINAL DATA INPUT AND PRINT OUT
cc      READ(5,DFORM) (X(I),I=1,N)
      DO 9 I=1,N
         X(I)=XX(I)
    9 CONTINUE
cc      WRITE(6,49)
cc      WRITE(6,50)
cc      WRITE(6,51)
cc      WRITE(6,52) N,MH
cc      WRITE(6,53)
cc      WRITE(6,55) ((X(I),I),I=1,N)
C
C     MEAN DELETION
      CST0=0.0D-00
      CST1 =1.0D-00
      AN=N
      BN =CST1/AN
      SUM =CST0
      DO 10 I=1,N
cxx   10 SUM=SUM+X(I)
      SUM=SUM+X(I)
   10 CONTINUE
      XMEAN=BN*SUM
      DO 11 I=1,N
cxx   11 X(I)=X(I)-XMEAN
      X(I)=X(I)-XMEAN
   11 CONTINUE
      DO 20 J=1,L1
      KL1=N-J+1
      T1=CST0
      DO 21 K=1,KL1
      KJ=K+J-1
cc      X1(K) =DBLE(X(KJ))*DBLE(X(K))
      X1(K) =X(KJ)*X(K)
cxx   21 T1=T1+X1(K)
      T1=T1+X1(K)
   21 CONTINUE
      CC(J)=BN*T1
      DO 22 I=J,L1
      KL2=N-I+1
      T2 =CST0
      DO 23 K=1,KL2
      KI=K+I-1
cxx   23 T2=T2+X(KI)*X1(K)
      T2=T2+X(KI)*X1(K)
   23 CONTINUE
      C(I,J)=BN*T2
   22 CONTINUE
   20 CONTINUE
C     NORMALIZATION
      CX0=CC(1)
C     COMMON SUBROUTINE CALL
      CALL CORNOM(CC,CN,L1,CX0,CX0)
C     AUTO COVARIANCE PRINT OUT
cc      WRITE(6,1162)
cc      WRITE(6,162) N,MH,XMEAN
cc      WRITE(6,163)
cc      DO 360 I=1,L1
cc      IM1=I-1
cc  360 WRITE(6,155) IM1,CC(I),CN(I)
C     C(I,J) PRINT OUT
cc      WRITE(6,180)
cc      DO 300 I=1,L1
cc      JG=-1
cc      JS=0
cc      JC=0
cc  319 JC=JC+1
cc      IF  (JC.GT.I) GO TO 305
cc      JS=JS+1
cc      IF  (JS.LE.7) GO TO 310
cc      JS=7
cc  316 WRITE(6,190) (IIND(J),ITAB(J),J=1,JS)
cc  316 CONTINUE
cc      JG=JG+1
cc      IF  (JG) 317,318,317
cc  317 WRITE(6,192) (CPR(J),J=1,JS)
cc  317 CONTINUE
cc      GO TO 315
cc  318 IM1=I-1
cc      WRITE(6,191) IM1,(CPR(J),J=1,JS)
cc  315 IF  (JC.EQ.54321) GO TO 300
cc      JS=1
cc  310 ITAB(JS)=JC-1
cc      CPR(JS)=C(I,JC)
cc      GO TO 319
cc  305 JC=54321
cc      GO TO 316
cc  300 CONTINUE
C     AUTO COVARIANCE PUNCH OUT
cc      WRITE(7,1) N,MH
cc      WRITE(7,2) (CC(I),I=1,L1)
C     C(I,J) PUNCH OUT
cc      DO 320 I=1,L1
cc  320 WRITE(7,2) (C(I,J),J=1,I)
cc      CALL FLCLS3(NFL)
cc  999 CONTINUE
      RETURN
cxx    1 FORMAT(16I5)
cxx    2 FORMAT(4D20.10)
cxx   49 FORMAT(1H ,'PROGRAM 74.6.1. THIRMO')
cxx   50 FORMAT(1H ,'THIRD ORDER MOMENTS COMPUTATION')
cxx   51 FORMAT(/1H ,'INITIAL CONDITION')
cxx   52 FORMAT(/1H ,'N=',I5,5X,'MH=',I5)
cxx   53 FORMAT(/1H ,'ORIGINAL DATA')
cxx   55 FORMAT(5(F13.4,' (',I5,'), '))
cxx 1162 FORMAT(///1H ,'AUTOCOVARIANCE')
cc  162 FORMAT(1H ,'N=',I5,5X,'MH=',I5,5X,'MEAN=',E15.5)
cxx  162 FORMAT(/1H ,'N=',I5,5X,'MH=',I5,5X,'MEAN=',D15.5)
cxx  163 FORMAT(/1H ,4X,'I',6X,'CC(I)=E(X(T+I)X(T))',6X,'NORMALIZED')
cxx  180 FORMAT(///1H ,'C(I,J)=E(X(T+I)X(T+J)X(T))')
cxx  181 FORMAT(1H ,2I5,D17.5)
cxx  155 FORMAT(1H ,I5,D17.5,8X,D17.5)
cxx  190 FORMAT(/1H ,7X,7(6X,A2,I5,4X))
cxx  191 FORMAT(1H ,'I=',I5,7D17.5)
cxx  192 FORMAT(1H ,7X,7D17.5)
      END


SUBROUTINE initialize(s,t,v,r,f,h,z,zeta,eta)
  IMPLICIT none

  INCLUDE "grid.inc"

!  Declare temporary arrays -
!    These were used because of the memory constraint on the ENIAC --
!      these values were on punched cards recycled through the system
  REAL s(0:p,0:p), t(0:q,0:q), v(0:p,0:q)
  REAL r(0:p,0:q), f(0:p,0:q), h(0:p,0:q)

!  Declare data, physical info.
  REAL z(0:p,0:q), zeta(0:p,0:q), eta(0:p,0:q)

!  Declare computational variables
  INTEGER i, j, l, m

!***********************************************************!!

! BEGIN THE EXECUTION HERE
! This file is not comparable to anything in the original program.
  OPEN (UNIT=1, FILE="ENIAC.OUT", FORM="FORMATTED")

  s = 0.
  t = 0.
  v = 0.
  r = 0.
  h = 0.
  f = 0.
  zeta = 0.0
  eta  = 0.0

  PRINT *,SECOND()*1000.,' ms'

!  Prepare the fixed field data decks - used due to memory constraints
  DO i = 1, p-1
    DO l = 1, p-1
      s(l,i) = SIN(pi*i*l/p)
    ENDDO
  ENDDO

  DO j = 1, q-1
    DO m = 1, q-1
      t(m,j) = SIN(pi*m*j/q)
    ENDDO
  ENDDO

  DO i = 0, p
    DO j = 0, q
      v(i,j) = p*q*(SIN(pi*i/(2*p))**2 + SIN(pi*j/(2*q))**2 )
      r(i,j) = (ds/(2*radius))**2 *((i-ip)**2+(j-jp)**2)
    ENDDO
  ENDDO

! metric --
! the nondimensionalized r = cos(phi)/(1+sin(phi)) where phi = latitude
!    and r**2 = (x-xp)**2 + (y-yp)**2
! f, h address the mapping/magnification factor
  f = (1.-r)/(1.+r)
  h = g/(2*omega*ds)**2 * (1.+r)**3 / (1.-r)

! Now get initial condition -- 500 mb height field -------------
!  !read in z (in 10's of feet)
!  z = z - 820
!! Rescale the heights (10's of feet) to metric
!  z    = z / fttom
  OPEN(11, FILE="fort.11", FORM="UNFORMATTED", STATUS="OLD")
  READ(11) z
  CLOSE(11)

  DO i = 1, p-1
    DO j = 1, q-1
      zeta(i,j) = z(i+1,j)+z(i,j+1)+z(i-1,j)+z(i,j-1) - 4.*z(i,j)
    ENDDO
  ENDDO
  DO j = 0, q
    zeta(0,j) = 2.*zeta(1,j)  - zeta(2,j)
    zeta(p,j) = 2.*zeta(p-1,j)- zeta(p-2,j)
  ENDDO
  DO i = 0, p
    zeta(i,0) = 2.*zeta(i,1)   - zeta(i,2)
    zeta(i,q) = 2.*zeta(i,q-1) - zeta(i,q-2)
  ENDDO

  eta = f + h*zeta

! END OF THE PRELIMINARY SET UP SECTION
  RETURN
END SUBROUTINE initialize


!******************************************************************
! Program which generates a matrix with ones on the even lines
! and increasing integers along the odd lines
!
!        1 2 3 4
!        1 1 1 1
!        5 6 7 8
!
! JLP
! Version 16/03/2001
!******************************************************************
program exo2
 implicit none
 integer(kind=2)			:: n, m, err, i
 integer, dimension(:,:),allocatable	:: mat

print *,"Nber of lines? :"; read(*,*) n
print *,"Nber of columns? :"; read(*,*) m

! Allocate memory
allocate(mat(n,m),stat=err)
if (err /= 0) then
  print *,"Error allocating memory"; stop 4
endif

! Fill even lines with ones:
mat(2:n:2,:) = 1

! Fill odd lines with 1,2,...
mat(1:n:2,:) = reshape((/ (i,i=1,size(mat(1:n:2,2:))) /), &
                       shape=shape(mat(1:n:2,:)), order=(/ 2,1 /))
! Order is 1,2 by default (i.e. along the columns). Here we want
! it along the lines, i.e., the lines have the priority when filling
! the array

! Now print the output:
do i=1,n
 print *,mat(i,:)
end do

end program exo2


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Type conversion generics and intrinsics: INT, IFIX, IDINT,
*   REAL, FLOAT, SNGL, DBLE, DFLOAT, and CMPLX.

	program p
	implicit double precision (d), complex (c)
	integer rslts(12), expect(12)
	real rrslts(13:23), rexpect(13:23)
	double precision drslts(7), dexpect(7)
	complex crslts(9), cexpect(9)
	common /r/ rslts, rrslts, drslts, crslts
	common /e/ expect, rexpect, dexpect, cexpect

	integer*2 j3

	data expect / 2, 3, 5, 5, -5, 5, 0, 5, 10, 7, 4, 3 /
	data rexpect/ 2.5, -5.9, 3.0, -5.0, 3.0, 0.0,
     +                5.5, 2.0, -5.9, -5.5, 2.0       /
	data dexpect/ 99999D0, -3.0d0, 99996d0, 2.0d0,
     +                5.5d0, 5.9, 3.0d0             /
	data cexpect/ (1234.0, 0.0),   (2.0, 0.0),
     +                (3.0, 0.0),      (4.0, 1.0),
     +                (66000.0, -5.0), (3.0, 2.0),
     +                (1.0, -1.0),     (5.5, 20.0),
     +                (1.0, -1.0)                     /

	data i2, j3 / 2, 3/
	data xn59, x0, x1 / -5.9, 0.0, 1.0 /
	data d59, d55, d1, d2, d11/ 5.9D0, 5.5d0, 1.0d0, 2.0d0, 11d0 /
	data c31 / (3.0, 1.0) /

c ------------- tests 1 - 7:     integer, real ----> integer

	call sub1(int(i2), int(j3), rslts)
	rslts(3) = int(i2 + j3)
	rslts(4) = int(5.9)
	rslts(5) = int(xn59)
	rslts(6) = ifix(-xn59)
	rslts(7) = ifix(0.0001)

c ------------- tests 8 - 12:    double, complex ----> integer

	rslts(8) = int(d59)
	rslts(9) = idint(d59) + int(5.9d0)
	rslts(idint(10.5d0)) = 7
 	rslts(int(d11)) = int((4.0, 3.0))
 	rslts(12) = int( c31 )

c ------------- tests 13 - 18:   real, integer ----> real

	rrslts(13) = real(2.5)
	rrslts(14) = real(xn59)
	rrslts(15) = real(j3)
	rrslts(16) = float( -(i2 + j3) )
	rrslts(17) = float(j3)
	rrslts(18) = real(-1) + float(1)

c ------------- tests 19 - 23:   double, complex ----> real

	call sub2(sngl(d55), real(2.0d0), real(xn59), rrslts(19))
	rrslts(22) = real( -d55 )
	rrslts(23) = real(c31) + real((-1.0, 5.0))

c ------------- tests 24 - 29:   integer ----> double

	drslts(1) = dfloat(99999)
	drslts(2) = dfloat( -j3 )
	drslts(3) = dble( 99999 - j3 )

c ------------- tests 30 - 37:   real, double, complex ----> double

	drslts(4) = int( dble(12345.1) - 12343.0 )
        drslts(5) = dble( d55 )
	drslts(6) = dble(x0 - xn59)
	drslts(7) = dble(c31)

c ------------- tests 38 - 45:   CMPLX intrinsic with one argument:

	crslts(1) = cmplx(1234)
	crslts(2) = cmplx(x1) + x1
	crslts(3) = cmplx(d1 + d2)
	crslts(4) = cmplx(c31 + cmplx(x1))

c ------------- tests 46 - 55:   CMPLX intrinsic with two arguments:

	crslts(5) = cmplx(66000, -5)
	crslts(6) = cmplx(INT(j3), i2)
	crslts(7) = cmplx(1.0, -x1)
	crslts(8) = cmplx( d55, 2.0d1 )
	crslts(9) = cmplx(-1.0, -1.0) + cmplx(2.0)

c ------------- check results:

	call check(rslts, expect, 55)
	end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	subroutine sub1(i, j, a)
	integer a(2)

	a(1) = i
	a(2) = j
	i = 99
	j = 99
	end

	subroutine sub2(x, y, z, a)
	real x, y, z, a(3)

	a(1) = x
	a(2) = y
	a(3) = z
	end


program example_elemental
  ! Example of calling an elemental function
  ! with scalars or arrays as arguments.
  ! Listing 3.20 in the book.
  implicit none

  print *, sum(3, 5)
  print *, sum([1, 2], 3)
  print *, sum(1, [2, 3, 4])
  print *, sum([1, 2, 3], [2, 3, 4])

  ! uncomment the line below to trigger compiler error
  ! print *, sum([1, 2], [2, 3, 4])

contains

  pure elemental integer function sum(a, b) result(r)
    integer, intent(in) :: a, b
    r = a + b
  end function sum

end program example_elemental


!> \file mo_xor4096_apps.f90

!> \brief This module provides useful applications of the random number generator xor4096.

!> \details This module provides useful applications of the random number generator xor4096, e.g.
!>          (1) generating several random numbers from one stream at once,
!>          (2) generating multivariate normal distributed random numbers, and
!>          (3) generation of random numbers within a given range.

!> \authors Juliane Mai, Stephan Thober
!> \date Feb 2013

MODULE mo_xor4096_apps

  ! This module is a template for the JAMS Fortran library.

  ! Written  Juliane Mai, Feb 2013
  ! Modified Stephan Thober, Feb 2013 - add multivariate normal

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

  USE mo_kind,    ONLY: i4, i8, sp, dp
  USE mo_xor4096, ONLY: xor4096, xor4096g, n_save_state

  IMPLICIT NONE

  PUBLIC :: xor4096_array  ! Generation of (subsequent) UNIFORM  random numbers of stream(s)
  PUBLIC :: xor4096g_array ! Generation of (subsequent) GAUSSIAN random numbers of stream(s)
  PUBLIC :: xor4096g_mvn   ! Generation of multivariate NORMAL distributed random numbers
  PUBLIC :: xor4096_range  ! Generation of UNIFORM random numbers within a given range [a,b]

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

  !     NAME
  !         xor4096_array

  !     PURPOSE
  !>        \brief Generation of (subsequent) UNIFORM  random numbers of stream(s).
  !
  !>        \details Generation of (subsequent) UNIFORM  random numbers of stream(s).\n
  !>                 It is calling the xor4096 several times and returns a vector of random numbers.\n
  !>                 It can be called with an optional argument to save the state of the current stream
  !>                 to allow for a later return to exactly this stream.\n
  !>                 The save_state variable has to be (I4) when random numbers are (I4) or (SP) and
  !>                 save_state variable has to be (I8) when random numbers are (I8) or (DP).
  !>                 The first dimension of save_state can be allocated using n_save_state of the xor4096 module.
  !>                 If there are N>1 streams used, the second dimension of save_state is N.
  !
  !     CALLING SEQUENCE
  !         call xor4096_array( rn, save_state=save_state )
  !
  !     INTENT(IN)
  !         None
  !
  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !>        \param[out] "integer(i4/i8)/real(sp/dp)   :: RN(:)/RN(:,:)"
  !>                                            uniform distributed random numbers with
  !>                                            interval:\n
  !>                                                i4: (-2^31,2^31-1)\n
  !>                                                i8: (-2^63,2^63-1)\n
  !>                                                sp: (0.0_sp, 1.0_sp)\n
  !>                                                dp: (0.0_dp, 1.0_dp)\n
  !>                                            rn(i,j) is the i^{th} number in the j^{th} stream
  !
  !     INTENT(IN), OPTIONAL
  !          None
  !
  !     INTENT(INOUT), OPTIONAL
  !>        \param[in, out] "integer(i4/i8) :: save_state(size(rn,2),n_save_state)"
  !>                                            array carrying state of random number stream\n
  !>                                            this should be used if several streams are used, i.e.
  !>                                            each stream has its own save_state
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURN
  !         None
  !
  !     RESTRICTIONS
  !>       \note The random number generator has to be initialized before and therefore is called without a seed.
  !
  !     EXAMPLE
  !         real(dp),    dimension(100)          :: rn
  !         integer(i8)                          :: seed
  !         integer(i8), dimension(n_save_state) :: save_state
  !
  !         ! initialize random number stream
  !         seed = 13546_i8
  !         call xor4096(seed, rn, save_state=save_state)
  !
  !         ! generating random numbers
  !         call xor4096_array(rn, save_state=save_state)
  !         rn --> 100 subsequent (dp) uniform random numbers from stream with seed 13546
  !
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !>        \author Juliane Mai
  !>        \date Feb 2013
  !         Modified,  -
  !
  INTERFACE xor4096_array
     MODULE PROCEDURE &
          xor4096_array_i4_1d, xor4096_array_i4_2d, xor4096_array_i8_1d, xor4096_array_i8_2d, &
          xor4096_array_sp_1d, xor4096_array_sp_2d, xor4096_array_dp_1d, xor4096_array_dp_2d
  END INTERFACE xor4096_array

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

  !     NAME
  !         xor4096g_array

  !     PURPOSE
  !>        \brief Generation of (subsequent) GAUSSIAN random numbers of stream(s).
  !
  !>        \details Generation of (subsequent) GAUSSIAN random numbers of stream(s).\n
  !>                 It is calling the xor4096g several times and returns a vector of random numbers.\n
  !>                 It can be called with an optional argument to save the state of the current stream
  !>                 to allow for a later return to exactly this stream.\n
  !>                 The save_state variable has to be (I4) when random numbers are (SP) and
  !>                 save_state variable has to be (I8) when random numbers are (DP).
  !>                 The first dimension of save_state can be allocated using n_save_state of the xor4096 module.
  !>                 If there are N>1 streams used, the second dimension of save_state is N.
  !
  !     CALLING SEQUENCE
  !         call xor4096g_array( rn, save_state=save_state )
  !
  !     INTENT(IN)
  !         None
  !
  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !>        \param[out] "real(sp/dp)   :: RN(:)/RN(:,:)"
  !>                                            gaussian distributed random numbers with
  !>                                            interval: mean 0.0 and variance 1.0
  !>                                            rn(i,j) is the i^{th} number in the j^{th} stream
  !
  !     INTENT(IN), OPTIONAL
  !          None
  !
  !     INTENT(INOUT), OPTIONAL
  !>        \param[in, out] "integer(i4/i8) :: save_state(size(rn,2),n_save_state)"
  !>                                            array carrying state of random number stream\n
  !>                                            this should be used if several streams are used, i.e.
  !>                                            each stream has its own save_state
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURN
  !         None
  !
  !     RESTRICTIONS
  !>       \note The random number generator has to be initialized before and therefore is called without a seed.
  !
  !     EXAMPLE
  !         real(dp),    dimension(100)          :: rn
  !         integer(i8)                          :: seed
  !         integer(i8), dimension(n_save_state) :: save_state
  !
  !         ! initialize random number stream
  !         seed = 13546_i8
  !         call xor4096g(seed, rn, save_state=save_state)
  !
  !         ! generating random numbers
  !         call xor4096g_array(rn, save_state=save_state)
  !         rn --> 100 subsequent (dp) gaussian random numbers from stream with seed 13546
  !
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !>        \author Juliane Mai
  !>        \date Feb 2013
  !         Modified,  -
  !
  INTERFACE xor4096g_array
     MODULE PROCEDURE &
          xor4096g_array_sp_1d, xor4096g_array_sp_2d, xor4096g_array_dp_1d, xor4096g_array_dp_2d
  END INTERFACE xor4096g_array

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

  !     NAME
  !         xor4096g_mvn

  !     PURPOSE
  !>        \brief Generation of multivariate NORMAL distributed random numbers.
  !
  !>        \details Generation of multivariate NORMAL distributed random numbers using a
  !>                 specified covariance matrix (cov).\n
  !>                 This function is a wrapper around the random number generator
  !>                 xor4096g!\n
  !>                 It can be called with an optional argument to save the state of the current stream
  !>                 to allow for a later return to exactly this stream.\n
  !>                 The save_state variable has to be (I4) when random numbers are (SP) and
  !>                 save_state variable has to be (I8) when random numbers are (DP).
  !>                 The first dimension of save_state can be allocated using n_save_state of the xor4096 module.
  !>                 The second dimension of save_state is according to the dimension of the covariance matrix.

  !     CALLING SEQUENCE
  !         call xor4096g_mvn( lcho, rn, save_state=save_state )

  !     INTENT(IN)
  !>        \param[in] "real(sp/dp), dimension(:,:) :: lcho"        lower cholesky factor of
  !>                                                                covariance matrix cov

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !>        \param[in, out] "integer(i4/i8) :: save_state( size(lcho,1),n_save_state)"
  !>                                                      array carrying state of random number stream\n
  !>                                                      this should be used if several streams are used, i.e.
  !>                                                      each stream has its own save_state

  !     INTENT(OUT), OPTIONAL
  !>        \param[out] "real(sp/dp), dimension(size(lcho,1))/dimension(:,size(lcho,1)) :: xor4096_mvn"
  !>                                                      array of multivariate gaussian variates

  !     RETURN
  !>       \return

  !     RESTRICTIONS
  !>       \note The random number generator has to be initialized before and therefore is called without a seed.

  !     EXAMPLE
  !         one can use LAPACK for calculating the lower
  !         Cholesky Factor of the covariance matrix, which is
  !         required by MVN
  !
  !         external DPOTRF   ! Lapack routine for calculating the cholesky factor
  !
  !         integer(i4)              :: info
  !         real(sp), dimension(2,2) :: cov  ! covariance matrix
  !         real(sp), dimension(2,2) :: lcho ! lower cholesky factor
  !
  !         cov = (/ 1., 0.25; 0.25, 1./)
  !         lcho = cov
  !         call DPOTRF('L', size(lcho,1), lcho, size(lcho,1), info) ! changes lower triangular (incl. main diagonal) of Lcho
  !         if ( info .gt. 0_i4 ) then
  !             write(*,*)'GetCholeskyFactor_dp: The algorithm failed!'
  !             stop
  !         end if
  !
  !         ! DONT forget to set upper triangular matrix to zero
  !         lcho(1,2) = 0._sp
  !
  !         call xor4096g_mvn( lcho , mvn )
  !         CAUTION: one has to sample a time series to stabilize the covariances
  !         between the entries of mvn

  !     LITERATURE
  !         see affine transformation at
  !         http://en.wikipedia.org/wiki/Multivariate_normal_distribution

  !     HISTORY
  !>        \author Stephan Thober
  !>        \date Oct 2012
  interface xor4096g_mvn
     module procedure mvn_sp_1d, mvn_dp_1d, mvn_sp_2d, mvn_dp_2d
  end interface xor4096g_mvn

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

  !     NAME
  !         xor4096_range

  !     PURPOSE
  !>        \brief Generation of UNIFORM random numbers within a given range [a,b].
  !
  !>        \details Generation of UNIFORM random numbers within a given range [a,b].\n
  !>                 It is calling the xor4096 and scales the random numbers to the given range.\n
  !>                 It can be called with an optional argument to save the state of the current stream
  !>                 to allow for a later return to exactly this stream.\n
  !>                 The save_state variable has to be (I4) when random numbers are (I4) or (SP) and
  !>                 save_state variable has to be (I8) when random numbers are (I8) or (DP).
  !>                 The first dimension of save_state can be allocated using n_save_state of the xor4096 module.
  !>                 If there are N>1 streams used, the second dimension of save_state is N.
  !
  !     CALLING SEQUENCE
  !         call xor4096_range( range, rn, save_state=save_state )
  !
  !     INTENT(IN)
  !>        \param[in] "integer(i4/i8)/real(sp/dp) :: rn_range(2)" lower and upper bound of the random number
  !
  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !>        \param[out] "integer(i4/i8)/real(sp/dp)   :: RN/RN(:)/RN(:,:)"
  !>                                            uniform distributed random numbers with
  !>                                            interval:\n
  !>                                                i4: [a,b]\n
  !>                                                i8: [a,b]\n
  !>                                                sp: [a,b]\n
  !>                                                dp: [a,b]\n
  !>                                            rn(i,j) is the i^{th} number in the j^{th} stream
  !
  !     INTENT(IN), OPTIONAL
  !          None
  !
  !     INTENT(INOUT), OPTIONAL
  !>        \param[in, out] "integer(i4/i8) :: save_state(size(rn,2),n_save_state)"
  !>                                            array carrying state of random number stream\n
  !>                                            this should be used if several streams are used, i.e.
  !>                                            each stream has its own save_state
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURN
  !         None
  !
  !     RESTRICTIONS
  !>       \note The random number generator has to be initialized before and therefore is called without a seed.
  !
  !     EXAMPLE
  !         real(dp),    dimension(100)          :: rn
  !         integer(i8)                          :: seed
  !         integer(i8), dimension(n_save_state) :: save_state
  !
  !         ! initialize random number stream
  !         seed = 13546_i8
  !         call xor4096(seed, rn, save_state=save_state)
  !
  !         ! generating random numbers
  !         call xor4096_range((/2.0_dp,4.0_dp/), rn, save_state=save_state)
  !         rn --> 100 subsequent (dp) uniform random numbers in interval [2.0,4.0] from stream with seed 13546
  !
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !>        \author Juliane Mai
  !>        \date Feb 2013
  !         Modified,  -
  !
  INTERFACE xor4096_range
     MODULE PROCEDURE &
          xor4096_range_i4_0d, xor4096_range_i4_1d, xor4096_range_i4_2d, &
          xor4096_range_i8_0d, xor4096_range_i8_1d, xor4096_range_i8_2d, &
          xor4096_range_sp_0d, xor4096_range_sp_1d, xor4096_range_sp_2d, &
          xor4096_range_dp_0d, xor4096_range_dp_1d, xor4096_range_dp_2d
  END INTERFACE xor4096_range

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

  PRIVATE

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

CONTAINS

  ! *********************************************************************
  ! TEST XOR4096_ARRAY
  ! *********************************************************************

  SUBROUTINE xor4096_array_i4_1d(rn, save_state)

    IMPLICIT NONE

    INTEGER(I4), DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I4), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096(0_i4, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(0_i4, rn(i))
       end do
    endif

  END SUBROUTINE xor4096_array_i4_1d

  SUBROUTINE xor4096_array_i4_2d(rn, save_state)

    IMPLICIT NONE

    INTEGER(I4), DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I4), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                        :: i
    INTEGER(I4), DIMENSION(size(rn,2)) :: seed_tmp

    seed_tmp = 0_i4

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096_array_i4_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:))
       end do
    endif

  END SUBROUTINE xor4096_array_i4_2d

  SUBROUTINE xor4096_array_i8_1d(rn, save_state)

    IMPLICIT NONE

    INTEGER(I8), DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I8), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096(0_i8, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(0_i8, rn(i))
       end do
    endif

  END SUBROUTINE xor4096_array_i8_1d

  SUBROUTINE xor4096_array_i8_2d(rn, save_state)

    IMPLICIT NONE

    INTEGER(I8), DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I8), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                        :: i
    INTEGER(I8), DIMENSION(size(rn,2)) :: seed_tmp

    seed_tmp = 0_i8

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096_array_i8_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:))
       end do
    endif

  END SUBROUTINE xor4096_array_i8_2d

  SUBROUTINE xor4096_array_sp_1d(rn, save_state)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I4), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096(0_i4, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(0_i4, rn(i))
       end do
    endif

  END SUBROUTINE xor4096_array_sp_1d

  SUBROUTINE xor4096_array_sp_2d(rn, save_state)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I4), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                        :: i
    INTEGER(I4), DIMENSION(size(rn,2)) :: seed_tmp

    seed_tmp = 0_i4

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096_array_sp_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:))
       end do
    endif

  END SUBROUTINE xor4096_array_sp_2d

  SUBROUTINE xor4096_array_dp_1d(rn, save_state)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I8), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096(0_i8, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(0_i8, rn(i))
       end do
    endif

  END SUBROUTINE xor4096_array_dp_1d

  SUBROUTINE xor4096_array_dp_2d(rn, save_state)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I8), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                        :: i
    INTEGER(I8), DIMENSION(size(rn,2)) :: seed_tmp

    seed_tmp = 0_i8

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096_array_dp_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:))
       end do
    endif

  END SUBROUTINE xor4096_array_dp_2d

  ! *********************************************************************
  ! TEST XOR4096G_ARRAY
  ! *********************************************************************

  SUBROUTINE xor4096g_array_sp_1d(rn, save_state)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I4), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096g(0_i4, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096g(0_i4, rn(i))
       end do
    endif

  END SUBROUTINE xor4096g_array_sp_1d

  SUBROUTINE xor4096g_array_sp_2d(rn, save_state)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I4), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                        :: i
    INTEGER(I4), DIMENSION(size(rn,2)) :: seed_tmp

    seed_tmp = 0_i4

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096g_array_sp_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096g(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096g(seed_tmp, rn(i,:))
       end do
    endif

  END SUBROUTINE xor4096g_array_sp_2d

  SUBROUTINE xor4096g_array_dp_1d(rn, save_state)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I8), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096g(0_i8, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096g(0_i8, rn(i))
       end do
    endif

  END SUBROUTINE xor4096g_array_dp_1d

  SUBROUTINE xor4096g_array_dp_2d(rn, save_state)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I8), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                        :: i
    INTEGER(I8), DIMENSION(size(rn,2)) :: seed_tmp

    seed_tmp = 0_i8

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096g_array_dp_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096g(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096g(seed_tmp, rn(i,:))
       end do
    endif

  END SUBROUTINE xor4096g_array_dp_2d

  ! *********************************************************************
  ! XOR4096G_MVN
  ! *********************************************************************

  subroutine mvn_SP_1d(lcho, mvn, save_state)

    implicit none

    real(sp),    dimension(:,:),           intent(in)    :: lcho
    real(sp),    dimension(size(lcho,1)),  intent(out)   :: mvn
    integer(i4), dimension(:,:), optional, intent(inout) :: save_state

    ! local variables
    integer(i4), dimension(size(lcho,1))  :: seed_tmp

    seed_tmp = 0_i4

    ! consistency check
    if ( size(lcho,1) /= size(lcho,2) ) then
       stop 'mvn_sp_1d: size mismatch in variable lcho.'
    end if

    ! ! initialize if non-zero
    ! if ( all(seed .ne. 0_i4) ) then
    !    if ( present(save_state) ) then
    !       call xor4096g(seed, mvn, save_state=save_state)
    !    else
    !       call xor4096g(seed, mvn)
    !    end if
    !    seed = 0_i4
    ! end if

    ! generate random
    if ( present(save_state) ) then
       if (size(save_state,1) .ne. size(lcho,1) .or. size(save_state,2) .ne. n_save_state) then
          stop 'mvn_sp_1d: dimensions of save_state matrix are not correct'
       end if
       call xor4096g(seed_tmp, mvn, save_state=save_state)
    else
       call xor4096g(seed_tmp, mvn)
    end if

    mvn = matmul(lcho,mvn)

  end subroutine mvn_SP_1d

  subroutine mvn_DP_1d(lcho, mvn, save_state)

    implicit none

    real(dp),    dimension(:,:),           intent(in)    :: lcho
    real(dp),    dimension(size(lcho,1)),  intent(out)   :: mvn
    integer(i8), dimension(:,:), optional, intent(inout) :: save_state

    ! local variables
    integer(i8), dimension(size(lcho,1))  :: seed_tmp

    seed_tmp = 0_i8

    ! consistency check
    if ( size(lcho,1) /= size(lcho,2) ) then
       stop 'mvn_dp_1d: size mismatch in variable lcho.'
    end if

    ! ! initialize if non-zero
    ! if ( all(seed .ne. 0_i8) ) then
    !    if ( present(save_state) ) then
    !       call xor4096g(seed, mvn, save_state=save_state)
    !    else
    !       call xor4096g(seed, mvn)
    !    end if
    !    seed = 0_i8
    ! end if

    ! generate random
    if ( present(save_state) ) then
       if (size(save_state,1) .ne. size(lcho,1) .or. size(save_state,2) .ne. n_save_state) then
          stop 'mvn_dp_1d: dimensions of save_state matrix are not correct'
       end if
       call xor4096g(seed_tmp, mvn, save_state=save_state)
    else
       call xor4096g(seed_tmp, mvn)
    end if

    mvn = matmul(lcho,mvn)

  end subroutine mvn_DP_1d

  subroutine mvn_SP_2d(lcho, mvn, save_state)

    implicit none

    real(sp),    dimension(:,:),           intent(in)    :: lcho
    real(sp),    dimension(:,:),           intent(out)   :: mvn         ! dim1=number of sets,
    !                                                                                ! dim2=size(lcho,1)
    integer(i4), dimension(:,:), optional, intent(inout) :: save_state

    ! local variables
    integer(i4)                           :: i
    integer(i4), dimension(size(lcho,1))  :: seed_tmp

    seed_tmp = 0_i4

    ! consistency check
    if ( size(lcho,1) /= size(lcho,2) ) then
       stop 'mvn_sp_2d: size mismatch in variable lcho.'
    end if

    ! ! initialize if non-zero
    ! if ( all(seed .ne. 0_i4) ) then
    !    if ( present(save_state) ) then
    !       call xor4096g(seed, mvn(1,:), save_state=save_state)
    !    else
    !       call xor4096g(seed, mvn(1,:))
    !    end if
    !    seed = 0_i4
    ! end if

    ! generate random
    if ( present(save_state) ) then
       if (size(save_state,1) .ne. size(lcho,1) .or. size(save_state,2) .ne. n_save_state) then
          stop 'mvn_sp_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(mvn,1)
          call xor4096g(seed_tmp, mvn(i,:), save_state=save_state)
          mvn(i,:) = matmul(lcho,mvn(i,:))
       end do
    else
       do i=1, size(mvn,1)
          call xor4096g(seed_tmp, mvn(i,:))
          mvn(i,:) = matmul(lcho,mvn(i,:))
       end do
    end if

  end subroutine mvn_SP_2d

  subroutine mvn_DP_2d(lcho, mvn, save_state)
    !
    implicit none
    !
    real(dp),    dimension(:,:),           intent(in)    :: lcho
    real(dp),    dimension(:,:),           intent(out)   :: mvn         ! dim1=number of sets,
    !                                                                                ! dim2=size(lcho,1)
    integer(i8), dimension(:,:), optional, intent(inout) :: save_state

    ! local variables
    integer(i4)                           :: i
    integer(i8), dimension(size(lcho,1))  :: seed_tmp

    seed_tmp = 0_i8

    ! consistency check
    if ( size(lcho,1) /= size(lcho,2) ) then
       stop 'mvn_dp_2d: size mismatch in variable lcho.'
    end if

    ! ! initialize if non-zero
    ! if ( all(seed .ne. 0_i8) ) then
    !    if ( present(save_state) ) then
    !       call xor4096g(seed, mvn(1,:), save_state=save_state)
    !    else
    !       call xor4096g(seed, mvn(1,:))
    !    end if
    !    seed = 0_i8
    ! end if

    ! generate random
    if ( present(save_state) ) then
       if (size(save_state,1) .ne. size(lcho,1) .or. size(save_state,2) .ne. n_save_state) then
          stop 'mvn_dp_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(mvn,1)
          call xor4096g(seed_tmp, mvn(i,:), save_state=save_state)
          mvn(i,:) = matmul(lcho,mvn(i,:))
       end do
    else
       do i=1, size(mvn,1)
          call xor4096g(seed_tmp, mvn(i,:))
          mvn(i,:) = matmul(lcho,mvn(i,:))
       end do
    end if

  end subroutine mvn_DP_2d

  ! *********************************************************************
  ! XOR4096_RANGE
  ! *********************************************************************

  SUBROUTINE xor4096_range_i4_0d(rn_range, rn, save_state)

    IMPLICIT NONE

    INTEGER(I4), DIMENSION(2),                      INTENT(IN)    :: rn_range       ! lower and upper bound
    INTEGER(I4),                                    INTENT(OUT)   :: rn
    INTEGER(I4), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    REAL(SP) :: rn_tmp

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_i4_0d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       call xor4096(0_i4, rn, save_state=save_state)
    else
       call xor4096(0_i4, rn)
    endif

    ! scale [-2^31, 2^31) to [0.0, 1.0)
    rn_tmp = real(rn,sp) / 2.0_sp**32_i4 + 0.5_sp

    ! scale [0.0, 1.0) to [rn_range(1),rn_range(2)]
    rn = int( rn_tmp * ( real(rn_range(2) - rn_range(1) + 1_i4,sp) ) + real(rn_range(1),sp) , i4)

  END SUBROUTINE xor4096_range_i4_0d

  SUBROUTINE xor4096_range_i4_1d(rn_range, rn, save_state)

    IMPLICIT NONE

    INTEGER(I4), DIMENSION(2),                      INTENT(IN)    :: rn_range       ! lower and upper bound
    INTEGER(I4), DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I4), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                       :: i
    REAL(SP),   DIMENSION(size(rn,1)) :: rn_tmp

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_i4_1d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096(0_i4, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(0_i4, rn(i))
       end do
    endif

    ! scale [-2^31, 2^31) to [0.0, 1.0)
    rn_tmp = real(rn,sp) / 2.0_sp**32_i4 + 0.5_sp

    ! scale [0.0, 1.0) to [rn_range(1),rn_range(2)]
    rn = int( rn_tmp * ( real(rn_range(2) - rn_range(1) + 1_i4,sp) ) + real(rn_range(1),sp) , i4)

  END SUBROUTINE xor4096_range_i4_1d

  SUBROUTINE xor4096_range_i4_2d(rn_range, rn, save_state)

    IMPLICIT NONE

    INTEGER(I4), DIMENSION(2),             INTENT(IN)    :: rn_range       ! lower and upper bound
    INTEGER(I4), DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I4), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                                    :: i
    REAL(SP),    DIMENSION(size(rn,1), size(rn,2)) :: rn_tmp
    INTEGER(I4), DIMENSION(size(rn,2))             :: seed_tmp

    seed_tmp = 0_i4

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_i4_2d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096_range_i4_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:))
       end do
    endif

    ! scale [-2^31, 2^31) to [0.0, 1.0)
    rn_tmp = real(rn,sp) / 2.0_sp**32_i4 + 0.5_sp

    ! scale [0.0, 1.0) to [rn_range(1),rn_range(2)]
    rn = int( rn_tmp * ( real(rn_range(2) - rn_range(1) + 1_i4,sp) ) + real(rn_range(1),sp) , i4)

  END SUBROUTINE xor4096_range_i4_2d

  SUBROUTINE xor4096_range_i8_0d(rn_range, rn, save_state)

    IMPLICIT NONE

    INTEGER(I8), DIMENSION(2),                      INTENT(IN)    :: rn_range       ! lower and upper bound
    INTEGER(I8),                                    INTENT(OUT)   :: rn
    INTEGER(I8), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    REAL(DP) :: rn_tmp

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_i8_0d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       call xor4096(0_i8, rn, save_state=save_state)
    else
       call xor4096(0_i8, rn)
    endif

    ! scale [-2^63, 2^63) to [0.0, 1.0)
    rn_tmp = real(rn,dp) / 2.0_dp**64_i4 + 0.5_dp

    ! scale [0.0, 1.0) to [rn_range(1),rn_range(2)]
    rn = int( rn_tmp * ( real(rn_range(2) - rn_range(1) + 1_i8,dp) ) + real(rn_range(1),dp) , i8)

  END SUBROUTINE xor4096_range_i8_0d

  SUBROUTINE xor4096_range_i8_1d(rn_range, rn, save_state)

    IMPLICIT NONE

    INTEGER(I8), DIMENSION(2),                      INTENT(IN)    :: rn_range       ! lower and upper bound
    INTEGER(I8), DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I8), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                       :: i
    REAL(DP),   DIMENSION(size(rn,1)) :: rn_tmp

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_i8_1d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096(0_i8, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(0_i8, rn(i))
       end do
    endif

    ! scale [-2^63, 2^63) to [0.0, 1.0)
    rn_tmp = real(rn,dp) / 2.0_dp**64_i4 + 0.5_dp

    ! scale [0.0, 1.0) to [rn_range(1),rn_range(2)]
    rn = int( rn_tmp * ( real(rn_range(2) - rn_range(1) + 1_i8,dp) ) + real(rn_range(1),dp) , i8)

  END SUBROUTINE xor4096_range_i8_1d

  SUBROUTINE xor4096_range_i8_2d(rn_range, rn, save_state)

    IMPLICIT NONE

    INTEGER(I8), DIMENSION(2),             INTENT(IN)    :: rn_range       ! lower and upper bound
    INTEGER(I8), DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I8), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)                                   :: i
    REAL(DP),   DIMENSION(size(rn,1), size(rn,2)) :: rn_tmp
    INTEGER(I8), DIMENSION(size(rn,2))  :: seed_tmp

    seed_tmp = 0_i8

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_i8_2d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096_range_i8_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:))
       end do
    endif

    ! scale [-2^63, 2^63) to [0.0, 1.0)
    rn_tmp = real(rn,dp) / 2.0_dp**64_i4 + 0.5_dp

    ! scale [0.0, 1.0) to [rn_range(1),rn_range(2)]
    rn = int( rn_tmp * ( real(rn_range(2) - rn_range(1) + 1_i8,dp) ) + real(rn_range(1),dp) , i8)

  END SUBROUTINE xor4096_range_i8_2d

  SUBROUTINE xor4096_range_sp_0d(rn_range, rn, save_state)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(2),                      INTENT(IN)    :: rn_range       ! lower and upper bound
    REAL(SP),                                       INTENT(OUT)   :: rn
    INTEGER(I4), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_sp_0d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       call xor4096(0_i4, rn, save_state=save_state)
    else
       call xor4096(0_i4, rn)
    endif
    rn = rn * ( rn_range(2) - rn_range(1) ) + rn_range(1)

  END SUBROUTINE xor4096_range_sp_0d

  SUBROUTINE xor4096_range_sp_1d(rn_range, rn, save_state)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(2),                      INTENT(IN)    :: rn_range       ! lower and upper bound
    REAL(SP),    DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I4), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_sp_1d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096(0_i4, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(0_i4, rn(i))
       end do
    endif
    rn = rn * ( rn_range(2) - rn_range(1) ) + rn_range(1)

  END SUBROUTINE xor4096_range_sp_1d

  SUBROUTINE xor4096_range_sp_2d(rn_range, rn, save_state)

    IMPLICIT NONE

    REAL(SP),    DIMENSION(2),             INTENT(IN)    :: rn_range       ! lower and upper bound
    REAL(SP),    DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I4), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i
    INTEGER(I4), DIMENSION(size(rn,2))  :: seed_tmp

    seed_tmp = 0_i4

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_sp_2d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096_range_sp_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:))
       end do
    endif
    rn = rn * ( rn_range(2) - rn_range(1) ) + rn_range(1)

  END SUBROUTINE xor4096_range_sp_2d

  SUBROUTINE xor4096_range_dp_0d(rn_range, rn, save_state)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(2),                      INTENT(IN)    :: rn_range       ! lower and upper bound
    REAL(DP),                                       INTENT(OUT)   :: rn
    INTEGER(I8), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_dp_0d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       call xor4096(0_i8, rn, save_state=save_state)
    else
       call xor4096(0_i8, rn)
    endif
    rn = rn * ( rn_range(2) - rn_range(1) ) + rn_range(1)

  END SUBROUTINE xor4096_range_dp_0d

  SUBROUTINE xor4096_range_dp_1d(rn_range, rn, save_state)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(2),                      INTENT(IN)    :: rn_range       ! lower and upper bound
    REAL(DP),    DIMENSION(:),                      INTENT(OUT)   :: rn
    INTEGER(I8), DIMENSION(n_save_state), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_dp_1d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       do i=1, size(rn,1)
          call xor4096(0_i8, rn(i), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(0_i8, rn(i))
       end do
    endif
    rn = rn * ( rn_range(2) - rn_range(1) ) + rn_range(1)

  END SUBROUTINE xor4096_range_dp_1d

  SUBROUTINE xor4096_range_dp_2d(rn_range, rn, save_state)

    IMPLICIT NONE

    REAL(DP),    DIMENSION(2),             INTENT(IN)    :: rn_range       ! lower and upper bound
    REAL(DP),    DIMENSION(:,:),           INTENT(OUT)   :: rn             ! dim2=number of streams
    INTEGER(I8), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: save_state

    ! local variables
    INTEGER(I4)  :: i
    INTEGER(I8), DIMENSION(size(rn,2))  :: seed_tmp

    seed_tmp = 0_i8

    if ( rn_range(1) .gt. rn_range(2) ) then
       stop 'xor4096_range_dp_2d: lower bound larger than upper bound'
    end if

    if (present(save_state)) then
       if (size(save_state,1) .ne. size(rn,2) .or. size(save_state,2) .ne. n_save_state) then
          stop 'xor4096_range_dp_2d: dimensions of save_state matrix are not correct'
       end if
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:), save_state=save_state)
       end do
    else
       do i=1, size(rn,1)
          call xor4096(seed_tmp, rn(i,:))
       end do
    endif
    rn = rn * ( rn_range(2) - rn_range(1) ) + rn_range(1)

  END SUBROUTINE xor4096_range_dp_2d

END MODULE mo_xor4096_apps


      subroutine pest_parm_read

      use basin_module
      use input_file_module
      use maximum_data_module
      use pesticide_data_module

      implicit none

      character (len=80) :: titldum   !           |title of file
      character (len=80) :: header    !           |header of file
      integer :: eof                  !           |end of file
      integer :: imax                 !none       |determine max number for array (imax) and total number in file
      logical :: i_exist              !none       |check to determine if file exists
      integer :: i                    !none       |counter
      integer :: num                  !           |
      integer :: ip                   !none       |counter

      eof = 0
      imax = 0

      inquire (file=in_parmdb%pest, exist=i_exist)
      if (.not. i_exist .or. in_parmdb%pest == "null") then
        allocate (pestdb(0:0))
        allocate (pestcp(0:0))
      else
      do
        open (106,file=in_parmdb%pest)
        read (106,*,iostat=eof) titldum
        if (eof < 0) exit
        read (106,*,iostat=eof) header
        if (eof < 0) exit
          do while (eof == 0)
            read (106,*,iostat=eof) titldum
            if (eof < 0) exit
            imax = imax + 1
          end do

        allocate (pestdb(0:imax))
        allocate (pestcp(0:imax))

        rewind (106)
        read (106,*,iostat=eof) titldum
        if (eof < 0) exit
        read (106,*,iostat=eof) header
        if (eof < 0) exit

        do ip = 1, imax
           read (106,*,iostat=eof) pestdb(ip)
           if (eof < 0) exit

          !! calculations: the first-order rate law for the decay of pesticides
          !! is dP/dt = -kP where P is the amount of pesticide,
          !! t is the time and k is the rate constant for degradation. To calculate
          !! the amount of pesticide at any time after application the equation
          !! P(t) = P_o*Exp(-kt) is used where P_o is the original amount of
          !! pesticide. k can be calculate with the equation k = 0.693/hlife.
          !! decay_f or decay_s = Exp(-k)
          if (pestdb(ip)%foliar_hlife > 0.) then
            pestcp(ip)%decay_f = Exp(-.693 / pestdb(ip)%foliar_hlife)
          else
            pestcp(ip)%decay_f = 0.
          endif
          if (pestdb(ip)%soil_hlife > 0.) then
            pestcp(ip)%decay_s = Exp(-.693 / pestdb(ip)%soil_hlife)
          else
            pestcp(ip)%decay_s = 0.
          endif

          if (pestdb(ip)%aq_hlife > 0.) then
            pestcp(ip)%decay_a = Exp(-.693 / pestdb(ip)%aq_hlife)
          else
            pestcp(ip)%decay_a = 0.
          endif
          if (pestdb(ip)%ben_hlife > 0.) then
            pestcp(ip)%decay_b = Exp(-.693 / pestdb(ip)%ben_hlife)
          else
            pestcp(ip)%decay_b = 0.
          endif

        end do
        exit
      enddo
      endif

      db_mx%pestparm = imax

      close (106)
      return
      end subroutine pest_parm_read


module turbine_lib_cpu
    use precision
    use dimen
    contains
    function get_interp_coeff_cpu(blade_ii,blade_jj,blade_kk)
        implicit none

        real(fp),intent(in) :: blade_ii,blade_jj,blade_kk
        real(fp),dimension(3) :: blade_point
        integer*4,dimension(3) :: blade_int
        integer*4 :: i,j,k,counter
        real(fp), dimension(3,2) :: l
        real(fp), dimension(8) :: get_interp_coeff_cpu

        blade_point = (/blade_ii,blade_jj,blade_kk/)
        ! Get the location in the cube
        do i = 1,3
            l(i,1) = 1._fp - (dble(blade_point(i)-int(blade_point(i))))
            l(i,2) = dble(blade_point(i)-int(blade_point(i)))
        end do
        ! Get the coefficient
        counter = 1
        do i = 1,2
            do j = 1,2
                do k = 1,2
                    get_interp_coeff_cpu(counter) = l(1,i)*l(2,j)*l(3,k)
                    counter = counter + 1
                end do
            end do
        end do

    end function get_interp_coeff_cpu

    function compute_vel_3D_cpu(u,blade_i,blade_j,blade_k,c)

        implicit none

        real(fp), dimension(nx,ny,nz2),intent(in)::u
        integer*4,intent(in) :: blade_i,blade_j,blade_k
        integer*4 :: i,j,k,counter
        real(fp),dimension(8),intent(in) :: c
        real(fp),dimension(8) :: u_stencil
        real(fp) :: compute_vel_3D_cpu
        ! To be rewritten using dot_product
        counter = 1
        do i = 0,1
            do j = 0,1
                do k = 0,1
                    u_stencil(counter) = u(blade_i+i,blade_j+j,blade_k+k)
                    counter = counter + 1
                end do
            end do
        end do

        compute_vel_3D_cpu=dot_product(u_stencil,c)

    end function compute_vel_3D_cpu

    ! compute_ang_cpu
function compute_ang_cpu(CTy,CTz)

    implicit none

    real*8 :: CTy,CTz,gau,compute_ang_cpu,RR

    RR = dsqrt(CTy**2+CTz**2)
    if (RR <= 1E-8) then
        compute_ang_cpu = 0._fp
    else
        gau = abs(CTz/dsqrt(CTy**2+CTz**2))
        if (CTz >= 0.0)then
            if(CTy >= 0.0) compute_ang_cpu = dasin(gau)
            if(CTy < 0.0) compute_ang_cpu = PI-abs(dasin(gau))
        else
            if(CTy < 0.0) compute_ang_cpu = PI+abs(dasin(gau))
            if(CTy >= 0.0) compute_ang_cpu = 2.0_fp*PI-dasin(gau)
        end if
    end if

end function compute_ang_cpu

! compute_vel_cpu
function compute_vel_cpu(u,i,blade_j,blade_k,c1,c2,c3,c4)

    implicit none

    real*8, dimension(nx,ny,nz2),intent(in)::u
    integer,intent(in) :: i,blade_j,blade_k
    real*8,intent(in) :: c1,c2,c3,c4
    real*8 :: compute_vel_cpu

    compute_vel_cpu=u(i,blade_j,blade_k)*c1+ &
        u(i,blade_j+1,blade_k)*c2+ &
        u(i,blade_j,blade_k+1)*c3+ &
        u(i,blade_j+1,blade_k+1)*c4

end function compute_vel_cpu
    end module


! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/33197
!
! Check for Fortran 2008's ATAN(Y,X) - which is equivalent
! to Fortran 77's ATAN2(Y,X).
!
real(4)    :: r4
real(8)    :: r8
complex(4) :: c4
complex(8) :: c8

r4 = atan2(r4,r4)
r8 = atan2(r8,r8)

r4 = atan(r4,r4) ! { dg-error "Too many arguments in call to 'atan'" }
r8 = atan(r8,r8) ! { dg-error "Too many arguments in call to 'atan'" }

r4 = atan2(r4,r8) ! { dg-error "same type and kind" }
r4 = atan2(r8,r4) ! { dg-error "same type and kind" }

r4 = atan2(c4,r8) ! { dg-error "must be REAL" }
r4 = atan2(c8,r4) ! { dg-error "must be REAL" }
r4 = atan2(r4,c8) ! { dg-error "same type and kind" }
r4 = atan2(r8,c4) ! { dg-error "same type and kind" }

r4 = atan2(c4,c8) ! { dg-error "must be REAL" }
r4 = atan2(c8,c4) ! { dg-error "must be REAL" }
end


INTEGER(kind = INT32), DIMENSION(0:12), PARAMETER                               :: const_factorial_INT32 = (/ &
                                                                                1_INT32, &
                                                                                1_INT32, &
                                                                                2_INT32, &
                                                                                6_INT32, &
                                                                                24_INT32, &
                                                                                120_INT32, &
                                                                                720_INT32, &
                                                                                5040_INT32, &
                                                                                40320_INT32, &
                                                                                362880_INT32, &
                                                                                3628800_INT32, &
                                                                                39916800_INT32, &
                                                                                479001600_INT32  &
                                                                                /)


	SUBROUTINE GCELIN ( xval, np, coeffs, xout, npout, yout, iret )
C************************************************************************
C* GCELIN								*
C*									*
C* This subroutine evalutes points on a piecewise linear curve.  The	*
C* coefficients to be used were found in GCFLIN.			*
C*									*
C* GCELIN ( XVAL, NP, COEFFS, XOUT, NPOUT, YOUT, IRET )			*
C*									*
C* Input parameters:							*
C*	XVAL (NP)	REAL		X input coordinates		*
C*	NP		INTEGER		Number of fitted points 	*
C*	COEFFS (2,NP)	REAL		Coefficients of line segments	*
C*	XOUT (NPOUT)	REAL		X coordinates to evaluate	*
C*	NPOUT		INTEGER		Number of points to evaluate	*
C*									*
C* Output parameters:							*
C*	YOUT (NPOUT)	REAL		Evaluated Y coordinates 	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	12/85						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		xval (*), coeffs (2,*), xout (*), yout (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Loop through all the points.
C
	DO  i = 1, npout
	    xx = xout (i)
C
C*		Do not evaluate if input is "missing".
C
	    IF ( ERMISS (xx)) THEN
		yout (i) = RMISSD
C
C*		Do not evaluate if input is out of bounds.
C
	      ELSE IF ( (xx .lt. xval (1) ) .or. (xx .gt. xval (np)))
     +          THEN
		yout (i) = RMISSD
C
C*		Check for input at first point.
C
	      ELSE IF ( xx .eq. xval (1) ) THEN
		yout (i) = coeffs (1,1) * xx + coeffs (2,1)
C
C*		Find the interval containing the point and use the
C*		coefficients to evaluate.
C
	      ELSE
		j = 2
		DO WHILE ( ( xx .gt. xval (j)) .and. ( j .le. np ) )
		    j = j + 1
		END DO
		j = j - 1
		yout (i) = coeffs (1,j) * xx + coeffs (2,j)
	    END IF
	END DO
C*
	RETURN
	END


      SUBROUTINE hpsel(m,n,arr,heap)
      INTEGER m,n
      REAL arr(n),heap(m)
CU    USES sort
      INTEGER i,j,k
      REAL swap
      if (m.gt.n/2.or.m.lt.1) pause 'probable misuse of hpsel'
      do 11 i=1,m
        heap(i)=arr(i)
11    continue
      call sort(m,heap)
      do 12 i=m+1,n
        if(arr(i).gt.heap(1))then
          heap(1)=arr(i)
          j=1
1         continue
            k=2*j
            if(k.gt.m)goto 2
            if(k.ne.m)then
              if(heap(k).gt.heap(k+1))k=k+1
            endif
            if(heap(j).le.heap(k))goto 2
            swap=heap(k)
            heap(k)=heap(j)
            heap(j)=swap
            j=k
          goto 1
2         continue
        endif
12    continue
      return
      end

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


! Modules for point in polgon tests

!  signa_[single,double]
!  pt_in_poly_[single,double]: point-in-polygon (tri/quad) test
!  pt_in_poly_ray_method_[single,double]: point-in-polygon test using ray tracing method (double prevision).
!====================================================================
  module pt_in_poly_test
   implicit none

   public

   contains

      function signa_single(x1,x2,x3,y1,y2,y3)
!...  Compute signed area formed by pts 1,2,3
      real :: signa_single,x1,x2,x3,y1,y2,y3

      signa_single=((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3))/2

      end function signa_single

      function signa_double(x1,x2,x3,y1,y2,y3)
!...  Compute signed area formed by pts 1,2,3
      real(kind=8) :: signa_double,x1,x2,x3,y1,y2,y3

      signa_double=((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3))/2

      end function signa_double

      subroutine pt_in_poly_single(i34,x,y,xp,yp,inside,arco,nodel)
!     (Single-precision) Routine to perform point-in-polygon
!     (triangle/quads) test and if it's inside, calculate the area coord.
!     (for quad, split it into 2 triangles and return the 3 nodes and
!     area coord.)
!     Inputs:
!            i34: 3 or 4 (type of elem)
!            x(i34),y(i34): coord. of polygon/elem. (counter-clockwise)
!            xp,yp: point to be tested
!     Outputs:
!            inside: 0, outside; 1, inside
!            arco(3), nodel(3) : area coord. and 3 local node indices (valid only if inside)
      implicit real(a-h,o-z), integer(i-n)
      integer, intent(in) :: i34
      real, intent(in) :: x(i34),y(i34),xp,yp
      integer, intent(out) :: inside,nodel(3)
      real, intent(out) :: arco(3)

      !Local
      integer :: list(3)
      real :: ar(2),swild(2,3)

      !Areas
      ar(1)=signa_single(x(1),x(2),x(3),y(1),y(2),y(3))
      ar(2)=0 !init
      if(i34==4) ar(2)=signa_single(x(1),x(3),x(4),y(1),y(3),y(4))
      if(ar(1)<=0.or.i34==4.and.ar(2)<=0) then
        print*, 'Negative area:',i34,ar,x,y
        stop
      endif

      zero=0; one=1
      inside=0
      do m=1,i34-2 !# of triangles
        if(m==1) then
          list(1:3)=(/1,2,3/) !local indices
        else !quads
          list(1:3)=(/1,3,4/)
        endif !m
        aa=0
        do j=1,3
          j1=j+1
          j2=j+2
          if(j1>3) j1=j1-3
          if(j2>3) j2=j2-3
          swild(m,j)=signa_single(x(list(j1)),x(list(j2)),xp,y(list(j1)),y(list(j2)),yp) !temporary storage
          aa=aa+abs(swild(m,j))
        enddo !j=1,3

        ae=abs(aa-ar(m))/ar(m)
        if(ae<=1.e-5) then
          inside=1
          nodel(1:3)=list(1:3)
          arco(1:3)=swild(m,1:3)/ar(m)
          arco(1)=max(zero,min(one,arco(1)))
          arco(2)=max(zero,min(one,arco(2)))
          if(arco(1)+arco(2)>1) then
            arco(3)=0
            arco(2)=1-arco(1)
          else
            arco(3)=1-arco(1)-arco(2)
          endif
          exit
        endif
      enddo !m

      end subroutine pt_in_poly_single

      subroutine pt_in_poly_double(i34,x,y,xp,yp,inside,arco,nodel)
!     (Double-precision) Routine to perform point-in-polygon
!     (triangle/quads) test and if it's inside, calculate the area coord.
!     (for quad, split it into 2 triangles and return the 3 nodes and
!     area coord.)
!     Inputs:
!            i34: 3 or 4 (type of elem)
!            x(i34),y(i34): coord. of polygon/elem. (counter-clockwise)
!            xp,yp: point to be tested
!     Outputs:
!            inside: 0, outside; 1, inside
!            arco(3), nodel(3) : area coord. and 3 local node indices (valid only if inside)
      implicit real*8(a-h,o-z), integer(i-n)
      integer, intent(in) :: i34
      real*8, intent(in) :: x(i34),y(i34),xp,yp
      integer, intent(out) :: inside,nodel(3)
      real*8, intent(out) :: arco(3)

      !Local
      integer :: list(3)
      real*8 :: ar(2),swild(2,3)

      !Areas
      ar(1)=signa_double(x(1),x(2),x(3),y(1),y(2),y(3))
      ar(2)=0 !init
      if(i34==4) ar(2)=signa_double(x(1),x(3),x(4),y(1),y(3),y(4))
      if(ar(1)<=0.or.i34==4.and.ar(2)<=0) then
        print*, 'Negative area:',i34,ar,x,y
        stop
      endif

      zero=0; one=1
      inside=0
      do m=1,i34-2 !# of triangles
        if(m==1) then
          list(1:3)=(/1,2,3/) !local indices
        else !quads
          list(1:3)=(/1,3,4/)
        endif !m
        aa=0
        do j=1,3
          j1=j+1
          j2=j+2
          if(j1>3) j1=j1-3
          if(j2>3) j2=j2-3
          swild(m,j)=signa_double(x(list(j1)),x(list(j2)),xp,y(list(j1)),y(list(j2)),yp) !temporary storage
          aa=aa+abs(swild(m,j))
        enddo !j=1,3

        ae=abs(aa-ar(m))/ar(m)
        if(ae<=1.e-5) then
          inside=1
          nodel(1:3)=list(1:3)
          arco(1:3)=swild(m,1:3)/ar(m)
          arco(1)=max(zero,min(one,arco(1)))
          arco(2)=max(zero,min(one,arco(2)))
          if(arco(1)+arco(2)>1) then
            arco(3)=0
            arco(2)=1-arco(1)
          else
            arco(3)=1-arco(1)-arco(2)
          endif
          exit
        endif
      enddo !m

      end subroutine pt_in_poly_double

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

!     Routines to perform point-in-polygon
!     test. Polygon may be multi-connected (and concave), and
!     the list of vertices can be either clock- or counter-clockwise.
!     The 1st vertex of each poly must be repeated, and 1 sub-polygon must
!     completely enclose all others, and sub-poly's do not cross each other.
!     Inputs:
!            nvertices: # of polygonal vertices. 1st vertex of each sub-poly
!            must be repeated.
!            small1,ray_angle: tolerance and search angle (see below)
!            xpoly(nvertices),ypoly(nvertices): list of vertices
!            xtest,ytest: test point
!     Outputs:
!            in_out: -1 if outside, 0 if on the polygon, 1 if inside
!            inters: # of intersections (no accurate if in_out=0). If
!            outside bounding box of poly, inters=-1.
!            npoly: # of sub-poly's found
!     Error: fort.11 (fatal)
!     Method: ray tracing method by testing each side of polygons and a
!     ray from the test point to infty along an angle. The point is
!     outside if the ray intersects polygonal sides even # of times,
!     inside if odd # of times. Check separately if on the side based
!     on a tolerance (small1).
!     Assume that the ray is not parallel to any side and also the
!     intersection does not coincide with any vertices if the test pt
!     is not one of them. If fatal error occurs, adjust
!     ray_angle or small1.

      subroutine pt_in_poly_ray_method_double(nvertices,small1,ray_angle,xpoly,ypoly,xtest,ytest,in_out,inters,npoly)
      implicit real*8(a-h,o-z), integer(i-n)
      integer, intent(in) :: nvertices
      real*8, intent(in) :: small1,ray_angle,xpoly(nvertices),ypoly(nvertices),xtest,ytest
      integer, intent(out) :: in_out,inters,npoly

      !Local
      real*8, parameter :: pi=3.1415926d0
      !real*8, parameter :: small1=1.e-5 !tolerance
      !real*8 :: ray_angle=3.13192 !degr - use a real number to enhance randomness
      integer :: list(3),firstv_poly(nvertices),endv_poly(nvertices)

      include 'pt_in_poly_ray_method.txt'

      end subroutine pt_in_poly_ray_method_double

      subroutine pt_in_poly_ray_method_single(nvertices,small1,ray_angle,xpoly,ypoly,xtest,ytest,in_out,inters,npoly)
      implicit real(a-h,o-z), integer(i-n)
      integer, intent(in) :: nvertices
      real, intent(in) :: small1,ray_angle,xpoly(nvertices),ypoly(nvertices),xtest,ytest
      integer, intent(out) :: in_out,inters,npoly

      !Local
      real, parameter :: pi=3.1415926
      !real, parameter :: small1=1.e-5 !tolerance
      !real :: ray_angle=3.13192 !degr - use a real number to enhance randomness
      integer :: list(3),firstv_poly(nvertices),endv_poly(nvertices)

      include 'pt_in_poly_ray_method.txt'

      end subroutine pt_in_poly_ray_method_single

!====================================================================
  end module pt_in_poly_test

!     Test driver
!     ifort -Bstatic -O2 -mcmodel=medium -o
!      program test_pt_in_poly
!      implicit real*8(a-h,o-z)
!      real*8, allocatable :: xpoly(:),ypoly(:)
!
!      !Use gredit/regions to generate a multi-connected poly
!      !Make sure to repeat 1st vertex of each sub-poly
!      open(12,file='multi.xy',status='old')
!      open(10,file='test_pts.bp',status='old')
!      read(12,*)nvertices
!      allocate(xpoly(nvertices),ypoly(nvertices))
!      do i=1,nvertices
!        read(12,*)xpoly(i),ypoly(i)
!      enddo !i
!      close(12)
!      read(10,*); read(10,*)npts
!      do i=1,npts
!        read(10,*)j,xtest,ytest
!
!        !Debug
!        write(98,*)'Test pt #',i
!
!        call pt_in_poly_ray_method(nvertices,xpoly,ypoly,xtest,ytest,in_out,inters)
!        print*, 'Point ',i,in_out,inters
!      enddo !i
!
!      !Test a pt on poly
!      xtest=0.53*xpoly(nvertices)+(1-0.53)*xpoly(nvertices-1)
!      ytest=0.53*ypoly(nvertices)+(1-0.53)*ypoly(nvertices-1)
!      call pt_in_poly_ray_method(nvertices,xpoly,ypoly,xtest,ytest,in_out,inters,npoly)
!      print*, 'Extra pt on poly:',in_out,inters
!
!      end program test_pt_in_poly


      SUBROUTINE slDC6S (V, A, B, R, AD, BD, RD)
*+
*     - - - - - -
*      D C 6 S
*     - - - - - -
*
*  Conversion of position & velocity in Cartesian coordinates
*  to spherical coordinates (double precision)
*
*  Given:
*     V      d(6)   Cartesian position & velocity vector
*
*  Returned:
*     A      d      longitude (radians)
*     B      d      latitude (radians)
*     R      d      radial coordinate
*     AD     d      longitude derivative (radians per unit time)
*     BD     d      latitude derivative (radians per unit time)
*     RD     d      radial derivative
*
*  P.T.Wallace   Starlink   28 April 1996
*
*  Copyright (C) 1996 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION V(6),A,B,R,AD,BD,RD

      DOUBLE PRECISION X,Y,Z,XD,YD,ZD,RXY2,RXY,R2,XYP

*  Components of position/velocity vector
      X=V(1)
      Y=V(2)
      Z=V(3)
      XD=V(4)
      YD=V(5)
      ZD=V(6)

*  Component of R in XY plane squared
      RXY2=X*X+Y*Y

*  Modulus squared
      R2=RXY2+Z*Z

*  Protection against null vector
      IF (R2.EQ.0D0) THEN
         X=XD
         Y=YD
         Z=ZD
         RXY2=X*X+Y*Y
         R2=RXY2+Z*Z
      END IF

*  Position and velocity in spherical coordinates
      RXY=SQRT(RXY2)
      XYP=X*XD+Y*YD
      IF (RXY2.NE.0D0) THEN
         A=ATAN2(Y,X)
         B=ATAN2(Z,RXY)
         AD=(X*YD-Y*XD)/RXY2
         BD=(ZD*RXY2-Z*XYP)/(R2*RXY)
      ELSE
         A=0D0
         IF (Z.NE.0D0) THEN
            B=ATAN2(Z,RXY)
         ELSE
            B=0D0
         END IF
         AD=0D0
         BD=0D0
      END IF
      R=SQRT(R2)
      IF (R.NE.0D0) THEN
         RD=(XYP+Z*ZD)/R
      ELSE
         RD=0D0
      END IF

      END


           program demo_sqrt
           use, intrinsic :: iso_fortran_env, only : real_kinds, &
           & real32, real64, real128
           implicit none
             real(kind=real64) :: x = 2.0_real64
             complex :: z = (1.0, 2.0)
             x = sqrt(x)
             z = sqrt(z)
           end program demo_sqrt


program ParabolicFloodWave

use NumberKindsModule
use LoggerModule
use PlanarSWEModule
use ParticlesModule
use FieldModule
use MPISetupModule
use PSEDirectSumModule
use SWEPlaneSolverModule

implicit none

include 'mpif.h'

!
!	computing environment
!
type(Logger) :: exeLog
character(len=MAX_STRING_LENGTH) :: logstring
character(len=15) :: logKey = "ParFlood"
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=MAX_STRING_LENGTH) :: namelistFilename
integer(kint) :: mpiErrCode
real(kreal) :: programStart, programEnd
integer(kint) :: i

!
!	mesh variables
!
type(SWEMesh) :: mesh
integer(kint) :: meshSeed
integer(kint) :: faceKind
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: amrLimit
real(kreal), parameter :: meshRadius = 6.0_kreal
real(kreal), parameter :: f0 = 0.0_kreal
real(kreal), parameter :: beta = 0.0_kreal
real(kreal), parameter :: g = 1.0_kreal
character(len=MAX_STRING_LENGTH) :: meshString

namelist /meshDefine/ faceKind, initNest, maxNest, amrLimit

!
!	problem variables
!
real(kreal) :: r0, h0, TT
real(kreal) :: vel(2)
namelist /parabolicFlood/ r0, h0

!
!	timestepping
!
type(SWESolver) :: timekeeper
real(kreal) :: dt
real(kreal) :: tfinal
real(kreal) :: t
integer(kint) :: timeJ, nTimesteps
type(PSE) :: pseSetup

namelist /timestepping/ dt, tfinal

!
!	I/O variables
!
character(len=MAX_STRING_LENGTH) :: outputDir, outputRoot, vtkFile, matlabFile, vtkRoot
integer(kint) :: frameOut, frameCounter
namelist /fileIO/ outputDir, outputRoot, frameOut

!--------------------------------
!	initialize : setup computing environment
!--------------------------------
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numProcs, mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD, procRank, mpiErrCode)
programStart = MPI_WTIME()

call InitLogger(exeLog, procRank)

call ReadNamelistFile(procRank)

!--------------------------------
!	initialize : setup problem / build mesh
!--------------------------------

call New(mesh, meshSeed, initNest, maxNest, amrLimit, meshRadius, f0, beta, g)
call SetInitialVorticityOnMesh( mesh, initVorticity )
call SetInitialDivergenceOnMesh( mesh, initDivergence)
call SetInitialVelocityOnMesh(mesh, initVelocity )
call SetInitialHOnMesh( mesh, initH )
call SetBottomHeightOnMesh( mesh, bottomTopo)
call SetInitialPotVortOnMesh( mesh )

call New(timekeeper, mesh, bottomTopo)
nTimesteps = floor(tfinal/dt)
t = 0.0_kreal
frameCounter = 1
call New(pseSetup, mesh%mesh)

call AddTracers(mesh, 3, [2,1,1])
mesh%tracers(1)%name = "exactVelocity"
mesh%tracers(1)%units = "m/s"
mesh%tracers(2)%name = "exactH"
mesh%tracers(2)%units = "m"
mesh%tracers(3)%name = "exactDivergence"
mesh%tracers(3)%units = "1/s"

TT = r0 / sqrt(2.0_kreal * g * h0 )

do i = 1, mesh%mesh%particles%N
	call InsertVectorToField(mesh%tracers(1), exactVelocity(mesh%mesh%particles%x(i), mesh%mesh%particles%y(i),t, TT ) )
	call InsertScalarToField(mesh%tracers(2), exactH(mesh%mesh%particles%x(i), mesh%mesh%particles%y(i),t, TT ) )
	call InsertScalarToField(mesh%tracers(3), exactDivergence(mesh%mesh%particles%x(i), mesh%mesh%particles%y(i),t, TT ) )
enddo

if ( procRank == 0 ) then
	call LogStats(mesh, exeLog)

	if ( meshSeed == TRI_HEX_SEED ) then
		write(meshString, '(A,I1,A)') '_triHex', initNest, '_'
	elseif ( meshSeed == QUAD_RECT_SEED ) then
		write(meshString, '(A,I1,A)') '_quadRect', initNest, '_'
	endif

	write(vtkRoot,'(4A)') trim(outputDir), '/vtkOut/', trim(outputRoot), trim(meshString)
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), 0, '.vtk'

	call OutputToVTKFile(mesh, vtkFile)
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logkey)//" t = ", t)
endif

!--------------------------------
!	run : evolve the problem in time (currently no remeshing)
!--------------------------------
do timeJ = 0, nTimesteps - 1

	call Timestep( timekeeper, mesh, dt, bottomTopo)

	t = real(timeJ+1,kreal) * dt
	mesh%mesh%t = t

	do i = 1, mesh%mesh%particles%N
		vel = exactVelocity(mesh%mesh%particles%x(i), mesh%mesh%particles%y(i), t, TT)
		mesh%tracers(1)%xComp(i) = vel(1)
		mesh%tracers(1)%yComp(i) = vel(2)
		mesh%tracers(2)%scalar(i) = exactH(mesh%mesh%particles%x(i), mesh%mesh%particles%y(i), t, TT)
		mesh%tracers(3)%scalar(i) = exactDivergence(mesh%mesh%particles%x(i), mesh%mesh%particles%y(i), t, TT)
	enddo

	if ( procRank == 0 .AND. mod(timeJ+1, frameOut) == 0 ) then
		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'

		call OutputToVTKFile( mesh, vtkFile )

		frameCounter = frameCounter + 1
		call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logkey)//" t = ", t)
	endif
enddo

!--------------------------------
!	finalize : clean up
!--------------------------------

programEnd = MPI_WTIME()
write(logString,'(A,F4.1,A)') "at t = ", tfinal, ","
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logString)//" max relVort err = ", maxval(abs(mesh%relVort%scalar)))
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logString)//" max h err = ", &
	maxval(abs(mesh%h%scalar - mesh%tracers(2)%scalar))/maxval(abs(mesh%tracers(2)%scalar)))
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logString)//" max div err = ",&
	 maxval(abs(mesh%divergence%scalar - mesh%tracers(3)%scalar))/maxval(abs(mesh%tracers(3)%scalar)))

write(logstring,'(A,F12.2,A)') "PROGRAM COMPLETE : elapsed time ", programEnd - programStart, " seconds."
call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logkey)//" ", logString)

call Delete(pseSetup)
call Delete(timekeeper)
call Delete(mesh)

call MPI_FINALIZE(mpiErrCode)

contains

function initDivergence( x, y )
	real(kreal) :: initDivergence
	real(kreal), intent(in) :: x, y
	initDivergence = 0.0_kreal
end function

function initVorticity( x, y )
	real(kreal) :: initVorticity
	real(kreal), intent(in) :: x, y
	initVorticity = 0.0_kreal
end function

function initVelocity(x, y)
	real(kreal) :: initVelocity(2)
	real(kreal), intent(in) :: x, y
	initVelocity = 0.0_kreal
end function

function initH(x, y)
	real(kreal) :: initH
	real(kreal), intent(in) :: x, y
	initH = max(h0 * ( 1.0_kreal - (x * x + y * y)/r0/r0), 0.0_kreal)
end function

subroutine InitLogger(log, rank)
	type(Logger), intent(inout) :: log
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(log, logLevel)
	else
		call New(log, ERROR_LOGGING_LEVEL)
	endif
	write(logKey,'(A,I0.2,A)') trim(logKey)//"_", rank, ":"
end subroutine

function bottomTopo(x,y)
	real(kreal) :: bottomTopo
	real(kreal), intent(in) :: x, y
	bottomTopo = 0.0_kreal
end function

function DepthLaplacian( x, y )
	real(kreal) :: DepthLaplacian
	real(kreal), intent(in) :: x, y
	DepthLaplacian = 0.0_kreal
end function

function exactVelocity( x, y, t, TT)
	real(kreal) :: exactVelocity(2)
	real(kreal), intent(in) :: x, y, t, TT
	exactVelocity(1) = x * t / ( t*t + TT*TT )
	exactVelocity(2) = y * t / ( t*t + TT*TT )
end function

function exactDivergence(x, y, t, TT)
	real(kreal) :: exactDivergence
	real(kreal), intent(in) :: x, y, t, TT
	exactDivergence = 2.0_kreal * t / ( t*t + TT*TT)
end function

function exactH(x, y, t, TT)
	real(kreal) :: exactH
	real(kreal), intent(in) :: x, y, t, TT
	exactH = max( h0 * ( TT*TT / ( t*t + TT*TT ) - (x*x + y*y) * TT**4 / ((t*t + TT*TT)**2)/r0/r0 ), 0.0_kreal)
end function

subroutine ReadNamelistFile(rank)
	integer(kint), intent(in) :: rank
	!
	integer(kint), parameter :: initBCAST_intSize = 5
	integer(kint), parameter :: initBCAST_realSize = 4
	integer(kint) :: readStat
	integer(kint) :: bcastIntegers(initBCAST_intSize)
	real(kreal) :: bcastReals(initBCAST_realSize)
	integer(kint) :: mpiErrCode

	if ( COMMAND_ARGUMENT_COUNT() /= 1 ) then
		call LogMessage(exeLog,ERROR_LOGGING_LEVEL, trim(logKey), " expected namelist file name as 1st argument.")
		stop
	endif

	if ( rank == 0 ) then
		call GET_COMMAND_ARGUMENT(1, namelistFilename)

		open( unit=READ_UNIT, file=namelistFilename, status='OLD', action='READ', iostat=readStat)
			if (readStat /= 0 ) then
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " cannot read namelist file.")
				stop
			endif
			read(READ_UNIT, nml=meshDefine)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=parabolicFlood)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=fileIO)
			! namelist /meshDefine/ faceKind, initNest, maxNest, amrLimit

			if ( faceKind == 3 ) then
				meshSeed = TRI_HEX_SEED
			elseif ( faceKind == 4 ) then
				meshSeed = QUAD_RECT_SEED
			else
				call LogMessage(exeLog, WARNING_LOGGING_LEVEL, trim(logKey)//" ReadNamelistFile WARNING :", &
					" invalid faceKind -- using triangles.")
				meshSeed = TRI_HEX_SEED
			endif

			if (amrLimit == 0) maxNest = initNest

			bcastIntegers(1) = meshSeed
			bcastIntegers(2) = initNest
			bcastIntegers(3) = maxNest
			bcastIntegers(4) = amrLimit
			bcastIntegers(5) = frameOut

			bcastReals(1) = dt
			bcastReals(2) = tfinal
			bcastReals(3) = r0
			bcastReals(4) = h0
		close(READ_UNIT)
	endif

	call MPI_BCAST(bcastIntegers, initBCAST_intSize, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)

	call MPI_BCAST(bcastReals, initBCAST_realSize, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, mpiErrCode)

	meshSeed = bcastIntegers(1)
	initNest = bcastIntegers(2)
	maxNest = bcastIntegers(3)
	amrLimit = bcastIntegers(4)
	frameOut = bcastIntegers(5)

	dt = bcastReals(1)
	tfinal = bcastReals(2)
	r0 = bcastReals(3)
	h0 = bcastReals(4)
end subroutine
end program


C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.

      subroutine MODEL_HV( NRHS, NZ, NY, NU, NP, T, Z, ZDOT, Y, U,
     1     P, LAM, RHS, RES, LDRS)
C
C     Model of Roscoe's Tank
C     Andreas Waechter  08-25-01  Fortran model version
C
      implicit none

      integer NRHS, NZ, NY, NU, NP
      double precision T        ! Time
      double precision Z(NZ)    ! Differential variables
      double precision ZDOT(NZ) ! Derivatives of differential variables
      double precision Y(NY)    ! Algebraic variables
      double precision U(NU)    ! Control Variables
      double precision P(NP)    ! Parameters
      double precision LAM(NZ+NY) ! weights for individual Hessians
      integer LDRS              ! leading dimension of RHS, RES
      double precision RHS(LDRS, NRHS) ! vectors to be multiplied
      double precision RES(LDRS, NRHS) ! result
C
C     names for variables
C
      double precision h, hdot, hbar, pres, p_atm, F0, F1, rho, g
      double precision Area, CV

      integer l_z, l_y, l_u, l_p, l_ae, l_de
      integer l_h, l_hdot, l_F1, l_pres, l_hbar, l_CV

      integer j

C =============================================================================
C
C                           Constants in model
C
C =============================================================================

      include 'TANK_CONSTS.INC'

C =============================================================================
C
C                      Initialize Product Result to Zero
C
C =============================================================================

      do j = 1, NRHS
         call DCOPY(2*NZ+NY+NU+NP, 0.d0, 0, RES(1,j), 1)
      enddo

C =============================================================================
C
C                  Copy Z, Y, U, P into variables with names
C
C =============================================================================

C
C     Initialize counters for variables
C
      l_z  = 0
      l_y  = 0
      l_p  = 0
      l_u  = 0
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                           Differential Variables
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      l_ z   = l_z + 1
      h      = Z   (l_z)
      l_h    = l_z
      hdot   = ZDOT(l_z)
      l_hdot = NZ+l_z
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                            Algebraic Variables
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      l_y    = l_y + 1
      F1     = Y(l_y)
      l_F1   = 2*NZ+l_y
C
      l_y    = l_y + 1
      pres   = Y(l_y) * 0.1d6
      l_pres = 2*NZ+l_y
C
      l_y    = l_y + 1
      hbar   = Y(l_y)
      l_hbar = 2*NZ+l_y
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                             Control Variables
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      l_u    = l_u + 1
      CV     = U(l_u)
      l_CV   = 2*NZ+NY+l_u
C
C =============================================================================
C
C                                  M O D E L
C
C =============================================================================
C

C
C     Loop over all RHS
C

      do j = 1, NRHS
C
C     Initialize counters for equations
C
         l_de = 0
         l_ae = NZ
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                            Differential Equations
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
         l_de     = l_de + 1
C         F(l_de)  = (F0-F1)/Area - hdot
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C                             Algebraic Equations
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
         l_ae     = l_ae + 1
C         F(l_ae)  = F1**2 - (CV**2)*(pres-p_atm)
         RES(l_F1  ,j) = RES(l_F1  ,j) +
     1        LAM(l_ae)*( 2.d0             )*RHS(l_F1  ,j)
         RES(l_CV  ,j) = RES(l_CV  ,j) +
     1        LAM(l_ae)*(-2.d0*(pres-p_atm))*RHS(l_CV  ,j)
         RES(l_CV  ,j) = RES(l_CV  ,j) +
     1        LAM(l_ae)*(-2.d0*CV          )*RHS(l_pres,j) * 0.1d6
         RES(l_pres,j) = RES(l_pres,j) +
     1        LAM(l_ae)*(-2.d0*CV          )*RHS(l_CV  ,j) * 0.1d6
C
         l_ae     = l_ae + 1
C         F(l_ae)  = pres - p_atm - rho*g*h
C
         l_ae     = l_ae + 1
C         F(l_ae)  = h - hbar

C
C     End Loop
C
      enddo
C
      return
      end