!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of rhof in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: *temp *tsal *pres rhof
!   with respect to varying inputs: *temp *tsal *pres
!   Plus diff mem management of: temp:in tsal:in pres:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!> @brief rhof(i,j,k,ismpl) calculates the density of the fluid (in kg/m^3),
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return rho  [kg/m^3]
!> @details
!> rhow(i,j,k,ismpl) calculates the density in (in kg/m^3) of brine,
!> given temperature (t, in c) pressure (p,in pa), and salinity (s, in
!> mol/L) at node(i,j,k)\n
!>
!> Source:\n
!> Batzle, M., & Wang, Z., Seismic properties of pore fluids,
!> GEOPHYSICS, 57(11), 1396–1408 (1992).
!> http://dx.doi.org/10.1190/1.1443207 \n\n
!>
!>   Pressures 5-100 MPa, Temperature 20-350°C, Salinity <=320 g/L\n \n
!>
!>  CODE VERIFICATION:\n
!>   INPUT:  TEMP = 298.15K  P =0.1013 MPa  S = 0.25 g/g      OUTPUT: RHO = 1187.35 kg/m3\n
!>   INPUT:  TEMP = 393.15K  P =   30 MPa   S = 0.10 g/g      OUTPUT: RHO = 1027.06 kg/m3\n\n
!>
!> ARGUMENTS NAME    TYPE    UNITS           DESCRIPTION\n
!>     INPUT:        Temp  Real    T                 C       Temperature \n
!>                         Real    P         Pa      Pressure\n
!>                         Real    S         g/g     Salinity in mass fraction\n
!>    OUTPUT:        LABEL            RHO            Real     kg/m3  Density of brine \n
SUBROUTINE RHOF_AD(i, j, k, ismpl, rhof_adv)
  use arrays

  USE ARRAYS_AD

  USE MOD_FLOW
  IMPLICIT NONE
  double precision :: rhof_adv
! Location indices
  INTEGER, INTENT(IN) :: i
  INTEGER, INTENT(IN) :: j
  INTEGER, INTENT(IN) :: k
! Sample index
  INTEGER :: ismpl
! Temperature (degC)
  DOUBLE PRECISION :: t
  DOUBLE PRECISION :: t_ad
! Pressure (MPa)
  DOUBLE PRECISION :: p
  DOUBLE PRECISION :: p_ad
! Salinity (mol/L)
  DOUBLE PRECISION :: s
  DOUBLE PRECISION :: s_ad
! Salinity fraction (g/L)
  DOUBLE PRECISION :: sr
  DOUBLE PRECISION :: sr_ad
! Molar mass of NaCl [g/mol]
! double precision, parameter :: mmnacl = 58.44277d0
  DOUBLE PRECISION, PARAMETER :: mmnacl=58.44d0
! Pure water density (kg/m3)
  DOUBLE PRECISION :: rw
  DOUBLE PRECISION :: rw_ad
  DOUBLE PRECISION, EXTERNAL :: RHOW
! Pure water density (g/cm3)
  DOUBLE PRECISION :: rw_gcm3
  DOUBLE PRECISION :: rw_gcm3_ad
! Fluid density (g/cm3)
  DOUBLE PRECISION :: rhof_gcm3
  DOUBLE PRECISION :: rhof_gcm3_ad
  DOUBLE PRECISION :: temporary_ad
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: temporary_ad0
  DOUBLE PRECISION :: rhof
! Local Temperature (degC)
  t = temp(i, j, k, ismpl)
! Local Pressure [MPa]
  p = pres(i, j, k, ismpl)*pa_conv1
! Local salinity [mol/L]
  s = tsal(i, j, k, ismpl)
! Pure water density [kg/m3]
  rw = RHOW(p, t)
  IF (s .LE. 0.0d0) THEN
    rw_ad = rhof_adv
    p_ad = 0.D0
    s_ad = 0.D0
    t_ad = 0.D0
  ELSE
! mol/L (Molarity) > g/g (Mass fraCtion)
    sr = s*mmnacl/(rw+s*mmnacl)
! Pure water density [g/cm3]
! Batzle, Equation (27b), densities in g/cm3
! Fluid density [kg/m3]
    rhof_gcm3_ad = 1.0d3*rhof_adv
    temp0 = 3.0d0*t - 3.3d3*sr + 47.0d0*p*sr - 13.0d0*p + 80.0d0
    rw_gcm3_ad = rhof_gcm3_ad
    temporary_ad = 1.0d-6*sr*rhof_gcm3_ad
    temporary_ad0 = t*temporary_ad
    sr_ad = (2*0.44d0*sr+1.0d-6*(3.0d2*p-2.4d3*(p*sr)+t*temp0)+0.668d0)*&
&     rhof_gcm3_ad + (p*47.0d0-3.3d3)*temporary_ad0 - p*2.4d3*temporary_ad
    p_ad = (3.0d2-sr*2.4d3)*temporary_ad + (sr*47.0d0-13.0d0)*temporary_ad0
    t_ad = temp0*temporary_ad + 3.0d0*temporary_ad0
    temporary_ad = mmnacl*sr_ad/(rw+mmnacl*s)
    temporary_ad0 = -(s*temporary_ad/(rw+mmnacl*s))
    rw_ad = rw_gcm3_ad/1.0d3 + temporary_ad0
    s_ad = temporary_ad + mmnacl*temporary_ad0
  END IF
  CALL RHOW_AD0(p, p_ad, t, t_ad, rw_ad)
  tsal_ad(i, j, k, ismpl) = tsal_ad(i, j, k, ismpl) + s_ad
  pres_ad(i, j, k, ismpl) = pres_ad(i, j, k, ismpl) + pa_conv1*p_ad
  temp_ad(i, j, k, ismpl) = temp_ad(i, j, k, ismpl) + t_ad
END SUBROUTINE RHOF_AD


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Single shift RQZ for complex Hessenberg pairs
! ___________________________________________________________________
module z_RQZ

use u_parameters
use u_activeparts
use z_setpoles
use z_swappoles
use z_computepoles
use z_deflations

implicit none
private
public z_RQZ1

contains
  subroutine z_RQZ1(A, B, compAB, strtidx, stpidx, Q, compQ, qcol, &
                    Z, compZ, zcol, alpha, beta)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Implements the single shift complex-valued RQZ method
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       complex double array [INOUT]
  !           Matrix in upper Hessenberg form on entrance.
  !           On exit, the part defined by strtidx and stpidx is
  !           in upper triangular form and is equivalent with A
  !           if compAB is true.
  !
  ! B       complex double array [INOUT]
  !           Matrix in upper Hessenberg form on entrance.
  !           On exit, the part defined by strtidx and stpidx is
  !           in upper triangular form and is equivalent with B
  !           if compAB is true.
  !
  ! compAB  boolean       [IN]
  !           If true, the equivalences are applied to (A,B) such
  !           that the output triangular pair is equivalent to
  !           the input pair. If not, the output is not
  !           equivalent but the eigenvalues of the original pair
  !           are available on the diagonal.
  !
  ! strtidx integer     [IN]
  !           Start index of part of the matrix pencil that needs
  !           to be reduced to Schur form. Provide '0' if start is
  !           the beginning of the pencil.
  !
  ! stpidx  integer     [IN]
  !           Stop index of the part of the matrix pencil that needs
  !           to be reduced to Schur form. Provide N (matrix size) if
  !           stop is the end of the pencil. The strt and stp parameters
  !           need to satisfy:
  !               0 <= strtidx < stpidx <= N
  !
  ! Q       complex double array [INOUT]
  !           Unitary matrix containing the left Schur
  !           vectors. The number of columns of Q should be at least
  !           stpidx-strtidx. The Q array is not initialized in this routine.
  !
  ! compQ   boolean       [IN]
  !           If true, the left Schur vectors are computed.
  !
  ! qcol    integer       [IN]
  !           Column index from whereon the equivalence transformations
  !           are applied. If they should be applied from the beginning
  !           of the Q array, qcol needs to be set to 1. If qcol > 1, then
  !           the Q array should have at least qcol+stpidx-strtidx-1 columns.
  !
  ! Z       complex double array [INOUT]
  !           Unitary matrix containing the right Schur
  !           vectors. The number of columns of Z should be at least
  !           stp-strt. The Z array is not initialized in this routine.
  !
  ! compZ   boolean       [IN]
  !           If true, the right Schur vectors are computed.
  !
  ! zcol    integer       [IN]
  !           Column index from whereon the equivalence transformations
  !           are applied. If they should be applied from the beginning
  !           of the Z array, zcol needs to be set to 1. If zcol > 1, then
  !           the Z array should have at least zcol+stpidx-strtidx-1 columns.
  !
  ! alpha   complex double array [OUT]
  !           Array of length stpidx-strtidx containing the numerators for
  !           the generalized eigenvalues
  !
  ! beta    complex double array [OUT]
  !           Array of length stpidx-strtidx containing the denominators
  !           for the generalized eigenvalues
  !
  ! On successful completion of the routine the following equivalences hold:
  !   A(out) = Q^* A(in) Z
  !   B(out) = Q^* B(in) Z
  !___________________________________________________________________________
  ! last edit: July 31, 2019

  complex(kind=dp), intent(inout)   ::  A(:,:), B(:,:), Q(:,:), Z(:,:)
  logical, intent(in)               ::  compAB, compQ, compZ
  integer, intent(in)               ::  strtidx, stpidx, qcol, zcol
  complex(kind=dp), intent(out)     ::  alpha(:), beta(:)

  ! Internal variables
  type(tAp), pointer                :: apHead, apCurrent, apTotal
  integer                           :: i, N, nit, nswaps, ld, qci, zci
  integer,pointer                   :: cstrt, cstp
  logical                           :: problemsolved, defl
  complex(kind=dp)                  :: mu, nu

  ! Initialize variables
  N = stpidx-strtidx
  ! apHead stores the active parts throughout the iteration
  call tApInit(apHead,strt=strtidx,stp=stpidx)
  ! apTotal stores the active part at the start and is never modified
  call tApInit(apTotal,strt=strtidx,stp=stpidx)
  ! Q and Z indices
  qci = qcol-strtidx
  zci = zcol-strtidx

  ! Performance tracking
  nit = 0
  nswaps = 0
  ld = 0
  problemsolved = .false.

  ! Start of main program
  do while (.not. problemsolved)
  ! Main loop is repeated until no active parts are left
  apCurrent => apHead
  do
  ! Loop over all active parts
    call tApGet(apCurrent,cstrt,cstp)
    if (cstp - cstrt .le. 1) then
      ! Not an active part anymore, remove from list
      if (.not. (associated(tApPrevious(apCurrent)))) then
        ! apCurrent is the head, update head
        apHead => tApNext(apCurrent) ! can be null()
      end if
      ! Delete and restart
      call tApDelete(apCurrent)
      apCurrent => apHead
    else
      ! Handle the current active part
      ! check for deflations
      ! at front:
      call z_check_start_deflation(defl,A,B,compAB,apCurrent,apTotal,&
                                   Q,compQ,qci+cstrt)
      ! apCurrent is updated; consequently cstrt, and cstp are !
      if (defl) then
        ld = 0
      end if
      ! along subdiagonal:
      call z_check_interior_deflations(defl,A, B, apCurrent)
      ! apCurrent is updated; consequently cstrt, and cstp
      if (defl) then
        ! Make sure that we're handling the correct range
        call tApGet(apCurrent,cstrt,cstp)
        ld = 0
      end if

      if (cstp - cstrt .gt. 1) then
        nit = nit + 1
        ld = ld + 1
        ! set the shift
        if ((ld .gt. 0) .and. (mod(ld,10) .eq. 0)) then
          ! exceptional shift
          mu = dconjg( A(cstp-1,cstp) )
          nu = dconjg( B(cstp-1,cstp) )
        else
          call z_get_shift(A, B, cstp, mu, nu)
        end if
        call z_set_first_pole(mu, nu, A, B, compAB, apCurrent, apTotal,&
                              Q, compQ, qci+cstrt)
        ! chase
        do i = cstrt+1, cstp-2
          ! swap
          call z_swap(i+1,i, A, B, compAB, apCurrent, apTotal, &
                      Q, compQ, qci+i, Z, compZ, zci+i-1)
          nswaps = nswaps + 1
        end do
        ! check for deflations at end
        call z_check_stop_deflation(defl, A, B, compAB,apCurrent, apTotal,&
                                    Z, compZ, zci+cstp-2)
        ! apCurrent is updated; consequently cstrt, and cstp
        if (defl) then
          ld = 0
        end if
        if (cstp - cstrt .gt. 1) then ! Check again
          ! set the pole
          call z_get_pole(A, B, cstrt+1, mu, nu)
          call z_set_last_pole(mu, nu, A, B, compAB, apCurrent,apTotal,&
                               Z, compZ, zci+cstp-2)
        end if
      end if
    end if

    ! Check for exit condition
    if (associated(tApNext(apCurrent))) then
      apCurrent => tApNext(apCurrent) ! Set the next one
    else
      exit ! Exit this loop over the active parts
    end if
  ! end of loop over active parts
  end do

  ! Check if entire problem is solved
  call tApGet(apHead,cstrt,cstp)
  if (.not. (associated(cstrt) .or. associated(cstp))) then
    problemsolved = .true.
  end if

  ! end of main loop
  end do

  ! return results
  do i = 1, N
    alpha(i) = A(strtidx+i, strtidx+i)
    beta(i) = B(strtidx+i,strtidx+i)
  end do

  ! free everything
  apCurrent => null()
  call tApFree(apHead)
  call tApFree(apTotal)

  end subroutine

end module z_RQZ


       PROGRAM  TESTL1_2

      !********************************************************************
      !*     Semi-analytic theory of motion of Galilean satellites        *
      !*          fitted to observations between 1891 and 2003            *
      !*                                                                  *
      !*                        (Version 1.2)                             *
      !*                                                                  *
      !*------------------------------------------------------------------*
      !*                   L.Duriez (Luc.Duriez@imcce.fr)                 *
      !*                   V.Lainey (lainey@oma.be)                       *
      !*                   A.Vienne (vienne@imcce.fr)                     *
      !*                                                                  *
      !*    IMCCE - 77, Avenue Denfert-Rochereau 75014 Paris (France)     *
      !*__________________________________________________________________*
      !*                                                                  *
      !*         Example of monitor for computing ephemerides             *
      !*         using the subroutine  DL1_2(ET,nsat,iv,ELEM,XVE) :       *
      !*                                                                  *
      !*                                                                  *
      !*  ET : Julian Day  ie  JD in the Terrestrial Time scale (TT)      *
      !*       ET  must be limited to dates between about                 *
      !*       years 1140 and 2760  (these limits concern accurate        *
      !*       ephemerides, else see comments in the subroutine DL1_2)    *
      !*                                                                  *
      !* nsat: satellite number, from 1 (Io) to  4 (Callisto)             *
      !*                                                                  *
      !*  iv : choice of output :                                         *
      !*       0 = orbital elements referred to the center of Jupiter in  *
      !*           a fixed reference frame close to the jovian equatorial *
      !*           frame for J2000.0  epoch,                              *
      !*       1 = cartesian jovicentric coordinates in the fixed         *
      !*           celestial reference frame : mean equator and mean      *
      !*           equinox for J2000.0 epoch.                             *
      !*                                                                  *
      !*         To compute geocentric ephemerides (and other), add the   *
      !*         Earth-Jupiter vector given by  DE406                     *
      !*                                                                  *
      !* ELEM(6) : orbital elements output :                              *
      !*            a, L, Re(z), Im(z), Re(zeta), Im(zeta)                *
      !*                                                                  *
      !* XVE(6)  : cartesian coordinates output :                         *
      !*                       x, y, z, vx, vy, vz                        *
      !********************************************************************
      !*                          15/02/2006                              *
      !********************************************************************

       implicit real*8 (a-h,o-z)
       parameter(ua=149597870.691d0)     !! UA value, from DE406
       real*8 ELEM(6),XVE(6),ELEM1(6),XVE1(6)
       real*8 axkm(4),fc(6),A0(4),MU(4),AN(4)
       common /axes/ A0,MU

       pi=4*atan(1.D0)
       pi2=2*pi
*
*  reading the series  L1.2 from BisL1.2.dat :
*
       call INITbis
*
*  OR reading the series  L1.2 from GalileanL1.2.dat :
*
*       call INIT

       do i=1,4
         axkm(i)= A0(i)*ua
         AN(i)=DSQRT(MU(i)/A0(i)**3.D0)
       end do

       open(12,file='validate.txt')

       write(12,*)'semi-major axes in km '
       write(12,*) axkm
       write(12,*)'mean motions in rad/day '
       write(12,*) AN
       write(12,*)'periods in days '
       write(12,*) (pi2/AN(i),i=1,4)
       write(12,*)

      !* ELEM(6) : orbital elements in order :
      !*            a, L, Re(z), Im(z), Re(zeta), Im(zeta)
      !*            a in AU   while  other elements in rad
      !* XVE(6)  : cartesian coordinates output, in order :
      !*                    x, y, z,  vx, vy, vz
      !*              x, y, z in AU   and   vx, vy, vz  in AU/day

       ET0=2451545.0d0
       pas=12.345d0

       write(12,*)'positions velocities (in AU and AU/day) :'
       iv=1
       do nsat=1,4
         write(12,*)'satellite',nsat
         do k=-2000,2000,400
           ET=ET0+k*pas
           CALL DL1_2(ET,nsat,iv,ELEM,XVE)
           write(12,'(f14.3,6d20.10)') ET,((XVE(i)),i=1,6)
         end do
       end do
       write(12,*)

       write(12,*)'differences on elements (in km) :'
       iv=0
       do nsat=1,4
         write(12,*)'satellite',nsat
         fc(1)=ua
         do i=2,6
          fc(i)=axkm(nsat)
         end do
         do k=-2000,2000,400
           ET=ET0+k*pas
           CALL DL1_2(ET,nsat,iv,ELEM,XVE)
           CALL DL1_2FRC(ET,nsat,0,ELEM1,XVE1)
           write(12,'(i8,6f20.6)') k,((ELEM1(i)-ELEM(i))*fc(i),i=1,6)
         end do
       end do
       close(12)
       stop
       end

       include  'L1.2.f'


* ----------------------------------------------------------------------------
* Numerical diagonalization of 3x3 matrcies
* Copyright (C) 2006  Joachim Kopp
* ----------------------------------------------------------------------------
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
* ----------------------------------------------------------------------------

* ----------------------------------------------------------------------------
      SUBROUTINE DSYTRD3(A, Q, D, E)
* ----------------------------------------------------------------------------
* Reduces a symmetric 3x3 matrix to real tridiagonal form by applying
* (unitary) Householder transformations:
*            [ D[1]  E[1]       ]
*    A = Q . [ E[1]  D[2]  E[2] ] . Q^T
*            [       E[2]  D[3] ]
* The function accesses only the diagonal and upper triangular parts of
* A. The access is read-only.
* ---------------------------------------------------------------------------
*     .. Arguments ..
      DOUBLE PRECISION A(3,3)
      DOUBLE PRECISION Q(3,3)
      DOUBLE PRECISION D(3)
      DOUBLE PRECISION E(2)

*     .. Parameters ..
      INTEGER          N
      PARAMETER        ( N = 3 )

*     .. Local Variables ..
      DOUBLE PRECISION U(N), P(N)
      DOUBLE PRECISION OMEGA, F
      DOUBLE PRECISION K, H, G
      INTEGER          I, J

*     Initialize Q to the identitity matrix
*     --- This loop can be omitted if only the eigenvalues are desired ---
      DO 10 I = 1, N
        Q(I,I) = 1.0D0
        DO 11, J = 1, I-1
          Q(I, J) = 0.0D0
          Q(J, I) = 0.0D0
   11   CONTINUE
   10 CONTINUE

*     Bring first row and column to the desired form
      H = A(1,2)**2 + A(1,3)**2
      IF (A(1,2) .GT. 0.0D0) THEN
        G = -SQRT(H)
      ELSE
        G = SQRT(H)
      END IF
      E(1)  = G
      F     = G * A(1,2)
      U(2)  = A(1,2) - G
      U(3)  = A(1,3)

      OMEGA = H - F
      IF (OMEGA > 0.0D0) THEN
        OMEGA = 1.0D0 / OMEGA
        K     = 0.0D0
        DO 20 I = 2, N
          F    = A(2,I)*U(2) + A(I,3)*U(3)
          P(I) = OMEGA * F
          K    = K + U(I) * F
  20    CONTINUE
        K = 0.5D0 * K * OMEGA**2

        DO 30 I = 2, N
          P(I) = P(I) - K * U(I)
  30    CONTINUE

        D(1) = A(1,1)
        D(2) = A(2,2) - 2.0D0 * P(2) * U(2)
        D(3) = A(3,3) - 2.0D0 * P(3) * U(3)

*       Store inverse Householder transformation in Q
*       --- This loop can be omitted if only the eigenvalues are desired ---
        DO 40, J = 2, N
          F = OMEGA * U(J)
          DO 41 I = 2, N
            Q(I,J) = Q(I,J) - F * U(I)
   41     CONTINUE
   40   CONTINUE

*       Calculated updated A(2, 3) and store it in E(2)
        E(2) = A(2, 3) - P(2) * U(3) - U(2) * P(3)
      ELSE
        DO 50 I = 1, N
          D(I) = A(I, I)
  50    CONTINUE
        E(2) = A(2, 3)
      END IF

      END SUBROUTINE
* End of subroutine DSYTRD3


!> This module contains constants for the SST turbulence model as presented in
!!
!! Schoenawa, Stefan, and Ralf Hartmann.
!! "Discontinuous Galerkin discretization of the Reynolds-averaged Navier–Stokes equations with the shear-stress transport model."
!! Journal of Computational Physics 262 (2014): 194-216.
!!
!! @author  Eric M Wolf
!! @date    1/26/2018
!!
!!
!--------------------------------------------------------------------------------
module mod_sst
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: ONE, TWO, THREE
    implicit none

    !
    ! k-w constants
    !

    real(rk), parameter :: sst_w_beta_k             = 0.09_rk
    real(rk), parameter :: sst_w_beta_w             = 0.075_rk

    real(rk), parameter :: sst_w_sigma_k            = 0.5_rk ! BSL value
    !real(rk), parameter :: sst_w_sigma_k            = 0.85_rk ! SST value
    real(rk), parameter :: sst_w_sigma_w            = 0.5_rk
    real(rk), parameter :: sst_w_sigma_d            = 0.0_rk

    real(rk), parameter :: sst_w_kappa              = 0.41_rk

    real(rk), parameter :: sst_w_alpha_w            = sst_w_beta_w/sst_w_beta_k - sst_w_sigma_w*sst_w_kappa**TWO/sqrt(sst_w_beta_k)

    !
    ! k-e constants
    !

    real(rk), parameter :: sst_e_beta_k             = 0.09_rk
    real(rk), parameter :: sst_e_beta_w             = 0.0828_rk

    real(rk), parameter :: sst_e_sigma_k            = 1.0_rk
    real(rk), parameter :: sst_e_sigma_w            = 0.856_rk
    real(rk), parameter :: sst_e_sigma_d            = TWO*sst_e_sigma_w

    real(rk), parameter :: sst_e_kappa              = 0.41_rk

    real(rk), parameter :: sst_e_alpha_w              = sst_e_beta_w/sst_e_beta_k - sst_e_sigma_w*sst_e_kappa**TWO/sqrt(sst_e_beta_k)

    ! Artificial viscosity constant
    real(rk), parameter :: sst_avc                  = 100.0_rk

    !
    ! Boundary condition constants
    !

    ! w_infty = rho_infty*k_infty/mu_t_ed_infty

    ! Farfield turbulence intensity
    ! k_infty = (3/2)*SSG_LRRW_tu_infty^2*U_infty^2
    !real(rk), parameter :: SSG_LRRW_tu_infty    = 0.00039_rk
    real(rk), parameter :: sst_tu_infty    = 0.0001_rk

    ! Farfield eddy viscosity fraction
    ! mu_t_ed_infty = SSG_LRRW_f_mu_infty*mu_infty
    !real(rk), parameter :: SSG_LRRW_f_mu_infty  = 0.009_rk
    real(rk), parameter :: sst_f_mu_infty  = 0.1_rk

    real(rk), parameter :: sst_k_infty    = 4.824e-3_rk
    real(rk), parameter :: sst_omega_infty    = 5.8e7_rk*sst_f_mu_infty*sst_k_infty
end module mod_sst


      SUBROUTINE T3BMGS (IERR,SHEART,IPT,IORDER,EGPDT,DGPTH,AIC,TH,
     1                   DETJAC,SHP,BTERMS,BMATRX)
C
C     [B] MATRIX GENERATOR ROUTINE FOR TRIA3 ELEMENTS
C
C     SINGLE PRECISION ROUTINE TO GENERATE A 9XNDOF [B] MATRIX AT A
C     GIVEN INTEGRATION POINT, USING THE DERIVATIVES OF THE 2-D SHAPE
C     FUNCTIONS.
C     OPTIONALLY, AN 8XNDOF [B] MATRIX IS CONSTRUCTED AND/OR SHEAR TERMS
C     MAY BE DROPPED ALTOGETHER, YIELDING 6XNDOF MATRIX.
C     FOR STRESS RECOVERY, THE EVALUATION POINTS ARE AT THE ELEMENT
C     INTERIOR POINTS RATHER THAN ON THE EDGES.
C     THE CONTENTS OF /TERMS/ ARE USED TO CONSTRUCT THE [B] MATRIX
C     ACCORDING TO THE BEHAVIORAL REQUIREMENTS OF THE ELEMENT.
C
C
C     INPUT :
C           IPT    - POINTER TO THE CURVILNEAR COORDINATES
C           SHEART - LOGICAL INDICATING THE REQUIREMENT FOR OUT-OF-PLANE
C                    SHEAR TERMS
C           IORDER - ARRAY OF INTERNAL SEQUENCE OF NODES
C           EGPDT  - GRID POINT DATA IN THE ELEMENT COORD. SYSTEM
C           DGPTH  - NODAL THICKNESSES
C           AIC    - TRANSFORMATION TO RELIEVE GEOMETRY BIAS
C     OUTPUT:
C           IERR   - ERROR FLAG
C           TH     - THICKNESS AT THE INTEG. PT.
C           DETJAC - DETERMINANT OF JACOBIAN AT THE INTEG. PT.
C           SHP    - ARRAY OF REORDERED SHAPE FUNCTIONS
C           BTERMS - DERIVATIVES WRT THE PHYSICAL COORDINATES
C           BMATRX - STRAIN-DISPLACEMENT RELATIONSHIP
C
C
      LOGICAL          SHEART,MEMBRN,BENDNG,SHRFLX,MBCOUP,NORPTH
      INTEGER          IORDER(3)
      REAL             EGPDT(4,1),DGPTH(1),AIC(1),TH,DETJAC,BMATRX(1),
     1                 BTERMS(1),SHP(3),DSHPX(3),DSHPE(3),TSHP(3),
     2                 TDSHPX(3),TDSHPE(3),VI(2),VJ(2),JACOB(4),EPS,
     3                 PTINT(2,7),TRC(2,3),XSI,XSII,ETA,ETAI,PSI,PSII,
     4                 DNX,DNY,SHPF
      COMMON /TERMS /  MEMBRN,BENDNG,SHRFLX,MBCOUP,NORPTH
      DATA    EPS   /  1.0E-13 /
      DATA    PTINT /  0.5,    0.0,    0.5, 0.5,    0.0,    0.5,
     1                 0.333333333333333D0, 0.333333333333333D0,
     2                 0.166666666666667D0, 0.166666666666667D0,
     3                 0.166666666666667D0, 0.666666666666667D0,
     4                 0.666666666666667D0, 0.166666666666667D0/
      DATA    TRC   /  0.0,    0.0,    1.0, 0.0,    0.0,    1.0/
C
C     INITIALIZE
C
      IERR = 0
      NNODE= 3
      ND1  = NNODE*6
      ND2  = ND1*2
      ND3  = ND1*3
      ND4  = ND1*4
      ND5  = ND1*5
      ND6  = ND1*6
      ND7  = ND1*7
      ND8  = ND1*8
      ND9  = ND1*9
C
      DO 30 I = 1,6
      BTERMS(I) = 0.0
   30 CONTINUE
      DO 40 I = 1,ND9
      BMATRX(I) = 0.0
   40 CONTINUE
C
C     CALCULATE THE SHAPE FUNCTIONS AND THEIR DERIVATIVES, THEN SORT
C     THEM.
C
      XSI = PTINT(1,IPT)
      ETA = PTINT(2,IPT)
      PSI = 1.0 - XSI - ETA
C
      DO 50 I = 1,3
      XSII = TRC(1,I)
      ETAI = TRC(2,I)
      PSII = 1.0 - XSII - ETAI
C
      SHP(I)   = XSI*XSII + ETA*ETAI + PSI*PSII
      DSHPX(I) = XSII - PSII
      DSHPE(I) = ETAI - PSII
   50 CONTINUE
C
      DO 60 I  = 1,NNODE
      TSHP(I)  = SHP(I)
      TDSHPX(I)= DSHPX(I)
      TDSHPE(I)= DSHPE(I)
   60 CONTINUE
C
      DO 70 I  = 1,NNODE
      KK       = IORDER(I)
      SHP(I)   = TSHP(KK)
      DSHPX(I) = TDSHPX(KK)
      DSHPE(I) = TDSHPE(KK)
   70 CONTINUE
C
C     COMPUTE THE ELEMENT THICKNESS
C
      TH = 0.0
      DO 80 ISH = 1,NNODE
      TH = TH + SHP(ISH)*DGPTH(ISH)
   80 CONTINUE
C
C     SET UP THE JACOBIAN
C
      DO 90 I = 1,2
      VI(I) = 0.0
      VJ(I) = 0.0
      II = I + 1
      DO 90 J = 1,NNODE
      VI(I) = VI(I) + EGPDT(II,J)*DSHPX(J)
      VJ(I) = VJ(I) + EGPDT(II,J)*DSHPE(J)
   90 CONTINUE
C
C     INVERT THE JACOBIAN
C
      DETJAC = VI(1)*VJ(2) - VI(2)*VJ(1)
      IF (DETJAC .GE. EPS) GO TO 100
      IERR = 1
      RETURN
C
  100 JACOB(1) =  VJ(2)/DETJAC
      JACOB(2) = -VI(2)/DETJAC
      JACOB(3) = -VJ(1)/DETJAC
      JACOB(4) =  VI(1)/DETJAC
C
      DO 110 I = 1,4
      IF (ABS(JACOB(I)) .LT. EPS) JACOB(I) = 0.0
  110 CONTINUE
C
      IPT1 = IPT*2 - 1
      I71  = IPT1
      I72  = IPT1 + 1
      I81  = IPT1 + 6
      I82  = IPT1 + 7
      I91  = IPT1 + 12
      I92  = IPT1 + 13
C
C     LOOP OVER NODES AND BUILD PARTITIONS OF [B]
C
      IP = 0
      DO 150 I = 1,NNODE
C
C     CALCULATE DERIVATIVES WRT THE PHYSICAL COORDINATES.
C
      DNX  = JACOB(1)*DSHPX(I) + JACOB(2)*DSHPE(I)
      DNY  = JACOB(3)*DSHPX(I) + JACOB(4)*DSHPE(I)
      SHPF = SHP(I)
C
      BTERMS(I      ) = DNX
      BTERMS(I+NNODE) = DNY
C
      IF (.NOT.MEMBRN) GO TO 120
C
C     ROW 1
C
      BMATRX(IP+1) = DNX
C
C     ROW 2
C
      BMATRX(IP+2+ND1) = DNY
C
C     ROW 3
C
      BMATRX(IP+1+ND2) = DNY
      BMATRX(IP+2+ND2) = DNX
C
  120 IF (.NOT.BENDNG) GO TO 150
C
C     ROW 4
C
      BMATRX(IP+5+ND3) = -DNX
C
C     ROW 5
C
      BMATRX(IP+4+ND4) =  DNY
C
C     ROW 6
C
      BMATRX(IP+5+ND5) = -DNY
      BMATRX(IP+4+ND5) =  DNX
C
      IF (.NOT.SHEART) GO TO 150
      IF (IPT .LT.  4) GO TO 130
C
C     8-ROW MATRIX
C
C     ROW 7
C
      BMATRX(IP+3+ND6) =  DNY
      BMATRX(IP+4+ND6) = -SHPF
C
C     ROW 8
C
      BMATRX(IP+3+ND7) =  DNX
      BMATRX(IP+5+ND7) =  SHPF
      GO TO 150
C
C     9-ROW MATRIX
C
C     ROW 7
C
  130 BMATRX(IP+3+ND6) =  AIC(I71)*DNY + AIC(I72)*DNX
      BMATRX(IP+4+ND6) = -AIC(I71)*SHPF
      BMATRX(IP+5+ND6) =  AIC(I72)*SHPF
C
C     ROW 8
C
      BMATRX(IP+3+ND7) =  AIC(I81)*DNY + AIC(I82)*DNX
      BMATRX(IP+4+ND7) = -AIC(I81)*SHPF
      BMATRX(IP+5+ND7) =  AIC(I82)*SHPF
C
C     ROW 9
C
      BMATRX(IP+3+ND8) =  AIC(I91)*DNY + AIC(I92)*DNX
      BMATRX(IP+4+ND8) = -AIC(I91)*SHPF
      BMATRX(IP+5+ND8) =  AIC(I92)*SHPF
C
  150 IP = IP + 6
C
      RETURN
      END


      subroutine FCN(x,f,n,par)

      parameter (nss = 24)
      dimension x(n), f(n), par(n+1), r(nss), g(nss)
      common/wblock6/ xmhigh(nss),ref_gamma_dot(nss),Pij_Dijdev(nss),
     >                tau(nss), p(nss,4), taur(nss), twomu, g
	  integer m

	  m=n+1
	  !write(*,*) 'in fcn n size par xmhigh1 ref_gamma_dot1'
	  !write(*,*) n
	  !write(*,*) size(par)
	  !write(*,*) xmhigh(1)
	  !write(*,*) ref_gamma_dot(1)
	  !write(*,*) x(1)
      do i=1,m
c      write(*,*) 'in fcn,par',par(i)
	  enddo
      dummy = 0.0
      sat   = 1.0/1.0
	  !write(*,*) taur
      do i = 1, n
         r(i) = ((abs(x(i)/taur(i))*sat)**(xmhigh(i)-1.0))*
     >                                 (x(i)/taur(i))*sat
         g(i) = 0.0
      end do

      do i = 1, n
         do j = 1, n
            dummy = r(j)*ref_gamma_dot(j)*(p(i,1)*p(j,1) +
     >                                     p(i,2)*p(j,2) +
     >                                  2* p(i,3)*p(j,3) +
     >                                     p(i,4)*p(j,4))
            g(i) = g(i) + dummy
         end do
      end do

      do i = 1, n
         f(i) = x(i)-par(i)-par(m)*twomu*(Pij_Dijdev(i)-g(i))
c		 write(*,*) 'in FCN, f, x, par',f(i),x(i),par(i)
      end do

       return
       end


      FUNCTION gasdev(idum)
C-----------------------------------------------------
C    DOUBLE PRECISION VERSION OF NUMREC ROUTINE
C    FRANK GROSSMANN, 12.9.1994
C-----------------------------------------------------
      INTEGER idum
      REAL*8 gasdev
CU    USES ran1
      INTEGER iset
      REAL*8 fac,gset,rsq,v1,v2,ran1
      SAVE iset,gset
      DATA iset/0/
      if (iset.eq.0) then
1       v1=2.*ran1(idum)-1.
        v2=2.*ran1(idum)-1.
        rsq=v1**2+v2**2
        if(rsq.ge.1..or.rsq.eq.0.)goto 1
        fac=sqrt(-2.*log(rsq)/rsq)
        gset=v1*fac
        gasdev=v2*fac
        iset=1
      else
        gasdev=gset
        iset=0
      endif
      return
      END


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      REAL FUNCTION SOLVE (XA, XK, X, XCEN, YCEN, R1, R2)
C***********************************************************************

C  FUNCTION SOLVE = FINDS A SOLUTION TO THE SPIRAL EQUATION
C                   GIVEN AN INTERVAL THAT CONTAINS THE SOLUTION

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

      EPS = 1.E-6

      F1 = SPIRAL (XA, XK, X, XCEN, YCEN, R1)
      IF (ABS(F1) .LT. EPS) THEN
         SOLVE = R1
         GO TO 110
      END IF
      F2 = SPIRAL (XA, XK, X, XCEN, YCEN, R2)
      IF (ABS(F2) .LT. EPS) THEN
         SOLVE = R2
         GO TO 110
      END IF

  100 CONTINUE
      IF (ABS(R1 - R2) .LT. EPS) THEN
         SOLVE = (R1 + R2)/2.0
      ELSE
         R3 = (R1 + R2)/2.0
         F3 = SPIRAL (XA, XK, X, XCEN, YCEN, R3)

         IF (ABS(F3) .LT. EPS) THEN
            SOLVE = R3
            GO TO 110
         ELSE IF (F1/F3 .LT. 0.0) THEN
            R2 = R3
            F2 = F3
         ELSE
            R1 = R3
            F1 = F3
         END IF
         GO TO 100
      END IF

  110 CONTINUE
      END


module fstpack
  use fftpack
  use hilbrt
  implicit none
  private
  public rdst2f
  public rfst1f
  public rfst1b

contains
  subroutine rfst1b(w, s, err)
    complex, intent(in) :: w(0:, 0:)
    real, intent(out) :: s(0:)
    integer, intent(out) :: err
    complex, allocatable :: h(:)
    integer :: i, l, l2, n

    l = size(s)
    allocate(h(0:l-1))
    h = 0
    l2 = size(w, 1)
    do concurrent(n = 0:l2-1, i = 0:l-1)
      h(n) = h(n) + w(n, i)
    end do

    call cht1b(h)
    call cfft1(h, 'b', err)
    if(err /= 0) return
    s = real(h) / l
  end subroutine

  subroutine rfst1f(s, w, err)
    real, intent(in) :: s(0:)
    complex, intent(out) :: w(0:, 0:)
    integer, intent(out) :: err
    complex, allocatable :: h(:)
    real, allocatable :: g(:)
    integer :: i, l, l2, n

    l = size(s)
    allocate(h(0:l-1))
    h = cmplx(s)
    call cfft1(h, 'f', err)
    if(err /= 0) return
    call cht1f(h)

    allocate(g(0:l-1))
    w(0, :) = cmplx(sum(s)/l)
    l2 = l / 2 + 1
    do n = 1, l2-1
      g(0) = gauss(n, 0)
      do concurrent(i = 1:l2-1)
        g(i) = gauss(n, i)
        g(l - i) = g(i)
      end do

      do concurrent(i = 0:l-1)
        w(n, i) = h(mod(n + i, l)) * g(i)
      end do

      call cfft1(w(n, :), 'b', err)
      if(err /= 0) return
    end do
  end subroutine

  subroutine rdst2f(s, w, err)
    real, intent(in) :: s(0:, 0:)
    complex, intent(out) :: w(0:, 0:)
    integer, intent(out) :: err
    complex, allocatable :: h(:, :)
    integer :: cx2, cy2, k, k2, n, nny, nny2,&
               nx, nx2, ny, ny2, px, py
    real :: sqny, sqnyx

    k = size(s, 1)
    if(k /= size(s, 2) .or. iand(k, k - 1) /= 0) then
      err = 1
      return
    end if
    allocate(h(0:k-1, 0:k-1))
    h = cmplx(s)
    call cfft2(h, 'f', err)
    if(err /= 0) return
    k2 = k / 2
    w = 0
    w(0, 0) = h(0, 0)
    w(k2, 0 ) = h(k2, 0)
    w(0, k2) = h(0, k2)
    w(k2, 1 ) = h(k2, 1)
    w(1, k2) = h(1, k2)
    w(k2, k2) = h(k2, k2)

    n = int(log(real(k))/log(2.))
    do py = 1, n
      do px = 1, n
        nx = 2**(px - 1)
        nx2 = nx * 2
        cx2 = -nx / 2
        ny = 2**(py - 1)
        ny2 = ny * 2
        cy2 = -ny / 2
        nny = k - ny + 1
        nny2 = k - ny2 + 1
        sqny = sqrt(real(ny))
        sqnyx = sqrt(real(ny*nx))

        call shifft(w(0, ny:ny2), h(0, ny:ny2),&
          cy2, sqny, err)
        if(err /= 0) return
        call shifft(w(ny:ny2, 0), h(ny:ny2, 0),&
          cy2, sqny, err)
        if(err /= 0) return
        call shifft(w(k2, ny:ny2), h(k2, ny:ny2),&
          cy2, sqny, err)
        if(err /= 0) return
        call shifft(w(ny:ny2, k2), h(ny:ny2, k2),&
          cy2, sqny, err)
        if(err /= 0) return
        call shifft(w(nny2:nny, k2), h(nny2:nny, k2),&
          cy2, sqny, err, rev=.true.)
        if(err /= 0) return

        call shifft2(w(ny:ny2, nx:nx2), h(ny:ny2, nx:nx2),&
          [cy2, cx2], sqnyx, err)
        if(err /= 0) return
        call shifft2(w(nny2:nny, nx:nx2), h(nny2:nny, nx:nx2),&
          [cy2, cx2], sqnyx, err, rev=.true.)
        if(err /= 0) return
      end do
    end do

    w(1:k2, k2+1:) = conjg(w(k-1:k2+1:-1, k2:1:-1))
    w(k2+1:, k2+1:) = conjg(w(k2:1:-1, k2:1:-1))
    w(0, k2+1:) = conjg(w(0, k2:1:-1))
    w(k2, k2+1:) = conjg(w(k2, k2:1:-1))
  end subroutine

  pure function gauss(n, m)
    real, parameter :: pi = 4. * atan(1.)
    integer, intent(in) :: n, m
    real :: gauss

    gauss = exp(-2. * pi**2 * m**2 / n**2)
  end function

  subroutine shifft(p, q, n, s, err, rev)
    complex, intent(out) :: p(:)
    complex, intent(in) :: q(:)
    integer, intent(in) :: n
    real, intent(in) :: s
    integer, intent(out) :: err
    logical, intent(in), optional :: rev

    p = cshift(q, n)
    call cfft1(p, 'b', err)
    if(present(rev) .and. rev) then
      p = p(size(p):1:-1) * s
    else
      p = p * s
    end if
  end subroutine

  subroutine shifft2(p, q, n, s, err, rev)
    complex, intent(inout) :: p(:, :)
    complex, intent(in) :: q(:, :)
    integer, intent(in) :: n(2)
    real, intent(in) :: s
    integer, intent(out) :: err
    logical, intent(in), optional :: rev

    p = cshift(q, n(1), 1)
    p = cshift(p, n(2), 2)
    call cfft2(p, 'b', err)
    if(present(rev) .and. rev) then
      p = p(size(p):1:-1, :) * s
    else
      p = p * s
    end if
  end subroutine
end module


      subroutine gslam(dgpit,dpslm,gpit,ipbtmx,nalpha,napmax,nslt,
     $ nsltmx,pslamn,pslm)
c
c     This subroutine computes the S-lambda coefficients and their
c     ionic strength derivatives. These coefficients are used
c     in Pitzer's equations.
c
c     This subroutine is called by:
c
c       EQLIBG/gcoeff.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       gpit   = array of values for the g(x) function
c       dgpit  = array of values of the ionic strength derivatives
c                  of g(x)
c       nslt   = number of S-lambda coeffcient parameter sets
c       pslamn = array of S-lambda(n) coefficient parameters
c       nalpha = array that gives the index in the palpha array
c                  corresponding to a given set of S-lambda coefficient
c                  parameters.
c
c     Principal output:
c
c       pslm   = array of the S-lambda functions
c       dpslm  = array of ionic strength derivatives of the
c                  S-lambda functions
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer ipbtmx,napmax,nsltmx
c
      integer nalpha(nsltmx)
      integer nslt
c
      real(8) dgpit(2,ipbtmx,napmax),dpslm(2,nsltmx),
     $ gpit(ipbtmx,napmax),pslamn(0:ipbtmx,nsltmx),pslm(nsltmx)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,k,nap,nsl
c
      real(8) dpx,px
c
c----------------------------------------------------------------------
c
      do nsl = 1,nslt
c
        nap = nalpha(nsl)
c
        px = pslamn(0,nsl)
        do i = 1,ipbtmx
          px = px + gpit(i,nap)*pslamn(i,nsl)
        enddo
        pslm(nsl) = px
c
        do k = 1,2
          dpx = 0.
          do i = 1,ipbtmx
            dpx = dpx + dgpit(k,i,nap)*pslamn(i,nsl)
          enddo
          dpslm(k,nsl) = dpx
        enddo
      enddo
c
      end


program main
implicit none
character*29::arg
character*8::filelist
integer :: status, system
real*4,dimension(17000)::tbb
integer*2,dimension(17000)::cnt
integer*2:: i, j, k, io,NoF,N
integer*2,parameter::pix=6000
integer*2,dimension(pix,pix)::data_all
real,dimension(pix,pix)::data_tbb

call getarg( 1, arg )
call getarg( 2, filelist)

! baca data
Open(21,file=arg,access='direct',status='old',iostat=io, recl=6000*6000*2)
if(status==0)then
read(21,rec=1)((data_all(i,j),i=1,pix),j=1,pix);close (21)
end if

! baca dan koreksi tabel Tbb
NoF=17000
Open ( Unit=20, FILE=filelist,&
   STATUS='OLD',ACCESS='SEQUENTIAL',FORM='FORMATTED')
do N=1,NoF
READ (20, *, IOSTAT = io ) cnt(N),tbb(N)
if (io .ne. 0)exit
end do

! konversi CTT ke TBB
do i=1,pix
   do j=1,pix
	 data_tbb(i,j)=real(tbb(data_all(i,j)+1))
   end do
end do

Open ( Unit=10, File="OUTPUT/grid20.dat", access='DIRECT',recl=6000*6000*4)
   Write ( 10,rec=1 )((data_tbb(i,j),i=1,6000),j=1,6000)
close(10)
end program


       subroutine autdat
c
c  this routine reads all input data files for the progam autobk.
c  the xmu data file is opened, the pre-edge is removed, and the
c  standard chi data (if used) is read. the routine inpdat is
c  used for all data files, allowing either uwexafs binary or
c  ascii column data to be used.
c
c   copyright 1992  university of washington :          matt newville
c-----------------------------------------------------------------------
       include 'autobk.h'
c local variables
       character    ftype*5, frmthe*10
       double precision qtemp (maxpts), chitmp(maxpts), small
       double precision q, rgrid, rsmall, rtemp
       double precision dummy1(maxpts), dummy2(maxpts)
       double precision dummy3(maxpts), xmuraw(maxpts)
       parameter (small  = 1.d-10)
       integer  ndocln, i, nxx, ipos, nemin, nemax, nofx
c--------------------------------------------------
       if (xmuf.eq. ' ') then
          call echo('   autobk error: no input xmu data'//
     $                ' file name given.')
          call fstop(' no xmu data')
       end if
c
c  get xmu data, do pre-edge and normalization, and store the
c  modified xmu values in xmudat.
       ndocln = maxdoc
       nxmu   = maxpts
       ftype  = 'xmu'
       irecl  = 512
       call inpdat( ftype, frminp,   xmuf, vaxflg, skeyxm,
     $      nkeyxm, irecl, ndocln, xmudoc,   nxmu, energy,
     $      xmuraw, dummy1, dummy2, dummy3)

cc       print*, ' irecl = ', irecl, nxmu, energy(1)
c
c simple kludge to allow columnd 3,4,5 to be used as xmuraw:
       if ((imucol.ge.3).and.(imucol.le.5)) then
          if (imucol.eq.3) then
             do  22 i = 1, nxmu
                xmuraw(i) = dummy1(i)
 22          continue
          elseif (imucol.eq.4) then
             do  23 i = 1, nxmu
                xmuraw(i) = dummy2(i)
 23          continue
          elseif (imucol.eq.5) then
             do  24 i = 1, nxmu
                xmuraw(i) = dummy3(i)
 24          continue
          endif
       endif
c
c remove pre-edge, get edge step
       nnorm = 2
       call preedg(eefind, stfind, nxmu, energy, xmuraw, ee,
     $      predg1, predg2, enor1, enor2, nnorm,
     $      step, slopre, bpre,cnorm)
       step = max(step, small)
       if (funnrm) step = one
c set background equal to xmu
       do 50 i = 1, nxmu
          xmudat(i) = xmuraw(i) - slopre * energy(i) - bpre
          spline(i) = xmudat(i)
 50    continue
c
c  get theory from a 'chi' file
c  if theory is not given thiq is filled with 0.0
       ntheor = 1
       qtemp(1) = zero
       if (theory) then
          ndocln = maxdoc
          ntheor = maxpts
          ftype  =  'chi'
c           frmthe = frminp
          frmthe = ' '
          call inpdat(ftype,  frmthe, theorf, vaxflg, skeyth,
     $         nkeyth, irecl, ndocln, thedoc, ntheor,  qtemp,
     $         chitmp, dummy1, dummy2, dummy3)
       end if
       nxx  = min(maxpts, 10 + int (qtemp(ntheor) / qgrid))
       ipos = 1
       do 200 i = 1, nxx
          q = i*qgrid
          if ( (q.lt.qtemp(1)).or.(q.ge.qtemp(ntheor)) ) then
              thiq(i) = zero
          else
              call lintrp ( qtemp, chitmp, ntheor, q, ipos, thiq(i) )
          end if
 200   continue
c-----------------------------------------------------------------------
c  move emin and emax to values on the energy grid
       emin = emin + ee
       emax = emax + ee
       if (emax.le.emin) emax = energy(nxmu)
       nemin = nofx(emin,energy,nxmu)
       nemax = nofx(emax,energy,nxmu)
       emin  = energy(nemin)
       emax  = energy(nemax)
c-----------------------------------------------------------------------
c  put r values on rgrid, get npts numbers
       if (r1st.le.rbkg) r1st = rbkg + 2.0
       rgrid  = pi / (qgrid * mftfit)
       rsmall = rgrid / 100.0
       rbkg   = rgrid * int( (rbkg + rsmall) / rgrid )
       r1st   = rgrid * int( (r1st + rsmall) / rgrid )
       if (rbkg.gt.r1st) then
            rtemp = rbkg
            rbkg  = r1st
            r1st  = rtemp
       end if
       nrbkg  = 2 * int((rbkg + rsmall)/rgrid) + 2
       nrpts  = 2 * int((r1st + rsmall)/rgrid) + 2
       nr1st  = nrpts - nrbkg

       if (nxmu.le.4) then
          call echo('   autobk error: data file empty, or not'//
     $         ' enough data points')
          call echo('      the data file may need # signs for'//
     $         ' comment lines.')
          call fstop(' bad data file')
       end if

c done
       return
c end subroutine autdat
       end


      SUBROUTINE ELMHES(A,N,NP)
      DIMENSION A(NP,NP)
      IF(N.GT.2)THEN
        DO 17 M=2,N-1
          X=0.
          I=M
          DO 11 J=M,N
            IF(ABS(A(J,M-1)).GT.ABS(X))THEN
              X=A(J,M-1)
              I=J
            ENDIF
11        CONTINUE
          IF(I.NE.M)THEN
            DO 12 J=M-1,N
              Y=A(I,J)
              A(I,J)=A(M,J)
              A(M,J)=Y
12          CONTINUE
            DO 13 J=1,N
              Y=A(J,I)
              A(J,I)=A(J,M)
              A(J,M)=Y
13          CONTINUE
          ENDIF
          IF(X.NE.0.)THEN
            DO 16 I=M+1,N
              Y=A(I,M-1)
              IF(Y.NE.0.)THEN
                Y=Y/X
                A(I,M-1)=Y
                DO 14 J=M,N
                  A(I,J)=A(I,J)-Y*A(M,J)
14              CONTINUE
                DO 15 J=1,N
                  A(J,M)=A(J,M)+Y*A(J,I)
15              CONTINUE
              ENDIF
16          CONTINUE
          ENDIF
17      CONTINUE
      ENDIF
      RETURN
      END


! This should be inconsistent because of the use of the literal "10"
! in the parametric polymorphic function sqr.
program example
  implicit none
  real :: a, b
  != unit(m) :: x
  real :: x = 1
  != unit(s) :: t
  real :: t = 2
  a = sqr(x)
  b = sqr(t)
  contains
  real function sqr(y)
    real :: y
    real :: z = 10
    sqr = y * y + z
  end function
end program example


c     program DRSUCOM2
c>> 1996-06-20 DRSUCOM2 Krogh Format changes for C conversion.
c>> 1996-05-28 DRSUCOM2 Krogh Added external statement.
c>> 1994-11-02 DRSUCOM2 Krogh  Changes to use M77CON
c>> 1994-08-12 DRSUCOM2 CLL New subroutine: SUSETN
c>> 1992-05-15 CLL Removed "stop '... finished'"
c>> 1992-04-21 CLL
c>> 1992-03-16 CLL
c>> 1992-03-12 CLL
c>> 1987-10-30 Original time stamp
c  Demo driver for the SUCOMP package.  This code was adapted from the
c  test driver to reduce the number of tests and the amount of output.
c  Here we have NCASES = 2 and MM(3:4) = (0,2), whereas the test driver
c  had NCASES = 12 and MM(3:4) = (0,0).
c     The SUCOMP package computes first and second
c     partial derivatives.
c     C.L.Lawson,JPL, 1969 Dec 4
c     CLL, JPL, Jan 1987, Modified for Fortran 77
c     CLL, JPL, Sept 1987, Added SUSINH, SUCOSH, SUTANH, SUTAN
c     1992-05-15 CLL Removed "stop '... finished'" to simplify
c     comparison of output from different systems.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c--S replaces "?": DR?UCOM2, ?UCOMP,  ?MXDIF, ?USETN
c--&    ?COPY , ?UACOS, ?UASIN, ?UATAN, ?UATN2, ?UCOS
c--&    ?UCOSH, ?UDIF , ?UDIF1, ?UEXP , ?ULOG , ?UPRO , ?UPRO1
c--&    ?UPWRI, ?UQUO , ?UQUO1, ?USET , ?USIN , ?USINH, ?USQRT
c--&    ?USUM , ?USUM1, ?UTAN , ?UTANH
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer N, M1, M2
      integer I, IANG, IANG4, ICOUNT, IMAX, IPWR, IPWR7
      integer J, JMAX, KEY, KK, L, L2, LOC
      integer MM(24), NCASES
      parameter(IMAX = 10, JMAX = 72, NCASES = 12)
      external SMXDIF
      real             SMXDIF
      real             U(IMAX, JMAX), TEST(IMAX), ZERO, TEN, ONE
      real             A1, A2, ANG, C, C8, C9, ERRMAX, ERROR
      parameter( ZERO = 0.0e0, TEN = 10.0e0, ONE = 1.0e0)
      parameter(A1 = -2.62e0, A2 = 1.57 e0, C8 = 0.8e0, C9 = 0.9e0)
      data MM/-1,-1,  0,2,  1,1,2,2,-1,-1,0,0,1,2,-1,-1,
     *        0,1,2,2,-1,-1,0,2/
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      print'('' DRSUCOM2..  Demo driver for the SUCOMP package.''/
     *   '' Computation of partial derivatives.''/
     *   '' Will print the numerical error in various calculations.''/
     *   '' These errors should be zero or small.'')'
      C=TEN
      N=3
      L=1 + N + (N*(N+1))/2
      M1=0
      M2=2
c
      do 900  KK=1, 2*NCASES-1, 2
         if(MM(KK) .lt. 0) then
            print '(1x/'' Test U-computation.  Set U(,) = 0.'')'

c                                 Zero the U() array.
            do 20 I=1,IMAX
               do 10 J=1,JMAX
                  U(I,J)=ZERO
   10          continue
   20       continue
c                                 Store values into U(,1) and U(,2)
            U(1,1) = C8
            U(1,2) = -C9

            do 30 I=2,L
                U(I,1) = -C8 * U(I-1,1)
                U(I,2) = -C9 * U(I-1,2)
   30       continue
c
            go to 800
         endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                  Set M1 and M2 for new case.
      M1=MM(KK)
      M2=MM(KK+1)
      call SUSETN(N, M1, M2)
      print '(1x/,'' N, M1, M2 ='',3i10/1x)', N,M1,M2
      if(M2 .eq. 0) then
         L2 = 1
      elseif(M2 .eq. 1) then
         L2 = 1 + N
      elseif(M2 .eq. 2) then
         L2 = 1 + N + (N*(N+1))/2
      endif
      ERRMAX = ZERO
c
      call SUPRO(U(1,1), U(1,2), U(1,3) )
      call SUQUO (U(1,3),U(1,1),U(1,4) )
      ERROR =  SMXDIF(L2,U(1,4),1, U(1,2),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in (u1*u2)/u1 - u2               ='', g11.3)',
     *  ERROR
c
      call SUSQRT (U(1,1), U(1,5) )
      call SUPWRI (2,U(1,5), U(1,6) )
      ERROR =  SMXDIF(L2,U(1,6),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in  sqrt(u1)**2 - u1             ='', g11.3)',
     *  ERROR
c
      call SUSIN  (U(1,1),U(1,7))
      call SUCOS  (U(1,1),U(1,8))
      call SUATN2(U(1,7), U(1,8), U(1,9))
      ERROR =  SMXDIF(L2,U(1,9),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in atan2(sin(u1),cos(u1)) - u1   ='', g11.3)',
     *  ERROR
c
      call SUEXP  (U(1,1), U(1,10))
      call SULOG  (U(1,10), U(1,11))
      ERROR =  SMXDIF(L2,U(1,11),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in log(exp(u1) - u1              ='', g11.3)',
     *  ERROR
c
      call SUQUO (U(1,7), U(1,8), U(1,12) )
      call SUATAN (U(1,12), U(1,13))
      ERROR =  SMXDIF(L2,U(1,13),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in atan(sin(u1)/cos(u1)) - u1    ='', g11.3)',
     *  ERROR
c
      call SUTAN(U(1,1), U(1,44))
      ERROR =  SMXDIF(L2,U(1,12),1, U(1,44),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in sin(u1)/cos(u1) - tan(u1)     ='', g11.3)',
     *  ERROR
c
      call SUSINH(U(1,1), U(1,45))
      call SUCOSH(U(1,1), U(1,46))
      call SUTANH(U(1,1), U(1,47))
      call SUQUO (U(1,45), U(1,46), U(1,48) )
      ERROR =  SMXDIF(L2,U(1,48),1, U(1,47),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in sinh(u1)/cosh(u1) - tanh(u1)  ='',g11.3)',
     *  ERROR
c
      call SUSUM  (U(1,1), U(1,2), U(1,14))
      call SUDIF   (U(1,14), U(1,1), U(1,15))
c
      ERROR =  SMXDIF(L2,U(1,15),1, U(1,2),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '(1x,''Error in ((u1+u2)-u1) - u2             ='',g11.3)',
     *  ERROR
c
      call SUSUM1 (C,U(1,1),U(1,16))
      call SUDIF1 (C,U(1,16),U(1,17))
      call SUPRO1 (C,U(1,17),U(1,18))
      call SUQUO1 (C,U(1,18),U(1,19))
      call SUQUO1 (-ONE,U(1,19),U(1,20))
      ERROR =  SMXDIF(L2,U(1,20),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in -1/(c/(c*(c-(c+u1)))) - u1    ='',g11.3)',
     *  ERROR
c
      call SUASIN(U(1,7), U(1,21))
      ERROR =  SMXDIF(L2,U(1,21),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in asin(sin(u1)) - u1            ='',g11.3)',
     *  ERROR
c
      call SUACOS(U(1,8), U(1,22))
      ERROR =  SMXDIF(L2,U(1,22),1, U(1,1),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in acos(cos(u1)) - u1            ='',g11.3)',
     *  ERROR
c
c        Test of SUSET.  We first use SUSUM1 to copy U(,1)
c        to U(,23+KEY) so it will have nonzero contents.
c        After calling SUSET it should be all zero except for 1 or 2
c        elements.  C will be stored to U(1,23+KEY).
c        When KEY = 0, everything else will be set to zero.
c        When KEY = 1, 2, or 3, and it will also set
c        U(KEY+1,23+KEY) = 1.0
c
      do 50 KEY = 0,3
         call SUSUM1(ZERO, U(1,1), U(1,23+KEY))
         call SUSET(C,KEY, U(1,23+KEY))
         do 40 I = 1,L
            TEST(I) = ZERO
   40    continue
         TEST(1) = C
         if(KEY .gt. 0) TEST(KEY+1) = ONE
      ERROR =  SMXDIF(L2,U(1,23+KEY),1, TEST,1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in SUSET(C,KEY,...)              ='',g11.3)',
     *  ERROR
   50 continue
c
c     Check quadrant resolution of SUATN2.
c
c                                 Store values into U(,1).
      ANG = A1 - A2
      do 60 IANG = 1,4
         IANG4 = 4*(IANG-1)
         ANG = ANG + A2
         call SCOPY(L, U(1,1),1, U(1,27+IANG4),1)
         U(1,27+IANG4) = ANG
         call SUSIN(U(1,27+IANG4), U(1,28+IANG4))
         call SUCOS(U(1,27+IANG4), U(1,29+IANG4))
         call SUATN2(U(1,28+IANG4), U(1,29+IANG4), U(1,30+IANG4))
         ERROR =  SMXDIF(L2,U(1,30+IANG4),1, U(1,27+IANG4),1)
         ERRMAX = max(ERRMAX, ERROR)
         print '('' Error in atan2(sin(u1),cos(u1)) - u1   ='',g11.3)',
     *     ERROR
   60 continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                           Test of SUPWRI( ,0, , )
c
         call SUPWRI( 0, U(1,1), U(1,49))
         call SUSET ( ONE, 0, U(1,50))
      ERROR =  SMXDIF(L2,U(1,49),1, U(1,50),1)
      ERRMAX = max(ERRMAX, ERROR)
      print '('' Error in x**0 - 1                      ='',g11.3)',
     *  ERROR
c
c                                     Loop through tests of SUPWRI
         do 80 IPWR = 1,3
            IPWR7 = 7*(IPWR-1)
            print '(1x/'' Test SUPWRI using I = '',i3)', IPWR
            call SUPWRI( IPWR, U(1,1), U(1,51+IPWR7))
            call SCOPY(L2, U(1,1),1, U(1,56+IPWR7),1)
            LOC = 0
            do 70 ICOUNT = 2,IPWR
               call SUPRO( U(1,1), U(1,56+LOC+IPWR7), U(1,57+LOC+IPWR7))
               LOC = LOC + 1
   70       continue
            ERROR =  SMXDIF(L2,U(1,51+IPWR7),1, U(1,56+LOC+IPWR7),1)
            ERRMAX = max(ERRMAX, ERROR)
            print '('' Error in x**I - x * x * ... * x        ='',
     *         g11.3)', ERROR
            call SUPWRI( -IPWR, U(1,1), U(1,53+IPWR7))
            call SUPRO( U(1,53+IPWR7), U(1,51+IPWR7), U(1,54+IPWR7))
            call SUSET ( ONE, 0, U(1,55+IPWR7))
            ERROR =  SMXDIF(L2,U(1,54+IPWR7),1, U(1,55+IPWR7),1)
            ERRMAX = max(ERRMAX, ERROR)
            print '('' Error in x**(-I) * x**I - 1            ='',
     *         g11.3)', ERROR
   80    continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

         print '('' ***>>> ERRMAX ='',g11.3)', ERRMAX
  800    continue
  900 continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      end
c     ==================================================================
      real             function SMXDIF(N,X,INCX, Y,INCY)
c
c     Compute max norm of difference between the N-vectors x and y.
c     The vectors are stored with a storage increment of INCX and INCY
c     between successive components.
c     C. L. Lawson, JPL, Sept 1987.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer I, N, INCX, INCY, IX, IY
      real             X(*), Y(*), ZERO, TEMP
      parameter(ZERO = 0.0e0)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      TEMP = ZERO
      IX = 1 - INCX
      IY = 1 - INCY
      do 10 I = 1,N
         IX = IX + INCX
         IY = IY + INCY
         TEMP = max(TEMP, abs(X(IX) - Y(IY)))
   10 continue
      SMXDIF = TEMP
      return
      end


      SUBROUTINE PSGEEQU( M, N, A, IA, JA, DESCA, R, C, ROWCND, COLCND,
     $                    AMAX, INFO )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IA, INFO, JA, M, N
      REAL               AMAX, COLCND, ROWCND
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      REAL               A( * ), C( * ), R( * )
*     ..
*
*  Purpose
*  =======
*
*  PSGEEQU computes row and column scalings intended to equilibrate an
*  M-by-N distributed matrix sub( A ) = A(IA:IA+N-1,JA:JA:JA+N-1) and
*  reduce its condition number.  R returns the row scale factors and C
*  the column scale factors, chosen to try to make the largest entry in
*  each row and column of the distributed matrix B with elements
*  B(i,j) = R(i) * A(i,j) * C(j) have absolute value 1.
*
*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
*  number and BIGNUM = largest safe number.  Use of these scaling
*  factors is not guaranteed to reduce the condition number of
*  sub( A ) but works well in practice.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  M       (global input) INTEGER
*          The number of rows to be operated on i.e the number of rows
*          of the distributed submatrix sub( A ). M >= 0.
*
*  N       (global input) INTEGER
*          The number of columns to be operated on i.e the number of
*          columns of the distributed submatrix sub( A ). N >= 0.
*
*  A       (local input) REAL pointer into the local memory
*          to an array of dimension ( LLD_A, LOCc(JA+N-1) ), the
*          local pieces of the M-by-N distributed matrix whose
*          equilibration factors are to be computed.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  R       (local output) REAL array, dimension LOCr(M_A)
*          If INFO = 0 or INFO > IA+M-1, R(IA:IA+M-1) contains the row
*          scale factors for sub( A ). R is aligned with the distributed
*          matrix A, and replicated across every process column. R is
*          tied to the distributed matrix A.
*
*  C       (local output) REAL array, dimension LOCc(N_A)
*          If INFO = 0,  C(JA:JA+N-1) contains the column scale factors
*          for sub( A ). C is aligned with the distributed matrix A, and
*          replicated down every process row. C is tied to the distri-
*          buted matrix A.
*
*  ROWCND  (global output) REAL
*          If INFO = 0 or INFO > IA+M-1, ROWCND contains the ratio of
*          the smallest R(i) to the largest R(i) (IA <= i <= IA+M-1).
*          If ROWCND >= 0.1 and AMAX is neither too large nor too small,
*          it is not worth scaling by R(IA:IA+M-1).
*
*  COLCND  (global output) REAL
*          If INFO = 0, COLCND contains the ratio of the smallest C(j)
*          to the largest C(j) (JA <= j <= JA+N-1). If COLCND >= 0.1, it
*          is not worth scaling by C(JA:JA+N-1).
*
*  AMAX    (global output) REAL
*          Absolute value of largest distributed matrix element.  If
*          AMAX is very close to overflow or very close to underflow,
*          the matrix should be scaled.
*
*  INFO    (global output) INTEGER
*          = 0:  successful exit
*          < 0:  If the i-th argument is an array and the j-entry had
*                an illegal value, then INFO = -(i*100+j), if the i-th
*                argument is a scalar and had an illegal value, then
*                INFO = -i.
*          > 0:  If INFO = i,  and i is
*                <= M:  the i-th row of the distributed matrix sub( A )
*                       is exactly zero,
*                >  M:  the (i-M)-th column of the distributed
*                       matrix sub( A ) is exactly zero.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          COLCTOP, ROWCTOP
      INTEGER            I, IACOL, IAROW, ICOFF, ICTXT, IDUMM, IIA,
     $                   IOFFA, IROFF, J, JJA, LDA, MP, MYCOL, MYROW,
     $                   NPCOL, NPROW, NQ
      REAL               BIGNUM, RCMAX, RCMIN, SMLNUM
*     ..
*     .. Local Arrays ..
      INTEGER            DESCC( DLEN_ ), DESCR( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, CHK1MAT, DESCSET, IGAMX2D,
     $                   INFOG2L, PCHK1MAT, PB_TOPGET, PXERBLA, SGAMN2D,
     $                   SGAMX2D
*     ..
*     .. External Functions ..
      INTEGER            INDXL2G, NUMROC
      REAL               PSLAMCH
      EXTERNAL           INDXL2G, NUMROC, PSLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, MOD
*     ..
*     .. Executable Statements ..
*
*     Get grid parameters
*
      ICTXT = DESCA( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     Test the input parameters.
*
      INFO = 0
      IF( NPROW.EQ.-1 ) THEN
         INFO = -(600+CTXT_)
      ELSE
         CALL CHK1MAT( M, 1, N, 2, IA, JA, DESCA, 6, INFO )
         CALL PCHK1MAT( M, 1, N, 2, IA, JA, DESCA, 6, 0, IDUMM, IDUMM,
     $                  INFO )
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL PXERBLA( ICTXT, 'PSGEEQU', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         ROWCND = ONE
         COLCND = ONE
         AMAX = ZERO
         RETURN
      END IF
*
      CALL PB_TOPGET( ICTXT, 'Combine', 'Rowwise', ROWCTOP )
      CALL PB_TOPGET( ICTXT, 'Combine', 'Columnwise', COLCTOP )
*
*     Get machine constants and local indexes.
*
      SMLNUM = PSLAMCH( ICTXT, 'S' )
      BIGNUM = ONE / SMLNUM
      CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA, JJA,
     $              IAROW, IACOL )
      IROFF = MOD( IA-1, DESCA( MB_ ) )
      ICOFF = MOD( JA-1, DESCA( NB_ ) )
      MP = NUMROC( M+IROFF, DESCA( MB_ ), MYROW, IAROW, NPROW )
      NQ = NUMROC( N+ICOFF, DESCA( NB_ ), MYCOL, IACOL, NPCOL )
      IF( MYROW.EQ.IAROW )
     $   MP = MP - IROFF
      IF( MYCOL.EQ.IACOL )
     $   NQ = NQ - ICOFF
      LDA = DESCA( LLD_ )
*
*     Assign descriptors for R and C arrays
*
      CALL DESCSET( DESCR, M, 1, DESCA( MB_ ), 1, 0, 0, ICTXT,
     $               MAX( 1, MP ) )
      CALL DESCSET( DESCC, 1, N, 1, DESCA( NB_ ), 0, 0, ICTXT, 1 )
*
*     Compute row scale factors.
*
      DO 10 I = IIA, IIA+MP-1
         R( I ) = ZERO
   10 CONTINUE
*
*     Find the maximum element in each row.
*
      IOFFA = (JJA-1)*LDA
      DO 30 J = JJA, JJA+NQ-1
         DO 20 I = IIA, IIA+MP-1
            R( I ) = MAX( R( I ), ABS( A( IOFFA + I ) ) )
   20    CONTINUE
         IOFFA = IOFFA + LDA
   30 CONTINUE
      CALL SGAMX2D( ICTXT, 'Rowwise', ROWCTOP, MP, 1, R( IIA ),
     $              MAX( 1, MP ), IDUMM, IDUMM, -1, -1, MYCOL )
*
*     Find the maximum and minimum scale factors.
*
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO 40 I = IIA, IIA+MP-1
         RCMAX = MAX( RCMAX, R( I ) )
         RCMIN = MIN( RCMIN, R( I ) )
   40 CONTINUE
      CALL SGAMX2D( ICTXT, 'Columnwise', COLCTOP, 1, 1, RCMAX, 1, IDUMM,
     $              IDUMM, -1, -1, MYCOL )
      CALL SGAMN2D( ICTXT, 'Columnwise', COLCTOP, 1, 1, RCMIN, 1, IDUMM,
     $              IDUMM, -1, -1, MYCOL )
      AMAX = RCMAX
*
      IF( RCMIN.EQ.ZERO ) THEN
*
*        Find the first zero scale factor and return an error code.
*
         DO 50 I = IIA, IIA+MP-1
            IF( R( I ).EQ.ZERO .AND. INFO.EQ.0 )
     $         INFO = INDXL2G( I, DESCA( MB_ ), MYROW, DESCA( RSRC_ ),
     $                NPROW ) - IA + 1
   50    CONTINUE
         CALL IGAMX2D( ICTXT, 'Columnwise', COLCTOP, 1, 1, INFO, 1,
     $                 IDUMM, IDUMM, -1, -1, MYCOL )
         IF( INFO.NE.0 )
     $      RETURN
      ELSE
*
*        Invert the scale factors.
*
         DO 60 I = IIA, IIA+MP-1
            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
   60    CONTINUE
*
*        Compute ROWCND = min(R(I)) / max(R(I))
*
         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
*
      END IF
*
*     Compute column scale factors
*
      DO 70 J = JJA, JJA+NQ-1
         C( J ) = ZERO
   70 CONTINUE
*
*     Find the maximum element in each column,
*     assuming the row scaling computed above.
*
      IOFFA = (JJA-1)*LDA
      DO 90 J = JJA, JJA+NQ-1
         DO 80 I = IIA, IIA+MP-1
            C( J ) = MAX( C( J ), ABS( A( IOFFA + I ) )*R( I ) )
   80    CONTINUE
         IOFFA = IOFFA + LDA
   90 CONTINUE
      CALL SGAMX2D( ICTXT, 'Columnwise', COLCTOP, 1, NQ, C( JJA ),
     $              1, IDUMM, IDUMM, -1, -1, MYCOL )
*
*     Find the maximum and minimum scale factors.
*
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO 100 J = JJA, JJA+NQ-1
         RCMIN = MIN( RCMIN, C( J ) )
         RCMAX = MAX( RCMAX, C( J ) )
  100 CONTINUE
      CALL SGAMX2D( ICTXT, 'Columnwise', COLCTOP, 1, 1, RCMAX, 1, IDUMM,
     $              IDUMM, -1, -1, MYCOL )
      CALL SGAMN2D( ICTXT, 'Columnwise', COLCTOP, 1, 1, RCMIN, 1, IDUMM,
     $              IDUMM, -1, -1, MYCOL )
*
      IF( RCMIN.EQ.ZERO ) THEN
*
*        Find the first zero scale factor and return an error code.
*
         DO 110 J = JJA, JJA+NQ-1
            IF( C( J ).EQ.ZERO .AND. INFO.EQ.0 )
     $         INFO = M + INDXL2G( J, DESCA( NB_ ), MYCOL,
     $                DESCA( CSRC_ ), NPCOL ) - JA + 1
  110    CONTINUE
         CALL IGAMX2D( ICTXT, 'Columnwise', COLCTOP, 1, 1, INFO, 1,
     $                 IDUMM, IDUMM, -1, -1, MYCOL )
         IF( INFO.NE.0 )
     $      RETURN
      ELSE
*
*        Invert the scale factors.
*
         DO 120 J = JJA, JJA+NQ-1
            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
  120    CONTINUE
*
*        Compute COLCND = min(C(J)) / max(C(J))
*
         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
*
      END IF
*
      RETURN
*
*     End of PSGEEQU
*
      END


! ###############################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

   MODULE JAC3D_Interface

   INTERFACE

      SUBROUTINE JAC3D ( SSI, SSJ, SSK, DPSHG, WRT_BUG_THIS_TIME, JAC, JACI, DETJ )

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_BUG, WRT_ERR, WRT_LOG, BUG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  JACOBIAN_BEGEND
      USE CONSTANTS_1, ONLY           :  ZERO
      USE PARAMS, ONLY                :  EPSIL
      USE MODEL_STUF, ONLY            :  EID, ELGP, NUM_EMG_FATAL_ERRS, TYPE, XEL
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG

      IMPLICIT NONE

      CHARACTER( 1*BYTE), INTENT(IN)  :: WRT_BUG_THIS_TIME ! If 'Y' then write to BUG file if WRT_BUG array says to

      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = JACOBIAN_BEGEND

      REAL(DOUBLE) , INTENT(IN)       :: SSI               ! A Gauss point coord.
      REAL(DOUBLE) , INTENT(IN)       :: SSJ               ! A Gauss point coord.
      REAL(DOUBLE) , INTENT(IN)       :: SSK               ! A Gauss point coord.
      REAL(DOUBLE) , INTENT(IN)       :: DPSHG(3,ELGP)     ! 3 x ELGP array of derivatives of element shape functions evaluated at
      REAL(DOUBLE) , INTENT(OUT)      :: DETJ              ! Determinant of JAC
      REAL(DOUBLE) , INTENT(OUT)      :: JAC(3,3)          ! 3 x 3 Jacobian matrix
      REAL(DOUBLE) , INTENT(OUT)      :: JACI(3,3)         ! 3 x 3 inverse of JAC
      REAL(DOUBLE)                    :: B(3,3)            ! Array used in calculating inverse of JAC
      REAL(DOUBLE)                    :: XL(ELGP,3)        ! Array of local element coords for the element (note: cannot use XEL
      END SUBROUTINE JAC3D

   END INTERFACE

   END MODULE JAC3D_Interface


      PROGRAM xeclass
C     driver for routine eclass
      INTEGER N,M
      PARAMETER(N=15,M=11)
      INTEGER i,j,k,lclas,nclass,
     *     lista(M),listb(M),nf(N),nflag(N),nsav(N)
      DATA lista/1,1,5,2,6,2,7,11,3,4,12/
      DATA listb/5,9,13,6,10,14,3,7,15,8,4/
      call eclass(nf,N,lista,listb,M)
      do 11 i=1,N
        nflag(i)=1
11    continue
      write(*,'(/1x,a)') 'Numbers from 1-15 divided according to'
      write(*,'(1x,a/)') 'their value modulo 4:'
      lclas=0
      do 13 i=1,N
        nclass=nf(i)
        if (nflag(nclass).ne.0) then
          nflag(nclass)=0
          lclas=lclas+1
          k=0
          do 12 j=i,N
            if (nf(j).eq.nf(i)) then
              k=k+1
              nsav(k)=j
            endif
12        continue
          write(*,'(1x,a,i2,a,3x,5i3)') 'Class',
     *         lclas,':',(nsav(j),j=1,k)
        endif
13    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xeclass.for


! chk_random_init.f90 --
!     Check if the compiler supports the random_init intrinsic function
!
program chk_random_init
    implicit none

    real, dimension(100) :: array1, array2

    !
    ! Call random_init and random_number twice in succession
    !
    call random_init( .true., .true. )
    call random_number( array1 )

    call random_init( .true., .true. )
    call random_number( array2 )

    if ( all( array1 == array2 ) ) then
        write( *, '(a)' ) 'The two arrays of random numbers are the same'
        write( *, '(a)' ) '(Apparently random_init reset the random number generator)'
    else
        write( *, '(a)' ) 'The two arrays of random numbers are NOT the same'
        write( *, '(a)' ) '(Apparently random_init did not reset the random number generator)'
    endif

end program chk_random_init


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_2Darray_random_normal
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine provides a matrix of pseudo-random number independent, standard,
! normally distributed (expected value 0, standard deviation 1).
! Call u_randomseed_initialize(INFO) first to set the seed of the number
! generator.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  M, N            INTEGER
!                    positive integers, dimension of A
!
!
! OUTPUT VARIABLES:
!
!  A               REAL(8) array of dimension (M,N)
!                    matrix of real random numbers
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_2Darray_random_normal(M,N,A)

  implicit none

  ! input variables
  integer, intent(in) :: M, N
  real(8), intent(inout) :: A(M,N)

  ! compute variables
  integer :: ii, jj

  ! check N
  if ((N .LT. 1).OR.(M .LT. 1)) then
    return
  end if

  do jj = 1,M
     do ii = 1,N

        call d_scalar_random_normal(A(jj,ii))

     end do
  end do

end subroutine d_2Darray_random_normal


program global_work
  call configure_arrays     ! Perform the appropriate allocations
  call compute              ! Use the arrays in computations
end program global_work
module work_arrays          ! An example set of work arrays
  integer n
  real, allocatable, save :: a(:), b(:,:), c(:,:,:)
end module work_arrays
subroutine configure_arrays ! Process to set up work arrays
  use work_arrays
  read (*,*) N
  allocate (a(n), b(n,n), c(n,n,2*n))
end subroutine configure_arrays
subroutine compute
  use work_arrays
  ! ... Computations involving arrays A, B, and C
end subroutine compute


! F2PY experiment
! http://stackoverflow.com/a/12200671/597371

subroutine minmaxr(a,n,amin,amax)
    implicit none
    !f2py intent(hidden) :: n
    !f2py intent(out) :: amin,amax
    !f2py intent(in) :: a
    integer n, i
    real a(n),amin,amax,acurr
    real :: x = 0

    if (n > 0) then
        amin = a(1)
        amax = a(1)
        do i=2, n
            acurr = a(i)
            if (acurr > amax) then
                amax = acurr
            elseif (acurr < amin) then
                amin = acurr
            endif
        enddo
    else
        ! set return values to (inf, -inf)
        amin = -log(x)
        amax = -amin
    endif
end subroutine minmaxr

! Calculate Expected Mutual Information given margins of RxC table
!
! For the sake of numeric precision, the resulting value is *not* normalized
! by N.
!
! License: BSD 3 clause
!
! .. codeauthor:: Robert Layton <robertlayton@gmail.com>
! .. codeauthor:: Corey Lynch <coreylynch9@gmail.com>
! .. codeauthor:: Eugene Scherba <escherba@gmail.com>
!
! List of changes (Eugene Scherba, 10/2/2015):
!
! 1) Removed/rewritten the lines that were creating RxC intermediate NumPy
! arrays which resulted in the O(n^2) memory requirement. Instead, the
! intermediate values are now calculated inside the loop, which may be
! slightly less efficient for small data sizes, but has huge advantages for
! large or even moderately sized data. This change reduces the memory
! requirements of this code from O(n^2) to O(n).
!
! 2) Removed normalization by N from the calculation. It is actually not
! needed to normalize by N if we also don't normalize the input MI value
! (in the calculation of the adjusted score which is ``MI - E(MI) / MI_max
! - E(MI)``, the N value cancels out). Not normalizing the EMI calculation
! by N avoids having to perform lots of tiny floating point increments to
! the EMI aggregate value and thus improves numeric accuracy, especially
! for small values of EMI.
!
! 3) A Fortran 90 version
!
subroutine emi_from_margins(a,R,b,C,emi)
    implicit none
    !f2py intent(hidden) :: R, C
    !f2py intent(out) :: emi
    !f2py intent(in) :: a, b
    integer(kind=8) R, C, i, j, nij, N, N1, N3, max_ab, ai_1, bj_1, N3_ai_1, N3_ai_bj_1

    real(kind=8) emi, log_ai, log_ab_outer_ij, outer_sum, gln_ai_Nai_Ni
    real(kind=8) log_a(R), log_b(C), gln_ai_Nai_N(R), gln_b_Nb(C)

    integer(kind=8) a(R), b(C), a1(R), b1(C)

    real(kind=8), dimension(:), allocatable :: nijs, gln_nij, log_Nnij
    real(kind=8) :: x = -1.0

    log_a = dlog(dble(a))
    log_b = dlog(dble(b))

    N = sum(a)
    if (N /= sum(b)) then
        ! set return value to nan
        emi = dsqrt(x)
        return
    endif

    ! There are three major terms to the EMI equation, which are multiplied to
    ! and then summed over varying nij values.

    ! term1 is nijs.
    ! While nijs[0] will never be used, having it simplifies the indexing.
    max_ab = max(maxval(a), maxval(b))

    allocate(nijs(max_ab + 1))
    do nij=1, max_ab + 1
        nijs(nij) = nij - 1
    enddo

    nijs(1) = 1.0  ! Stops divide by zero warnings. As its not used, no issue.

    ! term2 is log((N*nij) / (a a b)) == log(N * nij) - log(a * b)
    ! term2 uses log(N * nij)
    allocate(log_Nnij(max_ab + 1))
    log_Nnij = dlog(dble(N)) + dlog(nijs)

    ! term3 is large, and involved many factorials. Calculate these in log
    ! space to stop overflows.
    N1 = N + 1
    N3 = N + 3

    a1 = a + 1
    b1 = b + 1
    gln_ai_Nai_N = dlgama(dble(a1)) + dlgama(dble(N1 - a)) - dlgama(dble(N1))
    gln_b_Nb = dlgama(dble(b1)) + dlgama(dble(N1 - b))

    allocate(gln_nij(max_ab + 1))
    gln_nij = dlgama(nijs + 1.0)

    ! emi itself is a summation over the various values.
    emi = 0.0
    do i=1, R
        ai_1 = a1(i)
        log_ai = log_a(i)
        gln_ai_Nai_Ni = gln_ai_Nai_N(i)
        N3_ai_1 = N3 - ai_1
        do j=1, C
            bj_1 = b1(j)
            log_ab_outer_ij = log_ai + log_b(j)
            outer_sum = gln_ai_Nai_Ni + gln_b_Nb(j)
            N3_ai_bj_1 = N3_ai_1 - bj_1

            do nij=max(1, 1 - N3_ai_bj_1), min(ai_1, bj_1) - 1
                ! Numerators are positive, denominators are negative.
                emi = emi + ( &
                    & dble(nij) * &
                    & (log_Nnij(nij + 1) - log_ab_outer_ij) * &
                    & dexp(outer_sum &
                    &    - gln_nij(nij + 1) &
                    &    - dlgama(dble(ai_1 - nij)) &
                    &    - dlgama(dble(bj_1 - nij)) &
                    &    - dlgama(dble(nij + N3_ai_bj_1)) &
                    & ))
            enddo
        enddo
    enddo

    deallocate(gln_nij)
    deallocate(log_Nnij)
    deallocate(nijs)
end subroutine emi_from_margins


      complex function cdotc(n,cx,incx,cy,incy)
c
c     forms the dot product of two vectors, conjugating the first
c     vector.
c     jack dongarra, linpack,  3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      complex cx(*),cy(*),ctemp
      integer i,incx,incy,ix,iy,n
c
      ctemp = (0.0,0.0)
      cdotc = (0.0,0.0)
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        ctemp = ctemp + conjg(cx(ix))*cy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      cdotc = ctemp
      return
c
c        code for both increments equal to 1
c
   20 do 30 i = 1,n
        ctemp = ctemp + conjg(cx(i))*cy(i)
   30 continue
      cdotc = ctemp
      return
      end


PROGRAM dos_simple

  implicit none

  integer,parameter :: u5=5, u99=99, u10=10
  integer,parameter :: max_loop=10000000
  integer :: mbv,mbc,ne,nbk,natom,ie,mb,msp,s
  integer :: func_type, n_MP
  real(8),parameter :: HT=27.2116d0
  real(8),allocatable :: eval(:,:,:),occp(:,:,:)
  real(8),allocatable :: factor(:)
  real(8) :: gamma,evb,ecb,e1,e2,e,de,emin,emax,f(2),c1,c2

  natom = 0
  mbv   = 0
  mb    = 0
  nbk   = 0
  gamma = 0.0d0

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

  write(*,*) "# of atoms: natom="
  read(u5,*) natom
  if ( natom <= 0 ) natom=1
  write(*,*) natom

  write(*,*) "band index of energy origin: mbv="
  read(u5,*) mbv
  write(*,*) mbv

  write(*,*) "width of smearing (eV): gamma="
  read(u5,*) gamma
  if ( gamma < 1.d-5 ) then
     gamma = 1.d-4
     write(*,*) "gamma(eV) is replaced to ",gamma
  end if
  write(*,*) gamma

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

  call read_from_fort99(u99)
!  call read_from_band_eigv("band_eigv")

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

  emin = minval( eval )
  emax = maxval( eval )

  write(*,*) "emin     (HT,eV)=",emin,emin*HT
  write(*,*) "emax     (HT,eV)=",emax,emax*HT
  write(*,*) "emax-emin(HT,eV)=",emax-emin,(emax-emin)*HT

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

  if ( 1 <= mbv .and. mbv <= mb ) then

     mbc = mbv + 1
     evb = maxval( eval(1:mbv,1:nbk,1:msp) )
     ecb = minval( eval(mbc:mb,1:nbk,1:msp) )
     eval=eval-evb

     emin = minval( eval )
     emax = maxval( eval )

     write(*,*) "Energy is shifted by ", evb
     write(*,*) "emin   (HT,eV)=",emin,emin*HT
     write(*,*) "emax   (HT,eV)=",emax,emax*HT
     write(*,*) "ecb-evb(HT,eV)=",ecb-evb,(ecb-evb)*HT

  end if

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

  write(*,*) "# of energy grid: ne= ( 0: default value is set )"
  read(u5,*) ne
  write(*,*) ne
  write(*,*) "energy range: e1,e2= ( 0,0: default values are set )"
  read(u5,*) e1,e2
  write(*,*) e1,e2
  write(*,*) "func type [0:gaussian, 1:Lorentzian, 2:Methfessel-Paxton]"
  read(u5,*) func_type
  if ( func_type < 0 .or. 2 < func_type ) then
     func_type = 0
     write(*,*) "func_type is replaced to ",func_type
  end if
  write(*,*) func_type
  if ( func_type == 2 ) then
     write(*,*) "Order of MP =?"
     read(u5,*) n_MP
     write(*,*) n_MP
     call init_gg0( n_MP )
  end if

  if ( ne <= 0 .or. e1 >= e2 ) then
     ne = 2000
     e1 = emin
     e2 = emax
  end if

  de = (e2-e1)/ne

  gamma = gamma/HT

  c1 = HT
  c2 = 1.0d0/(HT*natom)

  rewind u10

  do ie=1,ne+1

     e=e1+(ie-1)*de

     select case( func_type )
     case( 0 )
        do s=1,msp
           call dos0(s,e,f(s))
        end do
     case( 1 )
        do s=1,msp
           call dos1(s,e,f(s))
        end do
     case( 2 )
        do s=1,msp
           call dos2(s,e,f(s),n_MP)
        end do
     end select

     write(u10,'(1x,4f20.15)') e*c1, f(1:msp)*c2, sum(f(1:msp))*c2

  end do ! ie

CONTAINS

  SUBROUTINE dos0(s,e,f)
    implicit none
    integer,intent(IN)  :: s
    real(8),intent(IN)  :: e
    real(8),intent(OUT) :: f
    real(8) :: a,b,c,x
    integer :: i,k

    a = ( 1.d0/gamma )**2
    b = sqrt( a/acos(-1.0d0) )

    f=0.0d0
    do k=1,nbk
       do i=1,mb

          x=e-eval(i,k,s)
          c=b*occp(i,k,s)
          f=f+c*exp(-a*x*x)

       end do
    end do

  END SUBROUTINE dos0

  SUBROUTINE dos1(s,e,f)
    implicit none
    integer,intent(IN)  :: s
    real(8),intent(IN)  :: e
    real(8),intent(OUT) :: f
    real(8) :: b,c,x
    integer :: i,k

    b = 1.0d0/acos(-1.0d0)

    f=0.0d0
    do k=1,nbk
       do i=1,mb

          x=e-eval(i,k,s)
          c=b*occp(i,k,s)
          f=f+c*gamma/(x*x+gamma*gamma)

       end do
    end do

  END SUBROUTINE dos1

  SUBROUTINE read_from_fort99(u)
    implicit none
    integer,intent(IN) :: u
    integer :: n,k,i,j,s
    real(8) :: dummy(3)
    character(11) :: cbuf

    rewind u
    do i=1,max_loop
       read(u,*,end=999) cbuf
       if ( cbuf == "Eigenvalues" ) exit
    end do
    read(u,*)
    do i=1,max_loop
       read(u,*,end=99) k,n,dummy(1:3)
    end do
    if ( i > max_loop ) stop "max_loop < # of data"
99  mb=n
    nbk=k
    j=i

    rewind u
    do i=1,max_loop
       read(u,*,end=999) cbuf
       if ( cbuf == "Eigenvalues" ) exit
    end do
    read(u,*)
    do i=1,max_loop
       read(u,*,end=98) k,n,dummy(1:6)
    end do
    if ( i > max_loop ) stop "max_loop < # of data"
98  continue
    msp=1
    if ( i == j ) msp=2

    write(*,*) "mb,nbk,msp=",mb,nbk,msp

    allocate( eval(mb,nbk,msp) ) ; eval=0.0d0
    allocate( occp(mb,nbk,msp) ) ; occp=0.0d0

    rewind u
    do i=1,max_loop
       read(u,*,end=999) cbuf
       if ( cbuf == "Eigenvalues" ) exit
    end do
    read(u,*)
    do k=1,nbk
       do n=1,mb
          read(u,*) i,j,(eval(n,k,s),dummy(1),occp(n,k,s),s=1,msp)
       end do
       do s=1,msp
          occp(2:mb,k,s)=occp(1,k,s)
       end do
    end do

    return

999 continue
    stop "The format of fort.99 is strange"

  END SUBROUTINE read_from_fort99

  SUBROUTINE dos2(s,e,f,N_MP)
    implicit none
    integer,intent(IN)  :: s
    real(8),intent(IN)  :: e
    real(8),intent(OUT) :: f
    integer,intent(IN)  :: N_MP
    real(8) :: c,x
    integer :: i,k

    f=0.0d0
    do k=1,nbk
       do i=1,mb

          x=e-eval(i,k,s)
          c=occp(i,k,s)/gamma
          f=f+c*gg0(N_MP,x/gamma)

       end do
    end do

  END SUBROUTINE dos2

  FUNCTION gg0(n,x)
    implicit none
    integer :: n,i
    real(8) :: x,gg,gg0,hp0,hp1,hp2,hp3
    gg0 = factor(0)*exp(-x*x)
    if ( n <= 0 ) return
    hp0 = 1.0d0
    hp1 = 2.0d0*x
    gg  = 0.0d0
    do i=1,n
       hp2 = 2.d0*x*hp1 - 2.d0*(2*i-1)*hp0
       hp3 = 2.d0*x*hp2 - 2.d0*(2*i  )*hp1
       gg  = gg + factor(i)*hp2
       hp0 = hp2
       hp1 = hp3
    end do
    gg0 = gg0 + gg*exp(-x*x)
    return
  END FUNCTION gg0

  SUBROUTINE init_gg0( nmax )
    implicit none
    integer,intent(IN) :: nmax
    integer :: n
    allocate( factor(0:nmax) ) ; factor=0.0d0
    factor(0)= 1.0d0/sqrt(acos(-1.0d0))
    if ( nmax == 0 ) return
    factor(1)=-1.0d0/(4.0d0*sqrt(acos(-1.0d0)))
    do n=2,nmax
       factor(n)=-factor(n-1)/(4.0d0*n)
    end do
  END SUBROUTINE init_gg0

END PROGRAM dos_simple


      SUBROUTINE ELASTICPPF(matObj,model,strain,tang,stress,isw,error)

!DEC$ IF DEFINED (_DLL)
!DEC$ ATTRIBUTES DLLEXPORT :: ELASTICPPF
!DEC$ END IF
      use materialTypes
      use materialAPI
      implicit none

      type(matObject)::matObj
      type(modelState)::model
      real *8::strain
      real *8::tang
      real *8::stress
      integer::isw
      integer::error;

      real *8, pointer::theParam(:)
      real *8, pointer::cState(:)
      real *8, pointer::tState(:)

      real *8 E, eyp, ep, fyp, fyn, f, fYieldSurface
      real *8 sigtrial, trialStrain, trialStress, trialTangent

      integer, target :: iData(2)
      integer, pointer ::iPtr(:)
      integer numData, err
      real *8, target :: dData(2)
      real *8, pointer:: dPtr(:)

c     outside functions called
c      integer OPS_GetIntInput, OPS_GetDoubleInput, OPS_AllocateMaterial

      IF (isw.eq.ISW_INIT) THEN

c     get the input data  - tag? E? eyp?

         numData = 1
         iPtr=>iData;
         err = OPS_GetIntInput(numData, iPtr)
         numData = 2
         dPtr=>dData;
         err = OPS_GetDoubleInput(numData, dPtr)

c     Allocate the element state
         matObj%tag = idata(1)
         matObj%nparam = 2
         matObj%nstate = 2

         err = OPS_AllocateMaterial(matObj)
         call c_f_pointer(matObj%theParam, theParam, [2]);

c     Initialize the element properties
         theParam(1) = dData(1);
         theParam(2) = dData(2);

      ELSE

         call c_f_pointer(matObj%theParam, theParam, [2]);
         call c_f_pointer(matObj%cState, cState, [2]);
         call c_f_pointer(matObj%tState, tState, [2]);

         IF (isw == ISW_COMMIT) THEN

            trialStrain = tState(1)

            E = theParam(1)
            eyp = theParam(2)
            ep = cState(2)

            fyp = E*eyp
            fyn = -fyp

c     compute trial stress
            sigtrial = E * ( trialStrain - ep );

c     evaluate yield function
            IF ( sigtrial >= 0.0 ) THEN
               f =  sigtrial - fyp
            ELSE
               f = -sigtrial + fyn
            END IF

            fYieldSurface = - E * DBL_EPSILON;

            IF ( f > fYieldSurface ) THEN
c     plastic
               IF ( sigtrial > 0.0 ) THEN
                  ep = ep + f / E
               ELSE
                  ep = ep - f / E
               END IF
            END IF

            cState(1) = trialStrain;
            cState(2) = ep;

         ELSE IF (isw == ISW_REVERT_TO_START) THEN
            cState(1) = 0.0;
            cState(2) = 0.0;
            tState(1) = 0.0;
            tState(2) = 0.0;

         ELSE IF (isw == ISW_FORM_TANG_AND_RESID) THEN

            trialStrain = strain;

            E = theParam(1);
            eyp = theParam(2);
            ep = cState(2);

            fyp = E*eyp;
            fyn = -fyp;

c     compute trial stress
            sigtrial = E * ( trialStrain - ep );

c     evaluate yield function
            IF ( sigtrial >= 0.0 ) THEN
               f =  sigtrial - fyp;
            ELSE
               f = -sigtrial + fyn;
            END IF

            fYieldSurface = - E * DBL_EPSILON;

            IF ( f <= fYieldSurface ) THEN

               trialStress = sigtrial;
               trialTangent = E;

            ELSE

c     plastic
               IF ( sigtrial > 0.0 ) THEN
                  trialStress = fyp;
               ELSE
                  trialStress = fyn;
               END IF

               trialTangent = 0.0;
            END IF

            tState(1) = trialStrain;
            stress = trialStress;
            tang = trialTangent;
         END IF
      END IF

c     return error code
      error = 0

      END SUBROUTINE elasticPPf

      SUBROUTINE LOCALINIT()

!DEC$ IF DEFINED (_DLL)
!DEC$ ATTRIBUTES DLLEXPORT :: LOCALINIT
!DEC$ END IF

      use materialAPI
      implicit none
      integer::error;
      character *60:: msg;
      msg = 'elasticPPf - Written by fmk UC Berkeley Copyright 2008'
      error = OPS_Error(msg);
      END SUBROUTINE localInit