      SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
     $                   LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
*
*  -- LAPACK auxiliary routine (instrumented to count operations) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      LOGICAL            NOINIT, RIGHTV
      INTEGER            INFO, LDB, LDH, N
      REAL               BIGNUM, EPS3, SMLNUM, WI, WR
*     ..
*     .. Array Arguments ..
      REAL               B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
     $                   WORK( * )
*     ..
*     Common block to return operation count.
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Scalars in Common ..
      REAL               ITCNT, OPS
*     ..
*
*  Purpose
*  =======
*
*  SLAEIN uses inverse iteration to find a right or left eigenvector
*  corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
*  matrix H.
*
*  Arguments
*  =========
*
*  RIGHTV   (input) LOGICAL
*          = .TRUE. : compute right eigenvector;
*          = .FALSE.: compute left eigenvector.
*
*  NOINIT   (input) LOGICAL
*          = .TRUE. : no initial vector supplied in (VR,VI).
*          = .FALSE.: initial vector supplied in (VR,VI).
*
*  N       (input) INTEGER
*          The order of the matrix H.  N >= 0.
*
*  H       (input) REAL array, dimension (LDH,N)
*          The upper Hessenberg matrix H.
*
*  LDH     (input) INTEGER
*          The leading dimension of the array H.  LDH >= max(1,N).
*
*  WR      (input) REAL
*  WI      (input) REAL
*          The real and imaginary parts of the eigenvalue of H whose
*          corresponding right or left eigenvector is to be computed.
*
*  VR      (input/output) REAL array, dimension (N)
*  VI      (input/output) REAL array, dimension (N)
*          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
*          a real starting vector for inverse iteration using the real
*          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
*          must contain the real and imaginary parts of a complex
*          starting vector for inverse iteration using the complex
*          eigenvalue (WR,WI); otherwise VR and VI need not be set.
*          On exit, if WI = 0.0 (real eigenvalue), VR contains the
*          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
*          VR and VI contain the real and imaginary parts of the
*          computed complex eigenvector. The eigenvector is normalized
*          so that the component of largest magnitude has magnitude 1;
*          here the magnitude of a complex number (x,y) is taken to be
*          |x| + |y|.
*          VI is not referenced if WI = 0.0.
*
*  B       (workspace) REAL array, dimension (LDB,N)
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= N+1.
*
*  WORK   (workspace) REAL array, dimension (N)
*
*  EPS3    (input) REAL
*          A small machine-dependent value which is used to perturb
*          close eigenvalues, and to replace zero pivots.
*
*  SMLNUM  (input) REAL
*          A machine-dependent value close to the underflow threshold.
*
*  BIGNUM  (input) REAL
*          A machine-dependent value close to the overflow threshold.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          = 1:  inverse iteration did not converge; VR is set to the
*                last iterate, and so is VI if WI.ne.0.0.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TENTH
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TENTH = 1.0E-1 )
*     ..
*     .. Local Scalars ..
      CHARACTER          NORMIN, TRANS
      INTEGER            I, I1, I2, I3, IERR, ITS, J
      REAL               ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
     $                   OPST, REC, ROOTN, SCALE, TEMP, VCRIT, VMAX,
     $                   VNORM, W, W1, X, XI, XR, Y
*     ..
*     .. External Functions ..
      INTEGER            ISAMAX
      REAL               SASUM, SLAPY2, SNRM2
      EXTERNAL           ISAMAX, SASUM, SLAPY2, SNRM2
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLADIV, SLATRS, SSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, REAL, SQRT
*     ..
*     .. Executable Statements ..
*
      INFO = 0
***
*     Initialize
      OPST = 0
***
*
*     GROWTO is the threshold used in the acceptance test for an
*     eigenvector.
*
      ROOTN = SQRT( REAL( N ) )
      GROWTO = TENTH / ROOTN
      NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
***
*        Increment op count for computing ROOTN, GROWTO and NRMSML
      OPST = OPST + 4
***
*
*     Form B = H - (WR,WI)*I (except that the subdiagonal elements and
*     the imaginary parts of the diagonal elements are not stored).
*
      DO 20 J = 1, N
         DO 10 I = 1, J - 1
            B( I, J ) = H( I, J )
   10    CONTINUE
         B( J, J ) = H( J, J ) - WR
   20 CONTINUE
***
      OPST = OPST + N
***
*
      IF( WI.EQ.ZERO ) THEN
*
*        Real eigenvalue.
*
         IF( NOINIT ) THEN
*
*           Set initial vector.
*
            DO 30 I = 1, N
               VR( I ) = EPS3
   30       CONTINUE
         ELSE
*
*           Scale supplied initial vector.
*
            VNORM = SNRM2( N, VR, 1 )
            CALL SSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
     $                  1 )
***
            OPST = OPST + ( 3*N+2 )
***
         END IF
*
         IF( RIGHTV ) THEN
*
*           LU decomposition with partial pivoting of B, replacing zero
*           pivots by EPS3.
*
            DO 60 I = 1, N - 1
               EI = H( I+1, I )
               IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
*
*                 Interchange rows and eliminate.
*
                  X = B( I, I ) / EI
                  B( I, I ) = EI
                  DO 40 J = I + 1, N
                     TEMP = B( I+1, J )
                     B( I+1, J ) = B( I, J ) - X*TEMP
                     B( I, J ) = TEMP
   40             CONTINUE
               ELSE
*
*                 Eliminate without interchange.
*
                  IF( B( I, I ).EQ.ZERO )
     $               B( I, I ) = EPS3
                  X = EI / B( I, I )
                  IF( X.NE.ZERO ) THEN
                     DO 50 J = I + 1, N
                        B( I+1, J ) = B( I+1, J ) - X*B( I, J )
   50                CONTINUE
                  END IF
               END IF
   60       CONTINUE
            IF( B( N, N ).EQ.ZERO )
     $         B( N, N ) = EPS3
***
*           Increment op count for LU decomposition
            OPS = OPS + ( N-1 )*( N+1 )
***
*
            TRANS = 'N'
*
         ELSE
*
*           UL decomposition with partial pivoting of B, replacing zero
*           pivots by EPS3.
*
            DO 90 J = N, 2, -1
               EJ = H( J, J-1 )
               IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
*
*                 Interchange columns and eliminate.
*
                  X = B( J, J ) / EJ
                  B( J, J ) = EJ
                  DO 70 I = 1, J - 1
                     TEMP = B( I, J-1 )
                     B( I, J-1 ) = B( I, J ) - X*TEMP
                     B( I, J ) = TEMP
   70             CONTINUE
               ELSE
*
*                 Eliminate without interchange.
*
                  IF( B( J, J ).EQ.ZERO )
     $               B( J, J ) = EPS3
                  X = EJ / B( J, J )
                  IF( X.NE.ZERO ) THEN
                     DO 80 I = 1, J - 1
                        B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
   80                CONTINUE
                  END IF
               END IF
   90       CONTINUE
            IF( B( 1, 1 ).EQ.ZERO )
     $         B( 1, 1 ) = EPS3
***
*           Increment op count for UL decomposition
            OPS = OPS + ( N-1 )*( N+1 )
***
*
            TRANS = 'T'
*
         END IF
*
         NORMIN = 'N'
         DO 110 ITS = 1, N
*
*           Solve U*x = scale*v for a right eigenvector
*             or U'*x = scale*v for a left eigenvector,
*           overwriting x on v.
*
            CALL SLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
     $                   VR, SCALE, WORK, IERR )
***
*           Increment opcount for triangular solver, assuming that
*           ops SLATRS = ops STRSV, with no scaling in SLATRS.
            OPS = OPS + N*N
***
            NORMIN = 'Y'
*
*           Test for sufficient growth in the norm of v.
*
            VNORM = SASUM( N, VR, 1 )
***
            OPST = OPST + N
***
            IF( VNORM.GE.GROWTO*SCALE )
     $         GO TO 120
*
*           Choose new orthogonal starting vector and try again.
*
            TEMP = EPS3 / ( ROOTN+ONE )
            VR( 1 ) = EPS3
            DO 100 I = 2, N
               VR( I ) = TEMP
  100       CONTINUE
            VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
***
            OPST = OPST + 4
***
  110    CONTINUE
*
*        Failure to find eigenvector in N iterations.
*
         INFO = 1
*
  120    CONTINUE
*
*        Normalize eigenvector.
*
         I = ISAMAX( N, VR, 1 )
         CALL SSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
***
         OPST = OPST + ( 2*N+1 )
***
      ELSE
*
*        Complex eigenvalue.
*
         IF( NOINIT ) THEN
*
*           Set initial vector.
*
            DO 130 I = 1, N
               VR( I ) = EPS3
               VI( I ) = ZERO
  130       CONTINUE
         ELSE
*
*           Scale supplied initial vector.
*
            NORM = SLAPY2( SNRM2( N, VR, 1 ), SNRM2( N, VI, 1 ) )
            REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
            CALL SSCAL( N, REC, VR, 1 )
            CALL SSCAL( N, REC, VI, 1 )
***
            OPST = OPST + ( 6*N+5 )
***
         END IF
*
         IF( RIGHTV ) THEN
*
*           LU decomposition with partial pivoting of B, replacing zero
*           pivots by EPS3.
*
*           The imaginary part of the (i,j)-th element of U is stored in
*           B(j+1,i).
*
            B( 2, 1 ) = -WI
            DO 140 I = 2, N
               B( I+1, 1 ) = ZERO
  140       CONTINUE
*
            DO 170 I = 1, N - 1
               ABSBII = SLAPY2( B( I, I ), B( I+1, I ) )
               EI = H( I+1, I )
               IF( ABSBII.LT.ABS( EI ) ) THEN
*
*                 Interchange rows and eliminate.
*
                  XR = B( I, I ) / EI
                  XI = B( I+1, I ) / EI
                  B( I, I ) = EI
                  B( I+1, I ) = ZERO
                  DO 150 J = I + 1, N
                     TEMP = B( I+1, J )
                     B( I+1, J ) = B( I, J ) - XR*TEMP
                     B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
                     B( I, J ) = TEMP
                     B( J+1, I ) = ZERO
  150             CONTINUE
                  B( I+2, I ) = -WI
                  B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
                  B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
***
                  OPST = OPST + ( 4*( N-I )+6 )
***
               ELSE
*
*                 Eliminate without interchanging rows.
*
                  IF( ABSBII.EQ.ZERO ) THEN
                     B( I, I ) = EPS3
                     B( I+1, I ) = ZERO
                     ABSBII = EPS3
                  END IF
                  EI = ( EI / ABSBII ) / ABSBII
                  XR = B( I, I )*EI
                  XI = -B( I+1, I )*EI
                  DO 160 J = I + 1, N
                     B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
     $                             XI*B( J+1, I )
                     B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
  160             CONTINUE
                  B( I+2, I+1 ) = B( I+2, I+1 ) - WI
***
                  OPST = OPST + ( 7*( N-I )+4 )
***
               END IF
*
*              Compute 1-norm of offdiagonal elements of i-th row.
*
               WORK( I ) = SASUM( N-I, B( I, I+1 ), LDB ) +
     $                     SASUM( N-I, B( I+2, I ), 1 )
***
               OPST = OPST + ( 2*( N-I )+4 )
***
  170       CONTINUE
            IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
     $         B( N, N ) = EPS3
            WORK( N ) = ZERO
*
            I1 = N
            I2 = 1
            I3 = -1
         ELSE
*
*           UL decomposition with partial pivoting of conjg(B),
*           replacing zero pivots by EPS3.
*
*           The imaginary part of the (i,j)-th element of U is stored in
*           B(j+1,i).
*
            B( N+1, N ) = WI
            DO 180 J = 1, N - 1
               B( N+1, J ) = ZERO
  180       CONTINUE
*
            DO 210 J = N, 2, -1
               EJ = H( J, J-1 )
               ABSBJJ = SLAPY2( B( J, J ), B( J+1, J ) )
               IF( ABSBJJ.LT.ABS( EJ ) ) THEN
*
*                 Interchange columns and eliminate
*
                  XR = B( J, J ) / EJ
                  XI = B( J+1, J ) / EJ
                  B( J, J ) = EJ
                  B( J+1, J ) = ZERO
                  DO 190 I = 1, J - 1
                     TEMP = B( I, J-1 )
                     B( I, J-1 ) = B( I, J ) - XR*TEMP
                     B( J, I ) = B( J+1, I ) - XI*TEMP
                     B( I, J ) = TEMP
                     B( J+1, I ) = ZERO
  190             CONTINUE
                  B( J+1, J-1 ) = WI
                  B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
                  B( J, J-1 ) = B( J, J-1 ) - XR*WI
***
                  OPST = OPST + ( 4*( J-1 )+6 )
***
               ELSE
*
*                 Eliminate without interchange.
*
                  IF( ABSBJJ.EQ.ZERO ) THEN
                     B( J, J ) = EPS3
                     B( J+1, J ) = ZERO
                     ABSBJJ = EPS3
                  END IF
                  EJ = ( EJ / ABSBJJ ) / ABSBJJ
                  XR = B( J, J )*EJ
                  XI = -B( J+1, J )*EJ
                  DO 200 I = 1, J - 1
                     B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
     $                             XI*B( J+1, I )
                     B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
  200             CONTINUE
                  B( J, J-1 ) = B( J, J-1 ) + WI
***
                  OPST = OPST + ( 7*( J-1 )+4 )
***
               END IF
*
*              Compute 1-norm of offdiagonal elements of j-th column.
*
               WORK( J ) = SASUM( J-1, B( 1, J ), 1 ) +
     $                     SASUM( J-1, B( J+1, 1 ), LDB )
***
               OPST = OPST + ( 2*( J-1 )+4 )
***
  210       CONTINUE
            IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
     $         B( 1, 1 ) = EPS3
            WORK( 1 ) = ZERO
*
            I1 = 1
            I2 = N
            I3 = 1
         END IF
*
         DO 270 ITS = 1, N
            SCALE = ONE
            VMAX = ONE
            VCRIT = BIGNUM
*
*           Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
*             or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
*           overwriting (xr,xi) on (vr,vi).
*
            DO 250 I = I1, I2, I3
*
               IF( WORK( I ).GT.VCRIT ) THEN
                  REC = ONE / VMAX
                  CALL SSCAL( N, REC, VR, 1 )
                  CALL SSCAL( N, REC, VI, 1 )
                  SCALE = SCALE*REC
                  VMAX = ONE
                  VCRIT = BIGNUM
               END IF
*
               XR = VR( I )
               XI = VI( I )
               IF( RIGHTV ) THEN
                  DO 220 J = I + 1, N
                     XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
                     XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
  220             CONTINUE
               ELSE
                  DO 230 J = 1, I - 1
                     XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
                     XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
  230             CONTINUE
               END IF
*
               W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
               IF( W.GT.SMLNUM ) THEN
                  IF( W.LT.ONE ) THEN
                     W1 = ABS( XR ) + ABS( XI )
                     IF( W1.GT.W*BIGNUM ) THEN
                        REC = ONE / W1
                        CALL SSCAL( N, REC, VR, 1 )
                        CALL SSCAL( N, REC, VI, 1 )
                        XR = VR( I )
                        XI = VI( I )
                        SCALE = SCALE*REC
                        VMAX = VMAX*REC
                     END IF
                  END IF
*
*                 Divide by diagonal element of B.
*
                  CALL SLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
     $                         VI( I ) )
                  VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
                  VCRIT = BIGNUM / VMAX
***
                  OPST = OPST + 9
***
               ELSE
                  DO 240 J = 1, N
                     VR( J ) = ZERO
                     VI( J ) = ZERO
  240             CONTINUE
                  VR( I ) = ONE
                  VI( I ) = ONE
                  SCALE = ZERO
                  VMAX = ONE
                  VCRIT = BIGNUM
               END IF
  250       CONTINUE
***
*           Increment op count for loop 260, assuming no scaling
            OPS = OPS + 4*N*( N-1 )
***
*
*           Test for sufficient growth in the norm of (VR,VI).
*
            VNORM = SASUM( N, VR, 1 ) + SASUM( N, VI, 1 )
***
            OPST = OPST + 2*N
***
            IF( VNORM.GE.GROWTO*SCALE )
     $         GO TO 280
*
*           Choose a new orthogonal starting vector and try again.
*
            Y = EPS3 / ( ROOTN+ONE )
            VR( 1 ) = EPS3
            VI( 1 ) = ZERO
*
            DO 260 I = 2, N
               VR( I ) = Y
               VI( I ) = ZERO
  260       CONTINUE
            VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
***
            OPST = OPST + 4
***
  270    CONTINUE
*
*        Failure to find eigenvector in N iterations
*
         INFO = 1
*
  280    CONTINUE
*
*        Normalize eigenvector.
*
         VNORM = ZERO
         DO 290 I = 1, N
            VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
  290    CONTINUE
         CALL SSCAL( N, ONE / VNORM, VR, 1 )
         CALL SSCAL( N, ONE / VNORM, VI, 1 )
***
         OPST = OPST + ( 4*N+1 )
***
*
      END IF
*
***
*     Compute final op count
      OPS = OPS + OPST
***
      RETURN
*
*     End of SLAEIN
*
      END


subroutine fgmax_values(mx,my,meqn,mbc,maux,q,aux,dx,dy, &
                   xlower,ylower,i1,i2,j1,j2,values)

    ! Given a grid q (and aux if needed), set the elements of
    !   values(mv,i,j)  for mv=1:FG_NUM_VAL
    ! to the desired values that will be output and/or monitored on
    ! the fixed grid(s).
    !
    ! Only the elements with indices in [i1,i2,j1,j2] need be set.

    ! This library routine expects FG_NUM_VAL to be 1, 2, or 5 and sets:
    !   values(1,i,j) = h              (if FG_NUM_VAL >= 1)
    !   values(2,i,j) = speed          (if FG_NUM_VAL >= 2)
    !   values(1,i,j) = momentum       (if FG_NUM_VAL == 5)
    !   values(1,i,j) = momentum flux  (if FG_NUM_VAL == 5)
    !   values(1,i,j) = -depth         (if FG_NUM_VAL == 5)
    ! The max of -depth can be used to determin the minimum depth of water
    ! at a point over the computation, useful in harbors where ships may be
    ! grounded if the depth goes too low.

    use fgmax_module
    use geoclaw_module, only: sea_level, dry_tolerance

    implicit none
    integer, intent(in) :: mx,my,meqn,mbc,maux
    real(kind=8), intent(in) :: q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
    real(kind=8), intent(in) :: aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc)
    real(kind=8), intent(in) :: dx,dy,xlower,ylower
    integer, intent(in) :: i1,i2,j1,j2
    real(kind=8), intent(inout) :: values(FG_NUM_VAL, 1-mbc:mx+mbc, 1-mbc:my+mbc)

    real(kind=8) :: s_dry_tol
    integer :: i,j

    if ((FG_NUM_VAL.ne.1) .and. (FG_NUM_VAL.ne.2) .and. (FG_NUM_VAL.ne.5)) then
        write(6,*) '*** Error -- expecting FG_NUM_VAL = 1, 2, or 5'
        write(6,*) '***   in fgmax_values, found FG_NUM_VAL = ',FG_NUM_VAL
        stop
        endif

    s_dry_tol = dry_tolerance

    do i=i1,i2
        do j=j1,j2
            values(1,i,j) = q(1,i,j)
            if (FG_NUM_VAL > 1) then
                if (q(1,i,j) > s_dry_tol) then
                    values(2,i,j) = sqrt(q(2,i,j)**2+q(3,i,j)**2) / q(1,i,j)
                  else
                    values(2,i,j) = 0.d0
                  endif
                endif
            if (FG_NUM_VAL > 2) then
                values(3,i,j) = q(1,i,j)*values(2,i,j)       ! hs,   momentum
                values(4,i,j) = values(3,i,j)*values(2,i,j)  ! hs^2, mom flux
                values(5,i,j) = -q(1,i,j)                    ! for min h
                endif
            enddo
        enddo

end subroutine fgmax_values


module hsccpdata

  implicit none

  ! PARAMETERS

  ! Sparsity rate
  real(8), parameter :: SPRATE = 1.0D-01
  ! Penalization term for the chance constraint
  real(8), parameter :: PEN = 1.0D+04

  ! Relative error for subroutine MVNDST
  real(8), parameter :: RELERR = 1.0D-05
  ! Absolute error for subroutine MVNDST
  real(8), parameter :: ABSERR = 1.0D-08

  ! COMMON ARRAYS

  integer, allocatable :: cA(:), pA(:)
  real(8), allocatable :: A(:), c(:), corr(:), mu(:)

  ! COMMON SCALARS

  integer :: m, np
  real(8) :: plim

  ! PRIVATE SCALARS

  integer :: initial_seed

  private :: initial_seed

contains

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

  subroutine set_seed(is)

    ! This subroutine sets the initial seed. It is usefull for massive
    ! random tests.

    ! SCALAR ARGUMENTS
    integer :: is

    initial_seed = is

  end subroutine set_seed

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

  subroutine initialize(np_, mi, x, l, u, plim_)

    ! This subroutine randomly initializes the structure needed by the
    ! Chance Constrained Problem.

    implicit none

    ! SCALAR ARGUMENTS
    integer :: np_, mi
    real(8) :: plim_

    ! ARRAY ARGUMENTS
    real(8) :: l(np_), u(np_), x(np_)

    intent(in ) :: np_, mi, plim_
    intent(out) :: l, u, x

    ! INTERFACES

    interface

       SUBROUTINE UNBIASED_CORRELATION( N, A, B, msg, lag, r, t, m)

         INTEGER, INTENT(IN)                :: N
         REAL(8), DIMENSION(N), INTENT(IN)  :: A
         REAL(8), DIMENSION(N), INTENT(IN)  :: B
         REAL(8), INTENT(IN)                :: msg
         INTEGER, INTENT(IN)                :: lag
         REAL(8), INTENT(OUT)               :: r
         REAL(8), INTENT(OUT)               :: t
         INTEGER, INTENT(OUT)               :: m

       END SUBROUTINE UNBIASED_CORRELATION

    end interface

    ! LOCAL SCALARS

    integer :: i, j, k, nover, nseed, pos
    real(8) :: pi, randnum, t, u1, u2

    ! LOCAL ARRAYS

    integer, allocatable :: seed(:)
    real(8), target, allocatable :: mObs(:,:)

    ! POINTERS

    real(8), pointer :: tmpA(:), tmpB(:)

    m  = mi

    np = np_

    plim = plim_

    ! Initialize the random structure

    call random_seed(SIZE=nseed)

    allocate(seed(nseed))

    do i = 1,nseed
       seed(i) = initial_seed
    end do

    call random_seed(PUT=seed)

    ! Initialize module objects

    allocate(c(np), corr((np - 1) * np / 2), mu(np), &
             mObs(np, np), A(np * m), pA(m + 1), cA(np * m))

    ! Randomly generates vector 'c'

    do i = 1, np

       call random_number(randnum)

       c(i) = 1.0D0 + 1.0D+01 * randnum

    end do

    ! Randomly generates sparse matrix 'A' in vector form

    pA(1) = 1

    do i = 1, m

       pos = pA(i)

       do j = 1, np

          call random_number(randnum)

          if ( randnum .le. SPRATE ) then

             call random_number(A(pos))

             A(pos) = - abs(A(pos))

             cA(pos) = j

             pos = pos + 1

          end if

       end do

       pA(i + 1) = pos

    end do

    ! Randomly generates mean 'mu'

    do i = 1, np

       call random_number(randnum)

       mu(i) = 5.0D0 * randnum

    end do

    ! Randomly generates the initial guess, lower and upper bounds

    do i = 1, np

       x(i) = 0.0D0

       l(i) = mu(i)

       u(i) = 1.0D+20

    end do

    ! Randomly generates correlation matrix 'corr', which is
    ! simmetric, definite positive and has 1's in the diagonal (in
    ! vector form)

    call genRandHouseDP(np,mObs,0.0D0,1.0D+02)

    do j = 1, np

       do i = 1, j - 1

          pos = i + (j - 1) * (j - 2) / 2

          corr(pos) = mObs(i,j) / (sqrt(mObs(i,i)) * sqrt(mObs(j,j)))

          ! write(*,*) i, j, corr(pos)

       end do

    end do

    deallocate(mObs, seed)

  end subroutine initialize

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

  subroutine genRandHouseDP(n,A,prob,magnitude)
    ! This subroutine generates a random symmetric matrix A with
    ! dimension n.
    !
    ! prob: is the probability of a eigenvalue to be very near to zero
    !
    ! magnitude: if is positive, defines the range of random
    ! values. If is negative, also defines this range, but the matrix
    ! has chance to be indefinite

    implicit none

    ! PARAMETERS
    real(8),parameter :: epsdiag = 1.0D-5

    ! ARRAY ARGUMENTS
    real(8) :: A(n,n)

    ! SCALAR ARGUMENTS
    integer :: n
    real(8) :: prob,magnitude

    intent( in) :: prob,n,magnitude
    intent(out) :: A

    ! LOCAL SCALARS
    integer :: i,j,k
    real(8) :: rnumber

    ! LOCAL ARRAYS
    real(8) :: Q(n,n),d(n)

    call genHouseholderOrt(n,Q,magnitude)

    ! Generates a random diagonal matrix D and calculates Q * D * Q^t

    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       if (rnumber .lt. prob) then
          ! Semi-definite positiveness probability
          CALL RANDOM_NUMBER(rnumber)
          d(i) = (1.0D0 + rnumber) * epsdiag
       else if (magnitude .gt. 0.0D0) then
          ! Matrix is positive definite
          CALL RANDOM_NUMBER(rnumber)
          d(i) = epsdiag + magnitude * rnumber
       else
          ! Matrix is indefinite
          CALL RANDOM_NUMBER(rnumber)
          d(i) = - abs(magnitude) + 2.0D0 * abs(magnitude) * rnumber
       end if
    end do

    do j = 1,n
       do i = 1,n
          A(i,j) = 0.0D0
       end do
    end do

    do j = 1,n
       do i = 1,n
          do k = 1,n
             A(k,j) = A(k,j) + Q(k,i) * Q(j,i) * d(i)
          end do
       end do
    end do

  end subroutine genRandHouseDP

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

  subroutine genHouseholderOrt(n,Q,magnitude)

    ! This subroutine generates an randomly generated orthogonal
    ! Householder matrix:
    !
    ! I - 2 * (u * u^T) / (u^T * u)
    !
    ! and returns such matrix in Q

    implicit none

    ! SCALAR ARGUMENTS
    integer :: n
    real(8) :: magnitude

    ! ARRAY ARGUMENTS
    real(8) :: Q(n,n)

    intent( in) :: n,magnitude
    intent(out) :: Q

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: rnumber,dp

    ! LOCAL ARRAYS
    real(8) :: u(n)

    dp = 0.0D0
    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       u(i) = - abs(magnitude) + 2.0D0 * abs(magnitude) * rnumber
       dp = dp + u(i) ** 2.0D0
    end do

    do j = 1,n
       do i = 1,n
          Q(i,j) = - 2.0D0 * u(i) * u(j) / dp
       end do
       Q(j,j) = Q(j,j) + 1.0D0
    end do

  end subroutine genHouseholderOrt

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

  subroutine destroy()

    deallocate(A, c, corr, mu, pA, cA)

  end subroutine destroy

end module hsccpdata


module setup_init_mod

use constants_mod

real(dp), save :: nodes(N_NODES),ws(N_NODES)

contains

subroutine hook_init_809

    use share_mod, only: mesh

    use interpol_mod, only: LegendreGaussNodesAndWeights

    integer :: level

    call LegendreGaussNodesAndWeights(N_NODES-1,nodes,ws)
    nodes = 0.5_dp*nodes
    ws = 0.5_dp*ws

end subroutine

subroutine fill(quad)

    use setup_config_mod
    use equations_const_mod
    use setup_manufacsol_mod

    use mesh_types_mod, only: quad_t
    use quad_utils_mod, only: quad_get_coords

    type(quad_t), intent(inout) :: quad

    real(dp) :: dens(N_NODES,N_NODES,N_NODES)
    real(dp) :: velx(N_NODES,N_NODES,N_NODES)
    real(dp) :: vely(N_NODES,N_NODES,N_NODES)
    real(dp) :: velz(N_NODES,N_NODES,N_NODES)
    real(dp) :: momx(N_NODES,N_NODES,N_NODES)
    real(dp) :: momy(N_NODES,N_NODES,N_NODES)
    real(dp) :: momz(N_NODES,N_NODES,N_NODES)
    real(dp) :: pres(N_NODES,N_NODES,N_NODES)
    real(dp) :: ener(N_NODES,N_NODES,N_NODES)

    real(dp) :: coords(N_NODES,N_NODES,N_NODES,N_DIMS)

    real(dp) :: u(N_NODES,N_NODES,N_NODES,N_VARS)
    real(dp) :: r(N_NODES,N_NODES,N_NODES,N_VARS)

    real(dp) :: xs(N_NODES)
    real(dp) :: ys(N_NODES)
    real(dp) :: zs(N_NODES)

    integer :: i,j,k, ii,jj,kk

    coords = quad_get_coords(quad)

    u = 0.0_dp
    r = 0.0_dp

    do k = 1,N_NODES; do j = 1,N_NODES; do i = 1,N_NODES;
        xs = coords(i,j,k,1) + quad%delta(1)/REAL(N_NODES,dp)*nodes
        ys = coords(i,j,k,2) + quad%delta(2)/REAL(N_NODES,dp)*nodes
        zs = coords(i,j,k,3) + quad%delta(3)/REAL(N_NODES,dp)*nodes

        do kk = 1,N_NODES; do jj = 1,N_NODES; do ii = 1,N_NODES;
            u(i,j,k,:) = u(i,j,k,:) + ws(ii)*ws(jj)*ws(kk)*init_manufacsol(xs(ii),ys(jj),zs(kk))
            r(i,j,k,:) = r(i,j,k,:) + ws(ii)*ws(jj)*ws(kk)*calc_manufacsol(xs(ii),ys(jj),zs(kk))
        end do; end do; end do
    end do; end do; end do

    dens = u(:,:,:,DENS_VAR)
    velx = u(:,:,:,VELX_VAR)
    vely = u(:,:,:,VELY_VAR)
    velz = u(:,:,:,VELZ_VAR)
    pres = u(:,:,:,PRES_VAR)

    momx = dens * velx
    momy = dens * vely
    momz = dens * velz
    ener = pres/(kappa-1) + 0.5*dens*(velx**2+vely**2+velz**2)

    quad%pld%hydro%state(:,:,:,DENS_VAR) = dens
    quad%pld%hydro%state(:,:,:,MOMX_VAR) = momx
    quad%pld%hydro%state(:,:,:,MOMY_VAR) = momy
    quad%pld%hydro%state(:,:,:,MOMZ_VAR) = momz
    quad%pld%hydro%state(:,:,:,ENER_VAR) = ener

end subroutine

function setup_init_probe_refine(quad) result(ok)

    use setup_config_mod
    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CORNERS
    use quad_utils_mod, only: quad_get_center
    use quad_utils_mod, only: quad_get_vertices

    type(quad_t), intent(in)        :: quad
    logical                         :: ok

    real(dp) :: verts(N_DIMS,MESH_CORNERS)
    real(dp) :: center(N_DIMS)

    verts = quad_get_vertices(quad)
    ! center = quad_get_center(quad)

    ok = .false.
    if (any(abs(SQRT(SUM((verts)**2,dim=1))) < 0.125*diameter)) then
        ok = .true.
    end if

end function

function setup_init_probe_coarsen(quads) result(ok)

    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CHILDREN
    use setup_config_mod, only: setup_amr_threshold_coarsen

    type(quad_t), intent(in)    :: quads(MESH_CHILDREN)
    logical                     :: ok

    real(dp)                    :: sensor(MESH_CHILDREN)

    integer :: i

    ok = .false.

end function

subroutine hook_init_810

    use share_mod, only: mesh

    use mesh_utils_mod, only: mesh_iterate_quads
    use mesh_utils_mod, only: mesh_refine

    integer :: level

    call srand(86456)

    do level = mesh%minlevel,mesh%maxlevel-1
        call mesh_refine(mesh,setup_init_probe_refine)
    end do
    call mesh_iterate_quads(mesh,fill)

end subroutine

end module


C
C**************************  AREAS  ************************************
C
C  calculate the area of an element
C
C***********************************************************************
C
      SUBROUTINE AREAS(IP3,TRIANL,X,Y,ARE)
C
      IMPLICIT  NONE
      INTEGER   I,J,M,II
      INTEGER   IP3(3,3),TRIANL(4)
      REAL*8    A2,A3
      REAL*8    ARE
      REAL*8    X(*),Y(*)
C
      A2=0.0D0
      A3=0.0D0
      DO II=1,3
         I=TRIANL(IP3(II,1))
         J=TRIANL(IP3(II,2))
         M=TRIANL(IP3(II,3))
         A3=X(I)*Y(J) + A3
         A2=X(I)*Y(M) + A2
      END DO
      ARE=0.5D0*(A3-A2)
C
      RETURN
      END


      SUBROUTINE DGEDI(A, LDA, N, IPVT, DET, WORK, JOB)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dscal_I
      USE daxpy_I
      USE dswap_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: LDA
      INTEGER  :: N
      INTEGER , INTENT(IN) :: JOB
      INTEGER , INTENT(IN) :: IPVT(1)
      REAL(DOUBLE)  :: A(LDA,1)
      REAL(DOUBLE) , INTENT(INOUT) :: DET(2)
      REAL(DOUBLE) , INTENT(INOUT) :: WORK(1)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, J, K, KB, KP1, L, NM1
      REAL(DOUBLE) :: T, TEN
!-----------------------------------------------
!
!     DGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
!     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
!
!     ON ENTRY
!
!        A       DOUBLE PRECISION(LDA, N)
!                THE OUTPUT FROM DGECO OR DGEFA.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  A .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!        IPVT    INTEGER(N)
!                THE PIVOT VECTOR FROM DGECO OR DGEFA.
!
!        WORK    DOUBLE PRECISION(N)
!                WORK VECTOR.  CONTENTS DESTROYED.
!
!        JOB     INTEGER
!                = 11   BOTH DETERMINANT AND INVERSE.
!                = 01   INVERSE ONLY.
!                = 10   DETERMINANT ONLY.
!
!     ON RETURN
!
!        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
!                OTHERWISE UNCHANGED.
!
!        DET     DOUBLE PRECISION(2)
!                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
!                OTHERWISE NOT REFERENCED.
!                DETERMINANT = DET(1) * 10.0**DET(2)
!                WITH  1.0 .LE. DABS(DET(1)) .LT. 10.0
!                OR  DET(1) .EQ. 0.0 .
!
!     ERROR CONDITION
!
!        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
!        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
!        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
!        AND IF DGECO HAS SET RCOND .GT. 0.0 OR DGEFA HAS SET
!        INFO .EQ. 0 .
!
!     LINPACK. THIS VERSION DATED 08/14/78 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     BLAS DAXPY,DSCAL,DSWAP
!     FORTRAN DABS,MOD
!
!     INTERNAL VARIABLES
!
!
!
!     COMPUTE DETERMINANT
!
      IF (JOB/10 /= 0) THEN
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         TEN = 10.0D0
         DO I = 1, N
            IF (IPVT(I) /= I) DET(1) = -DET(1)
            DET(1) = A(I,I)*DET(1)
!        ...EXIT
            IF (DET(1) == 0.0D0) EXIT
   10       CONTINUE
            IF (DABS(DET(1)) >= 1.0D0) GO TO 20
            DET(1) = TEN*DET(1)
            DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       CONTINUE
            IF (DABS(DET(1)) < TEN) CYCLE
            DET(1) = DET(1)/TEN
            DET(2) = DET(2) + 1.0D0
            GO TO 30
         END DO
      ENDIF
      IF (MOD(JOB,10) /= 0) THEN
         DO K = 1, N
            A(K,K) = 1.0D0/A(K,K)
            T = -A(K,K)
            CALL DSCAL (K - 1, T, A(1,K), 1)
            KP1 = K + 1
            IF (N < KP1) CYCLE
            DO J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0D0
               CALL DAXPY (K, T, A(1,K), 1, A(1,J), 1)
            END DO
         END DO
!
!        FORM INVERSE(U)*INVERSE(L)
!
         NM1 = N - 1
         IF (NM1 >= 1) THEN
            DO KB = 1, NM1
               K = N - KB
               KP1 = K + 1
               WORK(KP1:N) = A(KP1:N,K)
               A(KP1:N,K) = 0.0D0
               DO J = KP1, N
                  T = WORK(J)
                  CALL DAXPY (N, T, A(1,J), 1, A(1,K), 1)
               END DO
               L = IPVT(K)
               IF (L == K) CYCLE
               CALL DSWAP (N, A(1,K), 1, A(1,L), 1)
            END DO
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE DGEDI


!
!     -------------------------------------------------------------
!      I X J T I K
!     -------------------------------------------------------------
!
!                                                                  *
!     CHESKED TRIANGULAR CONDITIONS FOR 6j COEFFICIENT             *
!                                                                  *
!     | I/2  J/2  K/2 |            IXJTIK=1 - IF NOT SATISFY       *
!     | L/2  M/2  N/2 |            IXJTIK=0 - IN OVER CASES        *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius,  Lithuania                          December 1993   *
!
      INTEGER FUNCTION IXJTIK (I, J, K, L, M, N)
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:51:45  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER  :: J
      INTEGER  :: K
      INTEGER  :: L
      INTEGER  :: M
      INTEGER  :: N
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
!-----------------------------------------------
      IXJTIK = 0
      IF (ITTK(I,J,K) == 0) RETURN
      IF (ITTK(I,M,N) == 0) RETURN
      IF (ITTK(L,J,N) == 0) RETURN
      IF (ITTK(L,M,K) == 0) RETURN
      IXJTIK = 1
      RETURN
      END FUNCTION IXJTIK


!==========================================================================
elemental function gsw_melting_ice_equilibrium_sa_ct_ratio (sa, p)
!==========================================================================
!
!  Calculates the ratio of SA to CT changes when ice melts into seawater
!  with both the seawater and the seaice temperatures being almost equal to
!  the equilibrium freezing temperature.  It is assumed that a small mass
!  of ice melts into an infinite mass of seawater.  If indeed the
!  temperature of the seawater and the ice were both equal to the freezing
!  temperature, then no melting or freezing would occur an imbalance
!  between these three temperatures is needed for freezing or melting to
!  occur (the three temperatures being (1) the seawater temperature,
!  (2) the ice temperature, and (3) the freezing temperature.
!
!  The output, melting_ice_equilibrium_SA_CT_ratio, is dSA/dCT rather than
!  dCT/dSA.  This is done so that when SA = 0, the output, dSA/dCT is zero
!  whereas dCT/dSA would be infinite.
!
!  SA  =  Absolute Salinity of seawater                            [ g/kg ]
!  p   =  sea pressure at which the melting occurs                 [ dbar ]
!         ( i.e. absolute pressure - 10.1325d0 dbar )
!
!  melting_ice_equilibrium_SA_CT_ratio = the ratio dSA/dCT of SA to CT
!                                changes when ice melts into seawater, with
!                                the seawater and seaice being close to the
!                                freezing temperature.         [ g/(kg K) ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_ct_freezing_exact, gsw_enthalpy_ct_exact
use gsw_mod_toolbox, only : gsw_t_freezing_exact, gsw_enthalpy_ice
use gsw_mod_toolbox, only : gsw_enthalpy_first_derivatives_ct_exact

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p

real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio

real (r8) :: ctf, h, h_ih, t_seaice, h_hat_sa, h_hat_ct

real (r8), parameter :: saturation_fraction = 0.0_r8

ctf = gsw_ct_freezing_exact(sa,p,saturation_fraction)
t_seaice = gsw_t_freezing_exact(sa,p,saturation_fraction)

h = gsw_enthalpy_ct_exact(sa,ctf,p)
h_ih = gsw_enthalpy_ice(t_seaice,p)
call gsw_enthalpy_first_derivatives_ct_exact(sa,ctf,p,h_hat_sa,h_hat_ct)
          ! note that h_hat_ct is equal to cp0*(273.15 + t)/(273.15 + pt0)

gsw_melting_ice_equilibrium_sa_ct_ratio = sa*h_hat_ct/(h - h_ih - sa*h_hat_sa)

return
end function

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


program DSF_analysis
  implicit none
  integer::n,om
  integer::dummy
  integer::ex_i0, itr
  real(8) :: sztot, pi
  integer :: itr_num
  integer, parameter :: dim = 1000
  integer,parameter::omega_num=300000
  real(8),parameter::eta=0.04d0 !for DSF calculation
  real(8),parameter::eps=1.0d-8 !for degeneracy check
  real(8)::alpha(1:dim), beta(1:dim)
  !
  ! alpha(i) and beta(i+1) correspond to
  ! \alpha_i and \beta_i for Eq.~(23) in Sec.3.9 of arXiv:****.****
  !
  real(8)::omega, norm1, E0
  real(8)::kakko_real, kakko_image, tmp_real, tmp_image, bunbo
  real(8)::DSF(0:omega_num)
  character(len=5)::itr_name
  character(len=5)::eta_name

  pi = acos(-1.0d0)
  DSF=0.0d0
  write(eta_name,  '(I1)') INT(eta*100)

  if(itr_num<100)then
    write(itr_name, '(I2)') itr_num
  else if(100<=itr_num .and. itr_num<1000)then
    write(itr_name, '(I3)') itr_num
  else if(1000<=itr_num .and. itr_num<10000)then
    write(itr_name, '(I4)') itr_num
  end if

  !calculation of DSF

  alpha=0.0d0
  beta=0.0d0

  open(162, file='alpha_beta_values_E0-tmp.d',status='old')

  n = 1
  do
    read(162,*,end=999) ex_i0, dummy, itr, alpha(n), beta(n), norm1, E0, sztot
    n = n + 1
  end do
999 close(162)

  itr_num = n

  !continued-fraction-method
  do om=0, omega_num
    kakko_real=0.0d0
    kakko_image=0.0d0
    bunbo=0.0d0
    tmp_real=0.0d0
    tmp_image=0.0d0

    omega=dble(om)/10000d0

    n = itr_num - 1
    kakko_real=omega+E0-alpha(n)-beta(n+1)
    bunbo=kakko_real**2 + eta**2
    tmp_real=beta(n)*kakko_real/bunbo
    tmp_image=-beta(n)*eta

    do n=itr_num-2, 2,-1
      kakko_real=omega+E0-alpha(n)-tmp_real
      kakko_image=eta-tmp_image
      bunbo=kakko_real**2 + kakko_image**2
      tmp_real=beta(n)*kakko_real/bunbo
      tmp_image=-beta(n)*kakko_image/bunbo
    end do

    n=1
    kakko_real=omega+E0-alpha(n)-tmp_real
    kakko_image=eta-tmp_image
    bunbo=kakko_real**2+kakko_image**2
    tmp_real=norm1*kakko_real/bunbo
    tmp_image=-norm1*kakko_image/bunbo

    DSF(om)=DSF(om)+(-tmp_image/pi)

  end do

  !normalization
  DSF(:)=DSF(:)/dble(1) !modify as you need 2019/6/21

  !output dsf result for each samp
  open(40,file='DSF_itrnum'//trim(itr_name)//'_eta00'//trim(eta_name)//'.dat',position='append')
  do om=0, omega_num
    write(40,'(2e23.15)') dble(om)/10000d0, DSF(om)
  end do
  close(40)

end program DSF_analysis


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine input_parameters
  use global_variables
  implicit none

  Mx = 40
  Hx = 1000d0/a_B/Mx
  Nx_L = -aint(50000d0/a_B*4d0/Hx)
  Nx_R = aint(50000d0/a_B*4d0/Hx)

  dt = 0.04d0
  Nt = aint(30d0/0.02418d0/dt) + 1

! GaAs at \omega = 1.600 eV
  eps0 = 13.683d0
  sigma0 = 0.677d0*(1.6d0/(2d0*Ry))/(4d0*pi)

  IWcm2_1 = 1d12
  omega_ev_1 = 1.55d0
  tpulse_fs_1 = 14d0

end subroutine input_parameters


*DECK DGAMRN
      DOUBLE PRECISION FUNCTION DGAMRN (X)
C***BEGIN PROLOGUE  DGAMRN
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBSKIN
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (GAMRN-S, DGAMRN-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract   * A Double Precision Routine *
C         DGAMRN computes the GAMMA function ratio GAMMA(X)/GAMMA(X+0.5)
C         for real X.gt.0. If X.ge.XMIN, an asymptotic expansion is
C         evaluated. If X.lt.XMIN, an integer is added to X to form a
C         new value of X.ge.XMIN and the asymptotic expansion is eval-
C         uated for this new value of X. Successive application of the
C         recurrence relation
C
C                      W(X)=W(X+1)*(1+0.5/X)
C
C         reduces the argument to its original value. XMIN and comp-
C         utational tolerances are computed as a function of the number
C         of digits carried in a word by calls to I1MACH and D1MACH.
C         However, the computational accuracy is limited to the max-
C         imum of unit roundoff (=D1MACH(4)) and 1.0D-18 since critical
C         constants are given to only 18 digits.
C
C         Input      X is Double Precision
C           X      - Argument, X.gt.0.0D0
C
C         Output      DGAMRN is DOUBLE PRECISION
C           DGAMRN  - Ratio  GAMMA(X)/GAMMA(X+0.5)
C
C***SEE ALSO  DBSKIN
C***REFERENCES  Y. L. Luke, The Special Functions and Their
C                 Approximations, Vol. 1, Math In Sci. And
C                 Eng. Series 53, Academic Press, New York, 1969,
C                 pp. 34-35.
C***ROUTINES CALLED  D1MACH, I1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C   920520  Added REFERENCES section.  (WRB)
C***END PROLOGUE  DGAMRN
      INTEGER I, I1M11, K, MX, NX
      INTEGER I1MACH
      DOUBLE PRECISION FLN, GR, RLN, S, TOL, TRM, X, XDMY, XINC, XM,
     * XMIN, XP, XSQ
      DOUBLE PRECISION D1MACH
      DIMENSION GR(12)
      SAVE GR
C
      DATA GR(1), GR(2), GR(3), GR(4), GR(5), GR(6), GR(7), GR(8),
     * GR(9), GR(10), GR(11), GR(12) /1.00000000000000000D+00,
     * -1.56250000000000000D-02,2.56347656250000000D-03,
     * -1.27983093261718750D-03,1.34351104497909546D-03,
     * -2.43289663922041655D-03,6.75423753364157164D-03,
     * -2.66369606131178216D-02,1.41527455519564332D-01,
     * -9.74384543032201613D-01,8.43686251229783675D+00,
     * -8.97258321640552515D+01/
C
C***FIRST EXECUTABLE STATEMENT  DGAMRN
      NX = INT(X)
      TOL = MAX(D1MACH(4),1.0D-18)
      I1M11 = I1MACH(14)
      RLN = D1MACH(5)*I1M11
      FLN = MIN(RLN,20.0D0)
      FLN = MAX(FLN,3.0D0)
      FLN = FLN - 3.0D0
      XM = 2.0D0 + FLN*(0.2366D0+0.01723D0*FLN)
      MX = INT(XM) + 1
      XMIN = MX
      XDMY = X - 0.25D0
      XINC = 0.0D0
      IF (X.GE.XMIN) GO TO 10
      XINC = XMIN - NX
      XDMY = XDMY + XINC
   10 CONTINUE
      S = 1.0D0
      IF (XDMY*TOL.GT.1.0D0) GO TO 30
      XSQ = 1.0D0/(XDMY*XDMY)
      XP = XSQ
      DO 20 K=2,12
        TRM = GR(K)*XP
        IF (ABS(TRM).LT.TOL) GO TO 30
        S = S + TRM
        XP = XP*XSQ
   20 CONTINUE
   30 CONTINUE
      S = S/SQRT(XDMY)
      IF (XINC.NE.0.0D0) GO TO 40
      DGAMRN = S
      RETURN
   40 CONTINUE
      NX = INT(XINC)
      XP = 0.0D0
      DO 50 I=1,NX
        S = S*(1.0D0+0.5D0/(X+XP))
        XP = XP + 1.0D0
   50 CONTINUE
      DGAMRN = S
      RETURN
      END


!
! Copyright (C) 2010 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!=----------------------------------------------------------------------------=!
   MODULE gvect
!=----------------------------------------------------------------------------=!

     ! ... variables describing the reciprocal lattice vectors
     ! ... G vectors with |G|^2 < ecutrho, cut-off for charge density
     ! ... With gamma tricks, G-vectors are divided into two half-spheres,
     ! ... G> and G<, containing G and -G (G=0 is in G>)
     ! ... This is referred to as the "dense" (or "hard", or "thick") grid

     USE kinds, ONLY: DP

     IMPLICIT NONE
     SAVE

     INTEGER :: ngm  = 0  ! local  number of G vectors (on this processor)
                          ! with gamma tricks, only vectors in G>
     INTEGER :: ngm_g= 0  ! global number of G vectors (summed on all procs)
                          ! in serial execution, ngm_g = ngm
     INTEGER :: ngl = 0   ! number of G-vector shells
     INTEGER :: ngmx = 0  ! local number of G vectors, maximum across all procs

     REAL(DP) :: ecutrho = 0.0_DP ! energy cut-off for charge density
     REAL(DP) :: gcutm = 0.0_DP   ! ecutrho/(2 pi/a)^2, cut-off for |G|^2

     ! nl  = fft index for G-vectors (with gamma tricks, only for G>)
     ! nlm = as above, for G< (used only with gamma tricks)

     INTEGER, ALLOCATABLE :: nl(:), nlm(:)

     INTEGER :: gstart = 2 ! index of the first G vector whose module is > 0
                           ! Needed in parallel execution: gstart=2 for the
                           ! proc that holds G=0, gstart=1 for all others

     !     G^2 in increasing order (in units of tpiba2=(2pi/a)^2)
     !
     REAL(DP), ALLOCATABLE, TARGET :: gg(:)

     !     gl(i) = i-th shell of G^2 (in units of tpiba2)
     !     igtongl(n) = shell index for n-th G-vector
     !
     REAL(DP), POINTER :: gl(:)
     INTEGER, ALLOCATABLE, TARGET :: igtongl(:)
     !
     !     G-vectors cartesian components ( in units tpiba =(2pi/a)  )
     !
     REAL(DP), ALLOCATABLE, TARGET :: g(:,:)

     !     mill = miller index of G vectors (local to each processor)
     !            G(:) = mill(1)*bg(:,1)+mill(2)*bg(:,2)+mill(3)*bg(:,3)
     !            where bg are the reciprocal lattice basis vectors
     !
     INTEGER, ALLOCATABLE, TARGET :: mill(:,:)

     !     ig_l2g  = converts a local G-vector index into the global index
     !               ("l2g" means local to global): ig_l2g(i) = index of i-th
     !               local G-vector in the global array of G-vectors
     !
     INTEGER, ALLOCATABLE, TARGET :: ig_l2g(:)
     !
     !     sortedig_l2g = array obtained by sorting ig_l2g
     !
     INTEGER, ALLOCATABLE, TARGET :: sortedig_l2g(:)
     !
     !     mill_g  = miller index of all G vectors
     !
     INTEGER, ALLOCATABLE, TARGET :: mill_g(:,:)
     !
     ! the phases e^{-iG*tau_s} used to calculate structure factors
     !
     COMPLEX(DP), ALLOCATABLE :: eigts1(:,:), eigts2(:,:), eigts3(:,:)
     !
   CONTAINS

     SUBROUTINE gvect_init( ngm_ , comm )
       !
       ! Set local and global dimensions, allocate arrays
       !
       USE mp, ONLY: mp_max, mp_sum
       IMPLICIT NONE
       INTEGER, INTENT(IN) :: ngm_
       INTEGER, INTENT(IN) :: comm  ! communicator of the group on which g-vecs are distributed
       !
       ngm = ngm_
       !
       !  calculate maximum over all processors
       !
       ngmx = ngm
       CALL mp_max( ngmx, comm )
       !
       !  calculate sum over all processors
       !
       ngm_g = ngm
       CALL mp_sum( ngm_g, comm )
       !
       !  allocate arrays - only those that are always kept until the end
       !
       ALLOCATE( gg(ngm) )
       ALLOCATE( g(3, ngm) )
       ALLOCATE( mill(3, ngm) )
       ALLOCATE( nl (ngm) )
       ALLOCATE( nlm(ngm) )
       ALLOCATE( ig_l2g(ngm) )
       ALLOCATE( igtongl(ngm) )
       !
       RETURN
       !
     END SUBROUTINE gvect_init

     SUBROUTINE deallocate_gvect()
       IF( ALLOCATED( gg ) ) DEALLOCATE( gg )
       IF( ASSOCIATED( gl ) ) DEALLOCATE( gl )
       IF( ALLOCATED( g ) )  DEALLOCATE( g )
       IF( ALLOCATED( mill_g ) ) DEALLOCATE( mill_g )
       IF( ALLOCATED( mill ) ) DEALLOCATE( mill )
       IF( ALLOCATED( igtongl ) ) DEALLOCATE( igtongl )
       IF( ALLOCATED( ig_l2g ) ) DEALLOCATE( ig_l2g )
       IF( ALLOCATED( sortedig_l2g ) ) DEALLOCATE( sortedig_l2g )
       IF( ALLOCATED( eigts1 ) ) DEALLOCATE( eigts1 )
       IF( ALLOCATED( eigts2 ) ) DEALLOCATE( eigts2 )
       IF( ALLOCATED( eigts3 ) ) DEALLOCATE( eigts3 )
       IF( ALLOCATED( nl ) ) DEALLOCATE( nl )
       IF( ALLOCATED( nlm ) ) DEALLOCATE( nlm )
     END SUBROUTINE deallocate_gvect

!=----------------------------------------------------------------------------=!
   END MODULE gvect
!=----------------------------------------------------------------------------=!

!=----------------------------------------------------------------------------=!
   MODULE gvecs
!=----------------------------------------------------------------------------=!
     USE kinds, ONLY: DP

     IMPLICIT NONE
     SAVE

     ! ... G vectors with |G|^2 < 4*ecutwfc, cut-off for wavefunctions
     ! ... ("smooth" grid). Gamma tricks and units as for the "dense" grid
     !
     INTEGER :: ngms = 0  ! local  number of smooth vectors (on this processor)
     INTEGER :: ngms_g=0  ! global number of smooth vectors (summed on procs)
                          ! in serial execution this is equal to ngms
     INTEGER :: ngsx = 0  ! local number of smooth vectors, max across procs

     ! nl  = fft index for smooth vectors (with gamma tricks, only for G>)
     ! nlm = as above, for G< (used only with gamma tricks)

     INTEGER, ALLOCATABLE :: nls(:), nlsm(:)

     REAL(DP) :: ecuts = 0.0_DP   ! energy cut-off = 4*ecutwfc
     REAL(DP) :: gcutms= 0.0_DP   ! ecuts/(2 pi/a)^2, cut-off for |G|^2

     REAL(DP) :: dual = 0.0_DP    ! ecutrho=dual*ecutwfc
     LOGICAL  :: doublegrid = .FALSE. ! true if smooth and dense grid differ
                                      ! doublegrid = (dual > 4)

   CONTAINS

     SUBROUTINE gvecs_init( ngs_ , comm )
       USE mp, ONLY: mp_max, mp_sum
       IMPLICIT NONE
       INTEGER, INTENT(IN) :: ngs_
       INTEGER, INTENT(IN) :: comm  ! communicator of the group on which g-vecs are distributed
       !
       ngms = ngs_
       !
       !  calculate maximum over all processors
       !
       ngsx = ngms
       CALL mp_max( ngsx, comm )
       !
       !  calculate sum over all processors
       !
       ngms_g = ngms
       CALL mp_sum( ngms_g, comm )
       !
       !  allocate arrays
       !
       ALLOCATE( nls (ngms) )
       ALLOCATE( nlsm(ngms) )
       !
       RETURN
       !
     END SUBROUTINE gvecs_init

     SUBROUTINE deallocate_gvecs()
       IF( ALLOCATED( nls ) ) DEALLOCATE( nls )
       IF( ALLOCATED( nlsm ) ) DEALLOCATE( nlsm )
     END SUBROUTINE deallocate_gvecs

!=----------------------------------------------------------------------------=!
   END MODULE gvecs
!=----------------------------------------------------------------------------=!


c
c program ephemeris
c
      include 'VICMAIN_FOR'
      subroutine main44

      implicit real*8(a-h,o-z)
      character*100 msg,epoch,spicefile,object,viewer
      integer*4 def,count,object_num,viewer_num,h(2)
      integer*4 num,vnum
      logical failed
      real*8 lon,lat,light_time,state(6),tibf(3,3)

      call xvmessage('EPHEMERIS version 13 Sept 1998',' ')
      call init_spice

      call xvparm('SPICEFILE',spicefile,count,def,1)
      call spklef(spicefile,h(1))
      if (failed()) goto 900
c get parameters
      call xvparm('EPOCH',epoch,count,def,1)
      call xvparm('OBJECT',object,count,def,1)
      call xvparm('VIEWER',viewer,count,def,1)

c reads times like: asfd19920112044820a.vic
c with the time-stamp:  yyyymmddhhmmss
      i=index(epoch,'.vic')
      if(i.gt.0)then
        msg(1:2)=epoch(9:10) ! month
        msg(3:3)='/'
        msg(4:5)=epoch(11:12) ! day
        msg(6:6)='/'
        msg(7:10)=epoch(5:8) ! year
        msg(11:11)=' '
        msg(12:13)=epoch(13:14) ! hour
        msg(14:14)=':'
        msg(15:16)=epoch(15:16) ! min
        msg(17:17)=':'
        msg(18:19)=epoch(17:18) ! sec
        msg(20:100)='.'
        epoch(1:100)=msg(1:100)
      endif

c convert epoch to ephemeris time
      call utc2et(epoch,ephemeris_time)
      if (failed()) goto 901
c get the planet id #
      if(object.eq.'sun')object_num=10
      if(object.eq.'mercury')object_num=199
      if(object.eq.'venus')object_num=299
      if(object.eq.'earth')object_num=399
      if(object.eq.'moon')object_num=301
      if(object.eq.'mars')object_num=499
      if(object.eq.'jupiter')object_num=599
      if(object.eq.'saturn')object_num=699
      if(object.eq.'uranus')object_num=799
      if(object.eq.'neptune')object_num=899
      if(object.eq.'pluto')object_num=999
      if(viewer.eq.'sun')viewer_num=10
      if(viewer.eq.'mercury')viewer_num=199
      if(viewer.eq.'venus')viewer_num=299
      if(viewer.eq.'earth')viewer_num=399
      if(viewer.eq.'moon')viewer_num=301
      if(viewer.eq.'mars')viewer_num=499
      if(viewer.eq.'jupiter')viewer_num=599
      if(viewer.eq.'saturn')viewer_num=699
      if(viewer.eq.'uranus')viewer_num=799
      if(viewer.eq.'neptune')viewer_num=899
      if(viewer.eq.'pluto')viewer_num=999

c compute target state light time corrected at epoch from observer
      call spkez(object_num,ephemeris_time,'J2000','LT',viewer_num,
     +   state,light_time)
      if (failed()) then
         num = object_num
         vnum = viewer_num
         if (object_num.gt.10) num=object_num/100
         if (viewer_num.gt.10) vnum=viewer_num/100
         call xvmessage('Planet ephemerides not found',' ')
         call xvmessage('Using barycenter ephemerides',' ')
         call reset1
         call spkez(num,ephemeris_time,'J2000','LT',vnum,
     +      state,light_time)
         if (failed()) goto 902
      endif
c compute inertial to body-fixed rotation matrix tibf
      call bodmat(object_num,ephemeris_time - light_time,tibf)

c reverse state vector to from target to observer
      call vminus(state,state)

c rotate state into body-fixed
      call mxv(tibf,state,state)

c compute range to target, latitude & longitude of sub point
      call reclat(state,range,lon,lat)
      sclat=lat*dpr()
      sclon=lon*dpr()
      sclon=360.-sclon               ! convert to west
      if(sclon.gt.360.) sclon=sclon-360.
      if(sclon.lt.0.) sclon=sclon+360.

      write(msg,*)'Object center centric latitude=',sclat,' degrees'
      call xvmessage(msg,' ')
      write(msg,*)'Object center west longitude=',sclon,' degrees'
      call xvmessage(msg,' ')
      write(msg,*)'Object range= ',range,' km'
      call xvmessage(msg,' ')
      return

  900 call xvmessage('***Err loading SP kernel',' ')
      goto 999
  901 call xvmessage('***Err converting UTC to ET',' ')
      goto 999
  902 call xvmessage('***Err getting ephemeris data',' ')
  999 call xvmessage('***Ephemeris task canceled',' ')
      call abend
      end


!==========================================================================
elemental subroutine gsw_frazil_ratios_adiabatic (sa, p, w_ih, &
                              dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil)
!==========================================================================
!
!  Calculates the ratios of SA, CT and P changes when frazil ice forms or
!  melts in response to an adiabatic change in pressure of a mixture of
!  seawater and frazil ice crystals.
!
!  Note that the first output, dSA_dCT_frazil, is dSA/dCT rather than
!  dCT/dSA.  This is done so that when SA = 0, the output, dSA/dCT, is zero
!  whereas dCT/dSA would then be infinite.
!
!  Also note that both dSA_dP_frazil and dCT_dP_frazil are the pressure
!  derivatives with the pressure measured in Pa not dbar.
!
!  SA  =  Absolute Salinity of seawater                            [ g/kg ]
!  p   =  sea pressure of seawater at which melting occurs         [ dbar ]
!         ( i.e. absolute pressure - 10.1325d0 dbar )
!  w_Ih  =  mass fraction of ice, that is the mass of ice divided by the
!           sum of the masses of ice and seawater.  That is, the mass of
!           ice divided by the mass of the final mixed fluid.
!           w_Ih must be between 0 and 1.                      [ unitless ]
!
!  dSA_dCT_frazil =  the ratio of the changes in Absolute Salinity
!                    to that of Conservative Temperature       [ g/(kg K) ]
!  dSA_dP_frazil  =  the ratio of the changes in Absolute Salinity
!                    to that of pressure (in Pa)              [ g/(kg Pa) ]
!  dCT_dP_frazil  =  the ratio of the changes in Conservative Temperature
!                    to that of pressure (in Pa)                   [ K/Pa ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_ct_freezing_exact, gsw_enthalpy_ct_exact
use gsw_mod_toolbox, only : gsw_t_freezing_exact, gsw_enthalpy_ice
use gsw_mod_toolbox, only : gsw_adiabatic_lapse_rate_ice, gsw_cp_ice
use gsw_mod_toolbox, only : gsw_enthalpy_first_derivatives_ct_exact
use gsw_mod_toolbox, only : gsw_ct_freezing_first_derivatives
use gsw_mod_toolbox, only : gsw_t_freezing_first_derivatives

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p, w_ih
real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil

real (r8) :: bracket1, bracket2, cp_ih, gamma_ih, h, h_ih, part, rec_bracket3
real (r8) :: tf, wcp, h_hat_sa, h_hat_ct, tf_sa, tf_p, ctf, ctf_sa, ctf_p

real (r8), parameter :: saturation_fraction = 0.0_r8

ctf = gsw_ct_freezing_exact(sa,p,saturation_fraction)
tf = gsw_t_freezing_exact(sa,p,saturation_fraction)
h = gsw_enthalpy_ct_exact(sa,ctf,p)
h_ih = gsw_enthalpy_ice(tf,p)
cp_ih = gsw_cp_ice(tf,p)
gamma_ih = gsw_adiabatic_lapse_rate_ice(tf,p)
call gsw_enthalpy_first_derivatives_ct_exact(sa,ctf,p,h_hat_sa,h_hat_ct)
call gsw_t_freezing_first_derivatives(sa,p,saturation_fraction,tf_sa,tf_p)
call gsw_ct_freezing_first_derivatives(sa,p,saturation_fraction,ctf_sa,ctf_p)

wcp = cp_ih*w_ih/(1.0_r8 - w_ih)
part = (tf_p - gamma_ih)/ctf_p

bracket1 = h_hat_ct + wcp*part
bracket2 = h - h_ih - sa*(h_hat_sa + wcp*(tf_sa - part*ctf_sa))
rec_bracket3 = 1.0_r8/(h - h_ih - sa*(h_hat_sa + h_hat_ct*ctf_sa + wcp*tf_sa))

dsa_dct_frazil = sa*(bracket1/bracket2)
dsa_dp_frazil = sa*ctf_p*bracket1*rec_bracket3
dct_dp_frazil = ctf_p*bracket2*rec_bracket3

return
end subroutine

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


C    %W% %G%
      subroutine freqc
C * * *
C * * * THIS SUBROUTINE UPDATES THE PAST VALUE OF BUS
C * * * VOLTAGE ANGLE, BUS FREQUENCY, AND FILTERED BUS
C * * * FREQUENCY FOR ALL BUSES IN THE STUDY.
C * * * IT IS CALLED BY CNTRL.
C * * *
      include 'tspinc/params.inc'
      include 'tspinc/param.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/ldndxp.inc'
      include 'tspinc/busdta.inc'
      include 'tspinc/busvolt.inc'
      include 'tspinc/lshed1.inc'
      include 'tspinc/deltfq.inc'
      include 'tspinc/vrgov.inc'
      include 'tspinc/shdlod.inc'
C * * *
C * * *  CALCULATE BUS FREQUENCY AND FILTERED BUS FREQUENCY
C * * *  FOR ALL BUSES IN THE STUDY
C * * *
      do 100  ibus = 1,nmx
      dfreqo = deltfq(ibus)
      flfeqo = delfqo(ibus)
      eangp = emagrn(2,ibus)
      eyr1 = eyr(ibus)
      eyi1 = eyi(ibus)
      if((eyr1 .eq. 0.0) .and.(eyi1 .eq. 0.0)) go to 100
      eang=atan2(eyi1,eyr1)
      emagrn(2,ibus) = eang
C * * *
C   BYPASS ALL BUS FREQ CALCULATIONS WHEN COMING OUT OF DISCONTINUITY
C * * *
      if(i140.eq.0) go to 100
      delan = eang-eangp
      if(delan.lt.-3.14159) delan=delan+6.28318
      if(delan.gt. 3.14159) delan=delan-6.28318
C
C       A NEW ONE DIMENSIONED ARRAY NOW STORES THE BUS FREQUENCY
C       DIFFERENCE -- DELTFQ
C
      dfreq = delan/edt
      deltfq(ibus) = dfreq
C * * *
C * * * CALCULATE FILTERED BUS FREQUENCY DELFQO
C * * *
      if(tbusf .ne. 0.0)then
         flfeq = (dfreq + dfreqo +flfeqo*(abus-2.))*abusr
         delfqo(ibus) = flfeq
      endif
  100 continue
      return
      end


      subroutine BDKfillmm(k1,k2,k3,k4,k5,k6,mq,za,zb,ASLmm,Aslpp)
************************************************************************
*     Author: R.K. Ellis                                               *
*     August, 2010.                                                    *
************************************************************************
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      include 'scale.f'
      integer k1,k2,k3,k4,k5,k6,e
      double complex Lnrat,xl14,ASLmm(-2:0),ASLpp(-2:0),
     & A(-1:0),C0(-1:0),B0p23(-1:0),B0p3(-1:0),VV(-2:0),zba2
      double complex BDK1211mm,loreduced,lomm,lopp,qlI1,qlI2,qlI3,
     & BDKfinite
      double precision mq,mqsq,p2Dp3,s123,s234
      zba2(k1,k2,k3,k4)=zb(k1,k2)*za(k2,k4)+zb(k1,k3)*za(k3,k4)

      s123=+s(k1,k2)+s(k2,k3)+s(k3,k1)
      s234=+s(k2,k3)+s(k3,k4)+s(k4,k2)
      loreduced=2d0/(s(k5,k6)*s(k2,k3))
     & *(+za(k1,k6)/s234*zba2(k5,k3,k4,k2)*zb(k2,k4)
     &   -zb(k5,k4)/s123*za(k1,k2)*zba2(k2,k1,k3,k6))

      lomm=mq/zb(k2,k3)*loreduced
      lopp=mq/za(k2,k3)*loreduced
      xl14=Lnrat(musq,-s(k1,k4))

      VV(-2)=-cone
      VV(-1)=-(dcmplx(1.5d0)+xl14)
      VV(0)=-(dcmplx(4d0)+1.5d0*xl14+0.5d0*xl14**2)

      mqsq=mq**2
      do e=-1,0
      C0(e)=qlI3(mqsq,s(k2,k3),mqsq,zip,mqsq,mqsq,musq,e)
      B0p23(e)=qlI2(s(k2,k3),mqsq,mqsq,musq,e)
      B0p3(e)=qlI2(mqsq,zip,mqsq,musq,e)
      A(e)=qlI1(mqsq,musq,e)
      enddo
      p2Dp3=0.5d0*(s(k2,k3)-2d0*mqsq)

C---Contribution of Final vertex function (massive  case)
C   *(-2*p2.p3*C0(p2,p3,m,0,m)-B0(p23,m,m)+B0(p3,0,m)+1/2*A0(m)/m^2);

      VV(-1)=VV(-1)
     & +(-2d0*p2Dp3*C0(-1)+dcmplx(half))
      VV(0)=VV(0)
     & +(-2d0*p2Dp3*C0(0)-B0p23(0)+B0p3(0)+0.5d0*A(0)/mqsq)

      BDKfinite=BDK1211mm(k1,k2,k3,k4,k5,k6,za,zb)

      ASLmm(-2)=VV(-2)*lomm
      ASLmm(-1)=VV(-1)*lomm
      ASLmm(0)=VV(0)*lomm+BDKfinite*mq/zb(k2,k3)

      ASLpp(-2)=VV(-2)*lopp
      ASLpp(-1)=VV(-1)*lopp
      ASLpp(0)=VV(0)*lopp+BDKfinite*mq/za(k2,k3)
      return
      end


program main

  use mod_sha256

  implicit none

  integer, parameter  :: n = 3, num = 1000000
  character(len=1024) :: wBuffer, theMessage(n)
  character(len=64)   :: hashDigest, hashCorrect(n)
  integer :: i, j
  real    :: tStart, tEnd

  open(11,file="lipsum.txt")
  read(11,"(a1024)") wBuffer
  close(11)
  theMessage(1)  =  wBuffer
  hashCorrect(1) = "B6ACA4145A1DB0A151E1569F3B197E17ABD6329807BFFC531AB22053554066A7"

  theMessage(2)  = "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
  hashCorrect(2) = "248D6A61D20638B8E5C026930C3E6039A33CE45964FF2167F6ECEDD419DB06C1"

  theMessage(3)  = "abc"
  hashCorrect(3) = "BA7816BF8F01CFEA414140DE5DAE2223B00361A396177A9CB410FF61F20015AD"

  do i=1,n
    call cpu_time(tStart)
    do j=1,num
      call sha256_init(trim(theMessage(i)))
      call sha256_hash
    end do
    call cpu_time(tEnd)
    call sha256_digest(hashDigest)

    if(hashDigest /= hashCorrect(i)) then
      write(*,"(a)") "SHA-256 Failed :("
    end if
    write(*,"(a,i0,a,i3,a,f10.6,a)") "Digested ",num," messages of ",len_trim(theMessage(i))," bytes in ",tEnd-tStart," seconds."
  end do

end program main


! This file is part of nlopt-f.
! SPDX-Identifier: Apache-2.0 OR MIT
!
! Licensed under either of Apache License, Version 2.0 or MIT license
! at your option; you may not use this file except in compliance with
! the License.
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module test_opt
  use nlopt_wrap
  use nlopt_enum
  use testdrive, only : unittest_type, new_unittest, error_type, check
  implicit none
  private

  public :: collect_opt

  integer, parameter :: wp = kind(0.0d0)
  type :: constraint_data
    real(wp) :: d(2)
  end type
contains

!> Collect all exported unit tests
subroutine collect_opt(testsuite)
   !> Collection of tests
   type(unittest_type), allocatable, intent(out) :: testsuite(:)

   testsuite = [ &
     new_unittest("example", test_example) &
     ]
end subroutine collect_opt

subroutine test_example(error)
  !> Error handling
  type(error_type), allocatable, intent(out) :: error

  type(nlopt_opt) :: opt

  real(wp) :: lb(2), x(2), minf
  integer :: stat
  type(constraint_data), target :: d1, d2
  real(wp), parameter :: xtol = 1.0e-4_wp

  call create(opt, algorithm_from_string("LD_MMA"), 2)

  call opt%get_lower_bounds(lb, stat)
  call check(error, stat, NLOPT_SUCCESS)
  if (allocated(error)) return

  lb(2) = 0.0_wp
  call opt%set_lower_bounds(lb, stat)
  call check(error, stat, NLOPT_SUCCESS)
  if (allocated(error)) return

  d1%d = [+2.0_wp, +0.0_wp]
  d2%d = [-1.0_wp, +1.0_wp]
  associate(&
      & f => nlopt_func(myfunc), &
      & fc1 => nlopt_func(myconstraint, d1), &
      & fc2 => nlopt_func(myconstraint, d2))
    call opt%set_min_objective(f, stat)
    call check(error, stat, NLOPT_SUCCESS)
    if (allocated(error)) return

    call opt%add_inequality_constraint(fc1, 1.0e-8_wp, stat)
    call check(error, stat, NLOPT_SUCCESS)
    if (allocated(error)) return

    call opt%add_inequality_constraint(fc2, 1.0e-8_wp, stat)
    call check(error, stat, NLOPT_SUCCESS)
    if (allocated(error)) return

    call opt%set_xtol_rel(xtol, stat)
    call check(error, stat, NLOPT_SUCCESS)
    if (allocated(error)) return

    x = [1.234_wp, 5.678_wp]
    call opt%optimize(x, minf, stat)
    call check(error, stat, NLOPT_XTOL_REACHED)
    if (allocated(error)) return
  end associate

  call check(error, x(1), 0.33333333_wp, thr=xtol, rel=.true.)
  call check(error, x(2), 0.29629629_wp, thr=xtol, rel=.true.)
  call check(error, minf, 0.54433105_wp, thr=xtol, rel=.true.)

  call destroy(opt)
end subroutine test_example

function myfunc(x, gradient, func_data) result(f)
  real(wp), intent(in) :: x(:)
  real(wp), intent(inout), optional :: gradient(:)
  class(*), intent(in), optional :: func_data
  real(wp) :: f

  if (present(gradient)) then
    gradient(1) = 0.0_wp
    gradient(2) = 0.5_wp / sqrt(x(2))
  endif
  f = sqrt(x(2))
end function myfunc

function myconstraint(x, gradient, func_data) result(f)
  real(wp), intent(in) :: x(:)
  real(wp), intent(inout), optional :: gradient(:)
  class(*), intent(in), optional :: func_data
  real(wp) :: f

  select type(func_data)
  type is(constraint_data)
    associate(a => func_data%d(1), b => func_data%d(2))
      if (present(gradient)) then
        gradient(1) = 3.0_wp * a * (a*x(1) + b)**2
        gradient(2) = -1.0_wp
      endif
      f = (a*x(1) + b)**3 - x(2)
    end associate
  end select
end function myconstraint

end module test_opt


module fibresLib

use funcAux
use fibresModelsLib

implicit none

public calcSfib, calcDSfib, setFibreKinematic, setFibreKinematicSimple, &
		 getLambdaFibre, getLambdaFibreSimple, getEnergyFibre, calc_Kstiff_and_Res_TorsionalSpring, getTorsionalPsi

!~ 	call calcSfib(Sfib,qfib,matPar,constLaw)
!~ 	call calcDSfib(DSfib,qfib,matPar,constLaw)

contains

real*8 function getLambdaFibre(SolU,Xel,iFtype,NdimE) result(lambda)
	Real*8 , intent(in) :: SolU(:) , Xel(:)
	integer , intent(in) :: NdimE, iFtype
	Real*8  :: DeltaU(NdimE), afib(NdimE), qfib(NdimE), Lfib

	call setFibreKinematic(qfib,DeltaU,afib,Lfib,SolU,Xel,iFtype)

	lambda = norm2(qfib)

end function

real*8 function getEnergyFibre(SolU,Xel,MatPar,constLaw,iFtype,NdimE) result(energy)
	Real*8 , intent(in) :: SolU(:) , Xel(:), MatPar(:)
	integer , intent(in) :: NdimE, iFtype, constLaw
	Real*8  :: DeltaU(NdimE), afib(NdimE), qfib(NdimE), Lfib

	call setFibreKinematic(qfib,DeltaU,afib,Lfib,SolU,Xel,iFtype)

!~ 	write(0,*) 'qfib ===== ' , matPar(1), matPar(2) , matPar(3)
!~ 	if (norm2(qfib) > matPar(3) )then
!~ 		write(0,*)	(900.0/8.0d0)*(norm2(qfib) - matPar(3))**2.0d0
!~ 	end if
	call strainEnergy_fib(energy,qfib,MatPar,constLaw)

end function

real*8 function getLambdaFibreSimple(SolU,afib,Lfib,iFtype,NdimE) result(lambda)
	Real*8 , intent(in) :: SolU(:) , afib(:), Lfib
	integer , intent(in) :: NdimE, iFtype
	Real*8  :: DeltaU(NdimE), qfib(NdimE)

	call setFibreKinematicSimple(qfib,DeltaU,afib,Lfib,SolU,iFtype)

	lambda = norm2(qfib)

end function

subroutine get_afib(afib,Lfib,Xel)
	use globalVariables, only : NdimE
	Real*8 , intent(out) :: afib(:), Lfib
	Real*8 , intent(in) :: Xel(:)
	integer i

	do i = 1, NdimE
		afib(i) = Xel(NdimE + i) - Xel(i)
	end do

	Lfib = norm2(afib)
	afib = afib/Lfib

end subroutine

subroutine get_afibbar(afibbar,Xel)
	use globalVariables, only : NdimE
	Real*8 , intent(out) :: afibbar(:)
	Real*8 , intent(in) :: Xel(:)
	integer i

	do i = 1, NdimE
		afibbar(i) = 0.5d0*(Xel(NdimE + i) + Xel(i))
	end do

end subroutine

subroutine setFibreKinematic(qfib,DeltaU,afib,Lfib,SolU,Xel,iFtype)
	use globalVariables, only : getF, NdimE

	Real*8 , intent(out) :: DeltaU(:), afib(:), qfib(:), Lfib
	Real*8 , intent(in) :: SolU(:) , Xel(:)
	integer , intent(in) :: iFtype
	real*8 :: F(NdimE,NdimE)
	integer i

	call getF(F,iFtype)

	call get_afib(afib,Lfib,Xel)

	do i = 1, NdimE
		DeltaU(i) = SolU(NdimE+i) - SolU(i)
	end do

	qfib = matmul(F,afib) + DeltaU/Lfib

end subroutine

subroutine setFibreKinematicSimple(qfib,DeltaU,afib,Lfib,SolU,iFtype)
	use globalVariables, only : getF, NdimE

	Real*8 , intent(out) :: DeltaU(:), qfib(:)
	Real*8 , intent(in) :: SolU(:) , afib(:), Lfib
	integer , intent(in) :: iFtype
	real*8 :: F(NdimE,NdimE)
	integer i

	call getF(F,iFtype)
!~ 	call numprint(F)

	do i = 1, NdimE
		DeltaU(i) = SolU(NdimE+i) - SolU(i)
	end do

	qfib = matmul(F,afib) + DeltaU/Lfib

end subroutine

subroutine setFibreKinematicSimple2(qfib,F,SolUf,afib,Lfib)
	use globalVariables, only : getF, NdimE

	Real*8 , intent(out) :: qfib(:)
	Real*8 , intent(in) :: SolUf(:) , afib(:), F(:,:), Lfib
	integer :: i

	qfib = matmul(F,afib)

	do i = 1,NdimE
		qfib(i) = qfib(i) + (SolUf(NdimE + i) - SolUf(i))/Lfib
	end do

end subroutine

subroutine calcSfib(Sfib,qfib,matPar,constLaw,NdimE)
	integer , intent(in) :: constLaw, NDimE
	real*8, intent(in) :: MatPar(:), qfib(NDimE)
	real*8, intent(out) :: Sfib(NDimE)
	logical , parameter :: isAnalitic = .false.

	if(isAnalitic) then
		call SfibAnalytic(Sfib,qfib,matPar,constLaw)
	else
		call calcSfibNumeric(Sfib,qfib,matPar,constLaw,NdimE)
	end if

end subroutine

subroutine calcDSfib(DSfib,qfib,matPar,constLaw,NdimE)
	integer , intent(in) :: constLaw, NDimE
	real*8, intent(in) :: MatPar(:), qfib(NDimE)
	real*8, intent(out) :: DSfib(NDimE,NdimE)
	logical , parameter :: isAnalitic = .false.

	if(isAnalitic) then
		call DSfibAnalytic(DSfib,qfib,matPar,constLaw)
	else
		call calcDSfibNumeric(DSfib,qfib,matPar,constLaw,NdimE)
	end if

end subroutine

subroutine calcSfibNumeric(Sfib,qfib,matPar,constLaw,NdimE)
	integer , intent(in) :: constLaw, NDimE
	real*8, intent(in) :: MatPar(:), qfib(NDimE)
	real*8, intent(out) :: Sfib(NDimE)
	real*8 , parameter :: eps = 1.d-4
	real*8 ::  qfibP(NDimE), inv2eps, energyPr , energyPl
	integer :: i

	inv2eps = 0.5d0/eps

	Do i=1,NdimE
		qfibP=qfib
		qfibP(i) = qfibP(i) + eps
		Call strainEnergy_fib(energyPr,qfibP,MatPar,constLaw)

		qfibP=qfib
		qfibP(i) = qfibP(i) - eps
		Call strainEnergy_fib(energyPl,qfibP,MatPar,constLaw)

		Sfib(i) = (energyPr - energyPl)*inv2eps
	Enddo

end subroutine

subroutine calcDSfibNumeric(DSfib,qfib,matPar,constLaw,NdimE)
	integer , intent(in) :: constLaw, NDimE
	real*8, intent(in) :: MatPar(:), qfib(NDimE)
	real*8, intent(out) :: DSfib(NDimE,NdimE)
	real*8 , parameter :: eps = 1.d-4
	real*8 ::  qfibP(NDimE), inveps2, inv4eps2, energy, energyPr , energyPl,  &
				energyPrr , energyPrl , energyPlr, energyPll
	integer :: i,j

	Call strainEnergy_fib(energy,qfib,MatPar,constLaw)

	inveps2 = 1.0d0/(eps*eps)
	inv4eps2 = 0.25d0/(eps*eps)

	Do i=1,NdimE
		qfibP=qfib
		qfibP(i) = qfibP(i) + eps
		Call strainEnergy_fib(energyPr,qfibP,MatPar,constLaw)

		qfibP=qfib
		qfibP(i) = qfibP(i) - eps
		Call strainEnergy_fib(energyPl,qfibP,MatPar,constLaw)

		DSfib(i,i) = (energyPr + energyPl - 2.0d0*energy)*inveps2
	Enddo

	Do i=1,NdimE
	Do j=i+1,NdimE
		qfibP=qfib
		qfibP(i) = qfibP(i) + eps
		qfibP(j) = qfibP(j) + eps
		Call strainEnergy_fib(energyPrr,qfibP,MatPar,constLaw)

		qfibP=qfib
		qfibP(i) = qfibP(i) + eps
		qfibP(j) = qfibP(j) - eps
		Call strainEnergy_fib(energyPrl,qfibP,MatPar,constLaw)

		qfibP=qfib
		qfibP(i) = qfibP(i) - eps
		qfibP(j) = qfibP(j) + eps
		Call strainEnergy_fib(energyPlr,qfibP,MatPar,constLaw)

		qfibP=qfib
		qfibP(i) = qfibP(i) - eps
		qfibP(j) = qfibP(j) - eps
		Call strainEnergy_fib(energyPll,qfibP,MatPar,constLaw)

		DSfib(i,j) = (energyPrr + energyPll - energyPrl - energyPlr)*inv4eps2
		DSfib(j,i) = DSfib(i,j)
	Enddo
	Enddo

end subroutine

!~ subroutine SfibAnalytic(Sfib,qfib,matPar,constLaw)
!~ 	real*8, intent(in) :: qfib(:) , matPar(:)
!~ 	real*8 , intent(out) :: Sfib(:)
!~ 	integer , intent(in) :: constLaw
!~ 	real*8 :: I4, dPsi

!~ 	Sfib = 0.0d0

!~ 	I4 = dot_product(qfib,qfib)

!~ 	select case(constLaw)
!~ 		case(1)
!~ 			call dFibreExponential(dPsi,I4,matPar(1:3))
!~ 		case(2)
!~ 			call dFibreLinear(dPsi,I4,matPar(1:3))
!~ 		case(15)
!~ 			call dFibreLinearComp(dPsi,I4,matPar(1:3))
!~ 		case default
!~ 			write(0,*) constLaw, matpar(1:3), "Strain Energy case unknown"
!~ 			PAUSE
!~ 	end select

!~ 	Sfib = 2.0d0*dPsi*qfib

!~ end subroutine

!~ subroutine DSfibAnalytic(DSfib,qfib,matPar,constLaw)
!~ 	real*8, intent(in) :: qfib(:) , matPar(:)
!~ 	real*8 , intent(out) :: DSfib(:,:)
!~ 	integer , intent(in) :: constLaw
!~ 	real*8 :: I4, dPsi, d2Psi

!~ 	DSfib = 0.0d0

!~ 	I4 = dot_product(qfib,qfib)

!~ 	select case(constLaw)
!~ 		case(1)
!~ 			call dFibreExponential(dPsi,I4,matPar(1:3))
!~ 			call d2FibreExponential(d2Psi,I4,matPar(1:3))
!~ 		case(2)
!~ 			call dFibreLinear(dPsi,I4,matPar(1:3))
!~ 			call d2FibreLinear(d2Psi,I4,matPar(1:3))
!~ 		case(15)
!~ 			call dFibreLinearComp(dPsi,I4,matPar(1:3))
!~ 			call d2FibreLinearComp(d2Psi,I4,matPar(1:3))
!~ 		case default
!~ 			write(0,*) constLaw, matpar(1:3), "Strain Energy case unknown"
!~ 			PAUSE
!~ 	end select

!~ 	DSfib(1,1) = 4.0d0*d2Psi*qfib(1)*qfib(1) + 2.0d0*dPsi
!~ 	DSfib(1,2) = 4.0d0*d2Psi*qfib(1)*qfib(2)
!~ 	DSfib(2,1) = 4.0d0*d2Psi*qfib(2)*qfib(1)
!~ 	DSfib(2,2) = 4.0d0*d2Psi*qfib(2)*qfib(2) + 2.0d0*dPsi

!~ end subroutine

subroutine calcSfibDSfib_analytic(Sfib,DSfib,qfib,matPar,constLaw)
	use globalVariables, only : NdimE
	real*8, intent(in) :: qfib(:) , matPar(:)
	real*8 , intent(out) :: Sfib(:), DSfib(:,:)
	integer , intent(in) :: constLaw
	real*8 :: dPsi, d2Psi

	call derivatives_strainEnergy_fib(dPsi,d2Psi,qfib,matPar,constLaw)

	Sfib = 2.0d0*dPsi*qfib

!~ 	DSfib(1,1) = 4.0d0*d2Psi*qfib(1)*qfib(1) + 2.0d0*dPsi
!~ 	DSfib(1,2) = 4.0d0*d2Psi*qfib(1)*qfib(2)
!~ 	DSfib(2,1) = 4.0d0*d2Psi*qfib(2)*qfib(1)
!~ 	DSfib(2,2) = 4.0d0*d2Psi*qfib(2)*qfib(2) + 2.0d0*dPsi

	DSfib = 0.0d0
	call VotimesW(DSfib,qfib,qfib)
	DSfib = 4.0d0*d2Psi*DSfib + 2.0d0*dPsi*deltaKron(1:NdimE,1:NdimE)

end subroutine

real*8 function getTorsionalPsi(X,U,eta) result(Psi) ! just for 2D
	real*8 , intent(in) :: eta, X(:), U(:)
	integer, parameter :: NdimE = 2, NodG =3
	real*8 :: M1(NdimE), M2(NdimE), q1(NdimE), q2(NdimE), &
			  L1, L2, a, b, c, Dang

	M1 = X(3:4) - X(1:2)
	M2 = X(5:6) - X(1:2)
	L1 = norm2(M1)
	L2 = norm2(M2)

	M1 = M1/L1
	M2 = M2/L2

	q1 = M1 + (U(3:4) - U(1:2))/L1
	q2 = M2 + (U(5:6) - U(1:2))/L2

	q1 = q1/norm2(q1)
	q2 = q2/norm2(q2)

	a = dot_product(q1,q2)
	b = dot_product(M1,M2)

	c = a*b + dsqrt((1.0 - a*a)*(1.0 - b*b))
	Dang = dacos(c)

	Psi = 0.5*eta*Dang**2.0

end function

!!! Torsional Springs
subroutine calc_Kstiff_and_Res_TorsionalSpring(Kstiff, Res, X,U,eta) ! just for 2D

	integer, parameter :: NdimE=2, NodG = 3
	real*8, intent(in) :: X(:), U(:), eta
	real*8, intent(out) :: Kstiff(NdimE*NodG,NdimE*NodG) , Res(NdimE*NodG)
	real*8 , parameter :: eps = 1.d-5
	real*8 ::  Up(NodG*NDimE), inv2eps, inveps2, inv4eps2, &
			energy, energyPr , energyPl, energyPrr , energyPrl , energyPlr, energyPll
	integer :: i ,j, n

	inv2eps = 0.5d0/eps
	inveps2 = 1.0d0/(eps*eps)
	inv4eps2 = 0.25d0/(eps*eps)

	energy = getTorsionalPsi(X,U,eta)

	n = NdimE*NodG
	Do i=1,n
		Up=U
		Up(i) = Up(i) + eps
		energyPr = getTorsionalPsi(X,Up,eta)

		Up=U
		Up(i) = Up(i) - eps
		energyPl = getTorsionalPsi(X,Up,eta)

		Res(i) = (energyPr - energyPl)*inv2eps

		Kstiff(i,i) = (energyPr + energyPl - 2.0d0*energy)*inveps2

		Do j=i+1,n
			Up=U
			Up(i) = Up(i) + eps
			Up(j) = Up(j) + eps
			energyPrr = getTorsionalPsi(X,Up,eta)

			Up=U
			Up(i) = Up(i) + eps
			Up(j) = Up(j) - eps
			energyPrl = getTorsionalPsi(X,Up,eta)

			Up=U
			Up(i) = Up(i) - eps
			Up(j) = Up(j) + eps
			energyPlr = getTorsionalPsi(X,Up,eta)

			Up=U
			Up(i) = Up(i) - eps
			Up(j) = Up(j) - eps
			energyPll = getTorsionalPsi(X,Up,eta)

			Kstiff(i,j) = (energyPrr + energyPll - energyPrl - energyPlr)*inv4eps2
			Kstiff(j,i) = Kstiff(i,j)
		Enddo
	Enddo

end subroutine

end module


-- A simple form of processes: functions that accept
-- a number and return a number and a new process.

-- Process is a recursively defined _function_.
Process = Rec A. Nat -> { Nat, A };

-- A helper plus.
plus = fix (lambda s: Nat -> Nat -> Nat.
              lambda x: Nat. lambda y: Nat.
                if iszero y
                then x
                else s (succ x) (pred y));

-- A process p.
p = fix (lambda f: Nat -> Process. lambda acc: Nat. lambda n: Nat.
           let newacc = plus acc n in
           { newacc, f newacc }) 0;

-- Auxiliary functions.
curr = lambda s: Process. (s 0).1;
send = lambda n: Nat. lambda s: Process. ((s n).2) as Process;

curr (send 20 (send 3 (send 5 p)));


c filename: grid3d.f
c
c     An example of using PSPARSLIB to find extreme eigenvalues of
c     3-D Lapalacian operator.
c
      program grid3d
      implicit none
      include 'simphb.h'
      include 'mpif.h'
c     .. Parameters ..
      integer            memsize
      parameter          (memsize=2000000)
      double precision   one
      parameter          (one = 1.0D0)
c     ..
c     .. Local Scalars ..
      character*128      dimstr
      integer            i, ierr, j, maxlan, maxnloc, maxnzloc,
     &                   mpicom, mpx, msglvl, neig, ngridx, nloc, nw
      double precision   condm, endl, endr, kappa, lanso_time,
     &                   setup_time
c     ..
c     .. Local Arrays ..
      integer            riord(*), split(MAX_PROCS+1)
      double precision   bnd(*), ritz(*), wrk(*)
      pointer (pwrk, wrk), (pritz, ritz), (pbnd, bnd), (priord, riord)
c     ..
c     .. External Functions ..
      integer            iargc, ncells
      external           iargc
c     ..
c     .. External Subroutines ..
      external           dmalloc, dmfree, g3dmat, plandr2,
     &                   psp_setup
c     ..
      NCELLS(Nloc,i) = 5*Nloc+4*i+1+MAX(Nloc,i+1)
c     .. Executable Statements ..
      msglvl = 5
      amxtype = 30
      ptrn = 1
      kappa = 1.0D-8
c
      paloc = 0
      pjaloc = 0
      pialoc = 0
      pix = 0
      pqq = 0
      pwrk = 0
      pritz = 0
      pbnd = 0
      kmvcnt = 0
      mmvcnt = 0
      nreorth = 0
      kmvtime = 0
      mmvtime = 0
      reorthtime = 0
c
      call mpi_init(ierr)
      if (ierr.ne.mpi_success)stop 'FAILED TO INIT MPI'
      mpicom = mpi_comm_world
      call mpi_comm_size(mpi_comm_world, totprocs, ierr)
      call mpi_comm_rank(mpi_comm_world, myproc, ierr)
c
      if (iargc().gt.0) then
         call getarg(1, dimstr)
cCRAY         call pxfgetarg(1, dimstr, i, ierr)
         read(dimstr, *, iostat=ierr) ngridx
         if (ierr.ne.0)call mpi_abort(mpicom, ierr)
      else
         ngridx = 32
      endif
c
      mpx = nint(exp(log(dble(totprocs))/3.0D0))
      if (mpx*mpx*mpx.ne.totprocs) then
         if (myproc.eq.0)print *,
     &       'GRID3D: number of processors must be cubic.'
         call mpi_abort(mpicom, ierr)
      endif
      setup_time = mpi_wtime()
c
c     generate the local portion of the matrix and setup the data
c     structure required for matrix-vector multiplication
c
      call g3dmat(ngridx, ngridx, ngridx, mpx, mpx, mpx, myproc,
     &            maxnloc, maxnzloc, nloc, paloc, pjaloc, pialoc, split)
      call psp_setup(maxnloc, maxnzloc, nloc, myproc, totprocs, split,
     &               aloc, jaloc, ialoc, priord, nbnd, nproc, proc, pix,
     &               ipr, mpicom, ierr)
      if (ierr.ne.0) then
         print *, 'PSP_SETUP failed with error code ', ierr
         call mpi_abort(mpicom, ierr)
      endif
c
c     the workspace for LANSO is allocated to fill up to
c     the maximum memory size available
c
      i = 2*maxnzloc + 4*maxnloc + 8*nloc
      if (totprocs.gt.1 .and. pix.ne.0) then
         i = i + 3*(nloc+max(ipr(nproc+1),ipr(nproc+2)))
      endif
      endl = dble(memsize-i) / dble(nloc+5)
      if (mpi_real8.eq.0) then
         call mpi_allreduce(endl, endr, 1, mpi_double_precision,
     &                      mpi_min, mpicom, ierr)
      else
         call mpi_allreduce(endl, endr, 1, mpi_real8, mpi_min, mpicom,
     &                      ierr)
      endif
      if (ierr.ne.mpi_success) then
         print *, 'GRID: failed to compute MAXLAN.'
         call mpi_abort(mpicom, ierr)
      endif
      maxlan = min(int(endr), split(totprocs+1)-1)
      nw = ncells(nloc, maxlan)
      call dmalloc(pqq, nloc*(maxlan+2), 8)
      call dmalloc(pwrk, nw, 8)
      call dmalloc(pritz, maxlan, 8)
      call dmalloc(pbnd, maxlan, 8)
      endl = -1.0D-30
      endr = 1.0D-30
      condm = one
c
c     the initial guess for the eigenvector is always [1,1,...,1]^T
c
      do 10 i = 1, nloc
         wrk(i) = one
 10   continue
      if (myproc.eq.0 .and. msglvl.gt.0) then
         write(*, FMT = '(/A$)')'GRID: '
         print *, 'NPROCS = ', totprocs, '      MAXLAN = ', maxlan
         if (msglvl.gt.5) then
            print *, 'Matrix distribution:', split(1),
     &         ('--', split(i), i = 2, totprocs+1)
         endif
      endif
      lanso_time = mpi_wtime()
      setup_time = lanso_time - setup_time
c
c     main loop to compute the smallest eigenvalue
c
      j = 0
c$$$      call plandr2(nloc, maxlan, 5, 1, condm, kappa, j, neig, ritz, bnd,
c$$$     &             wrk, nw, ierr, msglvl, mpicom)
      call pLANDR(Nloc,MAXLAN,MAXLAN,CONDM,ENDL,ENDR,0,KAPPA,
     &           J,NEIG,RITZ,BND,WRK,NW,IERR,MSGLVL,MPICOM)
      if (ierr.ne.0) then
         print *, 'LANDR returned with error code = ', ierr
         if (j.le.0)call mpi_abort(mpi_comm_world, ierr)
      endif
c
      lanso_time = mpi_wtime() - lanso_time
      call dmfree(pwrk)
      call dmfree(pqq)
      if (mpi_real8.eq.0) then
         call mpi_reduce(setup_time, endl, 1, mpi_double_precision,
     &                   mpi_sum, 0, mpicom, ierr)
         call mpi_reduce(lanso_time, endr, 1, mpi_double_precision,
     &                   mpi_sum, 0, mpicom, ierr)
      else
         call mpi_reduce(setup_time, endl, 1, mpi_real8, mpi_sum, 0,
     &                   mpicom, ierr)
         call mpi_reduce(lanso_time, endr, 1, mpi_real8, mpi_sum, 0,
     &                   mpicom, ierr)
      endif
c
      condm = max(abs(ritz(1)), abs(ritz(j)))
      if (myproc.eq.0) then
         setup_time = endl / totprocs
         lanso_time = endr / totprocs
         print *, 'STEPS= ', j, '    NEIG = ',
     &      neig, '    ||A||=', condm
         print *, 'Setup time = ', setup_time, 'sec'
         print *, 'LANSO time = ', lanso_time, 'sec'
         print *, 'MATVEC = ', kmvcnt, mmvcnt, '  time ', kmvtime,
     &      mmvtime
         print *, 'N reorth = ', nreorth, '  time ', reorthtime
         if (msglvl.gt.3) then
            condm = kappa*condm
            write(*, FMT = 9999)
            write(*, FMT = 9989)1, ritz(1), bnd(1)
            do 20 i = 2, j-1
               if (bnd(i).le.condm)
     &              write(*, FMT = 9989)i, ritz(i), bnd(i)
 20         continue
            write(*, FMT = 9989)j, ritz(j), bnd(j)
         endif
      endif
 9999 format(1X, '   INDEX       Lambda(LANSO)       ErrorBound')
 9989 format(1X, I8, G25.17, 2X, 1P, E10.2)
c
      call mpi_finalize(ierr)
c
      end
c-----------------------------------------------------------------------
      subroutine opm(n, x, y, mpicom)
      implicit none
      include 'mpif.h'
      include 'simphb.h'
c     .. Scalar Arguments ..
      integer            mpicom, n
c     ..
c     .. Array Arguments ..
      double precision   x(n), y(n)
c     ..
c     .. Local Scalars ..
      integer            i
      double precision   tmptime
c     ..
c     .. Executable Statements ..
      mmvcnt = mmvcnt + 1
      tmptime = mpi_wtime()
      do 10 i = 1, n
         y(i) = x(i)
 10   continue
      mmvtime = mmvtime + mpi_wtime() - tmptime
      return
c     end subroutine opm
      end
c-----------------------------------------------------------------------
      subroutine op(n, p, q, r, mpicom)
      implicit none
      include 'mpif.h'
      include 'simphb.h'
c     .. Scalar Arguments ..
      integer            mpicom, n
c     ..
c     .. Array Arguments ..
      double precision   p(n), q(n), r(n)
c     ..
c     .. Local Scalars ..
      integer            length, lentmp
      double precision   tmptime
c     ..
c     .. Local Arrays ..
      double precision   xtmp(*), ytmp(*)
      pointer (pxtmp, xtmp), (pytmp, ytmp)
c     ..
c     .. External Subroutines ..
      external           amux, amxdis, dcopy, dmalloc, dmfree
c     ..
c     .. Save statement ..
      save               pxtmp, pytmp, length
c     ..
c     .. Data statements ..
      data               pxtmp, pytmp, length / 3*0 /
c     ..
c     .. Executable Statements ..
c
      kmvcnt = kmvcnt + 1
      tmptime = mpi_wtime()
      if (totprocs.gt.1) then
c
c     allocte enough temporary workspace before calling amxdis
c
         lentmp = n + max(ipr(nproc+1), ipr(nproc+2))
         if (length.lt.lentmp) then
            if (length.gt.0) then
               call dmfree(pxtmp)
               call dmfree(pytmp)
            endif
            call dmalloc(pxtmp, lentmp, 8)
            call dmalloc(pytmp, lentmp, 8)
            length = lentmp
         endif
         call dcopy(n, q, 1, xtmp, 1)
         call amxdis(n, nbnd, xtmp, ytmp, aloc, jaloc, ialoc, nproc,
     &               proc, ix, ipr, amxtype, length, ptrn)
         call dcopy(n, ytmp, 1, r, 1)
         if (xtmp(length+1).ne.0 .or. ytmp(length+1).ne.0) then
            print *, 'Guard elements of xtmp and ytmp are:',
     &         xtmp(length+1), ytmp(length+1)
         endif
      else
         call amux(n, q, r, aloc, jaloc, ialoc)
      endif
c
      kmvtime = kmvtime + mpi_wtime() - tmptime
      return
c     end subroutine op
      end
c-----------------------------------------------------------------------
      subroutine g3dmat(nx, ny, nz, mpx, mpy, mpz, myproc, nmax, nzmax,
     &                  nloc, paval, pja, pia, split)
c     .. Scalar Arguments ..
      integer            mpx, mpy, mpz, myproc, nloc, nmax, nx, ny, nz,
     &                   nzmax
c     ..
c     .. Array Arguments ..
      integer            split(mpx*mpy*mpz+1)
      integer            ia(*), ja(*)
      double precision   aval(*)
      pointer (paval, aval), (pja, ja), (pia, ia)
c     ..
c
c     G3DMAT: creats the part of the matrix on a subcube to be used by
c     PSPARSLIB
c
c     .. Local Scalars ..
      integer            i, ioffx, ipx, ipy, ipz, irow, ix, jcol,
     &                   joffy, jy, knz, koffz, kz, nxy
      double precision   dim
c     ..
c     .. External Subroutines ..
      external           dmalloc
c     ..
c     .. Intrinsic Functions ..
      intrinsic          int
c     ..
c     .. Executable Statements ..
      if (nx.gt.1 .and. ny.gt.1 .and. nz.gt.1) then
         dim = 6
      else if ((nx.gt.1 .and. ny.gt.1) .or. (nz.gt.1 .and. ny.gt.1) .or.
     &         (nx.gt.1 .and. nz.gt.1)) then
         dim = 4
      else
         dim = 2
      endif
      nxy = nx*ny
      nloc = nxy*nz
      ioffx = nloc - nx + 1
      joffy = nloc*mpx - (ny-1)*nx
      koffz = nloc*mpx*mpy - (nz-1)*nxy
      ipz = myproc / (mpx*mpy)
      ipy = (myproc-ipz*mpx*mpy) / mpx
      ipx = myproc - (ipz*mpy+ipy)*mpx
      split(1) = 1
      do 10 i = 1, mpx*mpy*mpz
         split(i+1) = split(i) + nloc
 10   continue
      nmax = nloc+nloc
      nzmax = int(dim+1)*nloc
      call dmalloc(paval, nzmax, 8)
      call dmalloc(pja, nzmax, 1)
      call dmalloc(pia, nmax+1, 1)
c
      irow = 0
      jcol = 0
      knz = 1
      ia(1) = 1
      do 40 kz = 1, nz
         do 30 jy = 1, ny
            do 20 ix = 1, nx
               jcol = split(myproc+1) + irow
               irow = irow + 1
               aval(knz) = dim
               ja(knz) = jcol
               knz = knz + 1
c     +/- x
               if (ipx.gt.0 .or. ix.gt.1) then
                  aval(knz) = -1
                  if (ix.gt.1) then
                     ja(knz) = jcol - 1
                  else
                     ja(knz) = jcol - ioffx
                  endif
                  knz = knz + 1
               endif
               if (ipx.lt.mpx-1 .or. ix.lt.nx) then
                  aval(knz) = -1
                  if (ix.lt.nx) then
                     ja(knz) = jcol + 1
                  else
                     ja(knz) = jcol + ioffx
                  endif
                  knz = knz + 1
               endif
c     +/- y
               if (ipy.gt.0 .or. jy.gt.1) then
                  aval(knz) = -1
                  if (jy.gt.1) then
                     ja(knz) = jcol - nx
                  else
                     ja(knz) = jcol - joffy
                  endif
                  knz = knz + 1
               endif
               if (ipy.lt.mpy-1 .or. jy.lt.ny) then
                  aval(knz) = -1
                  if (jy.lt.ny) then
                     ja(knz) = jcol + nx
                  else
                     ja(knz) = jcol + joffy
                  endif
                  knz = knz + 1
               endif
c     +/- z
               if (ipz.gt.0 .or. kz.gt.1) then
                  aval(knz) = -1
                  if (kz.gt.1) then
                     ja(knz) = jcol - nxy
                  else
                     ja(knz) = jcol - koffz
                  endif
                  knz = knz + 1
               endif
               if (ipz.lt.mpz-1 .or. kz.lt.nz) then
                  aval(knz) = -1
                  if (kz.lt.nz) then
                     ja(knz) = jcol + nxy
                  else
                     ja(knz) = jcol + koffz
                  endif
                  knz = knz + 1
               endif
c
               ia(irow+1) = knz
 20         continue
 30      continue
 40   continue
c
      return
c     end g3dmat
      end


program example_simple
  use mod_network, only: network_type
  implicit none
  type(network_type) :: net
  real, allocatable :: input(:), output(:)
  integer :: i
  net = network_type([3, 5, 2])
  input = [0.2, 0.4, 0.6]
  output = [0.123456, 0.246802]
  do i = 1, 500
    call net % train(input, output, eta=1.0)
    print *, 'Iteration: ', i, 'Output:', net % output(input)
  end do
end program example_simple


c
        subroutine fixcapaq(val,aux,mitot,mjtot,valc,auxc,mic,mjc,
     &                      nvar,naux,levc)

      implicit double precision (a-h,o-z)

      include "call.i"
c
c :::::::::::::::::::::::  FIXCAPAQ ::::::::::::::::::::::::::::::
c  new fine grid solution q was linearly interpolated. but want
c  to conserve kappa*q, not q. calculate the discrepancy
c  in kappa*q using this q, and modify q to account for it.
c ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

      dimension   val(mitot,mjtot,nvar), valc(mic,mjc,nvar)
      dimension   aux(mitot,mjtot,naux), auxc(mic,mjc,naux)

      dcapamax = 0.d0
      lratiox  = intratx(levc)
      lratioy  = intraty(levc)

      do 10 ic = 2, mic-1
      do 10 jc = 2, mjc-1

       do 15 ivar = 1, nvar

       capaqfine = 0.d0

       do 20 ico = 1, lratiox
       ifine = (ic-2)*lratiox + nghost + ico
       do 20 jco = 1, lratioy
         jfine = (jc-2)*lratioy + nghost + jco
         capaqfine = capaqfine + aux(ifine,jfine,mcapa)*
     &                           val(ifine,jfine,ivar)
20     continue

       dcapaq = auxc(ic,jc,mcapa)*valc(ic,jc,ivar)-
     &          capaqfine/(lratiox*lratioy)
       dcapamax = dmax1(dcapamax,dabs(dcapaq))

       do 30 ico = 1, lratiox
       ifine = (ic-2)*lratiox + nghost + ico
       do 30 jco = 1, lratioy
         jfine = (jc-2)*lratioy + nghost + jco
         val(ifine,jfine,ivar) = val(ifine,jfine,ivar) +
     &                           dcapaq/aux(ifine,jfine,mcapa)
30     continue

15     continue

10     continue

c      write(6,*)" max discrepancy ", dcapamax

       return
       end