!*==zscal.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b ZSCAL
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZSCAL(N,ZA,ZX,INCX)
!
!       .. Scalar Arguments ..
!       COMPLEX*16 ZA
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       COMPLEX*16 ZX(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    ZSCAL scales a vector by a constant.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] ZA
!> \verbatim
!>          ZA is COMPLEX*16
!>           On entry, ZA specifies the scalar alpha.
!> \endverbatim
!>
!> \param[in,out] ZX
!> \verbatim
!>          ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of ZX
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup complex16_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, 3/11/78.
!>     modified 3/93 to return if incx .le. 0.
!>     modified 12/3/93, array(1) declarations changed to array(*)
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZSCAL(N,Za,Zx,Incx)
      IMPLICIT NONE
!*--ZSCAL82
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      COMPLEX*16 Za
      INTEGER Incx , N
!     ..
!     .. Array Arguments ..
      COMPLEX*16 Zx(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , nincx
!     ..
      IF ( N<=0 .OR. Incx<=0 ) RETURN
      IF ( Incx==1 ) THEN
!
!        code for increment equal to 1
!
         DO i = 1 , N
            Zx(i) = Za*Zx(i)
         ENDDO
      ELSE
!
!        code for increment not equal to 1
!
         nincx = N*Incx
         DO i = 1 , nincx , Incx
            Zx(i) = Za*Zx(i)
         ENDDO
      ENDIF
      END SUBROUTINE ZSCAL


SUBROUTINE caldatw(dd,mm,yyyy)
!
IMPLICIT NONE
!
INCLUDE 'm1sim.inc'
!
! PARAMETER definitions
!
INTEGER,PARAMETER :: igreg = 2299161
!
! Subroutine arguments
!
INTEGER :: dd,mm,yyyy
!
! Local variables
!
REAL :: alpha,c,e
REAL*8 :: dble
INTEGER :: int
INTEGER :: ja,jalpha,jb,jc,jd,je,julian
!
!     + + + purpose + + +
!     inverse of the function julday. here 'julian' is input as a julian day
!     number, and the routine outputs the dd, mm, and yyyy on which the
!     specified julian day started at noon.
!
!     + + + keywords + + +
!     date, utility
!
!     + + + argument declarations + + +

!
!     + + + argument definitions + + +
!     mm     - integer value of mm in the range 1-12
!     dd     -                  dd in the range 1-31
!     yyyy   -                  yyyy (negative a.d., positive b.c.)
!     julian - integer value equal to julian day number
!
!     + + + parameters + + +
!     gregorian calendar was adopted on oct. 15, 1582.
!
!     + + + local variables + + +
!     alpha -
!     c -
!     dble -
!     e -
!     int -
!     ja -
!     jalpha -
!     jb -

!     + + + local parameters + + +
!     igreg -
!
!
!     + + + end specifications + + +
!
!     use simulation date
julian = am0jd

IF (julian.GE.igreg) THEN
  alpha = (dble(julian-1867216)-dble(0.25))/dble(36524.25)
  jalpha = int(alpha)
  ja = julian + 1 + jalpha - int(dble(0.25)*jalpha)
ELSE
  ja = julian
END IF
jb = ja + 1524
c = dble(6680.0) + ((jb-2439870)-dble(122.1))/dble(365.25)
jc = int(c)
jd = 365*jc + int(dble(0.25)*jc)
e = (jb-jd)/dble(30.6001)
je = int(e)
dd = jb - jd - int(dble(30.6001)*je)
mm = je - 1
IF (mm.GT.12) mm = mm - 12
yyyy = jc - 4715
IF (mm.GT.2) yyyy = yyyy - 1
IF (yyyy.LE.0) yyyy = yyyy - 1
!
END SUBROUTINE caldatw

Project Documents/Source Code Original/Caldatw.f90


program where_01
implicit none
real :: a(10), b(10)
where (a >= 0)
    b = 1
else where
    b = 0
end where

where (a >= 0)
    b = 1
elsewhere
    b = 0
end where

where (a >= 0)
    b = 1
elsewhere
    b = 0
endwhere
end program


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief Module defines the exponent table type objects and methods.
!>
!> For characteristics solvers that have to evaluate an exponential
!> (e.g. EXP()) a lot, it is often more computationally efficient to tabulate
!> evaluations of the exponential function and then to query the tables when
!> evaluating the exponential. This is because the table can often fit in L1
!> cache and because the EXP() function can take up to ~100 more FLOPS to
!> evaluate than multiply or add operation.
!>
!> The object is initialized with a parameter list. For valid reference lists
!> see @ref ExpTables::ExpTables_Declare_ValidParams
!> "ExpTables_Declare_ValidParams".
!>
!> This module is largely based on the following paper:
!>
!> A. Yamamoto, et al., "Computational efficiencies of approximated functions
!> for transport calculations of the characteristics method", Annals of Nucl.
!> Energy, @b 31, pp. 1027-1037, (2004).
!>
!> The module provides a Fortran 2003 derived type that represents the
!> exponential table. The types of tables available are:
!>  - @c EXACT_EXP_TABLE no approximation same as evaluating EXP()
!>  - @c SINGLE_LEVEL_TABLE table has no interpolation and only one level
!>  - @c TWO_LEVEL_EXP_TABLE table has no interpolation and uses two levels
!>       based on the identity exp(x)*exp(y) = exp(x+y)
!>  - @c LINEAR_EXP_TABLE table linear interpolates exp(x) as m*x+b
!>  - @c ORDER2_EXP_TABLE is table does second order interpolation of exp(x)
!>  - @c POLAR_EXP_TABLE table linear interpolates exp(x) as m*x+b
!>       for each polar angle
!>
!> The tables are generally set up for the interval x=[-10,0] and can be
!> specified for a given number of points in the table or a desired
!> accuracy for the table.
!>
!> According to the above paper the @c TWO_LEVEL_EXP_TABLE and
!> @c LINEAR_EXP_TABLE should perform favorably. This module is tested by
!> @c testExpTables.f90 which also measures performance if TAU/PAPI are
!> available on the test machine.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE ExpTables

USE IntrType
USE ExceptionHandler
USE Allocs
USE ParameterLists

IMPLICIT NONE
PRIVATE

!List of public members
PUBLIC :: EXACT_EXP_TABLE
PUBLIC :: SINGLE_LEVEL_EXP_TABLE
PUBLIC :: TWO_LEVEL_EXP_TABLE
PUBLIC :: LINEAR_EXP_TABLE
PUBLIC :: ORDER2_EXP_TABLE
PUBLIC :: POLAR_EXP_TABLE
PUBLIC :: ExpTableType
PUBLIC :: eExpTable
PUBLIC :: exptTbl
PUBLIC :: EXPT
PUBLIC :: ExpTableType_reqParams,ExpTableType_optParams
PUBLIC :: ExpTables_Declare_ValidParams
PUBLIC :: ExpTables_Clear_ValidParams

!Enumerations for the different table types

!> Value indicating an exact exponential table
INTEGER(SIK),PARAMETER :: EXACT_EXP_TABLE=1
!> Value indicating a single level exponential table
INTEGER(SIK),PARAMETER :: SINGLE_LEVEL_EXP_TABLE=2
!> Value indicating a two level exponential table
INTEGER(SIK),PARAMETER :: TWO_LEVEL_EXP_TABLE=3
!> Value indicating an exponential table with linear approximation
INTEGER(SIK),PARAMETER :: LINEAR_EXP_TABLE=4
!> Value indicating an exponential table with quadratic approximation
INTEGER(SIK),PARAMETER :: ORDER2_EXP_TABLE=5
!> Value indicating an exponential table with polar angle dependence and
!> linear approximation
INTEGER(SIK),PARAMETER :: POLAR_EXP_TABLE=6

!> @brief An exponential table type object
!>
!> It is table that has evaluations of EXP(x) at specific points
!> that can be queried or evaluated in kind to obtain an approximation
!> to EXP(x) in significantly less time.
TYPE :: ExpTableType
  !> Logical indicating initialization status
  LOGICAL(SBK) :: isinit=.FALSE.
  !> The type of exponential table
  INTEGER(SIK) :: tableType=-1
  !> The number of intervals in the table
  INTEGER(SIK) :: nintervals=-1
  !> The lower bound of the table index for x
  INTEGER(SIK) :: minTable=0
  !> The value between two entries in the table (delta x)
  REAL(SRK) :: dx=0._SRK
  !> The reciprocal of dx
  REAL(SRK) :: rdx=0._SRK
  !> The square of dx
  REAL(SRK) :: dx2rd=0._SRK
  !> The square of rdx
  REAL(SRK) :: rdx2rd=0._SRK
  !> The minimum value of the table
  REAL(SRK) :: minVal=0.0_SRK
  !> The maximum value of the table
  REAL(SRK) :: maxVal=0.0_SRK
  !> An upper bound estimate of the error of the table
  REAL(SRK) :: tableErr=0._SRK
  !> The first column of the table
  REAL(SRK),ALLOCATABLE :: table(:)
  !> The second column of the table (sometimes used)
  REAL(SRK),ALLOCATABLE :: table2rd(:)
  !> The third column of the table (sometimes used)
  REAL(SRK),ALLOCATABLE :: table3rd(:)
  !> Two dimensional table for better cache coherency
  REAL(SRK),ALLOCATABLE :: table2D(:,:)
  !> Three dimensional table storing the slope and intercept
  !> dimension([1(slope),2(intercept)],nx,npol)
  REAL(SRK),ALLOCATABLE :: table3D(:,:,:)
!
!List of type bound prodedures
  CONTAINS
    !> @copybrief ExpTables::init_ExpTable
    !> @copydetails ExpTables::init_ExpTable
    PROCEDURE,PASS :: initialize => init_ExpTable
    !> @copybrief ExpTables::EXPT
    !> @copydetails ExpTables::EXPT
    PROCEDURE,PASS :: EXPT
    !> @copybrief ExpTables::clear_ExpTable
    !> @copydetails ExpTables::clear_ExpTable
    PROCEDURE,PASS :: clear => clear_ExpTable
ENDTYPE ExpTableType

!> Module name
CHARACTER(LEN=*),PARAMETER :: modName='EXPTABLES'

!> Exponent table object used outside of this modular
TYPE(ExpTableType),SAVE,TARGET :: exptTbl

!> Exception handler for the module
TYPE(ExceptionHandlerType),SAVE :: eExpTable

!> Logical indicates whether or not the parameter lists for validation
!> have been initialized (only needs to be done once per execution)
LOGICAL(SBK),SAVE :: ExpTableType_Paramsflag=.FALSE.

!> The parameter lists to use when validating a parameter list for
!> initialization;
TYPE(ParamType),PROTECTED,SAVE :: ExpTableType_reqParams,ExpTableType_optParams
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Exponential function
!> @param myET Exponential table type object
!> @param x The variable
!> @param ans The return value
!>
ELEMENTAL FUNCTION EXPT(myET,x,ipol) RESULT(ans)
  CLASS(ExpTableType),INTENT(IN) :: myET
  REAL(SRK),INTENT(IN) :: x
  INTEGER(SIK),INTENT(IN),OPTIONAL :: ipol
  REAL(SRK) :: ans

  IF(myET%minVal <= x .AND. x <= myET%maxVal) THEN
    SELECTCASE(myET%tableType)
    CASE (SINGLE_LEVEL_EXP_TABLE)
      ans=EXPT_Single(myET,x)
    CASE (TWO_LEVEL_EXP_TABLE)
      ans=EXPT_TwoLevel(myET,x)
    CASE (LINEAR_EXP_TABLE)
      ans=EXPT_Linear(myET,x)
    CASE (ORDER2_EXP_TABLE)
      ans=EXPT_TwoOrder(myET,x)
    CASE (POLAR_EXP_TABLE)
      IF(PRESENT(ipol)) THEN
        ans=EXPT_Polar(myET,x,ipol)
      ELSE
!               CALL eExpTable%raiseError(modName//'::'//myName// &
!                 ' - Polar angle index is not passed in to look'// &
!                   ' up the polar angle dependent exponent table!')
      ENDIF
    CASE DEFAULT
      ans=1._SRK-EXP(x)
    ENDSELECT
  ELSE
    IF(x<-700._SRK) THEN
      ans=1._SRK
    ELSE
      ans=1._SRK-EXP(x)
    ENDIF
  ENDIF
ENDFUNCTION
!
!-------------------------------------------------------------------------------
!> @brief Clears a exponent table type object
!> @param myET Exponential table type object
!>
SUBROUTINE clear_ExpTable(myET)
  CLASS(ExpTableType),INTENT(INOUT) :: myET
  IF(ALLOCATED(myET%table)) CALL demallocA(myET%table)
  IF(ALLOCATED(myET%table2rd)) CALL demallocA(myET%table2rd)
  IF(ALLOCATED(myET%table3rd)) CALL demallocA(myET%table3rd)
  IF(ALLOCATED(myET%table2D)) CALL demallocA(myET%table2D)
  IF(ALLOCATED(myET%table3D)) CALL demallocA(myET%table3D)
  myET%tableType=-1
  myET%nintervals=-1
  myET%minTable=0
  myET%dx=0._SRK
  myET%rdx=0._SRK
  myET%dx2rd=0._SRK
  myET%rdx2rd=0._SRK
  myET%minVal=0._SRK
  myET%maxVal=0._SRK
  myET%tableErr=0._SRK
  myET%isinit=.FALSE.
  IF(ExpTableType_Paramsflag) CALL ExpTables_Clear_ValidParams()
ENDSUBROUTINE clear_ExpTable
!
!-------------------------------------------------------------------------------
!> @brief Initialization method for ExpTableType object
!> @param myET Exponential table type object
!> @param Params The parameter list used to initialize the ExpTable object.
!>
!> @page ParamList Description of Parameter List
!> @param reqParamsExpTables This parameter list is null.
!> @param ExpTableType_optParams
!>   - <TT><'ExpTables -> tabletype'></TT> - Takes an integer as an input. The
!>   integer is an enumeration specifying which table will be generated.  The
!>   options are: EXACT_EXP_TABLE, SINGLE_LEVEL_EXP_TABLE, TWO_LEVEL_EXP_TABLE,
!>   LINEAR_EXP_TABLE, ORDER2_EXP_TABLE, and POLAR_EXP_TABLE.
!>   The default value is LINEAR_EXP_TABLE.
!>   - <TT><'ExpTables -> minval'></TT> -
!>   - <TT><'ExpTables -> maxval'></TT> -
!>   - <TT><'ExpTables -> nintervals'></TT> -
!>   - <TT><'ExpTables -> error'></TT> -
!>   - <TT><'ExpTables -> errorflag'></TT> -
!>
SUBROUTINE init_ExpTable(myET,Params)
  CHARACTER(LEN=*),PARAMETER :: myName="init_ExpTable"
  CLASS(ExpTableType),INTENT(INOUT) :: myET
  TYPE(ParamType),OPTIONAL,INTENT(IN) :: Params

  LOGICAL(SBK) :: ErrFlag
  INTEGER(SIK) :: nerror,i,tableType,nintervals
  REAL(SRK) :: x,x2rd,tableErr,x1,x2,x3,y1,y2,y3,rdx2
  REAL(SRK) :: minVal,maxVal
  INTEGER(SIK) :: minTable,maxTable
  TYPE(ParamType) :: tmpList
  INTEGER(SIK) :: ipol,npol
  REAL(SRK),ALLOCATABLE :: rsinpol(:),y1p(:),y2p(:)

  !Initialize reference parameter lists
  IF(.NOT.ExpTableType_Paramsflag) CALL ExpTables_Declare_ValidParams()

  !Input checking
  nerror=eExpTable%getcounter(EXCEPTION_ERROR)
  IF(myET%isinit) THEN
    CALL eExpTable%raiseError(modName//'::'//myName// &
        ' - Exponent table is already initialized!')
  ELSE
    IF(PRESENT(Params)) tmpList=Params
    CALL tmpList%validate(ExpTableType_reqParams,ExpTableType_optParams)
    !
    !Default value for table type
    CALL tmpList%get('ExpTables -> tabletype',tableType)
    !tableType = POLAR_EXP_TABLE
    IF(tableType > 6 .OR. tableType < 1) THEN
      CALL eExpTable%raiseDebug(modName//'::'//myName// &
          ' - Exponent table type is not correct input!'// &
          ' Using default table type!')
      !Get Default param
      CALL ExpTableType_optParams%get('ExpTables -> tabletype',tableType)
    ENDIF

    IF(tableType == POLAR_EXP_TABLE) THEN
      IF(.NOT.tmpList%has('ExpTables -> RSIN_polars')) &
          CALL eExpTable%raiseError(modName//'::'//myName// &
          ' - POLAR_EXP_TABLE type requires 1/sin(polar_angle) on input!')
    ENDIF

    !Default value for minVal and maxVal
    minVal=0.0_SRK
    maxVal=0.0_SRK
    CALL tmpList%get('ExpTables -> minval',minVal)
    CALL tmpList%get('ExpTables -> maxval',maxVal)
    IF(minVal >= 0._SRK) THEN
      CALL eExpTable%raiseDebug(modName//'::'//myName// &
          ' - Minimum value of the range of the table is not negative!'// &
          ' Using default table type!')
      !Get Default param
      CALL ExpTableType_optParams%get('ExpTables -> minval',minVal)
    ENDIF
    IF(maxVal > 0._SRK) THEN
      CALL eExpTable%raiseDebug(modName//'::'//myName// &
          ' - Maximum value of the range of the table is positive!'// &
          ' Using default table type!')
      !Get Default param
      CALL ExpTableType_optParams%get('ExpTables -> maxval',maxVal)
    ENDIF
    IF(maxVal == minVal) &
        CALL eExpTable%raiseError(modName//'::'//myName// &
        ' - Maximum value of the range of the table!'// &
        ' is equal to the minimum value!')
    !Default value for ninterval
    CALL tmpList%get('ExpTables -> nintervals',nintervals)
    IF(nintervals <= 1) THEN
      CALL eExpTable%raiseDebug(modName//'::'//myName// &
          ' - Number of intervals is less than or equal to 1!'// &
          ' Using default value!')
      !Get Default param
      CALL ExpTableType_optParams%get('ExpTables -> nintervals',nintervals)
    ENDIF
    !Check the ErrFlag to see if we need to recalculate nintervals
    CALL tmpList%get('ExpTables -> errorflag',ErrFlag)
    !Overwrite nintervals using the error
    IF(ErrFlag) THEN
      !Get the error to recalculate the nintervals
      CALL tmpList%get('ExpTables -> error',tableErr)
      CALL eExpTable%raiseDebug(modName//'::'//myName// &
          ' - Number of intervals is overwritten by the value that'// &
          ' is determined from desired error!')
      SELECTCASE(tableType)
      CASE (EXACT_EXP_TABLE)
        !Do nothing!
      CASE (SINGLE_LEVEL_EXP_TABLE)
        nintervals=NINT(ABS(0.5_SRK/tableErr))
      CASE (TWO_LEVEL_EXP_TABLE)
        nintervals=NINT(SQRT(ABS(0.5_SRK/tableErr)))
      CASE (LINEAR_EXP_TABLE,POLAR_EXP_TABLE)
        nintervals=NINT(SQRT(ABS(0.125_SRK/tableErr)))
      CASE (ORDER2_EXP_TABLE)
        nintervals=NINT(ABS(9.630017699314371e-3_SRK/tableErr)**0.3333333333333333_SRK)
      CASE DEFAULT
        CALL eExpTable%raiseError(modName//'::'//myName// &
            ' - Exponent table type is incorrect!')
      ENDSELECT
    !Ignore the user error and keep the input nintervals
    ELSE
      SELECTCASE(tableType)
      CASE (EXACT_EXP_TABLE)
        tableErr=0._SRK
      CASE (SINGLE_LEVEL_EXP_TABLE)
        tableErr=0.5_SRK/nintervals
      CASE (TWO_LEVEL_EXP_TABLE)
        tableErr=0.5_SRK/(nintervals*nintervals)
      CASE (LINEAR_EXP_TABLE,POLAR_EXP_TABLE)
        tableErr=0.125_SRK/(nintervals*nintervals)
      CASE (ORDER2_EXP_TABLE)
        tableErr=9.630017699314371e-3_SRK/(nintervals*nintervals*nintervals)
      CASE DEFAULT
        tableErr=0._SRK
      ENDSELECT
    ENDIF
    IF(nerror == eExpTable%getcounter(EXCEPTION_ERROR)) THEN
      minTable=INT(minVal*nintervals)
      maxTable=INT(maxVal*nintervals)
      myET%minTable=minTable
      SELECTCASE(tableType)
      CASE (EXACT_EXP_TABLE)
        myET%tableType=EXACT_EXP_TABLE
      CASE(SINGLE_LEVEL_EXP_TABLE)
        CALL dmalloc0A(myET%table,minTable,maxTable)
        myET%nintervals=nintervals
        myET%tableType=tableType
        myET%maxVal=maxVal
        myET%minVal=minVal
        myET%rdx=REAL(nintervals,SRK)
        myET%dx=1._SRK/myET%rdx
        myET%tableErr=tableErr
        x=minVal
        DO i=minTable,maxTable
          myET%table(i)=1._SRK-EXP(x)
          x=x+myET%dx
        ENDDO
      CASE(TWO_LEVEL_EXP_TABLE)
        CALL dmalloc0A(myET%table,minTable,maxTable)
        CALL dmallocA(myET%table2rd,nintervals)
        myET%nintervals=nintervals
        myET%tableType=tableType
        myET%maxVal=maxVal
        myET%minVal=minVal
        myET%rdx=REAL(nintervals,SRK)
        myET%dx=1._SRK/myET%rdx
        myET%dx2rd=myET%dx*myET%dx
        myET%rdx2rd=myET%rdx*myET%rdx
        myET%tableErr=tableErr
        x=minVal
        !The two-level table still tabulates EXP(x), not 1-EXP(x)
        !because it makes use of the identity EXP(x+y)=EXP(x)*EXP(y)
        DO i=minTable,maxTable
          myET%table(i)=EXP(x)
          x=x+myET%dx
        ENDDO
        x2rd=0._SRK
        DO i=1,nintervals
          x2rd=x2rd+myET%dx2rd
          myET%table2rd(i)=EXP(x2rd)
        ENDDO
      CASE(LINEAR_EXP_TABLE)
        CALL dmalloc0A(myET%table2D,1,2,minTable,maxTable)
        myET%nintervals=nintervals
        myET%tableType=tableType
        myET%maxVal=maxVal
        myET%minVal=minVal
        myET%rdx=REAL(nintervals,SRK)
        myET%dx=1._SRK/myET%rdx
        myET%tableErr=tableErr
        x1=minVal
        y1=1._SRK-EXP(x1)
        DO i=minTable,maxTable
          x2=x1+myET%dx
          y2=1._SRK-EXP(x2)
          myET%table2D(1,i)=(y2-y1)*myET%rdx
          myET%table2D(2,i)=y1-myET%table2D(1,i)*x1
          x1=x2
          y1=y2
        ENDDO
      CASE(ORDER2_EXP_TABLE)
        CALL dmalloc0A(myET%table,minTable,maxTable)
        CALL dmalloc0A(myET%table2rd,minTable,maxTable)
        CALL dmalloc0A(myET%table3rd,minTable,maxTable)
        !The interpolation formula
        !f(x)=f(x1)*(x-x2)*(x-x3)/((x1-x2)*(x1-x3))
        !    +f(x2)*(x-x1)*(x-x3)/((x2-x1)*(x2-x3))
        !    +f(x3)*(x-x1)*(x-x2)/((x3-x1)*(x3-x2))
        !==>
        !f(x)=a+b*x+c*x*x
        !and a=x2*x3*f(x1)/((x1-x2)*(x1-x3))+x1*x3*f(x2)/((x2-x1)*(x2-x3)) &
        !     +x1*x2*f(x3)/((x3-x1)*(x3-x2))
        !    b=-(x2+x3)*f(x1)/((x1-x2)*(x1-x3))-(x1+x3)*f(x2)/((x2-x1)*(x2-x3)) &
        !     -(x1+x2)*f(x3)/((x3-x1)*(x3-x2))
        !    c=*f(x1)/((x1-x2)*(x1-x3))+*f(x2)/((x2-x1)*(x2-x3)) &
        !     +*f(x3)/((x3-x1)*(x3-x2))
        myET%nintervals=nintervals
        myET%tableType=tableType
        myET%maxVal=maxVal
        myET%minVal=minVal
        myET%rdx=REAL(nintervals,SRK)
        myET%dx=1._SRK/myET%rdx
        myET%tableErr=tableErr
        x1=minVal
        y1=1._SRK-EXP(x1)
        x2=x1+myET%dx
        y2=1._SRK-EXP(x2)
        rdx2=myET%rdx*myET%rdx
        DO i=minTable,maxTable
          x3=x2+myET%dx
          y3=1._SRK-EXP(x3)
          myET%table(i)=((y1+y3)*0.5_SRK-y2)*rdx2
          myET%table2rd(i)=(-((x2+x3)*y1+(x1+x2)*y3)*0.5_SRK+(x1+x3)*y2)*rdx2
          myET%table3rd(i)=((x3*y1+x1*y3)*x2*0.5_SRK-x1*x3*y2)*rdx2
          x1=x2
          x2=x3
          y1=y2
          y2=y3
        ENDDO
      CASE(POLAR_EXP_TABLE)
        CALL tmpList%get('ExpTables -> RSIN_polars',rsinpol)
        npol=SIZE(rsinpol)
        ALLOCATE(y1p(npol),y2p(npol))
        CALL dmalloc0A(myET%table3D,1,2,minTable,maxTable,1,npol)
        myET%nintervals=nintervals
        myET%tableType=tableType
        myET%maxVal=maxVal
        myET%minVal=minVal
        myET%minTable=minTable
        myET%rdx=REAL(nintervals,SRK)
        myET%dx=1._SRK/myET%rdx
        myET%tableErr=tableErr
        x1=minVal

        DO ipol=1,npol
          x1=minVal
          y1=1._SRK-EXP(x1*rsinpol(ipol))
          DO i=minTable,maxTable
            x2=x1+myET%dx
            y2=1._SRK-EXP(x2*rsinpol(ipol))
            myET%table3D(1,i,ipol)=(y2-y1)*myET%rdx
            myET%table3D(2,i,ipol)=y1-myET%table3D(1,i,ipol)*x1
            x1=x2
            y1=y2
          ENDDO
        ENDDO

        !The following loop structure may not be necessary.
!             DO ipol=1,npol
!               DO i=minTable,maxTable
!                 myET%table3D(1,i,ipol)=myET%table3D(1,i,ipol)*myET%dx
!               ENDDO
!             ENDDO
        ENDSELECT
      myET%isinit=.TRUE.
      CALL tmpList%clear()
    ENDIF
  ENDIF
ENDSUBROUTINE init_ExpTable
!
!-------------------------------------------------------------------------------
!> @brief Exponential function evaluated by single-level table without
!> interpolation
!> @param myET Exponential table type object
!> @param x the value to evaluate
!> @return ans the return value approximate to 1-EXP(x)
!>
!> It is assumed x is in the interval [myET%minVal,myET%maxVal], which is
!> checked in the calling routine which is the only public interface to this
!> routine.
!>
ELEMENTAL FUNCTION EXPT_Single(myET,x) RESULT(ans)
  CLASS(ExpTableType),INTENT(IN) :: myET
  REAL(SRK),INTENT(IN) :: x
  REAL(SRK) :: ans
  INTEGER(SIK) :: i
  i=NINT(x*myET%rdx)
  ans=myET%table(i)
ENDFUNCTION EXPT_Single
!
!-------------------------------------------------------------------------------
!> @brief Exponential function evaluated by two-level table without
!> interpolation
!> @param myET Exponential table type object
!> @param x the value to evaluate
!> @return ans the return value approximate to 1-EXP(x)
!>
!> It is assumed x is in the interval [myET%minVal,myET%maxVal], which is
!> checked in the calling routine which is the only public interface to this
!> routine.
!>
ELEMENTAL FUNCTION EXPT_TwoLevel(myET,x) RESULT(ans)
  CLASS(ExpTableType),INTENT(IN) :: myET
  REAL(SRK),INTENT(IN) :: x
  REAL(SRK) :: ans

  INTEGER(SIK) :: i,i2rd
  REAL(SRK) :: mid
  !
  mid=x*myET%nintervals
  i=FLOOR(mid)
  i2rd=INT((mid-i)*myET%nintervals)
  ans=myET%table(i)
  IF(i2rd /= 0_SIK) ans=ans*myET%table2rd(i2rd)
  ans=1._SRK-ans
ENDFUNCTION EXPT_TwoLevel
!
!-------------------------------------------------------------------------------
!> @brief Exponential function evaluated by table with linear interpolation
!> @param myET Exponential table type object
!> @param x the value to evaluate
!> @return ans the return value approximate to 1-EXP(x)
!>
!> It is assumed x is in the interval [myET%minVal,myET%maxVal], which is
!> checked in the calling routine which is the only public interface to this
!> routine.
!>
ELEMENTAL FUNCTION EXPT_Linear(myET,x) RESULT(ans)
  CLASS(ExpTableType),INTENT(IN) :: myET
  REAL(SRK),INTENT(IN) :: x
  REAL(SRK) :: ans
  INTEGER(SIK) :: i
  i=FLOOR(x*myET%rdx)
  !ans=myET%table(i)*x+myET%table2rd(i)
  ans=myET%table2D(1,i)*x+myET%table2D(2,i)
ENDFUNCTION EXPT_Linear
!
!-------------------------------------------------------------------------------
!> @brief Exponential function evaluated by table with linear interpolation
!> @param myET Exponential table type object
!> @param x the value to evaluate
!> @return ans the return value approximate to 1-EXP(x)
!>
!> It is assumed x is in the interval [myET%minVal,myET%maxVal], which is
!> checked in the calling routine which is the only public interface to this
!> routine.
!>
ELEMENTAL FUNCTION EXPT_Polar(myET,x,ipol) RESULT(ans)
  CLASS(ExpTableType),INTENT(IN) :: myET
  REAL(SRK),INTENT(IN) :: x
  INTEGER(SIK),INTENT(IN) :: ipol
  REAL(SRK) :: ans
  INTEGER(SIK) :: i
  i=FLOOR(x*myET%rdx)
  ans=myET%table3D(1,i,ipol)*x+myET%table3D(2,i,ipol)
ENDFUNCTION EXPT_Polar
!
!-------------------------------------------------------------------------------
!> @brief Exponential function evaluated by table with second order
!> interpolation
!> @param myET Exponential table type object
!> @param x the value to evaluate
!> @return ans the return value approximate to 1-EXP(x)
!>
!> It is assumed x is in the interval [myET%minVal,myET%maxVal], which is
!> checked in the calling routine which is the only public interface to this
!> routine.
!>
ELEMENTAL FUNCTION EXPT_TwoOrder(myET,x) RESULT(ans)
  CLASS(ExpTableType),INTENT(IN) :: myET
  REAL(SRK),INTENT(IN) :: x
  REAL(SRK) :: ans
  INTEGER(SIK) :: i
  i=FLOOR(x*myET%rdx)
  ans=(myET%table2rd(i)+myET%table(i)*x)*x+myET%table3rd(i)
ENDFUNCTION EXPT_TwoOrder
!
!-------------------------------------------------------------------------------
!> @brief Subroutine that sets up the default parameter lists for the
!>        ExpTableType.
!> The required parameters for the ExpTableType do not exist.
!> The optional parameters for the ExpTableType are:
!>        'ExpTableType->tabletype',SIK
!>        'ExpTableType->minval',SRK
!>        'ExpTableType->maxval',SRK
!>        'ExpTableType->nintervals',SIK
!>        'ExpTableType->error',SRK
!>        'ExpTableType->errorflag',SBK
!>
SUBROUTINE ExpTables_Declare_ValidParams()

  ExpTableType_Paramsflag=.TRUE.

  !Set names for required parameters
  !Set defaults for optional parameters
  CALL ExpTableType_optParams%add('ExpTables -> tabletype',LINEAR_EXP_TABLE, &
      'The default ExpTable is just a linear level lookup table.')
  CALL ExpTableType_optParams%add('ExpTables -> minval',-10._SRK, &
      'The default minimum value in the exponential table.')
  CALL ExpTableType_optParams%add('ExpTables -> maxval',0._SRK, &
      'The default maximum value in the exponential table.')
  CALL ExpTableType_optParams%add('ExpTables -> nintervals',1000, &
      'The default value for the number of intervals in the exponential table.')
  CALL ExpTableType_optParams%add('ExpTables -> error',0.0005_SRK, &
      'The default value for the error in the exponential table.')
  CALL ExpTableType_optParams%add('ExpTables -> errorflag',.FALSE., &
      'The default value for the error in the exponential table.')

ENDSUBROUTINE ExpTables_Declare_ValidParams

!-------------------------------------------------------------------------------
!> @brief Subroutine that clears the default parameter lists for the
!>        ExpTableType.
!>
SUBROUTINE ExpTables_Clear_ValidParams()

  ExpTableType_Paramsflag=.FALSE.

  !ExpTableType required parameters
  !ExpTableType optional parameters
  CALL ExpTableType_optParams%clear()
ENDSUBROUTINE ExpTables_Clear_ValidParams
!
ENDMODULE ExpTables


Program Ejemplo20

	IMPLICIT NONE

  integer :: n
  integer,allocatable :: seed(:)
  real, dimension (3, 4) :: r

  call random_seed(size=n)

  print*, 'n : ', n

  allocate(seed(n))

  seed = 123456789    ! putting arbitrary seed to all elements

!  call random_seed(put=seed) ! Si descomento esta linea, los nuevos nros serán distintos

  deallocate(seed)

  print*,'Seed : ', seed

  CALL RANDOM_NUMBER(r)
  print*, r    ! Observe como print sabe lo que Usted quiere!

End Program Ejemplo20


*> \brief \b SORT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID )
*
*       .. Scalar Arguments ..
*       CHARACTER          ROWCOL
*       INTEGER            LDU, LWORK, M, N
*       REAL               RESID
*       ..
*       .. Array Arguments ..
*       REAL               U( LDU, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SORT01 checks that the matrix U is orthogonal by computing the ratio
*>
*>    RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
*> or
*>    RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
*>
*> Alternatively, if there isn't sufficient workspace to form
*> I - U*U' or I - U'*U, the ratio is computed as
*>
*>    RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
*> or
*>    RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
*>
*> where EPS is the machine precision.  ROWCOL is used only if m = n;
*> if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is
*> assumed to be 'R'.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ROWCOL
*> \verbatim
*>          ROWCOL is CHARACTER
*>          Specifies whether the rows or columns of U should be checked
*>          for orthogonality.  Used only if M = N.
*>          = 'R':  Check for orthogonal rows of U
*>          = 'C':  Check for orthogonal columns of U
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix U.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix U.
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is REAL array, dimension (LDU,N)
*>          The orthogonal matrix U.  U is checked for orthogonal columns
*>          if m > n or if m = n and ROWCOL = 'C'.  U is checked for
*>          orthogonal rows if m < n or if m = n and ROWCOL = 'R'.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of the array U.  LDU >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The length of the array WORK.
*>          LWORK >= N*(N+1) if ROWCOL = 'C' or
*>          LWORK >= M*(M+1) if ROWCOL = 'R'.
*>          (Unlike LAPACK, here it is required.)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is REAL
*>          RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or
*>          RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE SORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID )
      implicit none
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          ROWCOL
      INTEGER            LDU, LWORK, M, N
      REAL               RESID
*     ..
*     .. Array Arguments ..
      REAL               U( LDU, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          TRANSU
      INTEGER            I, J, K, LDWORK, MNMIN
      INTEGER            INFO
      REAL               EPS, TMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SDOT, SLAMCH, SLANSY
      EXTERNAL           LSAME, SDOT, SLAMCH, SLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLASET, SSYRK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*
      RESID = ZERO
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
      EPS = SLAMCH( 'Precision' )
      IF( M.LT.N .OR. ( M.EQ.N .AND. LSAME( ROWCOL, 'R' ) ) ) THEN
         TRANSU = 'N'
         K = N
      ELSE
         TRANSU = 'T'
         K = M
      END IF
      MNMIN = MIN( M, N )
*
      IF( ( MNMIN+1 )*MNMIN.LE.LWORK ) THEN
         LDWORK = MNMIN
      ELSE
*        In MAGMA, require enough lwork to avoid dot cases below.
*        Calling zdotc crashes on some systems (MacOS).
         INFO = -7
         RESID = REAL( INFO )
         CALL XERBLA( 'SORT01', -INFO )
         RETURN
         LDWORK = 0
      END IF
      IF( LDWORK.GT.0 ) THEN
*
*        Compute I - U*U' or I - U'*U.
*
         CALL SLASET( 'Upper', MNMIN, MNMIN, ZERO, ONE, WORK, LDWORK )
         CALL SSYRK( 'Upper', TRANSU, MNMIN, K, -ONE, U, LDU, ONE, WORK,
     $               LDWORK )
*
*        Compute norm( I - U*U' ) / ( K * EPS ) .
*
         RESID = SLANSY( '1', 'Upper', MNMIN, WORK, LDWORK,
     $           WORK( LDWORK*MNMIN+1 ) )
         RESID = ( RESID / REAL( K ) ) / EPS
      ELSE IF( TRANSU.EQ.'T' ) THEN
*
*        Find the maximum element in abs( I - U'*U ) / ( m * EPS )
*
         DO 20 J = 1, N
            DO 10 I = 1, J
               IF( I.NE.J ) THEN
                  TMP = ZERO
               ELSE
                  TMP = ONE
               END IF
               TMP = TMP - SDOT( M, U( 1, I ), 1, U( 1, J ), 1 )
               RESID = MAX( RESID, ABS( TMP ) )
   10       CONTINUE
   20    CONTINUE
         RESID = ( RESID / REAL( M ) ) / EPS
      ELSE
*
*        Find the maximum element in abs( I - U*U' ) / ( n * EPS )
*
         DO 40 J = 1, M
            DO 30 I = 1, J
               IF( I.NE.J ) THEN
                  TMP = ZERO
               ELSE
                  TMP = ONE
               END IF
               TMP = TMP - SDOT( N, U( J, 1 ), LDU, U( I, 1 ), LDU )
               RESID = MAX( RESID, ABS( TMP ) )
   30       CONTINUE
   40    CONTINUE
         RESID = ( RESID / REAL( N ) ) / EPS
      END IF
      RETURN
*
*     End of SORT01
*
      END


! { dg-do run }
!
! PR fortran/51972
!
! Contributed by Damian Rouson
!
module surrogate_module
  type ,abstract :: surrogate
  end type
end module

module strategy_module
  use surrogate_module

  type :: strategy
  end type
end module

module integrand_module
  use surrogate_module
  use strategy_module
  implicit none

  type ,abstract, extends(surrogate) :: integrand
    class(strategy), allocatable :: quadrature
  end type
end module integrand_module

module lorenz_module
  use strategy_module
  use integrand_module
  implicit none

  type ,extends(integrand) :: lorenz
    real, dimension(:), allocatable :: state
  contains
    procedure ,public :: assign   => assign_lorenz
  end type
contains
  type(lorenz) function constructor(initial_state, this_strategy)
    real ,dimension(:) ,intent(in)  :: initial_state
    class(strategy)    ,intent(in)  :: this_strategy
    constructor%state=initial_state
    allocate (constructor%quadrature, source=this_strategy)
  end function

  subroutine assign_lorenz(lhs,rhs)
    class(lorenz)    ,intent(inout) :: lhs
    class(integrand) ,intent(in)    :: rhs
    select type(rhs)
      class is (lorenz)
        allocate (lhs%quadrature, source=rhs%quadrature)
        lhs%state=rhs%state
    end select
  end subroutine
end module lorenz_module

module runge_kutta_2nd_module
  use surrogate_module,only : surrogate
  use strategy_module ,only : strategy
  use integrand_module,only : integrand
  implicit none

  type, extends(strategy) ,public :: runge_kutta_2nd
  contains
    procedure, nopass :: integrate
  end type
contains
  subroutine integrate(this)
    class(surrogate) ,intent(inout) :: this
    class(integrand) ,allocatable   :: this_half

    select type (this)
      class is (integrand)
        allocate (this_half, source=this)
    end select
  end subroutine
end module

program main
  use lorenz_module
  use runge_kutta_2nd_module ,only : runge_kutta_2nd, integrate
  implicit none

  type(runge_kutta_2nd) :: timed_lorenz_integrator
  type(lorenz)          :: attractor

  attractor = constructor( [1., 1., 1.] , timed_lorenz_integrator)
  call integrate(attractor)
end program main


program i
  integer ::b
  integer ::a
  a = 3
  b = 20
  print *, (a + b)
end program i


      SUBROUTINE AXIS(COORD,NUMAT,A,B,C,SUMW, MASS,EVEC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION COORD(3,NUMAT)
************************************************************************
*
*  AXIS CALCULATES THE THREE MOMENTS OF INERTIA AND THE MOLECULAR
*       WEIGHT.  THE MOMENTS OF INERTIA ARE RETURNED IN A, B, AND C.
*       THE MOLECULAR WEIGHT IN SUMW.
*       THE UNITS OF INERTIA ARE 10**(-40)GRAM-CM**2,
*       AND MOL.WEIGHT IN ATOMIC-MASS-UNITS. (AMU'S)
************************************************************************
      COMMON /ATMASS/ ATMASS(NUMATM)
      DIMENSION T(6), X(NUMATM), Y(NUMATM),
     1          Z(NUMATM), ROT(3), XYZMOM(3), EIG(3), EVEC(3,3)
      LOGICAL FIRST
      DATA T /6*0.D0/, FIRST/.TRUE./
************************************************************************
*     CONST1 =  10**40/(N*A*A)
*               N = AVERGADRO'S NUMBER
*               A = CM IN AN ANGSTROM
*               10**40 IS TO ALLOW UNITS TO BE 10**(-40)GRAM-CM**2
*
************************************************************************
      CONST1 = 1.66053D0
************************************************************************
*
*     CONST2 = CONVERSION FACTOR FROM ANGSTROM-AMU TO CM**(-1)
*            = (PLANCK'S CONSTANT)/(4*PI*PI)
*
************************************************************************
      CONST2=16.85803902
C    FIRST WE CENTRE THE MOLECULE ABOUT THE CENTRE OF GRAVITY,
C    THIS DEPENDS ON THE ISOTOPIC MASSES, AND THE CARTESIAN GEOMETRY.
C
      SUMW=0.D0
      SUMWX=0.D0
      SUMWY=0.D0
      SUMWZ=0.D0
      WEIGHT=1.D0
      DO 10 I=1,NUMAT
         IF(MASS.GT.0)WEIGHT=ATMASS(I)
         SUMW=SUMW+WEIGHT
         SUMWX=SUMWX+WEIGHT*COORD(1,I)
         SUMWY=SUMWY+WEIGHT*COORD(2,I)
   10 SUMWZ=SUMWZ+WEIGHT*COORD(3,I)
      IF(MASS.GT.0.AND.FIRST)
     1 WRITE(6,'(/10X,''MOLECULAR WEIGHT ='',F8.2,/)')SUMW
      SUMWX=SUMWX/SUMW
      SUMWY=SUMWY/SUMW
      SUMWZ=SUMWZ/SUMW
      DO 20 I=1,NUMAT
         X(I)=COORD(1,I)-SUMWX
         Y(I)=COORD(2,I)-SUMWY
   20 Z(I)=COORD(3,I)-SUMWZ
************************************************************************
*
*    MATRIX FOR MOMENTS OF INERTIA IS OF FORM
*
*           |   Y**2+Z**2                         |
*           |    -Y*X       Z**2+X**2             | -I =0
*           |    -Z*X        -Z*Y       X**2+Y**2 |
*
************************************************************************
      DO 30 I=1,6
   30 T(I)=I*1.D-10
      DO 40 I=1,NUMAT
         IF(MASS.GT.0)WEIGHT=ATMASS(I)
         T(1)=T(1)+WEIGHT*(Y(I)**2+Z(I)**2)
         T(2)=T(2)-WEIGHT*X(I)*Y(I)
         T(3)=T(3)+WEIGHT*(Z(I)**2+X(I)**2)
         T(4)=T(4)-WEIGHT*Z(I)*X(I)
         T(5)=T(5)-WEIGHT*Y(I)*Z(I)
   40 T(6)=T(6)+WEIGHT*(X(I)**2+Y(I)**2)
      CALL HQRII(T,3,3,EIG,EVEC)
      IF(MASS.GT.0.AND. FIRST) THEN
         WRITE(6,'(//10X,'' PRINCIPAL MOMENTS OF INERTIA IN CM(-1)'',/)'
     1)
         DO 50 I=1,3
            IF(EIG(I).LT.3.D-4) THEN
               EIG(I)=0.D0
               ROT(I)=0.D0
            ELSE
               ROT(I)=CONST2/EIG(I)
            ENDIF
   50    XYZMOM(I)=EIG(I)*CONST1
         WRITE(6,'(10X,''A ='',F12.6,''   B ='',F12.6,
     1''   C ='',F12.6,/)')(ROT(I),I=1,3)
         WRITE(6,'(//10X,'' PRINCIPAL MOMENTS OF INERTIA IN '',
     1''UNITS OF 10**(-40)*GRAM-CM**2'',/)')
         WRITE(6,'(10X,''A ='',F12.6,''   B ='',F12.6,
     1''   C ='',F12.6,/)')(XYZMOM(I),I=1,3)
         C=ROT(1)
         B=ROT(2)
         A=ROT(3)
      ENDIF
C
C   NOW TO ORIENT THE MOLECULE SO THE CHIRALITY IS PRESERVED
C
      SUM=EVEC(1,1)*(EVEC(2,2)*EVEC(3,3)-EVEC(3,2)*EVEC(2,3)) +
     1    EVEC(1,2)*(EVEC(2,3)*EVEC(3,1)-EVEC(2,1)*EVEC(3,3)) +
     2    EVEC(1,3)*(EVEC(2,1)*EVEC(3,2)-EVEC(2,2)*EVEC(3,1))
      IF( SUM .LT. 0) THEN
         DO 60 J=1,3
   60    EVEC(J,1)=-EVEC(J,1)
      ENDIF
      DO 70 I=1,NUMAT
         COORD(1,I)=X(I)
         COORD(2,I)=Y(I)
         COORD(3,I)=Z(I)
   70 CONTINUE
      IF(MASS.GT.0)FIRST=.FALSE.
      END


C	PROGRAM TO CALCULATE AN AGE SPECTRUM FROM A GIVEN THERMAL
C		HISTORY. (AGES.F) (SPHERES)

C	R= GAS CONSTANT KCAL/(MOL*K)
C	XLAMBD= DECAY CONSTANT OF POTASSIUM IN 1/MYRS.
C	NUSA=# OF SAMPLES,  TOTIME = TOTAL TIME OF Ar ACCUMULATION
C	C40WD= TOTAL ARGON RADIOGENIC 40Ar PRODUCED POR UNIT VOL. FROM TIME=0.
C	C39WD= FRACTION OF 39Ar AT PRESENT.
C	NEND=TIME AT WHICH THE SYSTEM IS EFFECTIVELY CLOSED, TEMPERATURE
C       IS ASSUME CONSTANT FROM THIS TIME UNTIL PRESENT.
C	STEP= DURATION OF THE TIME STEP, PEND AND TEMIN DEFINE
C	 THE DIFFERENT SEGMENTS OF THE COOLING HISTORY
C	NI=# OF HEATING STEPS
C	TELAB = TEMPERATURE STEP (*K), TILAB= DURATION OF THE HEATING STEP (MIN)
C	NSAMP=# OF DIFFERENT DIFFUSION DOMAIN SIZES
C	D0(J)= FREQUENCY FACTOR (1/SEC)
C	E(J)= ACTIVACTION ENERGY (KCAL/MOL)
C       C(J)= VOLUME FRACION
C	SUBROUTINE GEOSEC CALCULATE THE DISTRIBUTION OF 40Ar AT PRESENT WHICH
C	IS GIVEN BY THE COEFFICIENT XI(N).
C	SUBROUTINE LAB CALCULATE THE RELEASED OF 40Ar and 39Ar AT LAB.
C	FOR EACH DIFFUSION DOMAIN SIZE. (REA40 AND REA39)
C	CURA= CUMULATIVE RATE OF A40 T0 A39 RELEASE.
C	RATE= STEP RATE OF A40 T0 A39 RELEASE
C	DR39 AND DR40 ARE THE STEP RELEASE OF A39 AND A40 RESPECTIVELY.

C=========================================================================

      implicit double precision (a-h,o-z)
      parameter(nn=340,nch=1005,ntp=100,pi=3.141592654,
     $xlambd=0.0005543,R= 1.987d-03,x1=1.2d0,x2=3.d0,acc=1.d-5)
      dimension r40(ntp),r39(ntp),dr39(ntp)
      dimension temp(nch),time(nch)
      dimension c(10),tra40(0:ntp),tra39(0:ntp),sra40(ntp)
      dimension sra39(ntp),scura(ntp),tilab(ntp),telab(ntp)
	dimension E(10),d0(10),tmin(50),tpin(50)
	double precision zero, bessj0, bessj1, rtsafe
      external zero, bessj0, bessj1, rtsafe
	character*9  tab1, yes*1
	common /var/ an(nn),xi(nn),b,c40
	common /integ/ lc(0:nn),imod

	tab1=char(09)
      open(unit=14,file='ages-me.out',status='unknown')
      open(unit=15,file='agesme.in',status='old')
      open(unit=16,file='ages-me.dat',status='unknown')
      open(unit=17,file='temstep.in',status='old')
      open(unit=19,file='each-me.out',status='unknown')
      open(unit=20,file='chist-me.dat',status='unknown')

      lc(0)=0.
C	CALCULATION OF THE COOLING HISTORY

	read(15,*)np
	do 2 j=1,np
	read(15,*)tmin(j),tpin(j)
	write(20,105)tmin(j),tab1,tpin(j)
2	tpin(j)=tpin(j) + 273.
	write(20,*)'&'
	dt=2
	dtdt=(tpin(1)-tpin(2))/(tmin(1)-tmin(2))
	call chist(np,tmin,tpin,time,temp,dt,ns,nch)
	c40=1.-dexp(-xlambd*tmin(1))
	c39wd=dexp(-xlambd*tmin(1))

      print *, 'If you want to see the CH?, type ''y'''
      read *,yes
      if (yes.eq.'y')stop

	print *, 'slabs= 1, spheres= 2 , cilinders= 3'
	read *, imod
	print *, 'model =', imod
      b = 10.d0 - 2.d0 * imod

C  DEFINITION OF STEP HEATING SCHEDULED AT LAB.

	read(17,110)ni
	do 12 j=1,ni
   	read(17,*)telab(j),tilab(j)
         if(telab(j).gt.1373.)goto 11
   12	tilab(j)=tilab(j)/5.256e11
   11   ni=j-1
        close(17)

C  DEFINITION OF DISTRIBUTION PARAMETERS

	read(15,110)nsamp
	do 14 js=1,nsamp
	read(15,*)e(js),d0(js),c(js)
        d0(js)= 10.**d0(js)
   14	d0(js)=d0(js)*(24.*3600.*365e06)

C CALCULATION OF LC
      nsq=1
      nsum=0
      m=0
      do 32 j=1,nn-1
	if(nsum.gt.20)then
	  nsum = 1
	  nsq = nsq*2
	endif
	m=m+nsq
	if(m.gt.100)nsum=nsum+1
	lc(j)=m
	if(imod.eq.1)an(j) = ((2*m-1)*pi)**2
      if(imod.eq.2)an(j) = (m*pi)**2
      if(imod.eq.3)an(j) = zero(m)**2
32    continue
      lc(nn)=lc(nn-1)+1
      if(imod.eq.3)an(1)=rtsafe(x1,x2,acc)**2

C	CALCULATION OF THE AGE SPECTRUM

	do 16 je=1,nsamp
	if(imod.eq.1)d0(je)=d0(je)/4.d0

C	tau=r*550.**2/(e(1)*dtdt)
C      tc= e(1)/r/dlog(8.7*tau*d0(1))-273.

        call geosec(ns,xlambd,d0(je),E(je),temp,time)
        call lab(d0(je),E(je),r40,r39,telab,tilab,dr39,ni,tab1)

C	SUMMATION OF THE CONTRIBUTION OF EACH DIFFUSION DOMAIN SIZE.

	do 18 k=1,ni
	tra40(k)=c(je)*r40(k)+tra40(k)
   18	tra39(k)=c(je)*r39(k)+tra39(k)
   16	continue
	do 20  j=1,ni
	sra40(j)=tra40(j)-tra40(j-1)
	sra39(j)=tra39(j)-tra39(j-1)
	if (sra40(j).gt.0.and.sra39(j).gt.0)goto  21
	age=0.
	goto 19
   21	continue
  	scura(j)=sra40(j)/sra39(j)
	age=dlog(1.+scura(j)/c39wd)/xlambd
   19	write(16,130)tra39(j-1)*100.,tab1,age
	av=(tra39(j-1)+tra39(j))*50.
	write(14,130)av,tab1,age
C     write(20,105)age,tab1,tc
   20	write(16,130)tra39(j)*100.,tab1,age
	do 22 j=1,ni
	tra39(j)=0.
   22	tra40(j)=0.
  110	format(i20)
  105     format(g20.8,a1,g20.8)
  100	format(g20.8)
  120	format(1x,3(f12.6,a1))
  130	format(1x,3(g20.8,a1))
	stop
	end

      subroutine geosec(nend,xlambd,d0,E,temp,time)
      implicit double precision (a-h,o-z)
      parameter(nch=1005, nn=340, pi=3.141592654,R= 1.987d-03)
      dimension time(nend+4),temp(nend+4),dzita(nch),d(nch)
      common /var/ an(nn),xi(nn),b,c40
	common /integ/ lc(0:nn),imod

	zit=0.
	do 10 j=1,nend
	  avtemp=(temp(j+1)+temp(j))/2.
          if(j.eq.1.and.avtemp.lt.800)then
             print *,"WARNING: the sample could had been"
             print *,"retaining argon at ages >",time(1)," Ma"
             print *,"The program assume zero argon concentration"
             print *,"at the initial age:",time(1)," Ma"
          endif
        d(j)=d0*dexp(-e/r/avtemp)
10	continue
	dzita(nend+1)=0.
	do 20 j=nend,1,-1
20	dzita(j)=dzita(j+1)+dabs(time(j+1)-time(j))*d(j)

C     COMPUTO OF XI(M) - M<80000 --> nn=340
      do 30 mi=1,nn-1
        xlogm=dlog(an(mi))
        sum=0.d0
        do 40 n=1,nend
            if(d(n).eq.0.)goto 40
            uplus=an(mi)*dzita(n+1)+xlambd*(time(1)-time(n+1))
            if (uplus-xlogm.gt.25.)goto 40
              al=an(mi)*d(n)-xlambd
              xal= al *(time(n)-time(n+1))
              if (dabs(xal).gt.30)then
                    camal=1.d0/al
              else
                    if (dabs(xal).gt.0.001)then
                        camal=(1.d0-dexp(-xal))/al
                   else
                       camal=(time(n)-time(n+1))*(1-xal/2+xal**2/6.d0)
                   endif
              endif
            sum=sum+d(n)*dexp(-uplus)*camal
40        continue
          tzita = dzita(1)*an(mi)
          if(tzita.lt.30.)then
               xfact = dexp(-tzita)
          else
               xfact = 0.d0
          endif
          xi(mi)=sum*an(mi) + xfact
30    continue
80    continue
      return
      end

      subroutine lab(d0,e,r40,r39,telab,tilab,dr39,ni,tab1)
      implicit double precision (a-h,o-z)
      parameter(nn=340,ntp=200,pi=3.141592654,xlambd=0.0005543,
     $R=1.987d-03)
      dimension r40(ni),zita(ntp),r39(ni),ages(ntp)
      dimension dr39(ni),dr40(ntp),rate(ntp),tilab(ni),telab(ni)
      character*9 tab1
      common /var/ an(nn),xi(nn),b,c40
	common /integ/ lc(0:nn),imod

	c39wd=1-c40
	zii=0.
	do 10 nt=1,ni
   	zita(nt)=zii+d0*tilab(nt)*dexp(-e/(r*telab(nt)))
   10	zii=zita(nt)

	do 20 j=1,ni
	  r39(j)=1.
	  r40(j)=0.
	  sumck = 0.
        do 20 k=1,nn-1
          xmat=0.d0
          do 22 k1=lc(k-1)+1,lc(k)-1
             if(imod.eq.1)an2 = ((2*k1-1)*pi)**2
             if(imod.eq.2)an2 = (k1*pi)**2
             if(imod.eq.3)an2 = zero(k1)**2
	       if (zita(j)*an2.gt.100.) then
	          ab = 0.
	       else
	          ab= dexp(-zita(j)*an2)/an2
		 endif
		 xmat= xmat+(1.d0-(lc(k)-k1)/(lc(k)-lc(k-1)))*(1./an2-ab)
22	    continue
          do 24 k1=lc(k),lc(k+1)-1
             if(imod.eq.1)an2 = ((2*k1-1)*pi)**2
             if(imod.eq.2)an2 = (k1*pi)**2
             if(imod.eq.3)an2 = zero(k1)**2
             if(imod.eq.3.and.k1.eq.1)an2=an(1)
	       if (zita(j)*an2.gt.100.) then
	          ab = 0.
	       else
	          ab= dexp(-zita(j)*an2)/an2
   		    r39(j)=r39(j)-b*ab
		 endif
		 sumck = sumck + b*1.d0/an2
		 xmat= xmat+(lc(k+1)-k1)/(lc(k+1)-lc(k))*(1./an2-ab)
             r40(j)=r40(j)+b*(c40-1)*(1./an2-ab)
24	    continue
             r40(j)=r40(j)+b*xmat*xi(k)
   20	continue
	rate(1)=r40(1)/r39(1)
	dr39(1)=r39(1)
	dr40(1)=r40(1)
	do 50 j=2,ni
	dr39(j)=r39(j)-r39(j-1)
   	dr40(j)=r40(j)-r40(j-1)
	if (dr39(j).gt.0.and.dr40(j).gt.0)goto 70
	ages(j)=0.
	goto 50
   70   rate(j)=dr40(j)/dr39(j)
   	ages(j)=dlog(1.+rate(j)/c39wd)/xlambd
   50 	continue
	ages(1)=dlog(1.+rate(1)/c39wd)/xlambd
	rnum = 1. - 1.0e-07
	do 80 j=1,ni
	if(r39(j).le.rnum)then
   	write(19,140)r39(j)*100,tab1,ages(j)
	endif
   80 	continue
  140	format(1x,4(f12.4,a1))
	return
	end

C	SUBROUTINE TO CALCULATE THE THERMAL HISTORY.
C		 (SUBROUTINE SUBCHIST.F)

        subroutine chist(np,tmin,tpin,time,temp,dt,ns,nch)
        implicit double precision (a-h,o-z)
        dimension temp(nch),time(nch)
        dimension tpin(np),tmin(np)
        CHARACTER TAB1*9
        TAB1=CHAR(09)
	open(unit=18,file='chist.dat')

c	DEFINITION OF THE TEMPERATURE STEP IN CENTIDEGREE.

C	CALCULATION OF THE COOLING HISTORY

        ns=0.
	temp(1)=tpin(1)
        time(1)=tmin(1)
	tem0=tpin(1)
     	do 4 k=1,np-1
	   nt=dabs(tpin(k)-tpin(k+1))/dt + ns
	   snt=(tpin(k)-tpin(k+1))
	   if(dabs(snt).lt.dt)then
	     	temp(nt+2)=tpin(k+1)
		time(nt+2)=tmin(k+1)
	        ns = ns + 1
		tem0=tpin(k+1)
		goto 4
            endif
	   snt=snt/dabs(tpin(k)-tpin(k+1))
	   do 6 j=ns+2,nt+1
	     temp(j)=tem0 - snt*dt
	     time(j)= age(temp(j),tmin(k),tmin(k+1),tpin(k),tpin(k+1))
	     tem0 = temp(j)
6	   continue
	   ns = nt
	   if(dmod(tpin(k)-tpin(k+1),dt).ne.0.)then
		temp(nt+2)=tpin(k+1)
		time(nt+2)=tmin(k+1)
	        tem0=temp(nt+2)
	        ns = ns + 1
           endif
           if(ns.gt.nch-2)stop 'Number of step larger than 1000'
4	continue

	do 8 jk=1,ns+1
            write(18,100)time(jk),tab1,temp(jk)-273.
8	continue
100     format(g20.8,a1,g20.8)
	return
	end

      double precision function age(y,a1,a2,t1,t2)
      implicit double precision (a-h,o-z)
      if(y.lt.0.)pause 'temperature less than zero'
          age=a1 + (y - t1)*(a2-a1)/(t2-t1)
        return
      end

       double precision function zero(n)
       implicit double precision (a-h,o-z)
       parameter(pi=3.14159265)
          den=pi*(4*n-1)
         zero= den/4.+1./(2.*den)-31./(6*den**3)+3779./(15*den**5)
       return
       end

       subroutine funcd(x1,f,df)
	implicit double precision (a-h,o-z)
           f=bessj0(x1)
           df= - bessj1(x1)
       return
       end

      double precision function bessj0(x)
       implicit double precision (a-h,o-z)
c      real*8 y,p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
C     *    s1,s2,s3,s4,s5,s6
      data p1,p2,p3,p4,p5/1.d0,-.1098628627d-2,.2734510407d-4,
     *    -.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-
     *1,
     *    .1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/
      data r1,r2,r3,r4,r5,r6/57568490574.d0,-13362590354.d0,651619640.7d
     *0,
     *    -11214424.18d0,77392.33017d0,-184.9052456d0/,
     *    s1,s2,s3,s4,s5,s6/57568490411.d0,1029532985.d0,
     *    9494680.718d0,59272.64853d0,267.8532712d0,1.d0/
      if(dabs(x).lt.8.)then
        y=x**2
        bessj0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))
     *      /(s1+y*(s2+y*(s3+y*(s4+y*(s5+y*s6)))))
      else
        ax=dabs(x)
        z=8./ax
        y=z**2
        xx=ax-.785398164
        bessj0=dsqrt(.636619772/ax)*(dcos(xx)*(p1+y*(p2+y*(p3+y*(p4+y
     *      *p5))))-z*dsin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
      endif
      return
      end

      double precision function bessj1(x)
	implicit double precision (a-h,o-z)
C      real*8 y,p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
c     *    s1,s2,s3,s4,s5,s6
      data r1,r2,r3,r4,r5,r6/72362614232.d0,-7895059235.d0,242396853.1d0
     *,
     *    -2972611.439d0,15704.48260d0,-30.16036606d0/,
     *    s1,s2,s3,s4,s5,s6/144725228442.d0,2300535178.d0,
     *    18583304.74d0,99447.43394d0,376.9991397d0,1.d0/
      data p1,p2,p3,p4,p5/1.d0,.183105d-2,-.3516396496d-4,.2457520174d-5
     *,
     *    -.240337019d-6/, q1,q2,q3,q4,q5/.04687499995d0,-.2002690873d-3
     *,
     *    .8449199096d-5,-.88228987d-6,.105787412d-6/
      if(dabs(x).lt.8.)then
        y=x**2
        bessj1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))
     *      /(s1+y*(s2+y*(s3+y*(s4+y*(s5+y*s6)))))
      else
        ax=dabs(x)
        z=8./ax
        y=z**2
        xx=ax-2.356194491
        bessj1=dsqrt(.636619772/ax)*(dcos(xx)*(p1+y*(p2+y*(p3+y*(p4+y
     *      *p5))))-z*dsin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
     *      *dsign(1.d0,x)
      endif
      return
      end

      double precision function rtsafe(x1,x2,xacc)
        implicit double precision (a-h,o-z)
      parameter (maxit=100)
      call funcd(x1,fl,df)
      call funcd(x2,fh,df)
      if(fl*fh.ge.0.) pause 'root must be bracketed'
      if(fl.lt.0.)then
        xl=x1
        xh=x2
      else
        xh=x1
        xl=x2
        swap=fl
        fl=fh
        fh=swap
      endif
      rtsafe=.5*(x1+x2)
      dxold=dabs(x2-x1)
      dx=dxold
      call funcd(rtsafe,f,df)
      do 11 j=1,maxit
        if(((rtsafe-xh)*df-f)*((rtsafe-xl)*df-f).ge.0.
     *      .or. dabs(2.*f).gt.dabs(dxold*df) ) then
          dxold=dx
          dx=0.5*(xh-xl)
          rtsafe=xl+dx
          if(xl.eq.rtsafe)return
        else
          dxold=dx
          dx=f/df
          temp=rtsafe
          rtsafe=rtsafe-dx
          if(temp.eq.rtsafe)return
        endif
        if(dabs(dx).lt.xacc) return
        call funcd(rtsafe,f,df)
        if(f.lt.0.) then
          xl=rtsafe
          fl=f
        else
          xh=rtsafe
          fh=f
        endif
11    continue
      pause 'rtsafe exceeding maximum iterations'
      return
      end


SUBROUTINE eq4_ackers(upstream)
!Till: computationally irrelevant: outcommented unused vars
!2012-09-14

!Till: computationally irrelevant: minor changes to improve compiler compatibility
!2011-04-29

! Code converted using TO_F90 by Alan Miller
! Date: 2005-08-23  Time: 12:57:31

use common_h
use time_h
use reservoir_h

IMPLICIT NONE

INTEGER, INTENT(IN OUT)                  :: upstream
INTEGER :: j,g  !i,h,id,ih,irout,imun,dummy1
real:: dummy2

real :: shear_bed,d50 !manning_sed,shear_sec,accum1,accum2
real :: hidexp(n_sed_class) !hidp(n_sed_class),expp(n_sed_class),
real :: wat_dens,sed_dens,shield !,crshear(n_sed_class)
real :: visc !,perc_bed(n_sed_class),perc_susp(n_sed_class)
!real :: transpfac_bed(n_sed_class),transpfac_susp(n_sed_class)
real :: D_gs(n_sed_class),diam_u,shear_vel

!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
REAL :: tempres(step,upstream),n_coef(n_sed_class),m_coef(n_sed_class),k_coef(n_sed_class),Fgr_cr(n_sed_class),Fgr(n_sed_class),rel_dens

real :: discharge(200),depth(200),hydrad(200),energslope(200)
real :: manning(200),topwidth(200),meanvel(200)

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

do j=1,nbrsec(upstream)
  if (j /= nbrsec(upstream)) then
    discharge(j)=(discharge_sec(j,upstream)+discharge_sec(j+1,upstream))/2.
    depth(j)=(depth_sec(j,upstream)+depth_sec(j+1,upstream))/2.
    hydrad(j)=(hydrad_sec(j,upstream)+hydrad_sec(j+1,upstream))/2.
    energslope(j)=(energslope_sec(j,upstream)+energslope_sec(j+1,upstream))/2.
    manning(j)=(manning_sec(j,upstream)+manning_sec(j+1,upstream))/2.
    topwidth(j)=(topwidth_sec(j,upstream)+topwidth_sec(j+1,upstream))/2.
    meanvel(j)=(meanvel_sec(j,upstream)+meanvel_sec(j+1,upstream))/2.
  else
    discharge(j)=discharge_sec(j,upstream)
    depth(j)=depth_sec(j,upstream)
    hydrad(j)=hydrad_sec(j,upstream)
    energslope(j)=energslope_sec(j,upstream)
    manning(j)=manning_sec(j,upstream)
    topwidth(j)=topwidth_sec(j,upstream)
    meanvel(j)=meanvel_sec(j,upstream)
  endif
enddo

! loop to calculate the sediment carrying capacity
DO j=1,nbrsec(upstream)

  if (discharge(j) /= 0.) then

!Ge mean diameter has to be calculated from the grain size distribution
  dummy2=d50_actlay(j,upstream)

! TOTAL LOAD FORMULA

! Gravitacional acceleration (m/s2)
! 9.807

! density of water and density of natural sediments (kg/m3)
  wat_dens=1.*1000.
  sed_dens=2.65*1000.

! relative density of sediment
  rel_dens=(sed_dens-wat_dens)/wat_dens

! bed shear stress (N/m2)
  shear_bed=9.807*wat_dens*depth(j)* energslope(j)

!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
  tempres(step,upstream)=20.

! kinematic viscosity (m2/s)
  visc=(1.14-0.031*(tempres(step,upstream)-15.)+  &
      0.00068*((tempres(step,upstream)-15.)**2.))*1.e-6
!write(*,*)j,visc

! loop to calculate the sediment carrying capacity for bed load
  DO g=1,n_sed_class
   IF (diam(g)*1000. > 0.040) THEN
    if(dummy2==0.) then
	  d50=diam(g)
	else
	  d50=dummy2
	endif
!write(*,*)j,g,d50

! dimensionless grain size (-)
	D_gs(g)=diam(g)*((9.807*rel_dens/(visc**2))**(1./3.))
!write(*,*)j,g,D_gs(g),diam(g),rel_dens,visc

! coefficients Ackers and White Formula
    if (D_gs(g)>1. .and. D_gs(g)<60.) then
	  n_coef(g)=1.-(.56*log10(D_gs(g)))
	  m_coef(g)=(9.66/D_gs(g))+1.34
	  k_coef(g)=10.**(-3.53+2.86*log10(D_gs(g))-(log10(D_gs(g))**2.))
	  Fgr_cr(g)=.14+(.23/sqrt(D_gs(g)))
	else if (D_gs(g)>=60.) then
	  n_coef(g)=0.
	  m_coef(g)=1.5
	  k_coef(g)=.025
	  Fgr_cr(g)=.17
	endif
!if(g==9)write(*,*)j,g,D_gs(g),n_coef(g),m_coef(g),k_coef(g),Fgr_cr(g)

! shear velocity (m/s)
    shear_vel=sqrt(9.807*depth(j)*energslope(j))

! sediment mobility number (-)
    Fgr(g)=(shear_vel**n_coef(g)/(sqrt(9.807*diam(g)*rel_dens)))* &
	     (meanvel(j)/(sqrt(32.)*log10(10.*depth(j)/diam(g))))**(1.-n_coef(g))

!if(g==10)write(*,*)j,g,(shear_vel**n_coef(g)/(sqrt(9.807*diam(g)*rel_dens))),(meanvel(j)/(sqrt(32.)*log10(10*depth(j)/diam(g))))**(1-n_coef(g)),Fgr(g)
!if(g==10)write(*,*)j,g,depth(j),energslope(j),shear_vel,diam(g)*1000,meanvel(j)

! shields parameter (-)
    shield=shear_bed/(wat_dens*rel_dens*9.807*d50)

! grain sizes that requires no correction (-)
    if (shield<=.04) then
	  diam_u=1.08*d50
	else if (shield>.04 .and. shield<=.046) then
	  diam_u=(-21.6*shield+1.944)*d50
	else if (shield>.46 .and. shield<=.097) then
	  diam_u=(-9.73*shield+1.40)*d50
	else if (shield>.097) then
	  diam_u=.456*d50
	endif

!if(g==10)write(*,*)j,g,shear_bed,wat_dens,rel_dens,d50,shield,diam_u

! hiding/exposure factor (-)
    if (diam_u/=0.) then
      if (diam(g)/diam_u<=.075) then
        hidexp(g)=2.5
      else if (diam(g)/diam_u>.075 .and. diam(g)/diam_u<3.7) then
	    hidexp(g)=1./((.53*log10(diam(g)/diam_u))+1.)
	  else if (diam(g)/diam_u>=3.7) then
        hidexp(g)=.769
	  endif
	endif

!if(g==10)write(*,*)j,g,hidexp(g)

! loop to calculate the fractional carrying capacity for total load (m3/day)
    if (Fgr(g)/(Fgr_cr(g)*hidexp(g)) <= 1.) then
	  fr_capacity(g,j)=0.
	else
      fr_capacity(g,j)=k_coef(g)*meanvel(j)*diam(g)*((meanvel(j)/shear_vel)**n_coef(g))*  &
        (((Fgr(g)/(Fgr_cr(g)*hidexp(g)))-1.)**m_coef(g))
    endif

!if(g==10)write(*,*)j,g,k_coef(g)*meanvel(j)*diam(g),((meanvel(j)/shear_vel)**n_coef(g)),(((Fgr(g)/(Fgr_cr(g)*hidexp(g)))-1)**m_coef(g))

!if(g==10)write(*,*)j,g,fr_capacity(g,j),topwidth(j)

! total suspended sediment transport (m3/day)
    fr_capacity(g,j)=min(1000.,fr_capacity(g,j))
    fr_capacity(g,j)=86400.*fr_capacity(g,j)*topwidth(j)

   ELSE
    fr_capacity(g,j)=1000.
    fr_capacity(g,j)=86400*fr_capacity(g,j)*topwidth(j)
   ENDIF

   setvel(g)=SQRT((13.95*visc/diam(g))**2.+1.09*  &
        ((sed_dens-wat_dens)/wat_dens)*9.807*diam(g)) -13.95*visc/diam(g)

  END DO

  else
    DO g=1,n_sed_class
      fr_capacity(g,j)=0.
	enddo
  endif

!write(*,*)d,j,(fr_capacity(g,j),g=1,n_sed_class)
!write(*,*)d,j,fr_capacity(9,j)
  DO g=1,n_sed_class
!if (j==10)write(*,'(3I4,3F20.5)')d,j,g,fr_capacity(g,j)
  END DO
!if (j==10)stop

!if (d==54)read(*,*)
END DO

RETURN
END SUBROUTINE eq4_ackers


module stokes_mod
!
! This module contains the scattering routines for isotropic and henyey-greenstein governed scattering
! Original is due to K. Woods
!

implicit none

contains
   subroutine stokes(packet, hgg, g2)

   use constants, only : PI, TWOPI, wp
   use random,    only : ran2
   use photonMod

   implicit none

   type(photon),  intent(INOUT) :: packet
   real(kind=wp), intent(IN)    :: hgg, g2

   real(kind=wp) :: costp, sintp, phip, bmu, b, ri1, ri3, cosi3, sini3
   real(kind=wp) :: cosb2, sinbt, cosi2, sini1, cosi1, sini2, bott, cosdph

   !***** isotropic scattering if g = 0.0 ******************************
   if(hgg == 0.0_wp) then
      packet%cost=2._wp * ran2() - 1._wp
      packet%sint=(1._wp - packet%cost**2)
      if(packet%sint <= 0._wp)then
         packet%sint = 0._wp
      else
         packet%sint=sqrt(packet%sint)
      endif

      packet%phi=TWOPI*ran2()
      packet%sinp=sin(packet%phi)
      packet%cosp=cos(packet%phi)

      packet%nxp=packet%sint*packet%cosp
      packet%nyp=packet%sint*packet%sinp
      packet%nzp=packet%cost

   else

   !***** heyney greenstein scattering ********************************

      costp=packet%cost
      sintp=packet%sint
      phip=packet%phi

      bmu=((1._wp+g2)-((1._wp-g2)/(1._wp-hgg+2._wp*hgg*ran2()))**2)/(2._wp*hgg)
      cosb2=bmu**2
      b=cosb2-1._wp

      if(abs(bmu) > 1._wp) then
         if(bmu > 1._wp) then
            bmu=1._wp
            cosb2=1._wp
            b=0._wp
         else
            bmu=-1._wp
            cosb2=1._wp
            b=0._wp
         end if
      end if
      sinbt=sqrt(1._wp-cosb2)
      ri1=TWOPI*ran2()

      if(ri1 > PI) then
         ri3=TWOPI-ri1
         cosi3=cos(ri3)
         sini3=sin(ri3)

         if(bmu == 1._wp) then
            goto 100
         else
            if(bmu == -1._wp) then
               goto 100
            end if
         end if

         packet%cost=costp*bmu+sintp*sinbt*cosi3
         if(abs(packet%cost) < 1._wp) then
            packet%sint=abs(sqrt(1._wp - packet%cost**2))
            sini2=sini3*sintp/packet%sint
            bott=packet%sint*sinbt
            cosi2=costp/bott-packet%cost*bmu/bott
         else
            packet%sint=0.
            sini2=0.
            if(packet%cost >= 1._wp)  cosi2=-1._wp
            if(packet%cost <= -1._wp) cosi2=1._wp
         end if

         cosdph=-cosi2*cosi3+sini2*sini3*bmu
         if(abs(cosdph) > 1._wp) then
            if(cosdph > 1._wp) then
               cosdph=1._wp
            else
               cosdph=-1._wp
            end if
         end if

         packet%phi=phip+acos(cosdph)
         if(packet%phi > TWOPI) packet%phi=packet%phi-TWOPI
         if(packet%phi.lt.0.)    packet%phi=packet%phi+TWOPI

         !      elseif(ri1 <= PI) then
      else
         cosi1=cos(ri1)
         sini1=sin(ri1)
         if(bmu == 1.) then
            goto 100
         else
            if(bmu == -1._wp) then
               goto 100
         end if
      end if

         packet%cost=costp*bmu+sintp*sinbt*cosi1
         if(abs(packet%cost).lt.1.) then
            packet%sint=abs(sqrt(1. - packet%cost**2))
            sini2=sini1*sintp/packet%sint
            bott=packet%sint*sinbt
            cosi2=costp/bott-packet%cost*bmu/bott
         else
            packet%sint=0._wp
            sini2=0._wp
            if(packet%cost >= 1._wp)  cosi2=-1._wp
            if(packet%cost <= -1._wp) cosi2=1._wp
         end if

         cosdph=-cosi1*cosi2+sini1*sini2*bmu
         if(abs(cosdph) > 1._wp) then
            if(cosdph > 1._wp) then
               cosdph=1._wp
            else
               cosdph=-1._wp
            end if
         end if
         packet%phi=phip-acos(cosdph)
         if(packet%phi > TWOPI) packet%phi=packet%phi-TWOPI
         if(packet%phi < 0._wp)    packet%phi=packet%phi+TWOPI
      end if

      packet%cosp=cos(packet%phi)
      packet%sinp=sin(packet%phi)

      packet%nxp=packet%sint*packet%cosp
      packet%nyp=packet%sint*packet%sinp
      packet%nzp=packet%cost

   end if

   100   continue

   end subroutine stokes
end MODULE stokes_mod


! Double precision
integer, parameter :: dp=kind(0.d0)

! Global variables
!   epsq = -2 * t ( cos(kx) + cos(ky) ) - mu
!     t      real.
!     mu     real.
!   chiq = -2 * x0 ( cos(kx) + cos(ky) ) - epsf
!     x0     real.
!     epsf   real.
!   Inv[G(k,omega)] = (omega)*I - H_k
!     Gkinv  real array of dimension 16 (4x4 matrix)
!            Inverse of Green function at k
!     Gkqinv real array of dimension 16 (4x4 matrix)
!            Inverse of Green function at k+q
common /gvars/ Pi, t, mu, x0, epsf, V, Uc, Uf, Gkinv, Gkqinv
common /date/  date, time
real(dp)    :: Pi, t, mu, x0, epsf, V, Uc, Uf
complex(dp) :: Gkinv(16), Gkqinv(16)
character(len=8) :: date
character(len=4) :: time

! Local variables
integer  :: i, j, k

! Interface for called procedures
interface
  subroutine write_data(om, del)
    implicit none
    integer, parameter   :: dp=kind(0.d0)
    real(dp), intent(in) :: om, del
  end subroutine write_data
end interface


***
      SUBROUTINE star(kw,mass,mt,tm,tn,tscls,lums,GB,zpars)
*
*
*       Stellar luminosity & evolution time.
*       ------------------------------------
*
      implicit none
*
      integer kw
*
      real*8 mass,mt,tm,tn,tscls(20),lums(10),GB(10),zpars(20)
      real*8 tgb,tbagb,mch,mcmax,mc1,mc2,mcbagb,dx,am
      real*8 lambda,tau,mtc,mass0
      parameter(mch=1.44d0)
*
      real*8 lzamsf,lzahbf,lzhef
      real*8 tbgbf,thookf,tHef,themsf,mcgbf,mcagbf,mcheif,mcgbtf
      real*8 ltmsf,lbgbf,lHeIf,lHef,lbagbf,lmcgbf
      external lzamsf,lzahbf,lzhef
      external tbgbf,thookf,tHef,themsf,mcgbf,mcagbf,mcheif,mcgbtf
      external ltmsf,lbgbf,lHeIf,lHef,lbagbf,lmcgbf
*
      logical saveflag
      COMMON /LOAD/ saveflag
*
*       Computes the characteristic luminosities at different stages (LUMS),
*       and various timescales (TSCLS).
*       Ref: P.P. Eggleton, M.J. Fitchett & C.A. Tout (1989) Ap.J. 347, 998.
*
*       Revised 27th March 1995 by C. A. Tout
*       and 24th October 1995 to include metallicity
*       and 13th December 1996 to include naked helium stars
*
*       Revised 5th April 1997 by J. R. Hurley
*       to include Z=0.001 as well as Z=0.02, convective overshooting,
*       MS hook and more elaborate CHeB. It now also sets the Giant
*       Branch parameters relevant to the mass of the star.
*
*       ------------------------------------------------------------
*       Times: 1; BGB              2; He ignition   3; He burning
*              4; Giant t(inf1)    5; Giant t(inf2) 6; Giant t(Mx)
*              7; FAGB t(inf1)     8; FAGB t(inf2)  9; FAGB  t(Mx)
*             10; SAGB t(inf1)    11; SAGB t(inf2) 12; SAGB  t(Mx)
*             13; TP              14; t(Mcmax)
*
*       LUMS:  1; ZAMS             2; End MS        3; BGB
*              4; He ignition      5; He burning    6; L(Mx)
*              7; BAGB             8; TP
*
*       GB:    1; effective A(H)   2; A(H,He)       3; B
*              4; D                5; p             6; q
*              7; Mx               8; A(He)         9; Mc,BGB
*
*       ------------------------------------------------------------
*
*
***
*
      mass0 = mass
c      if(mass0.gt.300.d0.and.saveflag.eqv..true.)then
c         WRITE(99,*)' MASS EXCEEDED in star.f',mass0
c         saveflag = .false.
c      endif
*
***
      if(kw.ge.7.and.kw.le.9) goto 90
      if(kw.ge.10) goto 95
*
* MS and BGB times
*
      tscls(1) = tbgbf(mass)
      tm = MAX(zpars(8),thookf(mass))*tscls(1)
*
* Zero- and terminal age main sequence luminosity
*
      lums(1) = lzamsf(mass)
      lums(2) = ltmsf(mass)
*
* Set the GB parameters
*
      GB(1) = MAX(-4.8d0,MIN(-5.7d0+0.8d0*mass,-4.1d0+0.14d0*mass))
      GB(1) = 10.d0**GB(1)
      GB(2) = 1.27d-05
      GB(8) = 8.0d-05
      GB(3) = MAX(3.0d+04,500.d0 + 1.75d+04*mass**0.6d0)
      if(mass.le.2.0)then
         GB(4) = zpars(6)
         GB(5) = 6.d0
         GB(6) = 3.d0
      elseif(mass.lt.2.5)then
         dx = zpars(6) - (0.975d0*zpars(6) - 0.18d0*2.5d0)
         GB(4) = zpars(6) - dx*(mass - 2.d0)/(0.5d0)
         GB(5) = 6.d0 - (mass - 2.d0)/(0.5d0)
         GB(6) = 3.d0 - (mass - 2.d0)/(0.5d0)
      else
         GB(4) = MAX(-1.d0,0.5d0*zpars(6) - 0.06d0*mass)
         GB(4) = MAX(GB(4),0.975d0*zpars(6) - 0.18d0*mass)
         GB(5) = 5.d0
         GB(6) = 2.d0
      endif
      GB(4) = 10.d0**GB(4)
      GB(7) = (GB(3)/GB(4))**(1.d0/(GB(5)-GB(6)))
*
* Change in slope of giant L-Mc relation.
      lums(6) = GB(4)*GB(7)**GB(5)
*
* HeI ignition luminosity
      lums(4) = lHeIf(mass,zpars(2))
      lums(7) = lbagbf(mass,zpars(2))
*
      if(mass.lt.0.1d0.and.kw.le.1)then
         tscls(2) = 1.1d0*tscls(1)
         tscls(3) = 0.1d0*tscls(1)
         lums(3) = lbgbf(mass)
         goto 96
      endif
*
      if(mass.le.zpars(3))then
* Base of the giant branch luminosity
         lums(3) = lbgbf(mass)
* Set GB timescales
         tscls(4) = tscls(1) + (1.d0/((GB(5)-1.d0)*GB(1)*GB(4)))*
     &              ((GB(4)/lums(3))**((GB(5)-1.d0)/GB(5)))
         tscls(6) = tscls(4) - (tscls(4) - tscls(1))*((lums(3)/lums(6))
     &              **((GB(5)-1.d0)/GB(5)))
         tscls(5) = tscls(6) + (1.d0/((GB(6)-1.d0)*GB(1)*GB(3)))*
     &              ((GB(3)/lums(6))**((GB(6)-1.d0)/GB(6)))
* Set Helium ignition time
         if(lums(4).le.lums(6))then
            tscls(2) = tscls(4) - (1.d0/((GB(5)-1.d0)*GB(1)*GB(4)))*
     &                      ((GB(4)/lums(4))**((GB(5)-1.d0)/GB(5)))
         else
            tscls(2) = tscls(5) - (1.d0/((GB(6)-1.d0)*GB(1)*GB(3)))*
     &                      ((GB(3)/lums(4))**((GB(6)-1.d0)/GB(6)))
         endif
         tgb = tscls(2) - tscls(1)
         if(mass.le.zpars(2))then
            mc1 = mcgbf(lums(4),GB,lums(6))
            mc2 = mcagbf(mass)
            lums(5) = lzahbf(mass,mc1,zpars(2))
            tscls(3) = tHef(mass,mc1,zpars(2))
         else
            lums(5) = lHef(mass)*lums(4)
            tscls(3) = tHef(mass,1.d0,zpars(2))*tscls(1)
         endif
      else
* Note that for M>zpars(3) there is no GB as the star goes from
* HG -> CHeB -> AGB. So in effect tscls(1) refers to the time of
* Helium ignition and not the BGB.
         tscls(2) = tscls(1)
         tscls(3) = tHef(mass,1.d0,zpars(2))*tscls(1)
* This now represents the luminosity at the end of CHeB, ie. BAGB
         lums(5) = lums(7)
* We set lums(3) to be the luminosity at the end of the HG
         lums(3) = lums(4)
      endif
*
* Set the core mass at the BGB.
*
      if(mass.le.zpars(2))then
         GB(9) = mcgbf(lums(3),GB,lums(6))
      elseif(mass.le.zpars(3))then
         GB(9) = mcheif(mass,zpars(2),zpars(9))
      else
         GB(9) = mcheif(mass,zpars(2),zpars(10))
      endif
*
* FAGB time parameters
*
      tbagb = tscls(2) + tscls(3)
      tscls(7) = tbagb + (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))*
     &               ((GB(4)/lums(7))**((GB(5)-1.d0)/GB(5)))
      tscls(9) = tscls(7) - (tscls(7) - tbagb)*((lums(7)/lums(6))
     &                                    **((GB(5)-1.d0)/GB(5)))
      tscls(8) = tscls(9) + (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))*
     &               ((GB(3)/lums(6))**((GB(6)-1.d0)/GB(6)))
*
* Now to find Ltp and ttp using Mc,He,tp
*
      mcbagb = mcagbf(mass)
      mc1 = mcbagb
      if(mc1.ge.0.8d0.and.mc1.lt.2.25d0)then
* The star undergoes dredge-up at Ltp causing a decrease in Mc,He
         mc1 = 0.44d0*mc1 + 0.448d0
      endif
      lums(8) = lmcgbf(mc1,GB)
      if(mc1.le.GB(7))then
         tscls(13) = tscls(7) - (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))*
     &                   (mc1**(1.d0-GB(5)))
      else
         tscls(13) = tscls(8) - (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))*
     &                   (mc1**(1.d0-GB(6)))
      endif
*
* SAGB time parameters
*
      if(mc1.le.GB(7))then
         tscls(10) = tscls(13) + (1.d0/((GB(5)-1.d0)*GB(2)*GB(4)))*
     &               ((GB(4)/lums(8))**((GB(5)-1.d0)/GB(5)))
         tscls(12) = tscls(10) - (tscls(10) - tscls(13))*
     &               ((lums(8)/lums(6))**((GB(5)-1.d0)/GB(5)))
         tscls(11) = tscls(12) + (1.d0/((GB(6)-1.d0)*GB(2)*GB(3)))*
     &               ((GB(3)/lums(6))**((GB(6)-1.d0)/GB(6)))
      else
         tscls(10) = tscls(7)
         tscls(12) = tscls(9)
         tscls(11) = tscls(13) + (1.d0/((GB(6)-1.d0)*GB(2)*GB(3)))*
     &               ((GB(3)/lums(8))**((GB(6)-1.d0)/GB(6)))
      endif
*
* Get an idea of when Mc,C = Mc,C,max on the AGB
      tau = tscls(2) + tscls(3)
      mc2 = mcgbtf(tau,GB(8),GB,tscls(7),tscls(8),tscls(9))
      mcmax = MAX(MAX(mch,0.773d0*mcbagb - 0.35d0),1.05d0*mc2)
*
      if(mcmax.le.mc1)then
         if(mcmax.le.GB(7))then
            tscls(14) = tscls(7) - (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))*
     &                      (mcmax**(1.d0-GB(5)))
         else
            tscls(14) = tscls(8) - (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))*
     &                      (mcmax**(1.d0-GB(6)))
         endif
      else
* Star is on SAGB and we need to increase mcmax if any 3rd
* dredge-up has occurred.
         lambda = MIN(0.9d0,0.3d0+0.001d0*mass**5)
         mcmax = (mcmax - lambda*mc1)/(1.d0 - lambda)
         if(mcmax.le.GB(7))then
            tscls(14) = tscls(10) - (1.d0/((GB(5)-1.d0)*GB(2)*GB(4)))*
     &                      (mcmax**(1.d0-GB(5)))
         else
            tscls(14) = tscls(11) - (1.d0/((GB(6)-1.d0)*GB(2)*GB(3)))*
     &                      (mcmax**(1.d0-GB(6)))
         endif
      endif
      tscls(14) = MAX(tbagb,tscls(14))
* MM: changed from 100 to 1000
c      if(mass.ge.1000.d0)then
c         tn = tscls(2)
c         goto 100
c      endif
*
* Calculate the nuclear timescale - the time of exhausting
* nuclear fuel without further mass loss.
* This means we want to find when Mc = Mt which defines Tn and will
* be used in determining the timestep required. Note that after some
* stars reach Mc = Mt there will be a Naked Helium Star lifetime
* which is also a nuclear burning period but is not included in Tn.
*
      if(ABS(mt-mcbagb).lt.1.0d-14.and.kw.lt.5)then
         tn = tbagb
      else
* Note that the only occurence of Mc being double-valued is for stars
* that have a dredge-up. If Mt = Mc where Mc could be the value taken
* from CHeB or from the AGB we need to check the current stellar type.
         if(mt.gt.mcbagb.or.(mt.ge.mc1.and.kw.gt.4))then
            if(kw.eq.6)then
               lambda = MIN(0.9d0,0.3d0+0.001d0*mass**5)
               mc1 = (mt - lambda*mc1)/(1.d0 - lambda)
            else
               mc1 = mt
            endif
            if(mc1.le.GB(7))then
               tn = tscls(10) - (1.d0/((GB(5)-1.d0)*GB(2)*GB(4)))*
     &                         (mc1**(1.d0-GB(5)))
            else
               tn = tscls(11) - (1.d0/((GB(6)-1.d0)*GB(2)*GB(3)))*
     &                         (mc1**(1.d0-GB(6)))
            endif
         else
            if(mass.gt.zpars(3))then
               mc1 = mcheif(mass,zpars(2),zpars(10))
               if(mt.le.mc1)then
                  tn = tscls(2)
               else
                  tn = tscls(2) + tscls(3)*((mt - mc1)/(mcbagb - mc1))
               endif
            elseif(mass.le.zpars(2))then
               mc1 = mcgbf(lums(3),GB,lums(6))
               mc2 = mcgbf(lums(4),GB,lums(6))
               if(mt.le.mc1)then
                  tn = tscls(1)
               elseif(mt.le.mc2)then
                  if(mt.le.GB(7))then
                     tn = tscls(4) - (1.d0/((GB(5)-1.d0)*GB(1)*GB(4)))*
     &                               (mt**(1.d0-GB(5)))
                  else
                     tn = tscls(5) - (1.d0/((GB(6)-1.d0)*GB(1)*GB(3)))*
     &                               (mt**(1.d0-GB(6)))
                  endif
               else
                  tn = tscls(2) + tscls(3)*((mt - mc2)/(mcbagb - mc2))
               endif
            else
               mc1 = mcheif(mass,zpars(2),zpars(9))
               mc2 = mcheif(mass,zpars(2),zpars(10))
               if(mt.le.mc1)then
                  tn = tscls(1)
               elseif(mt.le.mc2)then
                  tn = tscls(1) + tgb*((mt - mc1)/(mc2 - mc1))
               else
                  tn = tscls(2) + tscls(3)*((mt - mc2)/(mcbagb - mc2))
               endif
            endif
         endif
      endif
      tn = MIN(tn,tscls(14))
*
      goto 100
*
 90   continue
*
* Calculate Helium star Main Sequence lifetime.
*
      tm = themsf(mass)
      tscls(1) = tm
*
* Zero- and terminal age Helium star main sequence luminosity
*
      lums(1) = lzhef(mass)
      am = MAX(0.d0,0.85d0-0.08d0*mass)
      lums(2) = lums(1)*(1.d0+0.45d0+am)
*
* Set the Helium star GB parameters
*
      GB(8) = 8.0d-05
      GB(3) = 4.1d+04
      GB(4) = 5.5d+04/(1.d0+0.4d0*mass**4)
      GB(5) = 5.d0
      GB(6) = 3.d0
      GB(7) = (GB(3)/GB(4))**(1.d0/(GB(5)-GB(6)))
* Change in slope of giant L-Mc relation.
      lums(6) = GB(4)*GB(7)**GB(5)
*
*** Set Helium star GB timescales
*
      mc1 = mcgbf(lums(2),GB,lums(6))
      tscls(4) = tm + (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))*
     &                                          mc1**(1.d0-GB(5))
      tscls(6) = tscls(4) - (tscls(4) - tm)*((GB(7)/mc1)
     &                                     **(1.d0-GB(5)))
      tscls(5) = tscls(6) + (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))*
     &                                       GB(7)**(1.d0-GB(6))
*
* Get an idea of when Mc = MIN(Mt,Mc,C,max) on the GB
      mtc = MIN(mt,1.45d0*mt-0.31d0)
      if(mtc.le.0.d0) mtc = mt
      mcmax = MIN(mtc,MAX(mch,0.773d0*mass-0.35d0))
      if(mcmax.le.GB(7))then
         tscls(14) = tscls(4) - (1.d0/((GB(5)-1.d0)*GB(8)*GB(4)))*
     &                   (mcmax**(1.d0-GB(5)))
      else
         tscls(14) = tscls(5) - (1.d0/((GB(6)-1.d0)*GB(8)*GB(3)))*
     &                   (mcmax**(1.d0-GB(6)))
      endif
      tscls(14) = MAX(tscls(14),tm)
      tn = tscls(14)
*
      goto 100
*
 95   continue
      tm = 1.0d+10
      tscls(1) = tm
 96   continue
      tn = 1.0d+10
*
 100  continue
      mass = mass0
*
      return
      end
***


! This performs the calculations necessary to run a Lennard-Jones (LJ)
! simulation.
!
! Copyright (C) 2013, Joshua More and Michele Ceriotti
!
! 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.
!
!
! This contains the functions that calculate the potential, forces and
! virial tensor of a single-component LJ system.
! Includes functions which calculate the long-range correction terms for a
! simulation with a sharp nearest-neighbour cut-off.
!
! Functions:
!    LJ_functions: Calculates the LJ pair potential and the magnitude of the
!       forces acting on a pair of atoms.
!    LJ_fij: Calculates the LJ pair potential and force vector for the
!       interaction of a pair of atoms.
!    LJ_longrange: Calculates the long range correction to the potential
!       and virial.
!    LJ_getall: Calculates the potential and virial of the system and the
!       forces acting on all the atoms.

      MODULE LJ
         USE DISTANCE
      IMPLICIT NONE

      DOUBLE PRECISION, PARAMETER :: four_tau_by_3 = 8.3775804095727811d0

      CONTAINS

         SUBROUTINE LJ_functions(sigma, eps, r, pot, force)
            ! Calculates the magnitude of the LJ force and potential between
            ! a pair of atoms at a given distance from each other.
            !
            ! Args:
            !    sigma: The LJ distance parameter.
            !    eps: The LJ energy parameter.
            !    r: The separation of the atoms.
            !    pot: The LJ interaction potential.
            !    force: The magnitude of the LJ force.

            DOUBLE PRECISION, INTENT(IN) :: sigma
            DOUBLE PRECISION, INTENT(IN) :: eps
            DOUBLE PRECISION, INTENT(IN) :: r
            DOUBLE PRECISION, INTENT(OUT) :: pot
            DOUBLE PRECISION, INTENT(OUT) :: force

            DOUBLE PRECISION sigma_by_r6

            sigma_by_r6 = sigma/r
            sigma_by_r6 = sigma_by_r6*sigma_by_r6*sigma_by_r6
            sigma_by_r6 = sigma_by_r6*sigma_by_r6

            pot = 4*eps*(sigma_by_r6*(sigma_by_r6 - 1))
            force = 24*eps*(sigma_by_r6*(2*sigma_by_r6 - 1)/r)

         END SUBROUTINE

         SUBROUTINE LJ_fij(sigma, eps, rij, r, pot, fij)
            ! This calculates the LJ potential energy and the magnitude and
            ! direction of the force acting on a pair of atoms.
            !
            ! Args:
            !    sigma: The LJ distance parameter.
            !    eps: The LJ energy parameter.
            !    rij: The vector joining the two atoms.
            !    r: The separation of the two atoms.
            !    pot: The LJ interaction potential.
            !    fij: The LJ force vector.

            DOUBLE PRECISION, INTENT(IN) :: sigma
            DOUBLE PRECISION, INTENT(IN) :: eps
            DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: rij
            DOUBLE PRECISION, INTENT(IN) :: r
            DOUBLE PRECISION, INTENT(OUT) :: pot
            DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: fij

            DOUBLE PRECISION f_tot

            CALL LJ_functions(sigma, eps, r, pot, f_tot)
            fij = f_tot*rij/r

         END SUBROUTINE

         SUBROUTINE LJ_longrange(rc, sigma, eps, natoms, volume, pot_lr, vir_lr)
            ! Calculates the long range correction to the total potential and
            ! virial pressure.
            !
            ! Uses the tail correction for a sharp cut-off, with no smoothing
            ! function, as derived in Martyna and Hughes, Journal of Chemical
            ! Physics, 110, 3275, (1999).
            !
            ! Args:
            !    rc: The cut-off radius.
            !    sigma: The LJ distance parameter.
            !    eps: The LJ energy parameter.
            !    natoms: The number of atoms in the system.
            !    volume: The volume of the system box.
            !    pot_lr: The tail correction to the LJ interaction potential.
            !    vir_lr: The tail correction to the LJ virial pressure.

            DOUBLE PRECISION, INTENT(IN) :: rc
            DOUBLE PRECISION, INTENT(IN) :: sigma
            DOUBLE PRECISION, INTENT(IN) :: eps
            INTEGER, INTENT(IN) :: natoms
            DOUBLE PRECISION, INTENT(IN) :: volume
            DOUBLE PRECISION, INTENT(OUT) :: pot_lr
            DOUBLE PRECISION, INTENT(OUT) :: vir_lr

            DOUBLE PRECISION sbyr, s3byr3, s6byr3, s6byr6, prefactor

            sbyr = sigma/rc
            s3byr3 = sbyr*sbyr*sbyr
            s6byr6 = s3byr3*s3byr3
            prefactor = four_tau_by_3*natoms*natoms*eps/volume
            prefactor = prefactor*s3byr3*sigma*sigma*sigma

            pot_lr = prefactor*(s6byr6/3-1)
            vir_lr = prefactor*(s6byr6-1) + pot_lr

         END SUBROUTINE

         SUBROUTINE LJ_getall(rc, sigma, eps, natoms, atoms, cell_h, cell_ih, index_list, n_list, pot, forces, virial)
            ! Calculates the LJ potential energy and virial and the forces
            ! acting on all the atoms.
            !
            ! Args:
            !    rc: The cut-off radius.
            !    sigma: The LJ distance parameter.
            !    eps: The LJ energy parameter.
            !    natoms: The number of atoms in the system.
            !    atoms: A vector holding all the atom positions.
            !    cell_h: The simulation box cell vector matrix.
            !    cell_ih: The inverse of the simulation box cell vector matrix.
            !    index_list: A array giving the last index of n_list that
            !       gives the neighbours of a given atom.
            !    n_list: An array giving the indices of the atoms that neighbour
            !       the atom determined by index_list.
            !    pot: The total potential energy of the system.
            !    forces: An array giving the forces acting on all the atoms.
            !    virial: The virial tensor, not divided by the volume.

            DOUBLE PRECISION, INTENT(IN) :: rc
            DOUBLE PRECISION, INTENT(IN) :: sigma
            DOUBLE PRECISION, INTENT(IN) :: eps
            INTEGER, INTENT(IN) :: natoms
            DOUBLE PRECISION, DIMENSION(natoms,3), INTENT(IN) :: atoms
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_h
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_ih
            INTEGER, DIMENSION(natoms), INTENT(IN) :: index_list
            INTEGER, DIMENSION(natoms*(natoms-1)/2), INTENT(IN) :: n_list
            DOUBLE PRECISION, INTENT(OUT) :: pot
            DOUBLE PRECISION, DIMENSION(natoms,3), INTENT(OUT) :: forces
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(OUT) :: virial

            INTEGER i, j, k, l, start
            DOUBLE PRECISION, DIMENSION(3) :: fij, rij
            DOUBLE PRECISION r2, pot_ij, pot_lr, vir_lr, volume

            forces = 0.0d0
            pot = 0.0d0
            virial = 0.0d0

            start = 1

            DO i = 1, natoms - 1
               ! Only loops over the neigbour list, not all the atoms.
               DO j = start, index_list(i)
                  CALL vector_separation(cell_h, cell_ih, atoms(i,:), atoms(n_list(j),:), rij, r2)
                  IF (r2 < rc*rc) THEN ! Only calculates contributions between neighbouring particles.
                     CALL LJ_fij(sigma, eps, rij, sqrt(r2), pot_ij, fij)

                     forces(i,:) = forces(i,:) + fij
                     forces(n_list(j),:) = forces(n_list(j),:) - fij
                     pot = pot + pot_ij
                     DO k = 1, 3
                        DO l = k, 3
                           ! Only the upper triangular elements calculated.
                           virial(k,l) = virial(k,l) + fij(k)*rij(l)
                        ENDDO
                     ENDDO
                  ENDIF
               ENDDO
               start = index_list(i) + 1
            ENDDO

            ! Assuming an upper-triangular vector matrix for the simulation box.
            volume = cell_h(1,1)*cell_h(2,2)*cell_h(3,3)
            CALL LJ_longrange(rc, sigma, eps, natoms, volume, pot_lr, vir_lr)
            pot = pot + pot_lr
            DO k = 1, 3
               virial(k,k) = virial(k,k) + vir_lr
            ENDDO

         END SUBROUTINE

      END MODULE