PROGRAM Test_Fourier_Interpolate

  USE Type_Kinds           , ONLY: fp=>fp_kind
  USE Binary_File_Utility  , ONLY: Open_Binary_File
  USE Message_Handler      , ONLY: SUCCESS
  USE Fundamental_Constants, ONLY: PI
  USE FFT_Spectral_Utility , ONLY: Fourier_Interpolate
  IMPLICIT NONE
  ! Parameters
  CHARACTER(*), PARAMETER :: INFILE(2)=(/'test_spc.bin   ','test_boxcar.bin'/)
  INTEGER,      PARAMETER :: NFILTERS=4
  REAL(fp),     PARAMETER :: FILTERWIDTH(NFILTERS) = (/10.0_fp,20.0_fp,50.0_fp,100.0_fp/)
  ! Variables
  CHARACTER(256) :: outFile
  REAL(fp),    DIMENSION(:), ALLOCATABLE :: fIn, spcIn
  REAL(fp),    DIMENSION(:), ALLOCATABLE :: fOut, spcOut
  INTEGER  :: fileId
  INTEGER  :: i, j, nIn, po2, nPO2, nOut
  INTEGER  :: errStatus, allocStatus
  CHARACTER(5) :: cFilterWidth

  ! Select spectral data
  WRITE(*,'(/5x,"Select spectral data:")')
  DO i=1,2
    WRITE(*,'(10x,i1,") " ,a)') i, INFILE(i)
  END DO
  WRITE(*,'(5x,"Enter choice: ")',ADVANCE='NO')
  READ(*,*) i

  ! Enter a power-of-two value
  WRITE(*,'(/5x,"Enter a power-of-two [14]: ")',ADVANCE='NO')
  READ(*,*) po2

  ! Read the spectral data
  WRITE(*,'(/5x,"Reading input test spectrum ",a,"...")' ) TRIM(INFILE(i))
  errStatus = Open_Binary_File( INFILE(i), &
                                fileId     )
  IF ( errStatus /= SUCCESS ) THEN
    WRITE(*,*) 'Error opening test spectrum file.'
    STOP
  END IF
  READ(fileId) nIn  ! The number of SPC points
  nPO2 = (2**po2 + 1) + 10  ! The number of interpolated output points, plus some extra
  ALLOCATE(fIn(nIn), spcIn(nIn), fOut(nPO2), spcOut(nPO2), STAT=allocStatus)
  IF ( allocStatus /= 0 ) THEN
    WRITE(*,*) 'Error allocating arrays. STAT=',allocStatus
    STOP
  END IF
  READ(fileId)fIn   ! Frequency data
  READ(fileId)spcIn ! Only read the real part of SPC
  CLOSE(fileId)

  ! Loop over filter widths
  DO j=1,NFILTERS

    WRITE(cFilterWidth,'(f5.1)') FILTERWIDTH(j)
    cFilterWidth=ADJUSTL(cFilterWidth)

    ! Call the routine
    WRITE(*,'(/5x,"Calling Fourier_Interpolate with filter width of ",a,"cm-1...")' ) TRIM(cFilterWidth)
    errStatus=Fourier_Interpolate(fIn, spcIn, nOut, fOut, spcOut, &
                                  PowerOfTwo =po2, &
                                  FilterWidth=FILTERWIDTH(j))
    IF ( errStatus /= SUCCESS ) THEN
      WRITE(*,*) 'Error in Fourier_Interpolate call'
      STOP
    END IF

    ! Output an ASCII file for viewing results
    WRITE(outFile,'("Test_Fourier_Interpolate.fw-",a,".",a)') TRIM(cFilterWidth), TRIM(INFILE(i))
    WRITE(*,'(5x,"Writing output file ",a,"...")' ) TRIM(outFile)
    errStatus = Open_Binary_File( outFile, &
                                  fileId, &
                                  For_Output=1 )
    IF ( errStatus /= SUCCESS ) THEN
      WRITE(*,*) 'Error opening output results file.'
      STOP
    END IF
    ! The original SPC data (REAL ONLY)
    WRITE(fileId) nIn             ! The number of SPC points
    WRITE(fileId) fIn             ! Frequency data
    WRITE(fileId) spcIn           ! Real part of SPC
    ! The interpolated SPC data (REAL ONLY)
    WRITE(fileId) nOut            ! The number of SPC points
    WRITE(fileId) fOut(1:nOut)    ! Frequency data
    WRITE(fileId) spcOut(1:nOut)  ! Real part of SPC
    CLOSE(fileId)
  END DO

END PROGRAM Test_Fourier_Interpolate


      SUBROUTINE banbks(a,n,m1,m2,np,mp,al,mpl,indx,b)
      INTEGER m1,m2,mp,mpl,n,np,indx(n)
      REAL a(np,mp),al(np,mpl),b(n)
      INTEGER i,k,l,mm
      REAL dum
      mm=m1+m2+1
      if(mm.gt.mp.or.m1.gt.mpl.or.n.gt.np) pause 'bad args in banbks'
      l=m1
      do 12 k=1,n
        i=indx(k)
        if(i.ne.k)then
          dum=b(k)
          b(k)=b(i)
          b(i)=dum
        endif
        if(l.lt.n)l=l+1
        do 11 i=k+1,l
          b(i)=b(i)-al(k,i-k)*b(k)
11      continue
12    continue
      l=1
      do 14 i=n,1,-1
        dum=b(i)
        do 13 k=2,l
          dum=dum-a(i,k)*b(k+i-1)
13      continue
        b(i)=dum/a(i,1)
        if(l.lt.mm) l=l+1
14    continue
      return
      END

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


      PROGRAM xbcuint
C     driver for routine bcuint
      INTEGER i
      REAL ansy,ansy1,ansy2,ey,ey1,ey2
      REAL x1,x1l,x1u,x1x2,x2,x2l,x2u,xxyy
      REAL y(4),y1(4),y2(4),y12(4),xx(4),yy(4)
      DATA xx/0.0,2.0,2.0,0.0/
      DATA yy/0.0,0.0,2.0,2.0/
      x1l=xx(1)
      x1u=xx(2)
      x2l=yy(1)
      x2u=yy(4)
      do 11 i=1,4
        xxyy=xx(i)*yy(i)
        y(i)=xxyy**2
        y1(i)=2.0*yy(i)*xxyy
        y2(i)=2.0*xx(i)*xxyy
        y12(i)=4.0*xxyy
11    continue
      write(*,'(/1x,t6,a,t14,a,t22,a,t28,a,t38,a,t44,a,t54,a,t60,a/)')
     *     'X1','X2','Y','EXPECT','Y1','EXPECT','Y2','EXPECT'
      do 12 i=1,10
        x1=0.2*i
        x2=x1
        call bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,ansy1,ansy2)
        x1x2=x1*x2
        ey=x1x2**2
        ey1=2.0*x2*x1x2
        ey2=2.0*x1*x1x2
        write(*,'(1x,8f8.4)') x1,x2,ansy,ey,ansy1,ey1,ansy2,ey2
12    continue
      END

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


!-----------------------------------------------------------------------
      SUBROUTINE IP_SPLAT(IDRT,JMAX,SLAT,WLAT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  SPLAT      COMPUTE LATITUDE FUNCTIONS
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-20
!
! ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS
!           FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES.
!             GAUSSIAN LATITUDES (IDRT=4)
!             EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0)
!             EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256)
!           THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE
!           LEGENDRE POLYNOMIAL OF THE GIVEN ORDER.  THESE LATITUDES
!           ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE.
!           (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.)
!           THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON
!           ELLSAESSER (JAM,1966).  (NO WEIGHT IS GIVEN THE POLE POINT.)
!           NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS,
!           IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED.
!
! PROGRAM HISTORY LOG:
!   96-02-20  IREDELL
!
! USAGE:    CALL SPLAT(IDRT,JMAX,SLAT,WLAT)
!
!   INPUT ARGUMENT LIST:
!     IDRT     - INTEGER GRID IDENTIFIER
!                (IDRT=4 FOR GAUSSIAN GRID,
!                 IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
!                 IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
!     JMAX     - INTEGER NUMBER OF LATITUDES.
!
!   OUTPUT ARGUMENT LIST:
!     SLAT     - REAL (JMAX) SINES OF LATITUDE.
!     WLAT     - REAL (JMAX) GAUSSIAN WEIGHTS.
!
! SUBPROGRAMS CALLED:
!   MINV         SOLVES FULL MATRIX PROBLEM
!
! REMARKS: FORTRAN 90 EXTENSIONS ARE USED.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 77
!
!$$$
      REAL SLAT(JMAX),WLAT(JMAX)
      REAL PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2)
      PARAMETER(JZ=50)
      REAL BZ(JZ)
      DATA BZ        / 2.4048255577,  5.5200781103, &
       8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679, &
      21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684, &
      33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132, &
      46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550, &
      58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299, &
      71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711, &
      84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819, &
      96.6052679510, 99.7468198587, 102.888374254, 106.029930916, &
      109.171489649, 112.313050280, 115.454612653, 118.596176630, &
      121.737742088, 124.879308913, 128.020877005, 131.162446275, &
      134.304016638, 137.445588020, 140.587160352, 143.728733573, &
      146.870307625, 150.011882457, 153.153458019, 156.295034268 /
      REAL AWORK((JMAX+1)/2,((JMAX+1)/2+1)),BWORK(((JMAX+1)/2)*2)
      PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25)
      PARAMETER(EPS=1.E-6)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  GAUSSIAN LATITUDES
      IF(IDRT.EQ.4) THEN
        JH=JMAX/2
        JHE=(JMAX+1)/2
        R=1./SQRT((JMAX+0.5)**2+C)
!$OMP PARALLEL DO PRIVATE(J) SCHEDULE(STATIC)
        DO J=1,MIN(JH,JZ)
          SLAT(J)=COS(BZ(J)*R)
        ENDDO
!$OMP PARALLEL DO PRIVATE(J) SCHEDULE(STATIC)
        DO J=JZ+1,JH
          SLAT(J)=COS((BZ(JZ)+(J-JZ)*PI)*R)
        ENDDO
        SPMAX=1.
        DO WHILE(SPMAX.GT.EPS)
          SPMAX=0.
          DO J=1,JH
            PKM1(J)=1.
            PK(J)=SLAT(J)
          ENDDO
          DO N=2,JMAX
            DO J=1,JH
              PKM2(J)=PKM1(J)
              PKM1(J)=PK(J)
              PK(J)=((2*N-1)*SLAT(J)*PKM1(J)-(N-1)*PKM2(J))/N
            ENDDO
          ENDDO
          DO J=1,JH
            SP=PK(J)*(1.-SLAT(J)**2)/(JMAX*(PKM1(J)-SLAT(J)*PK(J)))
            SLAT(J)=SLAT(J)-SP
            SPMAX=MAX(SPMAX,ABS(SP))
          ENDDO
        ENDDO
        DO J=1,JH
          WLAT(J)=(2.*(1.-SLAT(J)**2))/(JMAX*PKM1(J))**2
          SLAT(JMAX+1-J)=-SLAT(J)
          WLAT(JMAX+1-J)=WLAT(J)
        ENDDO
        IF(JHE.GT.JH) THEN
          SLAT(JHE)=0.
          WLAT(JHE)=2./JMAX**2
          DO N=2,JMAX,2
            WLAT(JHE)=WLAT(JHE)*N**2/(N-1)**2
          ENDDO
        ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  EQUALLY-SPACED LATITUDES INCLUDING POLES
      ELSE
          WRITE(*,*) "IP_SPLAT SHOULD BE CALLED WITH IDRT=4 not ", IDRT
	  STOP 10
      ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine zhpsi
  use global_variables
  implicit none
! finite difference
  real(dp),parameter :: cN0=-205d0/72d0,cN1=8d0/5d0
  real(dp),parameter :: cN2=-1d0/5d0,cN3=8d0/315d0
  real(dp),parameter :: cN4=-1d0/560d0
  integer :: ix,iy
  real(dp) :: c0,c1,c2,c3,c4
  real(dp) :: c0e,c1e,c2e,c3e,c4e,c0n,c1n,c2n,c3n,c4n
! nine-points formula
  c0e=-0.5d0*cN0/(dx**2)/mu_e
  c1e=-0.5d0*cN1/(dx**2)/mu_e
  c2e=-0.5d0*cN2/(dx**2)/mu_e
  c3e=-0.5d0*cN3/(dx**2)/mu_e
  c4e=-0.5d0*cN4/(dx**2)/mu_e

  c0n=-0.5d0*cN0/(dr**2)/mu_n
  c1n=-0.5d0*cN1/(dr**2)/mu_n
  c2n=-0.5d0*cN2/(dr**2)/mu_n
  c3n=-0.5d0*cN3/(dr**2)/mu_n
  c4n=-0.5d0*cN4/(dr**2)/mu_n

  ztmp_wfn_b(:,:)=0d0
  ztmp_wfn_b(0:Nx,0:NR) = ztmp_wfn(0:Nx,0:NR)
  ztmp_wfn_b(0:Nx,-1) = ztmp_wfn(0:Nx,1)
  ztmp_wfn_b(0:Nx,-2) = ztmp_wfn(0:Nx,2)
  ztmp_wfn_b(0:Nx,-3) = ztmp_wfn(0:Nx,3)
  ztmp_wfn_b(0:Nx,-4) = ztmp_wfn(0:Nx,4)

  do iy=0,NR
  do ix=0,Nx
    ztmp_hwfn(ix,iy)=(c0e+c0n)*ztmp_wfn_b(ix,iy) &
          + c1e*(ztmp_wfn_b(ix+1,iy) + ztmp_wfn_b(ix-1,iy)) &
          + c2e*(ztmp_wfn_b(ix+2,iy) + ztmp_wfn_b(ix-2,iy)) &
          + c3e*(ztmp_wfn_b(ix+3,iy) + ztmp_wfn_b(ix-3,iy)) &
          + c4e*(ztmp_wfn_b(ix+4,iy) + ztmp_wfn_b(ix-4,iy)) &
          + c1n*(ztmp_wfn_b(ix,iy+1) + ztmp_wfn_b(ix,iy-1)) &
          + c2n*(ztmp_wfn_b(ix,iy+2) + ztmp_wfn_b(ix,iy-2)) &
          + c3n*(ztmp_wfn_b(ix,iy+3) + ztmp_wfn_b(ix,iy-3)) &
          + c4n*(ztmp_wfn_b(ix,iy+4) + ztmp_wfn_b(ix,iy-4))

  end do
  end do

  ztmp_hwfn(:,:) = ztmp_hwfn(:,:) + v_all(:,:)*ztmp_wfn(:,:)
  return
end subroutine zhpsi


! Filename: precision.f90
! Description: Module of precision parameters. Based on
!              http://fortranwiki.org/fortran/show/Real+precision
! Author: Tim Troxler
! Date: 7/17/2015
module precision

    integer, parameter :: sp = selected_real_kind(6, 37)
    integer, parameter :: dp = selected_real_kind(15, 307)
    integer, parameter :: qp = selected_real_kind(33, 4931)

end module precision


module m_Parameters
  use m_TypeDef
  use m_LogInfo
  implicit none
  private

  ! Flow type option
  integer,parameter,public:: FT_CH=1  ! Channel
  integer,parameter,public:: FT_HC=2  ! Half channel
  integer, public,save:: FlowType
  real(RK),public,save:: ubulk
  logical,public,save :: IsUxConst
  logical,public,save:: IsUseCRF
  real(RK),public::PrGradAver,uCRF

  ! mesh options
  real(RK),public,save::xlx, yly, zlz  ! domain length in three directions
  integer,public,save::nxp,nyp,nzp     ! grid point number in three directions
  integer,public,save::nxc,nyc,nzc     ! grid center number in three directions. nxc = nxp-1
  integer, public,save:: istret        ! Stretch y-mesh or not (0:no, 1:both sides, 2:bottom)
  real(RK),public,save:: cStret        ! Stretching parameter, if istret=0. this parameter doesn't work.

  integer,parameter,public:: x_pencil=1
  integer,parameter,public:: y_pencil=2
  integer,parameter,public:: z_pencil=3
  integer,parameter,public:: xm_dir=1  ! x- direction
  integer,parameter,public:: xp_dir=2  ! x+ direction
  integer,parameter,public:: ym_dir=3  ! y- direction
  integer,parameter,public:: yp_dir=4  ! y+ direction
  integer,parameter,public:: zm_dir=5  ! z- direction
  integer,parameter,public:: zp_dir=6  ! z+ direction

  ! Physical properties
  real(RK),save,public:: xnu                    ! Kinematic viscosity
  real(RK),dimension(3),save,public:: gravity   ! Gravity or  other constant body forces (if any)

  ! Time stepping scheme and Projection method options
  integer,parameter,public:: FI_AB2 =1          !  AB2 for convective term
  integer,parameter,public:: FI_RK2 =2          !  RK2 for convective term
  integer,parameter,public:: FI_RK3 =3          !  RK3 for convective term
  real(RK),save,public:: dt         ! current time step
  real(RK),save,public:: dtMax      ! Maxium time step
  real(RK),save,public:: SimTime    ! Real simulation time
  integer,save,public :: iCFL       ! Use CFL condition to change time step dynamically( 1: yes, 2:no ).
  real(RK),save,public:: CFLc       ! CFL parameter
  integer,save,public::  itime      ! current time step
  integer,save,public::  ifirst     ! First iteration
  integer,save,public::  ilast      ! Last iteration
  integer,save,public::  iadvance
  integer,save,public::  ischeme
  real(RK),dimension(3),save,public :: pmGammaConst
  real(RK),dimension(3),save,public :: pmThetaConst
  real(RK),dimension(3),save,public :: pmAlphaConst
  real(RK),save,public::pmGamma
  real(RK),save,public::pmTheta
  real(RK),save,public::pmAlpha
  real(RK),save,public::pmAlphaC
  real(RK),save,public::pmBeta
  real(RK),save,public::pmBetaT

  ! FFTW_option
  integer,save,public:: FFTW_plan_type

  ! Boundary conditions
  real(RK),public,dimension(6):: uxBcValue
  real(RK),public,dimension(6):: uyBcValue
  real(RK),public,dimension(6):: uzBcValue

  ! I/O, Statistics
  integer,public,save:: ivstats            ! time step interval for statistics calculation
  integer,public,save:: SaveVisu           ! Output visulizing file frequency
  integer,public,save:: BackupFreq         ! Output Restarting file frequency
  integer,public,save:: SaveStat           ! Output Statistics file frequency

  logical,public,save::       RestartFlag  ! restart or not
  character(64),public,save:: RunName      ! Run name
  character(64),public,save:: Res_Dir      ! Result directory
  character(64),public,save:: RestartDir   ! Restart directory
  integer,public,save:: Cmd_LFile_Freq= 1  ! report frequency in the terminal
  integer,public,save:: LF_file_lvl   = 5  ! logfile report level
  integer,public,save:: LF_cmdw_lvl   = 3  ! terminal report level

  ! Decomp2d options
  integer,public,save:: p_row,p_col

  ! limited velocity and div
  real(RK),public,save:: vel_limit
  real(RK),public,save:: div_limit

  ! SpectraOptions
  logical,public,save:: clc_Spectra
  integer,public,save:: ivSpec
  integer,public,save:: jSpecSet
  integer,public,save:: jSpecEnd
  integer,public,save:: jSpecinc

  public:: ReadAndInitParameters,DumpReadedParam,PMcoeUpdate
contains

  !******************************************************************
  ! InitParameters
  !******************************************************************
  subroutine ReadAndInitParameters(chFile)
    implicit none
    character(*),intent(in)::chFile

    ! locals
    integer:: nUnitFile,myistat
    NAMELIST/BasicParam/FlowType,ubulk,xlx,yly,zlz,nxp,nyp,nzp,istret,cStret,xnu,dtMax,iCFL,CFLc,    &
                        ifirst,ilast,ischeme,FFTW_plan_type,gravity,uxBcValue,uyBcValue,uzBcValue,   &
                        ivstats,BackupFreq,SaveStat,SaveVisu,IsUxConst,IsUseCRF,RestartFlag,RunName, &
                        Res_Dir,RestartDir,Cmd_LFile_Freq,LF_file_lvl,LF_cmdw_lvl,p_row,p_col, &
                        vel_limit,div_limit
    NAMELIST/SpectraOptions/clc_Spectra,ivSpec,jSpecSet,jSpecEnd,jSpecinc
    nUnitFile = GetFileUnit()
    open(unit=nUnitFile, file=chFile, status='old',form='formatted',IOSTAT=myistat )
    if(myistat/=0) then
      print*,"Cannot open file: "//trim(chFile); STOP
    endif
    read(nUnitFile, nml=BasicParam)
    rewind(nUnitFile)
    read(nUnitFile, nml=SpectraOptions)
    close(nUnitFile,IOSTAT=myistat)

    nxc= nxp-1
    nyc= nyp-1
    nzc= nzp-1
    if(IsUseCRF) then
      uCRF= ubulk
      uxBcValue= uxBcValue -uCRF
    else
      uCRF= zero
    endif

    if(ischeme==FI_AB2) then
      iadvance = 1
      pmGammaConst = (/ three/two, zero, zero/)
      pmThetaConst = (/     -half, zero, zero/)
    elseif(ischeme==FI_RK2) then
      iadvance = 2
      pmGammaConst = (/ half,  one, zero/)
      pmThetaConst = (/ zero,-half, zero/)
    elseif(ischeme==FI_RK3) then
      iadvance = 3
      pmGammaConst = (/ eight/fifteen,       five/twelve,    three/four/)
      pmThetaConst = (/          zero,  -seventeen/sixty,  -five/twelve/)
    else
      print*,"Time scheme WRONG!!! ischeme=",ischeme; STOP
    endif
    pmAlphaConst = pmGammaConst + pmThetaConst

  end subroutine ReadAndInitParameters

  !******************************************************************
  ! DumpReadedParam
  !******************************************************************
  subroutine DumpReadedParam()
    implicit none

    ! locals
    NAMELIST/BasicParam/FlowType,ubulk,xlx,yly,zlz,nxp,nyp,nzp,istret,cStret,xnu,dtMax,iCFL,CFLc,    &
                        ifirst,ilast,ischeme,FFTW_plan_type,gravity,uxBcValue,uyBcValue,uzBcValue,   &
                        ivstats,BackupFreq,SaveStat,SaveVisu,IsUxConst,IsUseCRF,RestartFlag,RunName, &
                        Res_Dir,RestartDir,Cmd_LFile_Freq,LF_file_lvl,LF_cmdw_lvl,p_row,p_col, &
                        vel_limit,div_limit
    NAMELIST/SpectraOptions/clc_Spectra,ivSpec,jSpecSet,jSpecEnd,jSpecinc

    write(MainLog%nUnit, nml=BasicParam)
    write(MainLog%nUnit, nml=SpectraOptions)
  end subroutine DumpReadedParam

  !******************************************************************
  ! PMcoeUpdate
  !******************************************************************
  subroutine PMcoeUpdate(ns)
    implicit none
    integer,intent(in)::ns

    pmGamma = pmGammaConst(ns) * dt
    pmTheta = pmThetaConst(ns) * dt
    pmAlpha = pmAlphaConst(ns) * dt
    pmBeta  = half * pmAlphaConst(ns) *xnu * dt
    SimTime=SimTime+dt*real(pmAlphaConst(ns),RK)

    pmAlphaC= pmAlphaConst(ns)              ! for pressure gradient purpose only
    if(ns==1) PrGradAver=zero
  end subroutine PMcoeUpdate

end module m_Parameters


        INTEGER  FUNCTION GCD ( P , Q )

C***********************************************************************
C Version "$Id: gcd.f 1 2017-06-10 18:05:20Z coats $"
C EDSS/Models-3 I/O API.
C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr.,
C (C) 2003-2010 by Baron Advanced Meteorological Systems.
C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
C See file "LGPL.txt" for conditions of use.
C.........................................................................
C  GCD function body starts at line 44
C  LCM function body starts at line 77
C
C  FUNCTION:
C       GCD computes greatest common divisors, and LCM computes
C       the least common multiple of integers P,Q
C
C  PRECONDITIONS REQUIRED:  none
C
C  REVISION  HISTORY:
C       prototype 3/1991 by CJC
C
C       Bugfix    9/2004 by CJC: handle case that P=0 or Q=0
C
C       Modified 03/2010 by CJC: F9x changes for I/O API v3.1
C***********************************************************************

        IMPLICIT NONE

C...........   Arguments:

        INTEGER, INTENT(IN   ) :: P , Q

C.......   Local Variables:

        INTEGER 	X, Y

C***********************************************************************
C   begin body of program  GCD2

        IF ( P .EQ. 0 ) THEN
            GCD = 0
            RETURN
        ELSE IF ( Q .EQ. 0 ) THEN
            GCD = 0
            RETURN
        END IF

        X = ABS ( P )
        Y = ABS ( Q )

111     CONTINUE

            IF ( X .GT. Y ) THEN
                X = MOD ( X , Y )
                IF ( X .NE. 0 ) GO TO 111
            ELSE IF ( X .LT. Y ) THEN
                Y = MOD ( Y , X )
                IF ( Y .NE. 0 ) GO TO 111
            END IF

        GCD = MAX ( X , Y )

        RETURN

        END FUNCTION GCD

        ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

        INTEGER FUNCTION LCM( I, J )
            INTEGER, INTENT( IN ) :: I, J
            INTEGER, EXTERNAL     :: GCD
            LCM = ( I * J ) / GCD( I, J )
        END FUNCTION LCM


! Mikayla Webber
! 4670 Numerical Analysis
! Homework Four Due 11/6/17

module secret

integer :: fcounter

end module secret

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

program WebberHomework4Question3
use secret
implicit none

stop
end program WebberHomework4Question3

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

implicit none

	double precision :: a,b,ci,d,f,simp2d
	integer :: m,n
	external f

	a = 0.0d0
	b = 2.0d0
	ci = 0.0d0
	d = 1.0d0
	simp2d = 0.0d0

	m = 20
	n = 20

	call CompSimpson2d(a,b,ci,d,m,n,f,simp2d)

	print*,"simpson 2d = ",simp2d

	stop
	end

	double precision function f(x,y)
	implicit none

	double precision :: x,y

	f = x*y**2.0d0

	return
	end


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program test_hist

! generate random values and bin them into histogram bins.
! easy enough to plot with the matlab 'bar()' function.

use      types_mod, only : r4, r8, digits12
use  utilities_mod, only : register_module, error_handler, E_ERR, E_MSG, &
                           initialize_utilities, finalize_utilities,     &
                           open_file, close_file
use random_seq_mod, only : random_seq_type, init_random_seq, random_uniform

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

type (random_seq_type) :: r
real(r8) :: val
integer :: i, bin, iunit
integer, parameter :: nbins = 500
integer :: repcount = 100000000
integer :: bincount(nbins)

call initialize_utilities('test_hist')
call register_module(source,revision,revdate)

write(*, *) 'creating file "makehist.m" with output in matlab format'

iunit = open_file("makehist.m", 'formatted', 'write')
write(iunit, '(A)') 'bindata = [ ... '
bincount(:) = 0

call init_random_seq(r, 5)
do i=1, repcount
   val = random_uniform(r)
   ! generates a bin number between 0 and nbins-1,
   ! or possibly equal to nbins w/ roundoff error.
   ! (tests found 3 cases in 100M samples)
   bin = floor(val*nbins) + 1
   !print *, i, val, bin
   if (bin == nbins+1) bin = nbins
   if (bin < 1 .or. bin > nbins+1) then
      print *, 'error: computed bin = ', bin, ' should be > 1 and  < ', nbins
   endif
   bincount(bin) = bincount(bin)+1
enddo

do i=1, nbins
   !print *, i, bincount(i)
   !print *, (1.0_r8/nbins)*(i-1), bincount(i)
   write(iunit, '(I8,A)') bincount(i), ', ... '
enddo

write(iunit, '(A)') '];'
write(iunit, '(A)') 'bar(bindata);'
write(iunit, '(A)') 'axis([0, 500, 190000, 210000]);'

write(*, *) 'closing "makehist.m" file'

call close_file(iunit)

call finalize_utilities()

end program test_hist

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!     brc  :  A parabolic PDE (the Brusselator)
!----------------------------------------------------------------------
!----------------------------------------------------------------------
! (Discretized in space by polynomial collocation at Chebyshev points)
!----------------------------------------------------------------------
!----------------------------------------------------------------------
! NOTE: The value of the constant NE is defined in the module brc below.
!
!      NE  :  the dimension of the PDE system
!
!      NN  :  the number of Chebyshev collocation points in space is
!             determined by the AUTO-constant NDIM:
!             NN = NDIM/NE
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      MODULE brc
        SAVE
        INTEGER, PARAMETER :: NE=2
        DOUBLE PRECISION, ALLOCATABLE :: D2(:,:)
      END MODULE brc

      SUBROUTINE FF(NE,U,PAR,F)
!     ---------- --
!     Define the nonlinear term

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NE
      DOUBLE PRECISION, INTENT(IN) :: U(NE),PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NE)

      DOUBLE PRECISION X,Y,A,B

        X=U(1)
        Y=U(2)
        A=PAR(1)
        B=PAR(2)

        F(1)= X**2*Y - (B+1)*X + A
        F(2)=-X**2*Y + B*X

      END SUBROUTINE FF

      SUBROUTINE SETDC(NE,DC,PAR)
!     ---------- -----
!     Set the diffusion constants (constant, or in terms of PAR)

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NE
      DOUBLE PRECISION, INTENT(OUT) :: DC(NE)
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)

        DC(1)=PAR(3)/PAR(5)**2
        DC(2)=PAR(4)/PAR(5)**2

      END SUBROUTINE SETDC

      SUBROUTINE SETBC(NE,PAR,U0,U1)
!     ---------- -----
! Set the boundary values (to be kept fixed in time)

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NE
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: U0(NE),U1(NE)

      DOUBLE PRECISION A,B

        A=PAR(1)
        B=PAR(2)

        U0(1)=A
        U0(2)=B/A
        U1(1)=A
        U1(2)=B/A

      END SUBROUTINE SETBC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----
! Define the starting stationary solution on the spatial mesh

      USE brc
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM/NE,NE),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      INTEGER I,NN
      DOUBLE PRECISION A,B,Dx,Dy,RL

! Set the parameter values
        A=2.d0
        B=5.45d0
        Dx=0.008d0
        Dy=0.004d0
        RL=0.4

        PAR(1)=A
        PAR(2)=B
        PAR(3)=Dx
        PAR(4)=Dy
        PAR(5)=RL

! Set the starting solution at the Chebyshev collocation points
        NN=NDIM/NE
        DO I=1,NN
          U(I,1)=A
          U(I,2)=B/A
        ENDDO

      END SUBROUTINE STPNT
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!                Problem-independent subroutines
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      USE brc
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM/NE,NE), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM/NE,NE)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION W(NE),FW(NE),DC(NE),U0(NE),U1(NE)
      INTEGER I,J,K,NN,NP

! Problem-independent initialization :
        NN=NDIM/NE
        NP=NN+1

        CALL SETDC(NE,DC,PAR)
        CALL SETBC(NE,PAR,U0,U1)

        DO I=1,NN
          DO K=1,NE
            W(K)=U(I,K)
          ENDDO
          CALL FF(NE,W,PAR,FW)
          DO J=1,NE
            F(I,J)=FW(J) + DC(J)*(U0(J)*D2(I,0)+U1(J)*D2(I,NP))
            DO K=1,NN
              F(I,J)=F(I,J)+DC(J)*D2(I,K)*U(K,J)
            ENDDO
          ENDDO
        ENDDO

      END SUBROUTINE FUNC

      SUBROUTINE GENCF(PAR,NN)
!     ---------- -----

      USE brc
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NN
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)

      DOUBLE PRECISION, ALLOCATABLE :: X(:),XX(:,:),CC(:,:),RI(:,:)
      INTEGER, ALLOCATABLE :: IR(:),IC(:)

      DOUBLE PRECISION pi,C,DET
      INTEGER I,J,K,M,NP

        NP=NN+1
        M=NN+2
        ALLOCATE(D2(NN,0:NP))
        ALLOCATE(X(M),XX(M,M),CC(M,0:NP),RI(M,M),IR(M),IC(M))

        pi=4*ATAN(1.d0)
        X(1)=0.d0
        DO K=2,NP
          C=COS( (2*K-3)*pi/(2*NN) )
          X(K)=(1+C)/2
        ENDDO
        X(M)=1.d0

        DO I=1,M
          DO J=1,M
            RI(I,J)=0.d0
            XX(I,J)=X(I)**(J-1)
          ENDDO
          RI(I,I)=1.d0
        ENDDO

        CALL GE(0,M,M,XX,M,M,CC,M,RI,IR,IC,DET)

        DO I=1,NN
          DO J=0,NP
            D2(I,J)=0.d0
            DO K=2,M-1
              D2(I,J)=D2(I,J)+CC(K+1,J)*K*(K-1)*X(I+1)**(K-2)
            ENDDO
          ENDDO
        ENDDO
        DEALLOCATE(X,XX,CC,RI,IR,IC)

      END SUBROUTINE GENCF

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE PVLS(NDIM,U,PAR)
!     ---------- ----

      USE brc
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)
      LOGICAL, SAVE :: ifrst = .TRUE.

! Problem-independent initialization :
      IF(ifrst)THEN
         CALL GENCF(PAR,NDIM/NE)
         ifrst=.FALSE.
      ENDIF

      END SUBROUTINE PVLS


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!This file is "fd_coef.f90"
!This file contain one subroutine.
!SUBROUTINE fd_coef
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine fd_coef
  use Global_Variables
  implicit none
  integer :: i,j,k,n
  real(8) :: t,s,s0

  lap=0.d0
  nab=0.d0

  n=Nd
  s=0.d0
  do i=-n,n
    if ( i==0 ) cycle
    do j=-n,n
      if ( j==i .or. j==0 ) cycle
      s=s+1.d0/dble(i*j)
    end do
  end do
  lap(0)=s

  do j=1,n
    t=1.d0
    do i=-n,n
      if ( i==j ) cycle
      t=t*(j-i)
    end do
    s=0.d0
    do k=-n,n
      if ( k==j .or. k==0 ) cycle
      s0=1.d0
      do i=-n,n
        if ( i==k .or. i==j .or. i==0 ) cycle
        s0=s0*(-i)
      end do
      s=s+s0
    end do
    lap( j)=2.d0*s/t
    lap(-j)=lap(j)
  end do

  do j=1,n
    t=1.d0
    do i=-n,n
      if ( i==j ) cycle
      t=t*(j-i)
    end do
    s=1.d0
    do i=-n,n
      if ( i==j .or. i==0 ) cycle
      s=s*(-i)
    end do
    nab( j)=s/t
    nab(-j)=-nab(j)
  end do

  lapx(-Nd:Nd)=lap(-Nd:Nd)/Hx**2
  lapy(-Nd:Nd)=lap(-Nd:Nd)/Hy**2
  lapz(-Nd:Nd)=lap(-Nd:Nd)/Hz**2
  nabx(-Nd:Nd)=nab(-Nd:Nd)/Hx
  naby(-Nd:Nd)=nab(-Nd:Nd)/Hy
  nabz(-Nd:Nd)=nab(-Nd:Nd)/Hz

  return
End Subroutine fd_coef
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130


PROGRAM TEST
! Test the existing functionalities of the neural network module.
USE NEURALNET_MOD
USE REAL_PRECISION
IMPLICIT NONE

TYPE(LAYER) :: MYLAYER
TYPE(NEURALNET) :: MYNET
REAL(KIND=R8) :: X(4), B(20)
REAL(KIND=R8) :: DATA(5,20), WEIGHTS(20), BIAS(5), A(20,4)
REAL(KIND=R8) :: WORK(50)
INTEGER :: IERR, LWORK, I

REAL(KIND=R8), EXTERNAL :: DDOT
CALL RANDOM_NUMBER(DATA(:,:))

A(:,:) = TRANSPOSE(DATA(1:4,:))
B(:) = DATA(5,:)
LWORK=50
CALL DGELS('N', 20, 4, 1, A, 20, B, 20, WORK, LWORK, IERR)
IF(IERR .NE. 0) PRINT *, IERR

MYNET = NEURALNET()
MYLAYER = LAYER(4, IERR)
IF(IERR .NE. 0) PRINT *, IERR
CALL MYNET%ADD(MYLAYER, IERR)
IF(IERR .NE. 0) PRINT *, IERR
MYLAYER = LAYER(4, IERR)
IF(IERR .NE. 0) PRINT *, IERR
CALL MYNET%ADD(MYLAYER, IERR)
IF(IERR .NE. 0) PRINT *, IERR
MYLAYER = LAYER(1, IERR)
IF(IERR .NE. 0) PRINT *, IERR
CALL MYNET%ADD(MYLAYER, IERR)
IF(IERR .NE. 0) PRINT *, IERR

CALL MYNET%TRAIN(DATA, IERR, LAMBDA=0.0_R8)
IF(IERR .NE. 0) PRINT *, IERR

DO I = 1, 4
   X(:) = 0.0_R8
   X(I) = 1.0_R8
   A(1,1) = DDOT(4, B, 1, X, 1)
   PRINT *, 'Optimal value: ', A(1,1)
   PRINT *, 'Predicted value: ', MYNET%EVALUATE(X,IERR)
END DO

END PROGRAM TEST


	function dcsin(z1)
	double complex dcsin, z1, z2
	double precision dummy(2), a, b, c, d
	equivalence (a,z2,dummy(1)), (b,dummy(2))

	z2 = z1
	c = dexp(b)
	d = 1.0d0/c
	b = dcos(a)*(c-d)/2.0d0
	a = dsin(a)*(c+d)/2.0d0
	dcsin = z2
	return
	end


      SUBROUTINE LAGDER(N,X,Y,DER)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(N),Y(N)
      XU=X(1)
      DE=0.D0
      DO 10 K=2,N
      DE=DE+1.D0/(XU-X(K))
   10 CONTINUE
      DE=DE*Y(1)
      DO 20 I=2,N
      ANU=1.D0
      DO 30 J=2,N
      IF(J.EQ.I) GO TO 30
      ANU=ANU*(XU-X(J))
   30 CONTINUE
      ADE=1.D0
      DO 40 J=1,N
      IF(J.EQ.I) GO TO 40
      ADE=ADE*(X(I)-X(J))
   40 CONTINUE
      DE=DE+Y(I)*ANU/ADE
   20 CONTINUE
      DER=DE
      RETURN
      END


    Program dggev_example

!     DGGEV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_sort_realmat_rank_rows, &
        nagf_sort_realvec_rank_rearrange
      Use lapack_interfaces, Only: dggev
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: eig
      Real (Kind=dp) :: scal_i, scal_r, small
      Integer :: i, ifail, info, j, k, lda, ldb, ldvr, lwork, n
      Logical :: pair
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), alphai(:), alphar(:), b(:, :), &
        beta(:), vr(:, :), vr_row(:), work(:)
      Real (Kind=dp) :: dummy(1, 1)
      Integer, Allocatable :: irank(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, all, cmplx, epsilon, max, maxloc, nint, sqrt, tiny
!     .. Executable Statements ..
      Write (nout, *) 'DGGEV Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvr = n
      Allocate (a(lda,n), alphai(n), alphar(n), b(ldb,n), beta(n), vr(ldvr,n), &
        irank(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dggev('No left vectors', 'Vectors (right)', n, a, lda, b, ldb, &
        alphar, alphai, beta, dummy, 1, vr, ldvr, dummy, lwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+7)*n, nint(dummy(1,1)))
      Allocate (work(lwork))

!     Read in the matrices A and B

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Solve the generalized eigenvalue problem

      Call dggev('No left vectors', 'Vectors (right)', n, a, lda, b, ldb, &
        alphar, alphai, beta, dummy, 1, vr, ldvr, work, lwork, info)

      If (info>0) Then
        Write (nout, *)
        Write (nout, 100) 'Failure in DGGEV. INFO =', info
      Else
!       If beta(:) > eps, Order eigenvalues by ascending real parts
!       and then by ascending imaginary parts
        If (all(abs(beta(1:n))>epsilon(1.0E0_dp))) Then
          work(1:n) = alphar(1:n)/beta(1:n)
          work(n+1:2*n) = alphai(1:n)/beta(1:n)
          ifail = 0
          Call nagf_sort_realmat_rank_rows(work, n, 1, n, 1, 2, 'Ascending', &
            irank, ifail)
          Call nagf_sort_realvec_rank_rearrange(alphar, 1, n, irank, ifail)
          Call nagf_sort_realvec_rank_rearrange(alphai, 1, n, irank, ifail)
          Call nagf_sort_realvec_rank_rearrange(beta, 1, n, irank, ifail)
!         Order the eigenvectors in the same way
          Allocate (vr_row(n))
          Do j = 1, n
            vr_row(1:n) = vr(j, 1:n)
            Call nagf_sort_realvec_rank_rearrange(vr_row, 1, n, irank, ifail)
            vr(j, 1:n) = vr_row(1:n)
          End Do
          Deallocate (vr_row)
        End If
        small = tiny(1.0E0_dp)
        pair = .False.
        Do j = 1, n
          Write (nout, *)
          If ((abs(alphar(j))+abs(alphai(j)))*small>=abs(beta(j))) Then
            Write (nout, 110) 'Eigenvalue(', j, ')', &
              ' is numerically infinite or undetermined', 'ALPHAR(', j, &
              ') = ', alphar(j), ', ALPHAI(', j, ') = ', alphai(j), ', BETA(', &
              j, ') = ', beta(j)
          Else
            If (alphai(j)==zero) Then
              Write (nout, 120) 'Eigenvalue(', j, ') = ', alphar(j)/beta(j)
            Else
              eig = cmplx(alphar(j), alphai(j), kind=dp)/ &
                cmplx(beta(j), kind=dp)
              Write (nout, 130) 'Eigenvalue(', j, ') = ', eig
            End If
          End If
          Write (nout, *)
          Write (nout, 140) 'Eigenvector(', j, ')'
          If (alphai(j)==zero) Then
!           Let largest element be positive
            work(1:n) = abs(vr(1:n,j))
            k = maxloc(work(1:n), 1)
            If (vr(k,j)<zero) Then
              vr(1:n, j) = -vr(1:n, j)
            End If
            Write (nout, 150)(vr(i,j), i=1, n)
          Else
            If (pair) Then
              Write (nout, 160)(vr(i,j-1), -vr(i,j), i=1, n)
            Else
!             Let largest element be real (and positive).
              work(1:n) = vr(1:n, j)**2 + vr(1:n, j+1)**2
              k = maxloc(work(1:n), 1)
              scal_r = vr(k, j)/sqrt(work(k))
              scal_i = -vr(k, j+1)/sqrt(work(k))
              work(1:n) = vr(1:n, j)
              vr(1:n, j) = scal_r*work(1:n) - scal_i*vr(1:n, j+1)
              vr(1:n, j+1) = scal_r*vr(1:n, j+1) + scal_i*work(1:n)
              Write (nout, 160)(vr(i,j), vr(i,j+1), i=1, n)
            End If
            pair = .Not. pair
          End If
        End Do

      End If

100   Format (1X, A, I4)
110   Format (1X, A, I2, 2A, /, 1X, 2(A,I2,A,1P,F11.3,3X), A, I2, A, 1P, &
        F11.3)
120   Format (1X, A, I2, A, 1P, F11.3)
130   Format (1X, A, I2, A, '(', 1P, F11.3, ',', 1P, F11.3, ')')
140   Format (1X, A, I2, A)
150   Format (1X, 1P, F11.5)
160   Format (1X, '(', 1P, F11.5, ',', 1P, F11.5, ')')
    End Program


!  ********************************************************************
!  *                                                                  *
!  *                        subroutine sim2dk                         *
!  *                                                                  *
!  ********************************************************************
!  Single Precision Version 3.0
!  Written by Gordon A. Fenton, TUNS, 1991
!  Latest Update: May 10, 2001
!
!  PURPOSE  to generate a realization of a soil conductivity field
!
!  This routine creates a realization of a soil conductivity field in 2-D.
!  The generation proceeds as follows;
!
!   1) generate a zero-mean, unit-variance, Gaussian random field in 2-D
!      with prescribed covariance structure.
!
!   2) transform the field into a lognormally distributed conductivity field
!      on a point-wise basis by setting Y = exp(ksdl + kmnl*G) at each field
!      coordinate (kmnl and ksdl being the mean and variance of the
!      log-conductivity field).
!
!   3) map discrete conductivity values into the finite element mesh, so that
!      each element takes on a particular conductivity value
!
!  Arguments are described as follows;
!
!    perm    real array of size at least NXE x NYE which on output will
!            contain the desired realization of conductivity.
!            The leading dimension of perm is assumed to be NXE.
!c            (output)
!c
!c     nxe    number of elements in the X direction. (input)
!c
!     nye    number of elements in the Y direction. (input)
!
!      dx    physical size of an element in the X direction. (input)
!
!      dy    physical size of an element in the Y direction. (input)
!
!     thx    scale of fluctuation of log-conductivity in the X direction.
!            Note that if either thx or thy is zero, the entire field is
!            assumed to be made up of independent values (ie a white
!            noise process). In this case, the mean and variance of each
!            cell is determined directly from kmn? and ksd?, that is the
!            effects of local averaging is not considered. (input)
!
!     thy    scale of fluctuation of log-conductivity in the Y direction.
!            See note on thx. (input)
!
!     kmn    (real) target mean of conductivity at a point. (input)
!
!     ksd    (real) target standard deviation of conductivity at a point.
!            (input)
!
!   lunif    logical flag which is true if the conductivity field is
!            uniform, corresponding to an infinite scale of fluctuation
!            in both directions. In this case, the conductivity field
!            is set equal to a single random value having mean kmn and
!            standard deviation ksd. (input)
!
!   kseed    integer seed to be used for the pseudo-random number generator.
!            If KSEED = 0, then a random seed will be used (based on the
!            clock time when LAS2D is called for the first time).
!            On output, KSEED is set to the value of the actual seed used.
!            (input/output)
!
!  dmpfld    logical flag which is true if the first generated random field
!            is to be dumped to a DISPLAY format file. Only one field is
!            dumped, so dmpfld is set to false after dumping. (input/output)
!
!   iperm    unit number to which the first field of log-conductivity is
!            dumped. (input)
!
!     job    character string containing the title of the run. (input)
!
!    sub1    character string containing the subtitle of the run. (input)
!
!    sub2    character string containing the sub-subtitle of the run. (input)
!
!  varfnc    character*6 string containing the name of the var/covar function
!            to be used by las2g. See las2g(3f) for details. (input)
!
!   debug    logical flag which is true if debugging information is to be
!            output to unit istat. (input)
!
!   istat    unit number to which error and warning messages are issued.
!            (input)
!
!  dmpagh    logical flag which is true if arithmetic, geometric and harmonic
!            means are to be calculated for the conductivity field. (input)
!
!  kstats    real array of size at least 3 x 4 containing conductivity stats;
!            (input/output)
!	       (1,1) = current block conductivity value
!	       (2,1) = sum of block conductivities (over the realizations)
!	       (3,1) = sum of (block conductivities)**2
!	       (1,2) = current arithmetic mean of conductivity field
!	       (2,2) = sum of arithmetic means (over the realizations)
!	       (3,2) = sum of (arithmetic means)**2
!	       (1,3) = current geometric mean of conductivity field
!	       (2,3) = sum of geometric means (over the realizations)
!	       (3,3) = sum of (geometric means)**2
!	       (1,4) = current harmonic mean of conductivity field
!	       (2,4) = sum of harmonic means (over the realizations)
!	       (3,4) = sum of (harmonic means)**2
!
!    kmne    (real) target mean of conductivity over a finite element (ie.
!            after locally averaging over (dx x dy)). (output)
!
!    ksde    (real) target standard deviation of conductivity over a finite
!            element (ie. after locally averaging over (dx x dy)). (output)
!
!    akmn    real value which which contains a running sum of
!            conductivities over each field and over all realizations.
!            (input/output)
!
!    aksd    real value which which contains a running sum of squared
!            conductivities over each field and over all realizations.
!            (input/output)
!
!  dcheck    logical flag which is true if this is a data-check run only, in
!            which case only the required field size and target statistics
!            are actually computed herein. (input)
!
!  Revision History:
!
!  2.5	now using libGAFsim variance functions dlavx2, dlsep2, and dlspx2,
!	rather than vfrtxx, vfsepx, and vfspxx (these are equivalent, they
!	are just part of the library now and renamed).
!  2.6	added the 2-D fractal process variance functions dlvfr2 and dlsfr2
!	(these come from libGAFsim).
!  2.7	made conductivity isotropic, assumes that kmn and ksd refer to the
!	point statistics (now kmne, ksde return the cell statistics).
!  2.71	corrected header.
!  2.8	improved the handling of the uniform field case (lunif = true)
!  2.9	LAS2G now uses covariances to produce simulations (via lvarfn)
!	(May 23/00)
!  3.0	removed lvarfn from common/dparam/ (LAS2G now uses Gauss quadrature
!	for all covariance calculations) (May 10/01)
!---------------------------------------------------------------------------
      subroutine sim2dk(perm,nxe,nye,dx,dy,thx,thy,kmn,ksd,               &
	               lunif,kseed,dmpfld,iperm,job,sub1,                     &
                       sub2,varfnc,debug,istat,dmpagh,                    &
                       kstats,kmne,ksde,akmn,aksd,dcheck)
      real perm(nxe,*), kstats(3,*)
      real*8 dvar, dpb, dthx, dthy, dthz, ddx, ddy, oned
      real*8 dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2, uservf
      real*8 dmin1, dble
      real kmn, kmne, ksd, ksde
      logical debug, dmpfld, liid, lunif, dmpagh, dcheck
      character*(*) job, sub1, sub2, varfnc
      external dlavx2, dlsep2, dlspx2, dlafr2, dlsfr2, uservf
      save pmn, psd, liid, XL, YL, nn
!				export parameters to variance function
      common/dparam/ dvar, dpb, dthx, dthy, dthz
      data ifirst/1/
      data zero/0.0/, half/0.5/, one/1.0/, two/2.0/, oned/1.d0/

   1  format(a,a)
   2  format(a,i4,a,i4,a)
   3  format(a,e12.5)
   4  format()

!-------------------------------------- initialize -------------------------
!					compute required field size (once)
      if( ifirst .eq. 1 ) then
         ifirst = 0
         liid   = (thx .eq. zero .or. thy .eq. zero)
         nn     = nxe*nye
         XL     = float(nxe)*dx
         YL     = float(nye)*dy

         ierr = 0
         if( debug ) write(istat,1)'SIM2DK: setting field parameters...'
         pvr  = alog(one + ksd*ksd/(kmn*kmn))
         pmn  = alog(kmn) - half*pvr
         psd  = sqrt(pvr)
         if( .not. liid .and. .not. lunif ) then
!						set variance fnc parameters
            dvar = oned
            dthx = thx
            dthy = thy
!					find mean and s.d. of log-conductivity
!					averaged over the element
            ddx  = dble(dx)
            ddy  = dble(dy)
            dvar = -dvar		! tell cov functions to return varfunc
            if( varfnc .eq. 'dlavx2' ) then
               vf  = dlavx2(ddx,ddy)
            elseif( varfnc .eq. 'dlsep2' ) then
               vf = dlsep2(ddx,ddy)
            elseif( varfnc .eq. 'dlspx2' ) then
               vf = dlspx2(ddx,ddy)
            elseif( varfnc .eq. 'dlafr2' ) then
               dpb = dmin1(ddx,ddy)
               vf  = dlafr2(ddx,ddy)
            elseif( varfnc .eq. 'dlsfr2' ) then
               dpb = dmin1(ddx,ddy)
               vf  = dlsfr2(ddx,ddy)
            elseif( varfnc .eq. 'uservf' ) then
               vf = uservf(ddx,ddy)
            else
               write(istat,1)'*** Error: unknown variance function name: ', varfnc
               stop
            endif
            dvar = -dvar		! tell cov functions to return cov
            kmne = exp(pmn + half*vf*pvr)
            ksde = kmne*sqrt((exp(vf*pvr) - one))
!						print out some information

            write(istat,2)'Specified Field size = (',nxe,' x ',nye,')'
            write(istat,3)'Variance reduction   = ',vf
            write(istat,3)'Point Log-Cond. mean = ',pmn
            write(istat,3)'Point Log-Cond. S.D. = ',psd
            write(istat,3)'Cell Cond. mean      = ',kmne
            write(istat,3)'Cell Cond. S.D.      = ',ksde
            write(istat,'()')
!						initialize LAS2G
	    if( varfnc .eq. 'dlavx2' ) then
	       call las2g(perm,nxe,nye,XL,YL,dlavx2,kseed,-1,istat)
	    elseif( varfnc .eq. 'dlsep2' ) then
	       call las2g(perm,nxe,nye,XL,YL,dlsep2,kseed,-1,istat)
	    elseif( varfnc .eq. 'dlspx2' ) then
	       call las2g(perm,nxe,nye,XL,YL,dlspx2,kseed,-1,istat)
	    elseif( varfnc .eq. 'dlafr2' ) then
	       call las2g(perm,nxe,nye,XL,YL,dlafr2,kseed,-1,istat)
	    elseif( varfnc .eq. 'dlsfr2' ) then
	       call las2g(perm,nxe,nye,XL,YL,dlsfr2,kseed,-1,istat)
	    elseif( varfnc .eq. 'uservf' ) then
	       call las2g(perm,nxe,nye,XL,YL,uservf,kseed,-1,istat)
	    endif
         else
!					for a white noise or uniform field
            kmne  = kmn
            ksde  = ksd
            kseed = iseed(kseed)
         endif
      endif

!------------------------------------ generate the random field(s) -----------
      if( dcheck ) return
      aa = zero
      va = zero
!						white noise field
      if( liid ) then
         if( dmpagh ) then
            ag = zero
            ah = zero
            do 10 iq = 1, nye
            do 10 ip = 1, nxe
               gk = pmn + psd*gausv(one)
               pk = exp( gk )
               ph = one/pk
               aa = aa + pk
               va = va + pk*pk
               ag = ag + gk
               ah = ah + ph
               perm(ip,iq) = pk
  10        continue
         else
            do 20 iq = 1, nye
            do 20 ip = 1, nxe
               perm(ip,iq)   = exp( pmn + psd*gausv(one) )
               aa = aa + perm(ip,iq)
               va = va + perm(ip,iq)*perm(ip,iq)
  20        continue
         endif
         if( dmpfld ) then
            call pltfld( job, sub1, sub2, perm, nxe, nxe, nye, XL, YL,'White Noise Conductivity Field', iperm )
            dmpfld = .false.
         endif
!						uniform field
      elseif( lunif ) then
         gk = pmn + psd*gausv(one)
         pk = exp( gk )
         aa = float(nn)*pk
         va = float(nn)*pk*pk
         if( dmpagh ) then
            ag = float(nn)*gk
            ah = float(nn)/pk
         endif
         do 30 iq = 1, nye
         do 30 ip = 1, nxe
            perm(ip,iq) = pk
  30     continue
      else
!						random field
	 if( varfnc .eq. 'dlavx2' ) then
	    call las2g(perm,nxe,nye,XL,YL,dlavx2,kseed,0,istat)
	 elseif( varfnc .eq. 'dlsep2' ) then
	    call las2g(perm,nxe,nye,XL,YL,dlsep2,kseed,0,istat)
	 elseif( varfnc .eq. 'dlspx2' ) then
	    call las2g(perm,nxe,nye,XL,YL,dlspx2,kseed,0,istat)
	 elseif( varfnc .eq. 'dlafr2' ) then
	    call las2g(perm,nxe,nye,XL,YL,dlafr2,kseed,0,istat)
	 elseif( varfnc .eq. 'dlsfr2' ) then
	    call las2g(perm,nxe,nye,XL,YL,dlsfr2,kseed,0,istat)
	 elseif( varfnc .eq. 'uservf' ) then
	    call las2g(perm,nxe,nye,XL,YL,uservf,kseed,0,istat)
	 endif
!						plot the first field?
	 if( dmpfld ) then
	    call pltfld( job, sub1, sub2, perm, nxe, nxe, nye, XL, YL,'Log-Conductivity Field', iperm )
	    dmpfld = .false.
	 endif
!						log-field --> field
         if( dmpagh ) then
            ag = zero
            ah = zero
            do 40 iq = 1, nye
            do 40 ip = 1, nxe
               gk = pmn + psd*perm(ip,iq)
               ag = ag + gk
               perm(ip,iq) = exp( gk )
               aa = aa + perm(ip,iq)
               va = va + perm(ip,iq)*perm(ip,iq)
               ah = ah + one/perm(ip,iq)
  40        continue
         else
            do 50 iq = 1, nye
            do 50 ip = 1, nxe
               perm(ip,iq) = exp( pmn + psd*perm(ip,iq) )
               aa = aa + perm(ip,iq)
               va = va + perm(ip,iq)*perm(ip,iq)
  50        continue
         endif
      endif
!						conductivity statistics
      akmn = akmn + aa
      aksd = aksd + va
      kstats(1,2) = aa/float(nn)
      if( dmpagh ) then
         kstats(2,2) = kstats(2,2) + kstats(1,2)
         kstats(3,2) = kstats(3,2) + kstats(1,2)*kstats(1,2)
         kstats(1,3) = exp(ag/float(nn))
         kstats(2,3) = kstats(2,3) + kstats(1,3)
         kstats(3,3) = kstats(3,3) + kstats(1,3)*kstats(1,3)
         kstats(1,4) = float(nn)/ah
         kstats(2,4) = kstats(2,4) + kstats(1,4)
         kstats(3,4) = kstats(3,4) + kstats(1,4)*kstats(1,4)
      endif
   do i=1,16
   enddo
      return
      end


MODULE PS9PARA
    IMPLICIT NONE
    REAL(KIND=8), PARAMETER:: PH=5.0, PL=0.0 ! PRICES
    REAL(KIND=8), PARAMETER:: ML=0.0, MH=15.0 ! MASS OF FIRMS
    REAL(KIND=8), PARAMETER:: THETA=0.64, BETA=0.8, GAMMA=0.5772156649
    REAL(KIND=8)::ENT_MASS=100.
    REAL(KIND=8), PARAMETER:: ENT_COST=5., FIX_COST=10.
    REAL(KIND=8),PARAMETER:: A=1./200.
    REAL(KIND=8), DIMENSION(5),PARAMETER:: ENT_DIST=(/0.37,0.4631,0.1102,0.0504,0.0063/) !V(S)
    REAL(KIND=8), DIMENSION(5),PARAMETER:: STATES=(/3.98E-4,3.58,6.82,12.18,18.79/) !5 STATES
    REAL(KIND=8), DIMENSION(5,5),PARAMETER:: TRANS=RESHAPE((/0.6598,0.1997,0.2,0.2,0.2,0.26,0.7201,0.2,0.2,&
    0.2,0.0416,0.042,0.5555,0.2502,0.25,0.0331,&
    0.0326,0.0344,0.3397,0.34,0.0055,0.0056,0.0101,0.0101,0.01/), (/5,5/))
    INTEGER, PARAMETER:: NZ=SIZE(STATES)
    REAL(KIND=8), PARAMETER:: CRIT=1E-2
    REAL(KIND=8), DIMENSION(1):: MUL_TMP ! A VARIABLE TO STORE RESULT OF MATMUL
END MODULE

MODULE PS9RES
    USE PS9PARA
    IMPLICIT NONE
    REAL(KIND=8):: P_HIGH=PH, P_LOW=PL, M_LOW=ML, M_HIGH=MH
    REAL(KIND=8):: P, M
    REAL(KIND=8):: ERROR_P, ERROR_LAB
    REAL(KIND=8), DIMENSION(NZ):: LAB_DEM
    REAL(KIND=8):: LAB_SUP, M_EXIT
    REAL(KIND=8):: AGG_LAB_DEM, INC_LAB_DEM, ENT_LAB_DEM, LAB_ENT_RATIO
    REAL(KIND=8), DIMENSION(NZ):: ENT_VF=0., ENT_VF_NEW, MOTIONS, MOTIONS_NEW
    INTEGER(KIND=8), DIMENSION(NZ):: ENT_PF
END MODULE

MODULE PS9TVRES
    USE PS9PARA
    IMPLICIT NONE
    REAL(KIND=8):: ALPHA
    REAL(KIND=8), DIMENSION(NZ, 2):: SIGMA1, SIGMA2, SIGMA
    REAL(KIND=8), DIMENSION(NZ):: PF_TV1, PF_TV2, VF_TV, VF_TV_NEW

END MODULE

PROGRAM PS9
    USE PS9PARA
    USE PS9RES
    USE PS9TVRES
    IMPLICIT NONE
    INTEGER:: IDX

    CALL STANDARD()
    PRINT*, "P, M_INC, M_ENT, M_EXIT, AGGLAB, INCLAB, ENTLAB, %ENTLAB"
    PRINT*, P, SUM(MOTIONS), M, M_EXIT, AGG_LAB_DEM, INC_LAB_DEM, ENT_LAB_DEM, ENT_LAB_DEM/AGG_LAB_DEM
    PRINT*, "================================================"
    PRINT*, "TV ALPHA=1"
    ALPHA=1.
    P_HIGH=PH
    P_LOW=PL
    M_LOW=ML
    M_HIGH=MH
    CALL TV()
    PRINT*, "P, M_INC, M_ENT, M_EXIT, AGGLAB, INCLAB, ENTLAB, %ENTLAB"
    PRINT*, P, SUM(MOTIONS), M, M_EXIT, AGG_LAB_DEM, INC_LAB_DEM, ENT_LAB_DEM, ENT_LAB_DEM/AGG_LAB_DEM
    PRINT*, "================================================"
    PRINT*, "TV ALPHA=2"
    ALPHA=2.
    P_HIGH=PH
    P_LOW=PL
    M_LOW=ML
    M_HIGH=MH
    CALL TV()
    PRINT*, "P, M_INC, M_ENT, M_EXIT, AGGLAB, INCLAB, ENTLAB, %ENTLAB"
    PRINT*, P, SUM(MOTIONS), M, M_EXIT, AGG_LAB_DEM, INC_LAB_DEM, ENT_LAB_DEM, ENT_LAB_DEM/AGG_LAB_DEM

    OPEN(UNIT=23, FILE='DECISION', STATUS='REPLACE')
        DO IDX=1, NZ
            WRITE(UNIT=23, FMT=*) ENT_PF(IDX), SIGMA1(IDX, 1), SIGMA2(IDX, 1)
        ENDDO
    CLOSE(UNIT=23)
    OPEN(UNIT=24, FILE='PRODUCTIVITY', STATUS='REPLACE')
        DO IDX=1, NZ
            WRITE(UNIT=24, FMT=*) STATES(IDX)
        ENDDO
    CLOSE(UNIT=24)
END PROGRAM

SUBROUTINE STANDARD()
    USE PS9PARA
    USE PS9RES
    IMPLICIT NONE

    ERROR_P=100.
    P = 0.8
    DO WHILE (ERROR_P>CRIT) ! ENTRANT CONDITION
        CALL ENTRY_CLEAR()
    ENDDO

    ERROR_LAB=100.
    M=1. ! AS STATED IN THE PROBLEM SET, INITIALIZE
    DO WHILE (ERROR_LAB>CRIT)
        CALL LAB_CLEAR(.TRUE.)
    ENDDO
END SUBROUTINE

SUBROUTINE ENTRY_CLEAR()
    USE PS9PARA
    USE PS9RES
    IMPLICIT NONE
    INTEGER:: IDX, NEXTI
    INTEGER:: DEBUG=0

    REAL(KIND=8):: NSTAR ! OPT EMPLOY
    REAL(KIND=8):: ERROR_VFI
    REAL(KIND=8):: VF_STAY, VF_EXIT
    REAL(KIND=8):: ENT_COND

    ERROR_VFI=100.
    ENT_VF = 0.
    DO WHILE(ERROR_VFI>CRIT)
        VF_STAY = 0.
        VF_EXIT=0.
        DO IDX=1, NZ
            NSTAR = (THETA*P*STATES(IDX))**(1/(1-THETA))
            LAB_DEM(IDX)=NSTAR
            VF_EXIT = P*STATES(IDX)*(NSTAR**THETA)-NSTAR-P*FIX_COST
            VF_STAY = VF_EXIT
            DO NEXTI=1,NZ
                 VF_STAY = VF_STAY+ BETA*TRANS(IDX, NEXTI)*ENT_VF(NEXTI)
            ENDDO
            ENT_VF_NEW(IDX)=MAX(VF_EXIT, VF_STAY)
            MUL_TMP = MAXLOC((/VF_STAY, VF_EXIT/))
            ENT_PF(IDX) = MUL_TMP(1) -1.
        ENDDO
        ERROR_VFI= MAXVAL(ABS(ENT_VF-ENT_VF_NEW))
        ENT_VF = ENT_VF_NEW
    ENDDO

    ! CALCUALTE ENTRY CONDITIONS
    ENT_MASS = 0.
    DO IDX=1, NZ
        ENT_MASS= ENT_MASS + ENT_DIST(IDX)*ENT_VF(IDX)
    ENDDO
    ENT_COND = ENT_MASS/(P*ENT_COST)-1

    IF (ENT_COND>0.) THEN
        P_HIGH = P
    ELSE
        P_LOW = P
    ENDIF
    P = (P_LOW+P_HIGH)*0.5
    ERROR_P= ABS(ENT_COND)
END SUBROUTINE

SUBROUTINE LAB_CLEAR(STAND)
    USE PS9PARA
    USE PS9RES
    USE PS9TVRES
    IMPLICIT NONE
    INTEGER:: IDX, NIDX
    REAL(KIND=8):: ERROR_VFI, PI
    LOGICAL, INTENT(IN):: STAND
    REAL(KIND=8), DIMENSION(NZ):: DECISION

    IF (STAND) THEN
        DECISION = ENT_PF
    ELSE
        DECISION = SIGMA(:,1)
    ENDIF

    ERROR_VFI=100.
    MOTIONS=0.1 ! JUST RANDOM GUESS
    DO WHILE(ERROR_VFI> CRIT)
        M_EXIT = 0.
        MOTIONS_NEW = 0.
        DO IDX=1,NZ
            DO NIDX=1,NZ
                MOTIONS_NEW(NIDX) = MOTIONS_NEW(NIDX)+(1-DECISION(IDX))*TRANS(NIDX, IDX)*MOTIONS(NIDX)+&
                (1-DECISION(NIDX))*TRANS(NIDX,IDX)*M*ENT_DIST(NIDX)
                ! MASS OF EXIT IS NOT HOW MUCH STATE 1 (BECAUSE THEY HAVE ALREADY EXIT), BUT HOW MUCH MASS GOING TO STAGE ONE.
                M_EXIT = M_EXIT+ DECISION(NIDX)*TRANS(IDX,NIDX)*(MOTIONS(IDX)+M*ENT_DIST(IDX))
            ENDDO
        ENDDO
        ERROR_VFI = MAXVAL(ABS(MOTIONS_NEW-MOTIONS))
        MOTIONS = MOTIONS_NEW
    ENDDO
    AGG_LAB_DEM=0.
    ENT_LAB_DEM= 0.
    INC_LAB_DEM = 0.
    DO IDX=1,NZ
        ! LABOR DEMAND AGGREGATE
        AGG_LAB_DEM= AGG_LAB_DEM+ MOTIONS(IDX)*LAB_DEM(IDX)+ M*ENT_DIST(IDX)*LAB_DEM(IDX)
        ! LABOR DEMAND ENTRANT
        ENT_LAB_DEM = ENT_LAB_DEM+M*ENT_DIST(IDX)*LAB_DEM(IDX)
        ! LABOR DEMAND INCUMBENT
        INC_LAB_DEM= INC_LAB_DEM+MOTIONS(IDX)*LAB_DEM(IDX)
    ENDDO

    PI=0.
    ! LABOR SUPPLY
    DO IDX=1, NZ
        PI =PI+(P*STATES(IDX)*(LAB_DEM(IDX)**THETA)-LAB_DEM(IDX)-P*FIX_COST)*MOTIONS(IDX)+&
        M*(P*STATES(IDX)*(LAB_DEM(IDX)**THETA)-LAB_DEM(IDX)-P*ENT_COST)*ENT_DIST(IDX)
    ENDDO

    LAB_SUP = (P/A)-PI ! BASED ON FOC

    ERROR_LAB = ABS(LAB_SUP-AGG_LAB_DEM)
    IF (LAB_SUP>AGG_LAB_DEM) THEN
        M_LOW = M
    ELSE
        M_HIGH = M
    ENDIF
    M=(M_HIGH+M_LOW)/2.
END SUBROUTINE

SUBROUTINE TV()
    USE PS9PARA
    USE PS9RES
    USE PS9TVRES
    IMPLICIT NONE
    REAL(KIND=8):: ERROR_TV_VFI, NSTAR, ERROR_TV, ENT_COND
    INTEGER:: IDX, NIDX
    REAL(KIND=8), DIMENSION(NZ):: VF_STAY, VF_EXIT
    REAL(KIND=8), DIMENSION(2):: EXP_VAL

    ERROR_TV = 100.
    P = 0.5
    DO WHILE (ERROR_TV> CRIT)
        VF_TV =1. ! INITIAL GUESS
        ERROR_TV_VFI=100.

        DO WHILE (ERROR_TV_VFI>CRIT) ! ENTRANT CONDITION
            DO IDX=1, NZ
                NSTAR = (THETA*P*STATES(IDX))**(1/(1-THETA))
                LAB_DEM(IDX)=NSTAR
                VF_EXIT(IDX) = P*STATES(IDX)*(NSTAR**THETA)-NSTAR-P*FIX_COST
                VF_STAY(IDX) = VF_EXIT(IDX)
                DO NIDX=1,NZ
                    VF_STAY(IDX) = VF_STAY(IDX) + BETA*TRANS(IDX,NIDX)*VF_TV(NIDX)
                ENDDO
                EXP_VAL = (/EXP(ALPHA*VF_EXIT(IDX)),EXP(ALPHA*VF_STAY(IDX))/)
                VF_TV_NEW(IDX) = (GAMMA/ALPHA)+LOG(SUM(EXP_VAL))/ALPHA
                SIGMA(IDX,:) = EXP_VAL/SUM(EXP_VAL) ! DECISION RULES 1-EXIT 2-STAY
            ENDDO
            ERROR_TV_VFI = MAXVAL(ABS(VF_TV-VF_TV_NEW))
            VF_TV = VF_TV_NEW
        ENDDO

        ! CALCUALTE ENTRY CONDITIONS
        ENT_MASS = 0.
        DO IDX=1, NZ
            ENT_MASS= ENT_MASS + ENT_DIST(IDX)*VF_TV(IDX)
        ENDDO
        ENT_COND = ENT_MASS/(P*ENT_COST)-1

        IF (ENT_COND>0.) THEN
            P_HIGH = P
        ELSE
            P_LOW = P
        ENDIF
        P = (P_LOW+P_HIGH)*0.5
        ERROR_TV= ABS(ENT_COND)
    ENDDO
    ! EXACTLY THE SAME
    ERROR_LAB=100.
    M=1. ! AS STATED IN THE PROBLEM SET, INITIALIZE
    DO WHILE (ERROR_LAB>CRIT)
        CALL LAB_CLEAR(.FALSE.)
    ENDDO

    ! JUST FOR SAVING AND PLOT GRAPH
    IF (ALPHA==1.) THEN
        SIGMA1 = SIGMA
    ELSE
        SIGMA2 = SIGMA
    ENDIF
END SUBROUTINE


! -*- f90 -*-
! ****************************************
! Routine for calculating finite-difference jacobian

SUBROUTINE FDJAC(m,n,x,fvec,fjac,func,eps,center_diff)
  IMPLICIT NONE
  INTEGER m,n, i
  REAL (KIND=8) x(n), dx(n), fvec(m), fjac(m,n), eps, epsmach, dpmpar
  LOGICAL center_diff
  REAL (KIND=8) h, temp1(m), temp2(m)

  epsmach = dpmpar(1)
  IF(center_diff) THEN
     DO i = 1, n
        h = eps*ABS(x(i))
        IF (h < epsmach) h = eps
        dx(:) = 0.0D+00
        dx(i) = 0.5d+0*h
        CALL func(m,n,x+dx,temp1,0)
        CALL func(m,n,x-dx,temp2,0)
        fjac(:,i) = (temp1 - temp2)/h
     END DO
  ELSE
     DO i = 1, n
        h = eps*ABS(x(i))
        IF (h < epsmach) h = eps
        dx(:) = 0.0D+00
        dx(i) = h
        CALL func(m,n,x+dx,temp1,0)
        fjac(:,i) = (temp1 - fvec)/h
     END DO
  END IF

END SUBROUTINE FDJAC


!======================================================================!
  PROGRAM Linija
!----------------------------------------------------------------------!
!   Places the nodes on the line defined with local block position     !
!----------------------------------------------------------------------!
  IMPLICIT NONE
!------------------------------[Calling]-------------------------------!
  REAL     atanh
!-------------------------------[Locals]-------------------------------!
  INTEGER  N, i, node, case
  REAL     x0, delx, t, dt, ddt, pr, xi
  REAL     x(0:1000)
  REAL     w
!--------------------------------[CVS]---------------------------------!
  character*80 rcs1,rcs2
  data rcs1/                                                        &
  '$Id: Stretch.f90,v 1.1 2000/09/07 07:39:08 niceno Exp $'/
  data rcs2/                                                        &
  '$Source: /home/IUS/mhadziabdic/.CVSROOT/T-Rex/Test/Stretch.f90,v $'/
!======================================================================!

 character*20 file1

  x0=0.0

  write(*,*) 'Distance: '
  read(*,*)  delx
  write(*,*) 'Weigth: '
  read(*,*)  w
  write(*,*) 'Number of cells: '
  read(*,*)  N

  x(0) = x0

!-----------------------------!
!     Linear distribution     !
!-----------------------------!
  if(w  > 0.0) then
    ddt = ( 2.0*(1.0-w) ) / ( 1.0*N*(1.0*N-1.0)*(1.0+w) )
    t=0.0
    do i=1,N
      dt=1.0/(1.0*N)+(1.0*i-0.5*(1.0*N+1)) * ddt
      t=t+dt
      x(i) = x0 + t*delx
    end do

!---------------------------------!
!     Hyperbolic distribution     !
!---------------------------------!
  else
    case = 0
    if     ((w  >  -0.5).and.(w <=  -0.25)) then
      pr = 1.0 - abs(0.5 - abs(w))
      case = 1
    else if((w >=  -0.75).and.(w  <  -0.5)) then
      pr = 1.0 - abs(0.5 - abs(w))
      case = 2
    else
      pr = -w
      case = 3
    endif

    do i=1,N
      if(case == 1) xi = -1.0*(1.0*i)/(1.0*N)
      if(case == 2) xi =  1.0 - 1.0*(1.0*i)/(1.0*N)
      if(case == 3) xi = -1.0 + 2.0*(1.0*i)/(1.0*N)
      if    (case == 1) then
        x(i) = x0 - (tanh(xi*atanh(pr))/pr)*delx
      elseif(case == 2) then
        x(i) = x0 + delx - (tanh(xi*atanh(pr))/pr)*delx
      elseif(case == 3) then
        x(i) = x0 + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*delx
      endif
    end do

  endif

!------------------------------------!
!     Print out the distribution     !
!------------------------------------!
  write(*,*) ' number:   node:                  cell:'
  do i=N,1,-1
    write(*,'(I6,F12.6,A10)') i+1, x(i),              ' +-------+'
    write(*,'(I6,A23,F12.6)') i,  '|   o   | ', 0.5*(x(i)+x(i-1))
  end do
  write(*,'(I6,F12.6,A10)') i+1, x(0),              ' +-------+'
  write(*,*) 'wall:    //////////////////////////////'

  file1 = 'fileout'

  open(3,file=file1)

  do i = 1, N

   write(3,*) 0.5*(x(i)+x(i-1))

  end do

  close (3)

  END PROGRAM

!======================================================================!
  REAL FUNCTION Atanh(x)
!----------------------------------------------------------------------!
!   Calculates inverse of hyperbolic tangens.                          !
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  REAL   x
!--------------------------------[CVS]---------------------------------!
  character*80 rcs1,rcs2
  data rcs1/                                                        &
  '$Id: Stretch.f90,v 1.1 2000/09/07 07:39:08 niceno Exp $'/
  data rcs2/                                                        &
  '$Source: /home/IUS/mhadziabdic/.CVSROOT/T-Rex/Test/Stretch.f90,v $'/
!======================================================================!
  if(x  > 1.0) then
    write(*,*) 'Error message from atanh: bad argument'
    stop
  end if

  atanh=log( sqrt( (1.0+x)/(1.0-x) ) )

  END FUNCTION


program main
    use matmul_m, only: matmul_t

    instantiate matmul_t(real, real, real, operator(*), sum), only: matmul

    real :: x(3, 2), y(2, 3), z(3, 3)

    x = reshape([(real(i), i = 1, 6)], [3, 2])
    y = reshape([(real(i), i = 6, 1, -1)], [2, 3])
    z = matmul(x, y)
    do i = 1, 3
      print *, z(i,:)
    end do
end program


      FUNCTION LEAP_YEAR (year)

c***********************************************************************
c                         function   leap_year
c***********************************************************************

c  Program Source:   Naval Ocean Systems Center - Code 542

c  Date:
c     22 Mar 1997

c  Function:
c     Determines if given year is a leap year.

c  Parameters passed:
c        year       [i  ] year

c  Parameters returned:
c        leap_year  [l  ] TRUE if a leap year; FALSE otherwise

c  Common blocks referenced:

c  Functions and subroutines referenced:

c  References:

c  Change History:

c*******************!***************************************************

      logical       leap_year
      integer       year

c     Determine if this is a leap_year year
      if (MOD(year,4) .eq. 0) then
         if (MOD(year,100) .eq. 0) then
            if (MOD(year,400) .eq. 0) then
               leap_year=.true.
            else
               leap_year=.false.
            end if
         else
            leap_year=.true.
         end if
      else
         leap_year=.false.
      end if

      RETURN
      END    ! LEAP_YEAR


!!# MODULE: FUNCTION  Heaviside
MODULE FUN_Heaviside

!!## PURPOSE
!! Defines function <Heaviside(x)>, which is $1$ for
!! $x \ge 0$ and $0$ elsewhere.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!## HISTORY
! 1.[waw] Author   = William A. Wieselquist
!         Modified = 105.2006
!         Contact  = william.wieselquist AT gmail.com

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE Heaviside
 MODULE PROCEDURE Heaviside_Rsp
 MODULE PROCEDURE Heaviside_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: Heaviside

!!## MODULE PROCEDURES
CONTAINS

!!### ELEMENTAL FUNCTION: Heaviside_Rsp
PURE ELEMENTAL FUNCTION Heaviside_Rsp( x ) RESULT(y)
USE PAR_Constants_Rsp ,ONLY: c_1,c_0           !!((02-A-PAR_Constants_Rsp.f90))
!!#### REQUIRED INPUT
REAL(KIND_Rsp),INTENT(IN) :: x
!!#### REQUIRED OUTPUT
REAL(KIND_Rsp)            :: y
!!--begin--
y = MERGE( c_1 , c_0 , x>=c_0 )
!!--end--
END FUNCTION

!!### ELEMENTAL FUNCTION: Heaviside_Rdp
PURE ELEMENTAL FUNCTION Heaviside_Rdp( x ) RESULT(y)
USE PAR_Constants_Rdp ,ONLY: c_1,c_0           !!((02-A-PAR_Constants_Rdp.f90))
!!#### REQUIRED INPUT
REAL(KIND_Rdp),INTENT(IN) :: x
!!#### REQUIRED OUTPUT
REAL(KIND_Rdp)            :: y
!!--begin--
y = MERGE( c_1 , c_0 , x>=c_0 )
!!--end--
END FUNCTION

END MODULE


      SUBROUTINE SVBKSB(U,W,V,M,N,MP,NP,B,X)

      include 'PARAMETER'  !mfitmax
      real*4 U(mfitmax,mfitmax),W(mfitmax),V(mfitmax,mfitmax),
     &       B(mfitmax),X(mfitmax),TMP(mfitmax)

      DO 12 J=1,N

        S=0.

        IF(W(J).NE.0.)THEN

          DO 11 I=1,M

            S=S+U(I,J)*B(I)

11        CONTINUE

          S=S/W(J)

        ENDIF

        TMP(J)=S

12    CONTINUE

      DO 14 J=1,N

        S=0.

        DO 13 JJ=1,N

          S=S+V(J,JJ)*TMP(JJ)

13      CONTINUE

        X(J)=S

14    CONTINUE

      RETURN

      END


module mod_mom
  use mpi
  use mod_common_mpi, only: ierr
  use mod_types
  implicit none
  private
  public momx_a,momy_a,momz_a, &
         momx_d,momy_d,momz_d, &
         momx_p,momy_p,momz_p, cmpt_wallshear
  contains
  !
  subroutine momx_a(nx,ny,nz,dxi,dyi,dzci,dzfi,u,v,w,dudt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi,dyi
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    real(rp), dimension(0:,0:,0:), intent(in   ) :: u,v,w
    real(rp), dimension( :, :, :), intent(inout) :: dudt
    integer :: i,j,k
    real(rp) :: uuip,uuim,uvjp,uvjm,uwkp,uwkm
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uuip,uuim,uvjp,uvjm,uwkp,uwkm) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,u,v,w,dudt,dzci,dzfi)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          uuip  = 0.25*( u(i+1,j,k)+u(i,j,k) )*( u(i+1,j  ,k  )+u(i,j  ,k  ) )
          uuim  = 0.25*( u(i-1,j,k)+u(i,j,k) )*( u(i-1,j  ,k  )+u(i,j  ,k  ) )
          uvjp  = 0.25*( u(i,j+1,k)+u(i,j,k) )*( v(i+1,j  ,k  )+v(i,j  ,k  ) )
          uvjm  = 0.25*( u(i,j-1,k)+u(i,j,k) )*( v(i+1,j-1,k  )+v(i,j-1,k  ) )
          uwkp  = 0.25*( u(i,j,k+1)+u(i,j,k) )*( w(i+1,j  ,k  )+w(i,j  ,k  ) )
          uwkm  = 0.25*( u(i,j,k-1)+u(i,j,k) )*( w(i+1,j  ,k-1)+w(i,j  ,k-1) )
          !
          ! Momentum balance
          !
          dudt(i,j,k) = dudt(i,j,k) + &
                        dxi*(     -uuip + uuim ) + &
                        dyi*(     -uvjp + uvjm ) + &
                        dzfi(k)*( -uwkp + uwkm )
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momx_a
  !
  subroutine momy_a(nx,ny,nz,dxi,dyi,dzci,dzfi,u,v,w,dvdt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi,dyi
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    real(rp), dimension(0:,0:,0:), intent(in   ) :: u,v,w
    real(rp), dimension( :, :, :), intent(inout) :: dvdt
    integer :: i,j,k
    real(rp) :: uvip,uvim,vvjp,vvjm,wvkp,wvkm
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uvip,uvim,vvjp,vvjm,wvkp,wvkm) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzci,dzfi,u,v,w,dvdt)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          uvip  = 0.25*( u(i  ,j,k  )+u(i  ,j+1,k  ) )*( v(i,j,k)+v(i+1,j,k) )
          uvim  = 0.25*( u(i-1,j,k  )+u(i-1,j+1,k  ) )*( v(i,j,k)+v(i-1,j,k) )
          vvjp  = 0.25*( v(i  ,j,k  )+v(i  ,j+1,k  ) )*( v(i,j,k)+v(i,j+1,k) )
          vvjm  = 0.25*( v(i  ,j,k  )+v(i  ,j-1,k  ) )*( v(i,j,k)+v(i,j-1,k) )
          wvkp  = 0.25*( w(i  ,j,k  )+w(i  ,j+1,k  ) )*( v(i,j,k+1)+v(i,j,k) )
          wvkm  = 0.25*( w(i  ,j,k-1)+w(i  ,j+1,k-1) )*( v(i,j,k-1)+v(i,j,k) )
          !
          ! Momentum balance
          !
          dvdt(i,j,k) = dvdt(i,j,k) + &
                        dxi*(     -uvip + uvim ) + &
                        dyi*(     -vvjp + vvjm ) + &
                        dzfi(k)*( -wvkp + wvkm )
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momy_a
  !
  subroutine momz_a(nx,ny,nz,dxi,dyi,dzci,dzfi,u,v,w,dwdt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi,dyi
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    real(rp), dimension(0:,0:,0:), intent(in   ) :: u,v,w
    real(rp), dimension( :, :, :), intent(inout) :: dwdt
    integer :: i,j,k
    real(rp) :: uwip,uwim,vwjp,vwjm,wwkp,wwkm
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uwip,uwim,vwjp,vwjm,wwkp,wwkm) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzci,dzfi,u,v,w,dwdt)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          uwip  = 0.25*( w(i,j,k)+w(i+1,j,k) )*( u(i  ,j  ,k)+u(i  ,j  ,k+1) )
          uwim  = 0.25*( w(i,j,k)+w(i-1,j,k) )*( u(i-1,j  ,k)+u(i-1,j  ,k+1) )
          vwjp  = 0.25*( w(i,j,k)+w(i,j+1,k) )*( v(i  ,j  ,k)+v(i  ,j  ,k+1) )
          vwjm  = 0.25*( w(i,j,k)+w(i,j-1,k) )*( v(i  ,j-1,k)+v(i  ,j-1,k+1) )
          wwkp  = 0.25*( w(i,j,k)+w(i,j,k+1) )*( w(i  ,j  ,k)+w(i  ,j  ,k+1) )
          wwkm  = 0.25*( w(i,j,k)+w(i,j,k-1) )*( w(i  ,j  ,k)+w(i  ,j  ,k-1) )
          !
          ! Momentum balance
          !
          dwdt(i,j,k) = dwdt(i,j,k) + &
                        dxi*(     -uwip + uwim ) + &
                        dyi*(     -vwjp + vwjm ) + &
                        dzci(k)*( -wwkp + wwkm )
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momz_a
  !
  subroutine momx_d(nx,ny,nz,dxi,dyi,dzci,dzfi,visc,u,dudt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi,dyi,visc
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    real(rp), dimension(0:,0:,0:), intent(in   ) :: u
    real(rp), dimension( :, :, :), intent(inout) :: dudt
    real(rp) :: dudxp,dudxm,dudyp,dudym,dudzp,dudzm
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(dudxp,dudxm,dudyp,dudym,dudzp,dudzm) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzci,dzfi,u,dudt,visc)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          dudxp = (u(i+1,j,k)-u(i,j,k))*dxi
          dudxm = (u(i,j,k)-u(i-1,j,k))*dxi
          dudyp = (u(i,j+1,k)-u(i,j,k))*dyi
          dudym = (u(i,j,k)-u(i,j-1,k))*dyi
          dudzp = (u(i,j,k+1)-u(i,j,k))*dzci(k  )
          dudzm = (u(i,j,k)-u(i,j,k-1))*dzci(k-1)
          dudt(i,j,k) = dudt(i,j,k) + &
                        (dudxp-dudxm)*visc*dxi + &
                        (dudyp-dudym)*visc*dyi + &
                        (dudzp-dudzm)*visc*dzfi(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momx_d
  !
  subroutine momy_d(nx,ny,nz,dxi,dyi,dzci,dzfi,visc,v,dvdt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi,dyi,visc
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    real(rp), dimension(0:,0:,0:), intent(in   ) :: v
    real(rp), dimension( :, :, :), intent(inout) :: dvdt
    real(rp) :: dvdxp,dvdxm,dvdyp,dvdym,dvdzp,dvdzm
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(dvdxp,dvdxm,dvdyp,dvdym,dvdzp,dvdzm) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzci,dzfi,v,dvdt,visc)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          dvdxp = (v(i+1,j,k)-v(i,j,k))*dxi
          dvdxm = (v(i,j,k)-v(i-1,j,k))*dxi
          dvdyp = (v(i,j+1,k)-v(i,j,k))*dyi
          dvdym = (v(i,j,k)-v(i,j-1,k))*dyi
          dvdzp = (v(i,j,k+1)-v(i,j,k))*dzci(k  )
          dvdzm = (v(i,j,k)-v(i,j,k-1))*dzci(k-1)
          dvdt(i,j,k) = dvdt(i,j,k) + &
                        (dvdxp-dvdxm)*visc*dxi+ &
                        (dvdyp-dvdym)*visc*dyi+ &
                        (dvdzp-dvdzm)*visc*dzfi(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momy_d
  !
  subroutine momz_d(nx,ny,nz,dxi,dyi,dzci,dzfi,visc,w,dwdt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi,dyi,visc
    real(rp), intent(in), dimension(0:) :: dzci,dzfi
    real(rp), dimension(0:,0:,0:), intent(in   ) :: w
    real(rp), dimension( :, :, :), intent(inout) :: dwdt
    integer :: i,j,k
    real(rp) :: dwdxp,dwdxm,dwdyp,dwdym,dwdzp,dwdzm
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(dwdxp,dwdxm,dwdyp,dwdym,dwdzp,dwdzm) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzci,dzfi,w,dwdt,visc)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          dwdxp = (w(i+1,j,k)-w(i,j,k))*dxi
          dwdxm = (w(i,j,k)-w(i-1,j,k))*dxi
          dwdyp = (w(i,j+1,k)-w(i,j,k))*dyi
          dwdym = (w(i,j,k)-w(i,j-1,k))*dyi
          dwdzp = (w(i,j,k+1)-w(i,j,k))*dzfi(k+1)
          dwdzm = (w(i,j,k)-w(i,j,k-1))*dzfi(k  )
          dwdt(i,j,k) = dwdt(i,j,k) + &
                        (dwdxp-dwdxm)*visc*dxi+ &
                        (dwdyp-dwdym)*visc*dyi+ &
                        (dwdzp-dwdzm)*visc*dzci(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momz_d
  !
  subroutine momx_p(nx,ny,nz,dxi,bforce,p,dudt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dxi
    real(rp), intent(in) :: bforce
    real(rp), dimension(0:,0:,0:), intent(in ) :: p
    real(rp), dimension( :, :, :), intent(out) :: dudt
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(nx,ny,nz,dxi,bforce,p,dudt)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          dudt(i,j,k) = - dxi*( p(i+1,j,k)-p(i,j,k) ) + bforce
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momx_p
  !
  subroutine momy_p(nx,ny,nz,dyi,bforce,p,dvdt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in) :: dyi
    real(rp), intent(in) :: bforce
    real(rp), dimension(0:,0:,0:), intent(in ) :: p
    real(rp), dimension( :, :, :), intent(out) :: dvdt
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(nx,ny,nz,dyi,bforce,p,dvdt)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          dvdt(i,j,k) = - dyi*( p(i,j+1,k)-p(i,j,k) ) + bforce
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momy_p
  !
  subroutine momz_p(nx,ny,nz,dzci,bforce,p,dwdt)
    implicit none
    integer , intent(in) :: nx,ny,nz
    real(rp), intent(in), dimension(0:) :: dzci
    real(rp), intent(in) :: bforce
    real(rp), dimension(0:,0:,0:), intent(in ) :: p
    real(rp), dimension( :, :, :), intent(out) :: dwdt
    integer :: i,j,k
    !
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(nx,ny,nz,dzci,bforce,p,dwdt)
    do k=1,nz
      do j=1,ny
        do i=1,nx
          dwdt(i,j,k) = - dzci(k)*( p(i,j,k+1)-p(i,j,k) ) + bforce
        end do
      end do
    end do
    !$OMP END PARALLEL DO
  end subroutine momz_p
  subroutine cmpt_wallshear(n,is_bound,l,dli,dzci,dzfi,visc,u,v,w,taux,tauy,tauz)
    implicit none
    integer , intent(in ), dimension(3) :: n
    logical , intent(in ), dimension(0:1,3) :: is_bound
    real(rp), intent(in ), dimension(3)     :: l,dli
    real(rp), intent(in ), dimension(0:)    :: dzci,dzfi
    real(rp), intent(in )                   :: visc
    real(rp), intent(in ), dimension(0:,0:,0:) :: u,v,w
    real(rp), intent(out), dimension(3) :: taux,tauy,tauz
    real(rp) :: dudxp,dudxm,dudyp,dudym,dudzp,dudzm, &
                dvdxp,dvdxm,dvdyp,dvdym,dvdzp,dvdzm, &
                dwdxp,dwdxm,dwdyp,dwdym,dwdzp,dwdzm
    integer :: i,j,k,nx,ny,nz
    !
    nx = n(1)
    ny = n(2)
    nz = n(3)
    taux(:) = 0.
    if(is_bound(0,2)) then
      do k=1,nz
        do i=1,nx
          dudyp = (u(i,1 ,k)-u(i,0   ,k))*dli(2)*visc
          taux(2) = taux(2) + dudyp/(dli(1)*dzfi(k)*l(1)*l(3))
        end do
      end do
    end if
    if(is_bound(1,2)) then
      do k=1,nz
        do i=1,nx
          dudym = (u(i,ny,k)-u(i,ny+1,k))*dli(2)*visc
          taux(2) = taux(2) + dudyp/(dli(1)*dzfi(k)*l(1)*l(3))
        end do
      end do
    end if
    if(is_bound(0,3)) then
      do j=1,ny
        do i=1,nx
          dudzp = (u(i,j,1 )-u(i,j,0   ))*dzci(0)*visc
          taux(3) = taux(3) + dudzp/(dli(1)*dli(2)*l(1)*l(2))
        end do
      end do
    end if
    if(is_bound(1,3)) then
      do j=1,ny
        do i=1,nx
          dudzm = (u(i,j,nz)-u(i,j,nz+1))*dzci(nz)*visc
          taux(3) = taux(3) + dudzm/(dli(1)*dli(2)*l(1)*l(2))
        end do
      end do
    end if
    call mpi_allreduce(MPI_IN_PLACE,taux(1),3,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
    !
    tauy(:) = 0.
    if(is_bound(0,1)) then
      do k=1,nz
        do j=1,ny
          dvdxp = (v(1  ,j,k)-v(0  ,j,k))*dli(1)*visc
          tauy(1) = tauy(1) + dvdxp/(dli(2)*dzfi(1)*l(2)*l(3))
        end do
      end do
    end if
    if(is_bound(1,1)) then
      do k=1,nz
        do j=1,ny
          dvdxm = (v(nx,j,k)-v(nx+1,j,k))*dli(1)*visc
          tauy(1) = tauy(1) + dvdxm/(dli(2)*dzfi(1)*l(2)*l(3))
        end do
      end do
    end if
    if(is_bound(0,3)) then
      do j=1,ny
        do i=1,nx
          dvdzp = (v(i,j,1 )-v(i,j,0   ))*dzci(0)*visc
          tauy(3) = tauy(3) + dvdzp/(dli(1)*dli(2)*l(1)*l(2))
        end do
      end do
    end if
    if(is_bound(1,3)) then
      do j=1,ny
        do i=1,nx
          dvdzm = (v(i,j,nz)-v(i,j,nz+1))*dzci(nz)*visc
          tauy(3) = tauy(3) + dvdzm/(dli(1)*dli(2)*l(1)*l(2))
        end do
      end do
    end if
    call mpi_allreduce(MPI_IN_PLACE,tauy(1),3,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
    !
    tauz(:) = 0.
    if(is_bound(0,1)) then
      do k=1,nz
        do j=1,ny
          dwdxp = (w(1 ,j,k)-w(0   ,j,k))*dli(1)*visc
          tauz(1) = tauz(1) + dwdxp/(dli(2)*dzfi(k)*l(2)*l(3))
        end do
      end do
    end if
    if(is_bound(1,1)) then
      do k=1,nz
        do j=1,ny
          dwdxm = (w(nx,j,k)-w(nx+1,j,k))*dli(1)*visc
          tauz(1) = tauz(1) + dwdxm/(dli(2)*dzfi(k)*l(2)*l(3))
        end do
      end do
    end if
    if(is_bound(0,2)) then
      do k=1,nz
        do i=1,nx
          dwdyp = (w(i,1,k )-w(i,0   ,k))*dli(2)*visc
          tauz(2) = tauz(2) + dwdyp/(dli(1)*dzfi(k)*l(1)*l(3))
        end do
      end do
    end if
    if(is_bound(1,2)) then
      do k=1,nz
        do i=1,nx
          dwdym = (w(i,ny,k)-w(i,ny+1,k))*dli(2)*visc
          tauz(2) = tauz(2) + dwdym/(dli(1)*dzfi(k)*l(1)*l(3))
        end do
      end do
    end if
    call mpi_allreduce(MPI_IN_PLACE,tauz(1),3,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
  end subroutine cmpt_wallshear
end module mod_mom


      program ellips
!     ------ Programm for calculation ellipsometric parameters ------
      integer n, i, j
      real f,q,d1,d2,ksi,delta,u,z
      complex e1,e2,e3
      parameter (pi=3.1415926)
      common f,e1,e2,e3,q,d1,d2
      write(*,*) 'Enter E1, E2, E3 /*.,-*/'
      read(*,*) e1,e2,e3
      write(*,*) 'Enter the wavelength of light'
      read(*,*)q
      open(1,file='EXIT.dat')
 1    write(*,*) 'Input thicknessis d1 and d2'
      read(*,*)d1,d2
      write(*,*) 'Input initial angle of incidence'
      read(*,*)f1
      write(*,*) 'Input step'
      read(*,*)f0
      write(*,*) 'Input quantity of angle'
      read(*,*)n
      write(*,6)
      read(1,6)
      do i=0,n
         fi=f1+i*f0
         f=fi*pi/180
         call FZU(z,u,delta,ksi)
         write(*,5) fi, u, z, delta, ksi
         write(1,5) fi, u, z, delta, ksi
      end do
      write(*,*) 'Continue? j=1, j=0 - Stop'
      read(*,*) j
      if(j.eq.1)goto 1
      if(j.eq.0)goto 2
 5    format(2x,f5.2,4(2x,f12.7))
 6    format(4x,'F',10x,'COS',11x,'TAN',10x,'DELTA',10x,'KSI')
 2    Stop
      end program ELLIPS
!     ---------Calculation of ellipsometric parameters-----------------
      SUBROUTINE FZU(z,u,delta,ksi)
      real f,q,d1,d2,ksi,delta,u,z
      complex dl1,dl2,e1,e2,e3,cf1,cf2,cf3
      complex r01p,r12p,r23,r01s,r12s,r23s
      complex r,rs,rp,ex1,ex2,ex3
      parameter (pi=3.1415926)
      common f,e1,e2,e3,q,d1,d2
      cf1=CSQRT(1-sin(f)**2/(e1*e1))
      cf2=CSQRT(1-sin(f)**2/(e2*e2))
      cf3=CSQRT(1-sin(f)**2/(e3*e3))
      r01p=(e1*cos(f)-cf1)/(e1*cos(f)+cf1)
      r12p=(e2*cf1-e1*cf2)/(e2*cf1+e1*cf2)
      r23p=(e3*cf2-e2*cf3)/(e3*cf2+e2*cf3)
      r01s=(cos(f)-e1*cf1)/(cos(f)+e1*cf1)
      r12s=(e1*cf1-e2*cf2)/(e1*cf1+e2*cf2)
      r23s=(e2*cf1-e2*cf2)/(e1*cf1+e2*cf2)
      dl1=2*pi/q*d1*CSQRT(e1*e1-sin(f)**2)
      ex1=CEXP(2*(0.,-1.)*dl1)
      dl2=2*pi/q*d2*CSQRT(e2*e2-sin(f)**2)
      ex2=CEXP(2*(0.,-1.)*dl2)
      ex3=CEXP(2*(0.,-1.)*(dl1+dl2))
!     ---------------------------------------------------------------
      rp=r01p+r12p*ex1+r01p*r12p*r23p*ex2+r23p*ex3
      rp=rp/(1+r01p*r12p*ex1+r12p*r23p*ex2+r01p*r23p*ex3)
      rs=r01s+r12s*ex1+r01s*r12s*r23s*ex2+r23s*ex3
      rs=rs/(1+r01s+r12s*ex1+r12s*r23s*ex2+r01s*r23s*ex3)
      r=rp/rs
      z=CABS(r)
      u=REAL(r)/z
      ksi=ATAN(z)*180/pi
      delta=ACOS(u)*180/pi
      end SUBROUTINE FZU


module mod_chkdiv
  use mpi
  use mod_common_mpi, only: ierr
  use mod_types
  implicit none
  private
  public chkdiv
  contains
  subroutine chkdiv(lo,hi,dxf,dyf,dzf,l,u,v,w,divtot,divmax)
    !
    ! checks the divergence of the velocity field
    !
    implicit none
    integer , intent(in ), dimension(3) :: lo,hi
    real(rp), intent(in ), dimension(lo(1)-1:) :: dxf
    real(rp), intent(in ), dimension(lo(2)-1:) :: dyf
    real(rp), intent(in ), dimension(lo(3)-1:) :: dzf
    real(rp), intent(in ), dimension(3)        :: l
    real(rp), intent(in ), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:) :: u,v,w
    real(rp), intent(out) :: divtot,divmax
    real(rp) :: div
    integer  :: i,j,k
    !
    divtot = 0._rp
    divmax = 0._rp
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(lo,hi,u,v,w,dxf,dyf,dzf,l) &
    !$OMP PRIVATE(i,j,k,div) &
    !$OMP REDUCTION(+:divtot) &
    !$OMP REDUCTION(max:divmax)
    do k=lo(3),hi(3)
      do j=lo(2),hi(2)
        do i=lo(1),hi(1)
          div = (w(i,j,k)-w(i,j,k-1))/dzf(k) + &
                (v(i,j,k)-v(i,j-1,k))/dyf(j) + &
                (u(i,j,k)-u(i-1,j,k))/dxf(i)
          divmax = max(divmax,abs(div))
          divtot = divtot + div*dxf(i)*dyf(j)*dzf(k)/(l(1)*l(2)*l(3))
        enddo
      enddo
    enddo
    !$OMP END PARALLEL DO
    call mpi_allreduce(MPI_IN_PLACE,divtot,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
    call mpi_allreduce(MPI_IN_PLACE,divmax,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
  end subroutine chkdiv
end module mod_chkdiv


!
!   FnVFR.f90
!
!
!   Created by Kurt Mitman on 14/10/14.
!

DOUBLE PRECISION FUNCTION FnVFR(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

cons=gliq-FnQb(bsav,0.0d0)*bsav

if(cons .LT. cmin) then
    FnVFR = 1.d10+10.0d0*(cmin-cons)

else
    call basefun(GridB,nb,bsav,vals,inds)
    FnVFR = -1.0d0*(urent(cons,GridHR(gih),gij)+bet*(vals(1)*EVrent(inds(1),gij)+vals(2)*EVrent(inds(2),gij)))
endif

END FUNCTION FnVFR


*> \brief  SGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGESV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       REAL               A( LDA, * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGESV computes the solution to a real system of linear equations
*>    A * X = B,
*> where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*>
*> The LU decomposition with partial pivoting and row interchanges is
*> used to factor A as
*>    A = P * L * U,
*> where P is a permutation matrix, L is unit lower triangular, and U is
*> upper triangular.  The factored form of A is then used to solve the
*> system of equations A * X = B.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of linear equations, i.e., the order of the
*>          matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the N-by-N coefficient matrix A.
*>          On exit, the factors L and U from the factorization
*>          A = P*L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          The pivot indices that define the permutation matrix P;
*>          row i of the matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          On entry, the N-by-NRHS matrix of right hand side matrix B.
*>          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
*>                has been completed, but the factor U is exactly
*>                singular, so the solution could not be computed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realGEsolve
*
*  =====================================================================
      SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK driver routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           SGETRF, SGETRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGESV ', -INFO )
         RETURN
      END IF
*
*     Compute the LU factorization of A.
*
      CALL SGETRF( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL SGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
     $                INFO )
      END IF
      RETURN
*
*     End of SGESV
*
      END
c $Id$


c CONVERT_H2J converts astrocentric orbital elements in ascii files
c from follow_symba(2) to Jacobi elements. It assumes that there are
c only two planets.

c Last modified by Man Hoi Lee, Aug. 13, 2003.

	include 'swift.inc'

	real*8 SMASSYR
	parameter (SMASSYR=TWOPI*TWOPI)

	integer nbod

	real*8 mass(NTPMAX)
	real*8 xh(NTPMAX),yh(NTPMAX),zh(NTPMAX)
	real*8 vxh(NTPMAX),vyh(NTPMAX),vzh(NTPMAX)
	real*8 xj(NTPMAX),yj(NTPMAX),zj(NTPMAX)
	real*8 vxj(NTPMAX),vyj(NTPMAX),vzj(NTPMAX)
	real*8 t

        real*8 a(3),e(3),inc(3),capom(3),omega(3),capm(3),peri,apo,gm

	integer i,lfile,ifoln(3),ialpha

	character*80 filecode

	write (*,*) ' Enter code of input/output files: '
	read (*,100) filecode
 100    format (a)
	write (*,*) ' Mass of central star (in solar mass):'
	read (*,*) mass(1)

	do i=1,80
	  if (filecode(i:i).ne.' ') lfile = i
	enddo

	nbod = 3

	mass(1) = mass(1)*SMASSYR
	xh(1) = 0.d0
	yh(1) = 0.d0
	zh(1) = 0.d0
	vxh(1) = 0.d0
	vyh(1) = 0.d0
	vzh(1) = 0.d0

	open (unit=10, file='follow_symba.'//filecode(1:lfile)//'.1',
     &        status='old')
	open (unit=20, file='follow_symba.'//filecode(1:lfile)//'.2',
     &        status='old')
	open (unit=30, file='convert_h2j.'//filecode(1:lfile)//'.1',
     &        status='new')
	open (unit=40, file='convert_h2j.'//filecode(1:lfile)//'.2',
     &        status='new')

 200	continue

	read (10,*,err=900) t,ifoln(2),a(2),e(2),inc(2),capom(2),
     &	                    omega(2),capm(2),peri,apo,mass(2)
	read (20,*) t,ifoln(3),a(3),e(3),inc(3),capom(3),
     &	            omega(3),capm(3),peri,apo,mass(3)

	do i=2,nbod
	    ialpha = -1
	    mass(i) = mass(i)*mass(1)
	    gm = mass(1) + mass(i)
	    inc(i) = inc(i)/DEGRAD
	    capom(i) = capom(i)/DEGRAD
	    omega(i) = omega(i)/DEGRAD
	    capm(i) = capm(i)/DEGRAD
	    call ORBEL_EL2XV(gm,ialpha,a(i),e(i),inc(i),capom(i),
     &	         omega(i),capm(i),xh(i),yh(i),zh(i),vxh(i),vyh(i),
     &	         vzh(i))
	enddo

	call COORD_H2J(nbod,mass,xh,yh,zh,vxh,vyh,vzh,xj,yj,zj,
     &                 vxj,vyj,vzj)

	gm = mass(1)
	do i=2,nbod
	    gm = gm + mass(i)
	    call ORBEL_XV2EL(xj(i),yj(i),zj(i),vxj(i),vyj(i),vzj(i),
     &	         gm,ialpha,a(i),e(i),inc(i),capom(i),omega(i),capm(i))
	    inc(i) = inc(i)*DEGRAD
	    capom(i) = capom(i)*DEGRAD
	    omega(i) = omega(i)*DEGRAD
	    capm(i) = capm(i)*DEGRAD
	enddo

	write (30,800) t,ifoln(2),a(2),e(2),inc(2),capom(2),
     &	               omega(2),capm(2)
	write (40,800) t,ifoln(3),a(3),e(3),inc(3),capom(3),
     &	               omega(3),capm(3)
 800	format (1x,e15.7,1x,i3,1x,e13.5,1x,f7.5,4(1x,f9.4))

	goto 200

 900    close (unit=10)
	close (unit=20)
	close (unit=30)
	close (unit=40)

	stop
	end


! =========================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =========================================================

! solve Riemann problems for the 1D Euler equations using the HLLE
! approximate Riemann solver.

! waves: 2
! equations: 3

! Conserved quantities:
!       1 density
!       2 momentum
!       3 energy

    implicit none

    integer, intent(in) :: maxmx, meqn, mwaves, mbc, mx, maux
    double precision, dimension(meqn,1-mbc:maxmx+mbc), intent(in) :: ql, qr
    double precision, dimension(maux,1-mbc:maxmx+mbc), intent(in) :: auxl, auxr
    double precision, dimension(meqn, mwaves, 1-mbc:maxmx+mbc), intent(out) :: wave
    double precision, dimension(meqn, 1-mbc:maxmx+mbc), intent(out) :: amdq, apdq
    double precision, dimension(mwaves, 1-mbc:maxmx+mbc), intent(out) :: s

    double precision :: u_l, u_r, c_l, c_r, u_hat, c_hat
    double precision :: p_l, p_r, H_l, H_r, rhsqrt_l, rhsqrt_r
    double precision :: rhsq2, H_hat, gamma, gamma1, E_l, E_r
    double precision :: rho_m, rhou_m, E_m, s1, s2
    integer :: m, i, mw

    common /cparam/  gamma

    gamma1 = gamma - 1.d0

    do i=2-mbc,mx+mbc
        ! Velocity
        u_l = qr(2,i-1) / qr(1,i-1)
        u_r = ql(2,i  ) / ql(1,i  )
        ! Pressure
        p_l = gamma1 * (qr(3,i-1) - qr(1,i-1)*u_l**2/2.d0)
        p_r = gamma1 * (ql(3,i  ) - ql(1,i  )*u_r**2/2.d0)
        ! Enthalpy
        H_l = (qr(3,i-1) + p_l) / qr(1,i-1)
        H_r = (ql(3,i  ) + p_l) / ql(1,i  )
        ! Sound speed
        c_l = dsqrt(gamma1*H_l-u_l**2/2.)
        c_r = dsqrt(gamma1*H_r-u_r**2/2.)

        E_l = qr(3,i-1)
        E_r = ql(3,i  )

        rhsqrt_l = dsqrt(qr(1,i-1))
        rhsqrt_r = dsqrt(ql(1,i))
        rhsq2 = rhsqrt_l + rhsqrt_r
        u_hat = (qr(2,i-1)/rhsqrt_l + ql(2,i)/rhsqrt_r) / rhsq2
        H_hat = (((qr(3,i-1)+p_l)/rhsqrt_l + (ql(3,i)+p_r)/rhsqrt_r)) / rhsq2
        c_hat = dsqrt(gamma1*(H_hat - .5d0*u_hat**2))

        s1 = min(u_l - c_l, u_hat - c_hat)
        s2 = max(u_r + c_r, u_hat + c_hat)
        rho_m = (ql(2,i) - qr(2,i-1) - s2*ql(1,i) + s1*qr(1,i-1))/(s1-s2)
        rhou_m = (ql(1,i)*u_r**2 - qr(1,i-1)*u_l**2 + p_r - p_l - s2*ql(2,i) + s1*qr(2,i-1))/(s1-s2)
        E_m = ( u_r*(E_r+p_r) - u_l*(E_l+p_l) -s2*E_r + s1*E_l)/(s1-s2)

        wave(1,1,i) = rho_m - qr(1,i-1)
        wave(2,1,i) = rhou_m - qr(2,i-1)
        wave(3,1,i) = E_m - qr(3,i-1)
        s(1,i) = s1

        wave(1,2,i) = ql(1,i) - rho_m
        wave(2,2,i) = ql(2,i) - rhou_m
        wave(3,2,i) = ql(3,i) - E_m
        s(2,i) = s2

    end do

    do m=1,3
        do i=2-mbc, mx+mbc
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do mw=1,mwaves
                if (s(mw,i) < 0.d0) then
                    amdq(m,i) = amdq(m,i) + s(mw,i)*wave(m,mw,i)
                else
                    apdq(m,i) = apdq(m,i) + s(mw,i)*wave(m,mw,i)
                endif
            end do
        end do
    end do

end subroutine rp1