! -*- mode: F90; mode: font-lock -*-
! ------------------------------------------------------------------------------
! $Id$
! ------------------------------------------------------------------------------
! Module pao_array_utility
! ------------------------------------------------------------------------------
! Code area 11: basis functions
! ------------------------------------------------------------------------------

!!****h* Conquest/pao_array_utility
!!  NAME
!!   pao_array_utility
!!  PURPOSE
!!   contains routines to reproject an array of given grid spacing onto
!!   a different grid spacing
!!  AUTHOR
!!   R Choudhury
!!  CREATION DATE
!!   24/07/03
!!  MODIFICATION HISTORY
!!   2008/02/06 08:30 dave
!!    Changed for output to file not stdout
!!   2019/08/16 12:12 dave
!!    Now uses splines, also changed name
!!  SOURCE
!!
module pao_array_utility

  use global_module, ONLY: io_lun

  implicit none

!!***
contains

!!****f* pao_array_utility/reproject_array *
!!
!!  NAME
!!   reproject_array
!!  USAGE
!!   reproject_array(yin,del_old,n_old,yout,del_new,n_new)
!!  PURPOSE
!!   Reprojects an array from a given grid spacing onto new grid spacing
!!  INPUTS
!!   yin - array to be reprojected
!!   del_old - old grid spacing
!!   n_old - old no of grid points
!!   yout - reprojected array values
!!   del_new - new array grid spacing
!!   n_new - new no of grid points
!!  USES
!!   datatypes
!!  AUTHOR
!!   R Choudhury
!!  CREATION DATE
!!   24/07/03
!!  MODIFICATION HISTORY
!!
!!  SOURCE
!!
  subroutine reproject_array(yin,del_old,n_old,yout,del_new,n_new)

    use datatypes
    use numbers
    use splines, ONLY: spline_nonU

    implicit none

    integer, intent(in) :: n_old,n_new
    real(double), intent(in) :: del_old,del_new
    real(double), intent(in), dimension(n_old) :: yin
    real(double), intent(out), dimension(n_new) :: yout

    integer :: i,j,l,m
    real(double), allocatable, dimension(:) :: y2,xin
    real(double) :: yp1,ypn, x,y, xx
    real(double) :: a, b, c, d, r1, r2, r3, r4

    allocate(xin(n_old))
    allocate(y2(n_old))
    !setting up x grid for spline_new subroutine
    do i=1,n_old
       xin(i) = (i-1)*del_old
    enddo

    !setting first derivatives of endpoints for spline
    !nb this DOES introduce an inaccuracy (depending on grid fineness)
    yp1 = (yin(2)-yin(1))/del_old
    ypn = (yin(n_old)-yin(n_old-1))/del_old

    call spline_nonU(n_old,xin,yin,yp1,ypn,y2)

    do i=1,n_new
       x=real(i-1,double)*del_new
       j = floor(x/del_old) + 1
       if(j+1<=n_old) then
          xx = real(j,double)*del_old
          a = (xx - x)/del_old
          b = one - a
          c = a * ( a * a - one ) * del_old * del_old / six
          d = b * ( b * b - one ) * del_old * del_old / six
          r1 = yin(j)
          r2 = yin(j+1)
          r3 = y2(j)
          r4 = y2(j+1)
          yout(i) = a*r1 + b*r2 + c*r3 + d*r4
       end if
    enddo
    deallocate(xin)
    deallocate(y2)

  end subroutine reproject_array
!!***

!!****f* pao_array_utility/matcharrays *
!!
!!  NAME
!!   matcharrays
!!  USAGE
!!   matcharrays(y1,n1,d1,y2,n2,d2,d12,n1_new,n2_new,n12)
!!
!!  PURPOSE
!!   Takes two arrays and projects them onto (same) specified grid spacing
!!  INPUTS
!!   y1, y2 - (values of) the two arrays
!!   n1, n2 - no of points in each array
!!   d1, d2 - spacing of original arrays
!!   d12 - new grid spacing
!!   n1_new, n2_new  - no of points in reprojected arrays
!!   n12 - size of reprojected arrays - power of two for FFT algorithms
!!  USES
!!   datatypes
!!  AUTHOR
!!   R Choudhury
!!  CREATION DATE
!!   24/07/03
!!  MODIFICATION HISTORY
!!
!!  SOURCE
!!
  subroutine matcharrays(y1,n1,d1,y2,n2,d2,d12,n1_new,n2_new,n12)

    use datatypes

    implicit none

    integer, intent(in) :: n1,n2,n12
    real(double), intent(inout), dimension(n12) :: y1,y2
    real(double), allocatable, dimension(:) :: ytemp
    real(double), intent(in) :: d1,d2,d12
    integer,intent(inout) :: n1_new,n2_new
    integer i

    n1_new = ((n1-1)*d1/d12)+1
    allocate(ytemp(n1_new))
    call reproject_array(y1(1:n1),d1,n1,ytemp,d12,n1_new)
    y1(1:n1_new) = ytemp(1:n1_new)
    y1(n1_new+1:n12) = 0.0_double
    deallocate(ytemp)

    n2_new = ((n2-1)*d2/d12)+1
    allocate(ytemp(n2_new))
    call reproject_array(y2(1:n2),d2,n2,ytemp,d12,n2_new)
    y2(1:n2_new) = ytemp(1:n2_new)
    y2(n2_new+1:n12) = 0.0_double
    deallocate(ytemp)

  end subroutine matcharrays
!!***

end module pao_array_utility


! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

MODULE sunGeomtry_module
USE nrtype
implicit none
private
public::clrsky_rad
contains

! *************************************************************************************************
! public subroutine CLRSKY_RAD: get hourly radiation index
! *************************************************************************************************
 SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN)
 ! ----------------------------------------------------------------------------------------
 ! Used to get hourly radiation index
 !
 ! Modification history
 !  - comments added by David Rupp 2006.
 !
 ! Procedure appears similar to Stull(1988) "An Introduction to Boundary Layer
 ! Meteorology " as seen in matlab routine obtained from Joe Kidston <joekidston@yahoo.co.uk>.
 ! Note that equation of time is not used.  Also, solar declination is assumed to stay
 ! constant over the period of one day. What other assumptions are made?  Is this
 ! adequate for the level of precision we require?  Worth reading Stull(1988).
 !
 !  - Modified to integrate over time step up to, but not greater than, 24 hours (D. Rupp, July 2006)
 !
 ! ----------------------------------------------------------------------------------------
 IMPLICIT NONE
 ! Input variables
 INTEGER(I4B), INTENT(IN)                  :: MONTH   ! month as mm integer
 INTEGER(I4B), INTENT(IN)                  :: DAY     ! day of month as dd integer
 REAL(DP), INTENT(IN)                      :: HOUR    ! hour of day as real
 REAL(DP), INTENT(IN)                      :: DT      ! time step in units of hours
 REAL(DP), INTENT(IN)                      :: SLOPE   ! slope of ground surface in degrees
 REAL(DP), INTENT(IN)                      :: AZI     ! aspect (azimuth) of ground surface in degrees
 REAL(DP), INTENT(IN)                      :: LAT     ! latitude in degrees (negative for southern hemisphere)
 ! Outputs
 REAL(DP), INTENT(OUT)                     :: HRI     ! average radiation index over time step DT
 REAL(DP), INTENT(OUT)                     :: COSZEN  ! average cosine of the zenith angle over time step DT
 ! Internal
 REAL(DP)                                  :: CRAD    ! conversion from degrees to radians
 REAL(DP)                                  :: YRAD    ! conversion from year to radians
 REAL(DP)                                  :: T       ! time from noon in radians
 REAL(DP)                                  :: DELT1   ! time step in radians
 REAL(DP)                                  :: SLOPE1  ! slope of ground surface in radians
 REAL(DP)                                  :: AZI1    ! aspect (azimuth) of ground surface in radians
 REAL(DP)                                  :: LAT1    ! latitude in radians
 REAL(DP)                                  :: FJULIAN ! julian date as real
 REAL(DP)                                  :: D       ! solar declination
 REAL(DP)                                  :: LP      ! latitude adjusted for non-level surface (= LAT1 for level surface)
 REAL(DP)                                  :: TD      ! used to calculate sunrise/set
 REAL(DP)                                  :: TPI     ! used to calculate sunrise/set
 REAL(DP)                                  :: TP      ! used to calculate sunrise/set
 REAL(DP)                                  :: DDT     ! used to calculate sunrise/set(= 0 for level surface)
 REAL(DP)                                  :: T1      ! first time in time step or sunrise
 REAL(DP)                                  :: T2      ! last time in time step or sunset
 ! ----------------------------------------------------------------------------------------
 ! CONVERSION FACTORS
 !   degrees to radians
 CRAD=PI_D/180.0D0
 !   days-of-year to radians
 YRAD=2.0D0*PI_D/365.0D0
 ! CONVERT TIME TO RADIANS FROM NOON
 T=(HOUR-12.0)*PI_D/12.0D0
 ! Convert time step to radians
 DELT1=DT*PI_D/12.0D0
 ! CONVERT ground slope, ground aspect, and latitude TO RADIANS
 SLOPE1=SLOPE*CRAD  ! tilt angle
 AZI1=AZI*CRAD ! surface-solar Azimuth ??
 LAT1=LAT*CRAD ! latitude
 ! Calculate julian date
 FJULIAN=dble(JULIAN(MONTH,DAY))
 ! Calculate solar declination
 D=CRAD*23.5*SIN((FJULIAN-82.0)*YRAD)
 ! Calculate latitude "adjustment" for ground slope, aspect and latitude (LP = LAT1 for level surface)
 LP=ASIN(SIN(SLOPE1)*COS(AZI1)*COS(LAT1) + COS(SLOPE1)*SIN(LAT1)) ! angle between solar rays and surface (tilted) ??
 ! Calculate time of sunrise/sunset on level surface as radians from noon
 TD=ACOS(-TAN(LAT1)*TAN(D))
 ! print *, 'Sunrise = ', TD
 ! Calculate time of sunrise/sunset adjusted for inclined ground surface as radians from noon???
 TPI=-TAN(LP)*TAN(D)
 IF(ABS(TPI).LT.1.0) THEN
  TP=ACOS(TPI)
 ELSE
  TP=0.0
 ENDIF
 ! Calculate time adjustment for ground slope, aspect and latitude (DDT = 0 for level surface)
 DDT=ATAN(SIN(AZI1)*SIN(SLOPE1)/(COS(SLOPE1)*COS(LAT1)-COS(AZI1)*SIN(SLOPE1)*SIN(LAT1)))
 ! print*, 'ddt = ', ddt
 ! Set beginning time of time step (set to sunrise if before sunrise)
 T1=MAX(T,-TP-DDT,-TD)
 ! Set end time of time step (adjust if after sunset)
 T2=MIN(T+DELT1,TD,TP-DDT)
 ! print *, 'First t1 and t2 = ', t1, t2
 IF(T2.LE.T1) THEN
  HRI=0.0 ! nighttime
 ELSE
 ! Calculate integral of radiation index from T1 to T2 and divide by time step DELTA1
 ! NOTE: this assumes the declination does not change from T1 to T2
  HRI=(SIN(D)*SIN(LP)*(T2-T1)+COS(D)*COS(LP)*(SIN(T2+DDT) &
      -SIN(T1+DDT)))/(COS(SLOPE1)*DELT1)  ! radiation index
 ENDIF
 ! print *, hri
 ! ----------------- for time intervals that extend to following day ----------------------
 ! Check to see of timestep extends to following day
 IF((T+DELT1).GT.PI_D) THEN
  ! Advance julian day by 1
  FJULIAN = FJULIAN + 1
  ! Calculate solar declination
  D=CRAD*23.5*SIN((FJULIAN-82.0)*YRAD)
  ! Calculate time of sunrise/sunset on level surface as radians from noon
  TD=ACOS(-TAN(LAT1)*TAN(D))
  ! print *, 'Sunrise #2 = ', TD, DELT1
  ! Calculate time of sunrise/sunset adjusted for inclined ground surface as radians from noon???
  TPI=-TAN(LP)*TAN(D)
  IF(ABS(TPI).LT.1.0) THEN
   TP=ACOS(TPI)
  ELSE
   TP=0.0
  ENDIF
  ! Set beginning time to sunrise
  T1=MAX(-TP-DDT,-TD)
  ! Set end time of time step
  T2=MIN(T+DELT1-2*PI_D,TD,TP-DDT)
  ! print *, 'Second t1 and t2 = ', t1, t2
  IF(T2.LE.T1) THEN
   HRI=HRI ! still nighttime in day 2
  ELSE
   ! Calculate integral of radiation index from T1 to T2 and divide by time step DELTA1
   ! NOTE: this assumes the declination does not change from T1 to T2
   HRI=HRI+(SIN(D)*SIN(LP)*(T2-T1)+COS(D)*COS(LP)*(SIN(T2+DDT) &
           -SIN(T1+DDT)))/(COS(SLOPE1)*DELT1)  ! radiation index
  ENDIF
  ! print *, hri
 ENDIF
 ! ----------------------------------------------------------------------------------------
 ! Calculate cosine of solar zenith angle (= HRI for level surface)
 COSZEN = HRI*COS(SLOPE1)
 ! this is assumed to be an appropriate representative value over the
 ! time step.  It is used for albedo calculations.
 ! ----------------------------------------------------------------------------------------
 CONTAINS

 ! *************************************************************************************************
 ! internal function JULIAN: calculate day of year
 ! *************************************************************************************************
  FUNCTION JULIAN(MONTH,DAY)
  USE nrtype
  IMPLICIT NONE
  ! input
  INTEGER(I4B)                             :: MONTH,DAY  ! month and day
  ! output
  INTEGER(I4B)                             :: JULIAN     ! julian day
  ! internal
  INTEGER(I4B),DIMENSION(12)               :: MADD       ! julian day at start of each month
  ! specify the julian day at the start of each month (-1)
  MADD = (/0,31,59,90,120,151,181,212,243,273,304,334/)
  ! compute the julian day
  JULIAN=DAY+MADD(MONTH)
  RETURN
  END FUNCTION JULIAN
 ! ----------------------------------------------------------------------------------------
 END SUBROUTINE CLRSKY_RAD

end module sunGeomtry_module


c=============================================================================c
        program confpc
c=============================================================================c
c
c  Purpose:  make parabolic-cylinder mesh using conformal mapping
c
c  Author:   S. Scott Collis
c
c  Revised:  8-7-96
c
c  (1) Fixed a bug in the second derivative metric for Mahesh mapping
c
c  (2) Added the capability of doing mapping in s as opposed to \xi
c
c  Revised:  8-12-96
c
c  (1) Added a virtual orgin option so that I can do a downstream section
c      of the plate.
c
c  (2) Cleaned up some extaneous stuff
c
c   Make sure to compile with -N80 on the Cray
c=============================================================================c
        implicit double precision (a-h,o-z)

        logical IRIS, DIAG
        parameter (IRIS = .false.)

        parameter (mx=1024,my=255)

        parameter (zero   = 0.0d0,  pt5 = 0.5d0,  one    = 1.0d0,
     &             onept5 = 1.5d0,  two = 2.0d0,  twopt5 = 2.5d0,
     &             three  = 3.0d0)

        dimension x(mx,my), y(mx,my), xi(mx), eta(my), s(mx)
        dimension ss(mx), dss(mx), d2ss(mx)
        dimension rr(my), drr(my), d2rr(my)
        dimension rm1(mx,my),  rm2(mx,my)
        dimension rn1(mx,my),  rn2(mx,my)
        dimension rjac(mx,my)
        dimension rm11(mx,my), rm12(mx,my), rm21(mx,my), rm22(mx,my)
        dimension rn11(mx,my), rn12(mx,my), rn21(mx,my), rn22(mx,my)
        dimension g11x(mx,my), g11y(mx,my), g12x(mx,my), g12y(mx,my)
        dimension g22x(mx,my), g22y(mx,my)

        external calcdd, calcs

!.... argument parameters

        integer narg
        character*80  arg
        integer yflag, xflag
        logical plot3d, debug
#ifndef __GFORTRAN__
        integer, external iargc
#endif
        external arc, calcxi
c=============================================================================c
        yflag = 1
        xflag = 0
        plot3d = .false.
        debug = .false.
c
c.... parse the argument list
c
        narg = iargc()
        do iarg = 1, narg
          call getarg(iarg,arg)
          if (arg(1:2) .eq. '-y') then
            if (arg(1:3) .eq. '-y1') then               ! exponential
              yflag = 1
            else if (arg(1:3) .eq. '-y2') then          ! hyperbolic tangent
              yflag = 2
            else if (arg(1:3) .eq. '-y3') then          ! Mahesh
              yflag = 3
            else                                        ! uniform
              yflag = 0
            end if
          else if (arg(1:2) .eq. '-x') then
            if (arg(1:3) .eq. '-x1') then               ! exponential
              xflag = 1
            else if (arg(1:3) .eq. '-x2') then          ! hyperbolic tangent
              xflag = 2
            else if (arg(1:3) .eq. '-x3') then          ! Mahesh in xi
              xflag = 3
            else if (arg(1:3) .eq. '-x4') then          ! Mahesh in s
              xflag = 4
            else                                        ! uniform in xi
              xflag = 0
            end if
          else if (arg(1:2) .eq. '-p') then
            plot3d = .true.
          else if (arg(1:2) .eq. '-d') then
            debug = .true.
          else if (arg(1:2) .eq. '-h') then
            write(*,"('Usage:  confpc [options]')")
            write(*,"('   -h:  this help')")
            write(*,"('   -d:  debug output')")
            write(*,"('  -x1:  exponential stretching in x')")
            write(*,"('  -x2:  hyperbolic tangent stretching in x')")
            write(*,"('  -x3:  Mahesh''s mapping in x')")
            write(*,"('  -x4:  Mahesh''s mapping in s')")
            write(*,"('  -y1:  exponential stretching in y')")
            write(*,"('  -y2:  hyperbolic tangent stretching in y')")
            write(*,"('  -y3:  Mahesh''s mapping in y')")
            call exit(0)
          else
            write(*,"('Argument ',i2,' ignored.')") iarg
          end if
        end do
c
c.... get user input
c
        write(*,"('Enter (nx,ny) ==> ',$)")
        read(*,*) nx, ny
        if (nx.gt.mx) then
           write(*,*) 'Nx is greater than Mx ',mx
           call exit(1)
        end if
        if (ny.gt.my) then
           write(*,*) 'Ny is greater than My ',my
           call exit(1)
        end if
        write(*,"('Enter (Xmin, Xmax) ==> ',$)")
        read(*,*) qLx, rLx
        write(*,"('Enter (Ymax) ==> ',$)")
        read(*,*) rLy
        qLy = zero
c
c.... uniform grid in computational space
c
        ximax = sqrt(rLx)
        ximin = sqrt(qLx)
        dxi = (ximax - ximin) / dble(nx-1)
        write(*,*) 'Uniform dxi = ',dxi
        ds  = one / dble(nx-1)
        do i = 1, nx
          ss(i)   = dble(i-1) * ds
          xi(i)   = ximin + dble(i-1) * dxi
          dss(i)  = (ximax - ximin)
          d2ss(i) = zero
        end do

        etamax = sqrt(one + two * rLy)
        etamin = sqrt(one + two * qLy)
        deta = (etamax - etamin) / dble(ny-1)
        write(*,*) 'Uniform dy = ', pt5*((one+deta)**2-one)
        dr   = one / dble(ny-1)
        do j = 1, ny
          rr(j)   = dble(j-1) * dr
          eta(j)  = etamin + dble(j-1) * deta
          drr(j)  = (etamax - etamin)
          d2rr(j) = zero
        end do
c
c.... exponential map in the streamwise direction
c
        if (xflag.eq.1) then
          write(*,"('Enter dxmin ==> ',$)")
          read(*,*) dxmin
          if (dxmin.ne.zero) then
            sx = calcs( ximin, ximax, dxmin, ds )
            write(*,*) 'Sx = ', sx
            c2 = log( dxmin / ds )
            c1 = (log( sx * dxmin / ds) - c2) / ds
            do i = 1, nx
              ss(i)   = dble(i-1) * ds
              xi(i)   = ximin + one / c1 * ( exp(c1 * ss(i) + c2) - exp(c2) )
              dss(i)  = exp(c1 * ss(i) + c2)
              d2ss(i) = c1 * exp(c1 * ss(i) + c2)
            end do
            write(*,*) 'Xmax = ', xi(nx)**2
          else
            write(*,*) 'Uniform mesh in xi'
          end if
        end if
c
c.... hyperbolic tangent mapping in the streamwise direction
c.... this increases resolution in the sponge
c
        if (xflag.eq.2) then
        smax = (ximax - ximin)
        sd1 = 0.4d0             ! set for R=1000 PCYL, Lx=500
        sd2 = 0.6d0
        dd = calcdd(sd1,sd2)
        write(*,*) 'dd = ',dd
        dxi = one / dble(nx-1)
        do i = 1, nx
          ss(i) =  dble(i-1) * ds
          xi(i) =  ximin + smax*(pt5 + one/Tanh(dd*pt5)*Tanh(dd*(-pt5 +
     &             ss(i)))*pt5)/(Sqrt(sd2/sd1) +
     &             (one - Sqrt(sd2/sd1))*
     &             (pt5 + one/Tanh(dd*pt5)*Tanh(dd*(-pt5 +
     &             ss(i)))*pt5))
          dss(i) = dd*Sqrt(sd2/sd1)*smax*Cosh(dd*pt5)*
     &             one/Cosh(dd*(-pt5 + ss(i)))*
     &             (Sinh(dd*(one - ss(i))) + Sinh(dd*ss(i)))/
     &             (Sqrt(sd2/sd1)*Sinh(dd*(one - ss(i))) +
     &             Sinh(dd*ss(i)))**2
          d2ss(i) = dd**2*Sqrt(sd2/sd1)*smax*
     &              (-Cosh(dd*(one - three*ss(i))) +
     &              Sqrt(sd2/sd1)*Cosh(dd*(two - three*ss(i))) -
     &              Cosh(dd*(one - ss(i))) +
     &              two*Sqrt(sd2/sd1)*Cosh(dd*(one - ss(i))) -
     &              two*Cosh(dd*ss(i)) +
     &              Sqrt(sd2/sd1)*Cosh(dd*ss(i)))*
     &              (one/Cosh(dd*(-pt5 + ss(i))))**2*(Sinh(dd))/
     &              (two*(Sqrt(sd2/sd1)*(Sinh(dd*(one - ss(i)))) +
     &              (Sinh(dd*ss(i))))**3)
        end do
        end if
c
c.... Mahesh's mapping, personal communication (6-5-96)
c
        if (xflag.eq.3) then
          write(*,"('Enter dsmin, b, sc ==> ',$)")
          read(*,*) dsmin, b, sc
          dsmin = dsmin / sqrt(two)
          smax = (ximax - ximin)
          cm = ( two * b * tanh(b*sc) + (nx-1)*dsmin/smax *
     &           log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) ) /
     &         ( one - (nx-1)*dsmin/smax )
          do i = 1, nx
            ss(i)   = dble(i-1) * ds
            xi(i)   = ximin + smax*( cm * ss(i) + log( cosh(b*(ss(i)-sc)) /
     &                cosh(b*(ss(i)+sc)) ) ) /
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
            dss(i)  = smax*(cm + b*tanh(b*(ss(i)-sc)) - b*tanh(b*(ss(i)+sc)))/
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
            d2ss(i) = smax*(-b**2*(tanh(b*(ss(i)-sc)))**2 +
     &                b**2*(tanh(b*(ss(i)+sc)))**2)/
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
          end do
        end if
c
c.... Uniform arc-length mapping
c
        if (xflag.eq.4) then
          smin  = arc(ximin)
          smax  = arc(ximax)
          write(*,"('smin, smax, ds uniform = ',3(1pe20.13,1x))")
     &      smin, smax, (smax-smin)/real(nx-1)

          write(*,"('Enter dsmin, b, sc ==> ',$)")
          read(*,*) dsmin, b, sc

          cm = ( two * b * tanh(b*sc) + (nx-1)*dsmin/(smax-smin) *
     &           log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) ) /
     &         ( one - (nx-1)*dsmin/(smax-smin) )
          do i = 1, nx
            ss(i)   = dble(i-1) * ds
            s(i)    = smin + (smax-smin)*( cm * ss(i) +
     &                log( cosh(b*(ss(i)-sc)) /
     &                cosh(b*(ss(i)+sc)) ) ) /
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
            dss(i)  = (smax-smin)*(cm - b*(1.0/Cosh(b*(ss(i) - sc)))*
     &                (1.0/Cosh(b*(ss(i) + sc)))*Sinh(2.0*b*sc)) /
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
            d2ss(i) = (smax-smin)*(-b**2*(tanh(b*(ss(i)-sc)))**2 +
     &                b**2*(tanh(b*(ss(i)+sc)))**2)/
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
          end do
c
c.... transform from s to \xi
c
          do i = 1, nx
            xi(i)   = calcxi( s(i) )
            dxids   = 1.0 / (
     &                Sqrt(2.)*xi(i)**2/Sqrt(1. + 2.*xi(i)**2) +
     &                Sqrt(1. + 2.*xi(i)**2)/Sqrt(2.) +
     &                (Sqrt(2.) + 2.*xi(i)/Sqrt(1. + 2.*xi(i)**2))/
     &                (2.*(Sqrt(2.)*xi(i) + Sqrt(1. + 2.*xi(i)**2))) )
            d2xids2 = (
     &                -2.*xi(i)*(Sqrt(2.) + 2.**(5./2.)*xi(i)**2 +
     &                4.*xi(i)*Sqrt(1.0 + 2.0*xi(i)**2))/
     &                ((1.0 + 2.0*xi(i)**2)**(3.0/2.0)*(2.0*xi(i) +
     &                Sqrt(2.0)*Sqrt(1.0 + 2.0*xi(i)**2))**2) ) * dxids
            d2ss(i) = dss(i)**2 * d2xids2 + d2ss(i) * dxids
            dss(i)  = dss(i) * dxids
          end do
        end if
c
c.... output the tangent mapping
c
        if (debug) then
          open(10,file='tangent.dat')
          do i = 1, nx
            write(10,30) ss(i), xi(i), dss(i), d2ss(i), d2ss(i)/dss(i)
          end do
          close(10)
        end if
c
c.... exponential map in the wall normal direction
c
        if (yflag.eq.1) then
          rmin = qLy
          rmax = rLy
          dymin = 1.0d-2
          sy = 1.01d0
          write(*,"('Enter dymin ==> ',$)")
          read(*,*) dymin
          if (dymin.ne.zero) then
            sy = calcs( rmin, rmax, dymin, dr )
            write(*,*) 'Sy = ', sy
            c2 = log( dymin / dr )
            c1 = (log( sy*dymin / dr) - c2) / dr
            do j = 1, ny
              rr(j)   = dble(j-1) * dr
              eta(j)  = one / c1 * ( exp(c1 * rr(j) + c2) - exp(c2) )
              drr(j)  = exp(c1 * rr(j) + c2)
              d2rr(j) = c1 * exp(c1 * rr(j) + c2)
            end do
            write(*,*) 'Rmax = ', eta(ny)
            do j = 1, ny
              d2rr(j) = -(drr(j)**2)/( 1.0 + 2.0 * eta(j) )**(1.5) +
     &                  d2rr(j) / sqrt( 1.0 + 2.0 * eta(j) )
              drr(j)  = drr(j) / sqrt( 1.0 + 2.0 * eta(j) )
              eta(j)  = sqrt( 1.0 + 2.0 * eta(j) )
            end do
          else
            write(*,*) 'Uniform mesh in eta'
          end if
        end if
c
c.... hyperbolic tangent stretching in wall normal direction
c
        if (yflag.eq.2) then
        rmin = qLy
        rmax = rLy
        rd1 = 0.00028d0         ! set for R=1000 PCYL, r=500
        rd2 = 5.5d0
        dd = calcdd(rd1,rd2)
        write(*,*) 'dd = ',dd
        deta = one / dble(ny-1)
        do j = 1, ny
          rr(j) = dble(j-1) * dr
          eta(j) = rmax*(pt5 + one/Tanh(dd*pt5)*Tanh(dd*(-pt5 +
     &             rr(j)))*pt5)/(Sqrt(rd2/rd1) +
     &             (one - Sqrt(rd2/rd1))*
     &             (pt5 + one/Tanh(dd*pt5)*Tanh(dd*(-pt5 +
     &             rr(j)))*pt5))
          drr(j) = dd*Sqrt(rd2/rd1)*rmax*Cosh(dd*pt5)*
     &             one/Cosh(dd*(-pt5 + rr(j)))*
     &             (Sinh(dd*(one - rr(j))) + Sinh(dd*rr(j)))/
     &             (Sqrt(rd2/rd1)*Sinh(dd*(one - rr(j))) +
     &             Sinh(dd*rr(j)))**2
          d2rr(j) = dd**2*Sqrt(rd2/rd1)*rmax*
     &              (-Cosh(dd*(one - three*rr(j))) +
     &              Sqrt(rd2/rd1)*Cosh(dd*(two - three*rr(j))) -
     &              Cosh(dd*(one - rr(j))) +
     &              two*Sqrt(rd2/rd1)*Cosh(dd*(one - rr(j))) -
     &              two*Cosh(dd*rr(j)) +
     &              Sqrt(rd2/rd1)*Cosh(dd*rr(j)))*
     &              (one/Cosh(dd*(-pt5 + rr(j))))**2*(Sinh(dd))/
     &              (two*(Sqrt(rd2/rd1)*(Sinh(dd*(one - rr(j)))) +
     &              (Sinh(dd*rr(j))))**3)
        end do
        write(*,*) 'Rmax = ', eta(ny)
        do j = 1, ny
          d2rr(j) = -(drr(j)**2)/( 1.0 + 2.0 * eta(j) )**(1.5) +
     &              d2rr(j) / sqrt( 1.0 + 2.0 * eta(j) )
          drr(j)  = drr(j) / sqrt( 1.0 + 2.0 * eta(j) )
          eta(j)  = sqrt( 1.0 + 2.0 * eta(j) )
        end do
        end if
c
c.... Mahesh's mapping, personal communication (6-5-96)
c
        if (yflag.eq.3) then
          write(*,"('Enter drmin, b, rc ==> ',$)")
          read(*,*) drmin, b, rc
          rmax = rLy
          cm = ( two * b * tanh(b*rc) + (ny-1)*drmin/rmax *
     &           log( cosh(b*(one-rc)) / cosh(b*(one+rc)) ) ) /
     &         ( one - (ny-1)*drmin/rmax )
          do j = 1, ny
            rr(j)   = dble(j-1) * dr
            eta(j)  = rmax*( cm * rr(j) + log( cosh(b*(rr(j)-rc)) /
     &                cosh(b*(rr(j)+rc)) ) ) /
     &                (cm + log( cosh(b*(one-rc)) / cosh(b*(one+rc)) ) )
            drr(j)  = rmax*(cm + b*tanh(b*(rr(j)-rc)) - b*tanh(b*(rr(j)+rc))) /
     &                (cm + log( cosh(b*(one-rc)) / cosh(b*(one+rc)) ) )
            d2rr(j) = rmax*(-b**2*(tanh(b*(rr(j)-rc)))**2 +
     &                b**2*(tanh(b*(rr(j)+rc)))**2)/
     &                (cm + log( cosh(b*(one-rc)) / cosh(b*(one+rc)) ) )
          end do
c
c.... transform from r to \eta
c
          do j = 1, ny
            d2rr(j) = -(drr(j)**2)/( one + two * eta(j) )**onept5 +
     &                d2rr(j) / sqrt( one + two * eta(j) )
            drr(j)  = drr(j) / sqrt( one + two * eta(j) )
            eta(j)  = sqrt( one + two * eta(j) )
          end do
        end if
c
c.... output the normal mapping
c
        if (debug) then
          open(20,file='normal.dat')
          do j = 1, ny
             write(20,30) rr(j), eta(j), drr(j), d2rr(j), d2rr(j)/drr(j)
          end do
          close(20)
        end if
c
c.... build the mesh
c
        do i = 1, nx
          do j = 1, ny
            x(i,j) = xi(i)**2 + (one - eta(j)**2) * pt5
            y(i,j) = sqrt(two) * xi(i) * eta(j)

            if (i.eq.1 .and. j.eq.1 .and. qLx.eq.zero) then
              x(i,j) = zero
              y(i,j) = zero
            end if

            dsdxi  = dss(i)
            drdxi  = zero

            dsdeta = zero
            drdeta = drr(j)

            dxds  = two * xi(i)
            dxdr  = -eta(j)

            dyds  = sqrt(two) * eta(j)
            dydr  = sqrt(two) * xi(i)

            dxdxi  = dxds * dsdxi  + dxdr * drdxi
            dxdeta = dxds * dsdeta + dxdr * drdeta

            dydxi  = dyds * dsdxi  + dydr * drdxi
            dydeta = dyds * dsdeta + dydr * drdeta

            rjac(i,j) = one / ( dxdxi * dydeta - dxdeta * dydxi )

            rm1(i,j) =  dydeta * rjac(i,j)
            rm2(i,j) = -dxdeta * rjac(i,j)

            rn1(i,j) = -dydxi * rjac(i,j)
            rn2(i,j) =  dxdxi * rjac(i,j)

            d2sdxi2    = d2ss(i)
            d2sdxideta = zero
            d2sdeta2   = zero

            d2rdxi2    = zero
            d2rdxideta = zero
            d2rdeta2   = d2rr(j)

            d2xds2  = two
            d2xdsdr = zero
            d2xdr2  = -one

            d2yds2  = zero
            d2ydsdr = sqrt(two)
            d2ydr2  = zero

            d2xdxi2 = d2xds2 * dsdxi**2 + dxds * d2sdxi2 +
     &                d2xdsdr * drdxi * dsdxi + d2xdsdr * drdxi * dsdxi +
     &                d2xdr2 * drdxi**2 + dxdr * d2rdxi2

            d2xdxideta = d2xds2 * dsdeta * dsdxi + dxds * d2sdxideta +
     &                   d2xdsdr * drdeta * dsdxi + d2xdsdr * drdxi * dsdeta +
     &                   d2xdr2 * drdeta * drdxi + dxdr * d2rdxideta

            d2xdeta2 = d2xds2 * dsdeta**2 + dxds * d2sdeta2 +
     &                 d2xdsdr * drdeta * dsdeta + d2xdsdr * drdeta * dsdeta +
     &                 d2xdr2 * drdeta**2 + dxdr * d2rdeta2

            d2ydxi2 = d2yds2 * dsdxi**2 + dyds * d2sdxi2 +
     &                d2ydsdr * drdxi * dsdxi + d2ydsdr * drdxi * dsdxi +
     &                d2ydr2 * drdxi**2 + dydr * d2rdxi2

            d2ydxideta = d2yds2 * dsdeta * dsdxi + dyds * d2sdxideta +
     &                   d2ydsdr * drdeta * dsdxi + d2ydsdr * drdxi * dsdeta +
     &                   d2ydr2 * drdeta * drdxi + dydr * d2rdxideta

            d2ydeta2 = d2yds2 * dsdeta**2 + dyds * d2sdeta2 +
     &                 d2ydsdr * drdeta * dsdeta + d2ydsdr * drdeta * dsdeta +
     &                 d2ydr2 * drdeta**2 + dydr * d2rdeta2

            drjacdxi = -(d2xdxi2*dydeta + dxdxi*d2ydxideta - d2xdxideta*dydxi -
     &                   dxdeta*d2ydxi2) * rjac(i,j)**2

            drjacdeta = -(d2xdxideta*dydeta + dxdxi*d2ydeta2 - d2xdeta2*dydxi -
     &                    dxdeta*d2ydxideta) * rjac(i,j)**2

            rm11(i,j) = drjacdxi * dydeta * rm1(i,j) +
     &                  d2ydxideta * rjac(i,j) * rm1(i,j) +
     &                  drjacdeta * dydeta * rn1(i,j) +
     &                  d2ydeta2 * rjac(i,j) * rn1(i,j)

            rm12(i,j) = drjacdxi * dydeta * rm2(i,j) +
     &                  d2ydxideta * rjac(i,j) * rm2(i,j) +
     &                  drjacdeta * dydeta * rn2(i,j) +
     &                  d2ydeta2 * rjac(i,j) * rn2(i,j)

            rm21(i,j) = -( drjacdxi * dxdeta * rm1(i,j) +
     &                     d2xdxideta * rjac(i,j) * rm1(i,j) +
     &                     drjacdeta * dxdeta * rn1(i,j) +
     &                     d2xdeta2 * rjac(i,j) * rn1(i,j) )

            rm22(i,j) = -( drjacdxi * dxdeta * rm2(i,j) +
     &                     d2xdxideta * rjac(i,j) * rm2(i,j) +
     &                     drjacdeta * dxdeta * rn2(i,j) +
     &                     d2xdeta2 * rjac(i,j) * rn2(i,j) )

            rn11(i,j) = -( drjacdxi * dydxi * rm1(i,j) +
     &                     d2ydxi2 * rjac(i,j) * rm1(i,j) +
     &                     drjacdeta * dydxi * rn1(i,j) +
     &                     d2ydxideta * rjac(i,j) * rn1(i,j) )

            rn12(i,j) = -( drjacdxi * dydxi * rm2(i,j) +
     &                     d2ydxi2 * rjac(i,j) * rm2(i,j) +
     &                     drjacdeta * dydxi * rn2(i,j) +
     &                     d2ydxideta * rjac(i,j) * rn2(i,j) )

            rn21(i,j) = drjacdxi * dxdxi * rm1(i,j) +
     &                  d2xdxi2 * rjac(i,j) * rm1(i,j) +
     &                  drjacdeta * dxdxi * rn1(i,j) +
     &                  d2xdxideta * rjac(i,j) * rn1(i,j)

            rn22(i,j) = drjacdxi * dxdxi * rm2(i,j) +
     &                  d2xdxi2 * rjac(i,j) * rm2(i,j) +
     &                  drjacdeta * dxdxi * rn2(i,j) +
     &                  d2xdxideta * rjac(i,j) * rn2(i,j)

          end do
        end do
c
c.... compute the error in the cross derivatives
c
        errn = zero
        errm = zero
        do i = 1, nx
          do j = 1, ny
            errm = errm + ( rm12(i,j) - rm21(i,j) )**2
            errn = errn + ( rn12(i,j) - rn21(i,j) )**2
          end do
        end do
        write(*,*) 'Error in m ',sqrt(errm)/dble(nx*ny)
        write(*,*) 'Error in n ',sqrt(errn)/dble(nx*ny)
c
c.... write out the nose element spacing
c
        dr = x(1,1) - x(1,2)
        yl = y(2,1)
        ds = yl * 0.5 * sqrt( 1.0 + yl**2) +
     &       0.5 * log( abs( yl + sqrt(1.0 + yl**2)))

        write(*,10) ds, dr, (x(1,2)-x(1,3))/dr
 10     format('ds_min = ',1pe20.13,' dr_min = ',1pe20.13,
     &         ' dr(2)/dr(1)     = ',1pe20.13)
c
c.... write out the maximum spacing
c
        dr = x(1,ny-1) - x(1,ny)
        yl = y(nx,1)
        ds = yl * 0.5 * sqrt( 1.0 + yl**2) +
     &       0.5 * log( abs( yl + sqrt(1.0 + yl**2)))
        yl = y(nx-1,1)
        ds = ds - (yl * 0.5 * sqrt( 1.0 + yl**2) +
     &       0.5 * log( abs( yl + sqrt(1.0 + yl**2))))
        write(*,20) ds, dr, (x(1,ny-2)-x(1,ny-1))/dr
 20     format('ds_max = ',1pe20.13,' dr_max = ',1pe20.13,
     &         ' dr(ny)/dr(ny-1) = ',1pe20.13)
c
c.... write out the wall spacing
c
        if (debug) then
        do i = 2, nx
          yl = y(i,1)
          sl = yl * 0.5 * sqrt( 1.0 + yl**2) +
     &         0.5 * log( abs( yl + sqrt(1.0 + yl**2)))
          yl = y(i-1,1)
          ds = sl - (yl * 0.5 * sqrt( 1.0 + yl**2) +
     &         0.5 * log( abs( yl + sqrt(1.0 + yl**2))))
          write(70,"(3(1pe20.13,1x))") sl, ds
        end do
        close(70)
        end if
c
c.... write out the body.dat file
c
        open(9,file='body.dat',status='unknown')
        j = 1
        do i = 1, nx
          yl = y(i,j)
          sl = yl * 0.5 * sqrt( 1.0 + yl**2) +
     &         0.5 * log( abs( yl + sqrt(1.0 + yl**2)))
          bn1 = rn1(i,j) / sqrt( rn1(i,j)**2 + rn2(i,j)**2 )
          bn2 = rn2(i,j) / sqrt( rn1(i,j)**2 + rn2(i,j)**2 )
          write(9,"(1(i5,1x),5(1pe20.13,1x))") i, sl, x(i,j), yl, bn1, bn2
        end do
        close(9)
c
c.... write out some Plot3d files
c
        nz = 1
        write(*,*) 'Writing plot3d files for ',nx, ny, nz
c
c.... write out binary if on an IRIS
c
        if (IRIS) then
          call wgrid(x, y, nx, ny, nz, mx, my, 'grid.bin'//char(0))
          call wdata(rm1, rn1, rm2, rn2, rjac, nx, ny, nz, mx, my,
     &               'm1.bin'//char(0))
          call wdata(rm11, rm12, rm21, rm22, rjac, nx, ny, nz, mx, my,
     &               'm11.bin'//char(0))
          call wdata(rn11, rn12, rn21, rn22, rjac, nx, ny, nz, mx, my,
     &               'n11.bin'//char(0))
        else
c
c.... write out unformatted if on a CRAY
c
          open(unit=10,file='grid.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) (((sngl(x(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(y(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(zero),   i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          if (debug) then

          open(unit=10,file='m1.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((sngl( rm1(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl( rn1(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl( rm2(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl( rn2(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rjac(i,j)), i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          open(unit=10,file='m11.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((sngl(rm11(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rm12(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rm21(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rm22(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rm1(i,j)*rn1(i,j)+rm2(i,j)*rn2(i,j)),
     &              i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          open(unit=10,file='n11.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((sngl(rn11(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rn12(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rn21(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rn22(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((sngl(rjac(i,j)), i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          end if  ! debug
c
c.... write out the metric file (Note the order of i and j are reversed)
c
          open (unit=10, file='metric.dat', form='unformatted',
     &          status='unknown')
          write(10) (( sngl( rm1(i,j)), j=1,ny), i=1,nx),
     &              (( sngl( rm2(i,j)), j=1,ny), i=1,nx),
     &              (( sngl( rn1(i,j)), j=1,ny), i=1,nx),
     &              (( sngl( rn2(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rm11(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rm12(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rm22(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rn11(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rn12(i,j)), j=1,ny), i=1,nx),
     &              (( sngl(rn22(i,j)), j=1,ny), i=1,nx)
          close(10)
        end if

        stop
 30     format(7(1x,1pe20.13))
        end

c=============================================================================c
        function arc(xi)
c=============================================================================c
        implicit double precision (a-h,o-z)
c=============================================================================c
        arc = sqrt(2.0)*0.5*xi*sqrt(1.0+2.0*xi**2) +
     &        0.5*log(sqrt(2.0)*xi + sqrt(1.0+2.0*xi**2))
        return
        end

c=============================================================================c
        function calcxi(s)
c=============================================================================c
        implicit double precision (a-h,o-z)

        common /xistuff/ sloc

        external funcxi, zbrent
c=============================================================================c
        sloc = s

        calcxi = zbrent(funcxi,0.0d0,2000.0d0,1.0d-14)

        return
        end

c=============================================================================c
        function funcxi(xi)
c=============================================================================c
        implicit double precision (a-h,o-z)

        common /xistuff/ sloc
c=============================================================================c
        funcxi = sloc - arc(xi)

        return
        end

c=============================================================================c
        function calcdd(d1, d2)
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ rd1, rd2

        external func, rtflsp
c=============================================================================c
        rd1 = d1
        rd2 = d2

        dd1 = 1.0
        dd2 = 7.0

c       calcdd = rtflsp(func,dd1,dd2,1.0d-14)
        calcdd = zbrent(func,dd1,dd2,1.0d-14)

        return
        end

c=============================================================================c
        function func(x)
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ rd1, rd2
c=============================================================================c
        func = sinh(x)/x - one / sqrt(rd1 * rd2)

        return
        end

c=============================================================================c
        function calcs( ximin1, ximax1, dxmin1, ds1)
c
c  Calculate a stretching ratio to fill a domain using exponential
c  stretching.
c
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuffs/ ximin, ximax, dxmin, ds

        external funcs, rtflsp
c=============================================================================c
        ximin = ximin1
        ximax = ximax1
        dxmin = dxmin1
        ds = ds1

c       calcs = rtflsp(funcs, 1.01d0, 1.02d0, 1.0d-14)
        calcs = zbrent(funcs, 1.0001d0, 1.2d0, 1.0d-14)

        return
        end

c=============================================================================c
        function funcs(sx)
c=============================================================================c
        implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuffs/ ximin, ximax, dxmin, ds
c=============================================================================c
        c2 = log( dxmin / ds )
        c1 = (log( sx*dxmin / ds) - c2) / ds

        funcs = ximax - ximin - one / c1 * ( exp(c1 + c2) - exp(c2) )

        return
        end


subroutine neighbours_brute
  ! Subroutine finds nearest neighbours in radius 2h, using the octree
  ! h already defined for all particles
  ! This counts accreted particles and pointmasses too
  use sphdata
  use treedata, only: nneigh,neighb,neighmax

  implicit none

 integer :: i,j

  real :: hi,hj, hmean, sep,percent,increment
  real, parameter :: tiny = 1.0e-34

  print*, 'Beginning brute force search for neighbours ',npart
  print*, "------------------------------------------------------------------------"

  percent = 0.0
  increment = 10.0

  !$OMP PARALLEL &
  !$OMP shared(nelement, iphase,xyzmh, nneigh,neighb) &
  !$OMP private(i,j,hi,hj,hmean,sep)
  !$OMP DO SCHEDULE(runtime)
  do i=1,npart

     call particle_percent_complete(i,npart,percent,increment)

      IF(iphase(i)<0) cycle

      do j=1,npart

          IF(i==j) cycle
          IF(iphase(j)<0) cycle

          hi = xyzmh(5,i)
          hj = xyzmh(5,j)

          if(i/=j) then
              hmean = (hi + hj)/2.0

              sep = (xyzmh(1,i) - xyzmh(1,j))**2 + &
                  (xyzmh(2,i) - xyzmh(2,j))**2 + &
                  (xyzmh(3,i) - xyzmh(3,j))**2 + tiny
              sep = sqrt(sep)

              !	if particle j in neighbour sphere, then add to neighbour list
              if(sep<2.0*hmean.and.nneigh(i)<neighmax) then
                 !$OMP CRITICAL
                  nneigh(i) = nneigh(i) + 1
                  neighb(i,nneigh(i)) = j
                  !$OMP END CRITICAL
              endif
          endif

      enddo
  enddo
  !$OMP END DO
  !$OMP END PARALLEL

  return
  end subroutine neighbours_brute


module particle_defs

	integer, parameter :: rk = selected_real_kind(15,300)
	integer, parameter :: ik = selected_int_kind(5)
	real(rk), parameter :: pi = 3.141592653589793238462643383279502884197_rk

end module particle_defs


PROGRAM create_coordinates
!!-----------------------------------------------------------
!!
!!	  to create regional coordinates file (e.g. 1_coordinates.nc)
!!    for fine grid from coarse grid (e.g. coordinates.nc)
!!
!!   to make it we use a 4th order polynomial interpolation
!!
!!	        Created by Brice Lemaire on 12/2009.
!!
!!-----------------------------------------------------------
  USE netcdf
  USE cfg_tools
  USE mixed_grid
  USE domain
  !------------
  IMPLICIT NONE
  !
  INTEGER :: narg,iargc
  INTEGER :: nstat, imodulo
  INTEGER :: nik, njk, npk
  INTEGER :: ival
  CHARACTER(len=80) :: cnmlname, cfingrdname
  !
  !
  !
  !*************************************
  ! Read input file (namelist file)
  !         using types.f90
  !*************************************
  narg = iargc()
  !
  IF (narg == 0) THEN
    cnmlname = 'namelist.input'
  ELSE
	CALL getarg(1,cnmlname)
  ENDIF
  !
  CALL read_namelist(cnmlname)
  !
  nstat = read_coordinates(TRIM(cn_parent_coordinate_file),scoagrd)
  IF (nstat/=1) THEN
   WRITE(*,*) 'unable to open netcdf file : ',cn_parent_coordinate_file
   STOP
  ENDIF
  !
  nsizex = SIZE(scoagrd%glamt,1)
  nsizey = SIZE(scoagrd%glamt,2)
  !
  WRITE(*,*) ''
  WRITE(*,*) 'Size of input matrix: '
  WRITE(*,*) '(',nsizex,';', nsizey,')'
  WRITE(*,*) ''
  !
  WRITE(*,*) 'Domain: '
  WRITE(*,*) ''
  WRITE(*,*) '           ', '    min(1,1:nsizey)       ', '      max(nsizex,1:nsizey)            '
  WRITE(*,*) 'longitude: ', MINVAL(scoagrd%glamt(1,1:nsizey)), ' --> ', MAXVAL(scoagrd%glamf(nsizex,1:nsizey))
  WRITE(*,*) 'latitude:  ', MINVAL(scoagrd%gphit(1:nsizex,1)), ' --> ', MAXVAL(scoagrd%gphif(1:nsizex,nsizey))
  WRITE(*,*) ''
  !
  !*************************************
  ! Check the values read in the namelist
  !*************************************
  IF(nn_imin.LE.0.OR.nn_imin.GT.nsizex)THEN
    WRITE(*,*) 'Wrong values in namelist:'
	WRITE(*,*) 'nn_imin must be greater than 0 and less than', nsizex
	STOP
  ENDIF
  !
  IF(nn_imax.LE.0.OR.nn_imax.GT.nsizex)THEN
    WRITE(*,*) 'Wrong values in namelist:'
	WRITE(*,*) 'nn_imax must be greater than 0 and less than', nsizex
	STOP
  ENDIF
  !
  IF(nn_jmin.LE.0.OR.nn_jmin.GT.nsizey)THEN
    WRITE(*,*) 'Wrong values in namelist:'
	WRITE(*,*) 'nn_jmin must be greater than 0 and less than', nsizey
	STOP
  ENDIF
  !
  IF(nn_jmax.LE.0.OR.nn_jmax.GT.nsizey)THEN
    WRITE(*,*) 'Wrong values in namelist:'
	WRITE(*,*) 'nn_jmax must be greater than 0 and less than', nsizey
	STOP
  ENDIF
  !
  !*************************************
  ! Define the sub-domain chosen by user
  !*************************************
  WRITE(*,*) 'Domain defined by user: '
  WRITE(*,*) ''
  WRITE(*,*) '           ', '          min           ', '               max            '
  WRITE(*,*) 'longitude: ', MINVAL(scoagrd%glamt(nn_imin,nn_jmin:nn_jmax)), ' --> ', MAXVAL(scoagrd%glamf(nn_imax,nn_jmin:nn_jmax))
  WRITE(*,*) 'latitude:  ', MINVAL(scoagrd%gphit(nn_imin:nn_imax,nn_jmin)), ' --> ', MAXVAL(scoagrd%gphif(nn_imin:nn_imax,nn_jmax))
  WRITE(*,*) ''
  !
  IF(nn_imin.EQ.nn_imax.AND.nn_jmin.EQ.nn_jmax) THEN
    nglobal = .TRUE.
	WRITE(*,*) 'Size of domain: GLOBAL'
  ELSE
    nglobal = .FALSE.
	WRITE(*,*) 'Size of domain: REGIONAL'
  ENDIF
  !
  IF(cn_position_pivot.EQ.'F-grid') THEN       !case of ORCA05 & ORCA025 grids
   npivot = 0
  ELSEIF(cn_position_pivot.EQ.'T-grid') THEN   !case of ORCA2 grid
   npivot = 1
  ENDIF
  !
  nmid = nsizex/2 + npivot
  !
  !
  !
  !*************************************
  ! Redefine for particular cases
  !*************************************
  IF(((nn_imax - nn_imin).EQ.-1).OR.((nn_imax - nn_imin).EQ.-2)) THEN
    nn_imax = nn_imin
  ELSEIF(ABS(nn_imin - nn_imax).GE.nsizex-1) THEN
    nn_imax = nn_imin
  ELSEIF((nn_imin.EQ.1).AND.(nn_imax.EQ.nsizex)) THEN
    nn_imax = nn_imin
  ELSEIF(nn_imin.EQ.1.AND.nn_imax.GT.nn_imin) THEN
    nn_imin = nsizey-2
  ELSEIF(nn_imax.EQ.nsizex) THEN
    nn_imax = 3
  ELSEIF(nn_imin.EQ.nsizex) THEN
    nn_imin = nsizex-1
  ELSEIF(nn_imax.EQ.1.AND.nn_imax.NE.nn_imin) THEN
    nn_imax = 2
  ENDIF
  !
  !
  !
  !*************************************
  ! We want to fix equator along T and U-points
  !*************************************
  imodulo =  MOD(nn_rhoy,2)
  !
  IF(.NOT.nglobal.AND.(scoagrd%gphit(nn_imin,nn_jmin)*scoagrd%gphit(nn_imin,nn_jmax)).LT.0.AND.imodulo.EQ.0) THEN
    nequator = 1
  ELSEIF(nglobal.AND.imodulo.EQ.0) THEN
    nequator = 1
  ELSE
    nequator = 0
  ENDIF
  !
  !
  !
  !*************************************
  ! CREATE MIXED GRID
  !*************************************
  CALL define_domain
  !
  CALL define_mixed_grid
  !
  !
  !
  !*************************************
  !!! CALCULATE FINE GRID DIMENSIONS
  !*************************************
  IF(.NOT.nglobal) THEN
	IF(nn_rhox.EQ.1) THEN
	  nxfine = nxcoag
	ELSE
	  nxfine = (nxcoag-2)*nn_rhox + 1
	ENDIF
	!
	 IF(nn_rhoy.EQ.1) THEN
	  nyfine = nycoag
	ELSE
	  nyfine = (nycoag-2)*nn_rhoy + 1
	ENDIF
	!
  ELSEIF(nglobal) THEN
    IF(nn_rhox.GT.1) THEN
	  nxfine = (nxgmix - 4*(nn_rhox-1))/2
	ELSEIF(nn_rhox.EQ.1) THEN
	  nxfine = nsizex
	ENDIF
	!
	IF(nn_rhoy.GT.1) THEN
	  nyfine = (nygmix - (2*nn_rhoy))/2 - nn_rhoy + nequator
	ELSEIF(nn_rhoy.EQ.1) THEN
	  nyfine = nsizey
	ENDIF
	!
  ENDIF
  !
  WRITE(*,*) ''
  WRITE(*,*) '*** SIZE OF FINE GRID ***'
  WRITE(*,*) nxfine, ' x ', nyfine
  WRITE(*,*) ''
  !
  !
  !
  !*************************************
  ! Interpolation inside the mixed grid
  !        from cfg_tools.f90
  !*************************************
  IF(nn_rhox.GT.1.OR.nn_rhoy.GT.1) THEN
	CALL interp_grid
  ENDIF
  !
  !
  !
  !*************************************
  ! Define name of child coordinate file
  !  coordinates.nc -> 1_coordinates.nc
  !*************************************
  CALL set_child_name(cn_parent_coordinate_file,cfingrdname)
  !
  !
  !
  !*************************************
  ! Allocation of child grid elements
  !          from types.f90
  !*************************************
  CALL grid_allocate(sfingrd,nxfine,nyfine)
  !
  !
  !
  !*************************************
  ! Break the mixed grid smixgrd into 4 grids
  !        from cfg_tools.f90
  !*************************************
  CALL child_grid
  !
  !
  !
  !*************************************
  ! Read parent coordinate file
  !      from readwrite.f90
  !*************************************
  nstat = write_coordinates(cfingrdname,sfingrd,nxfine,nyfine)
  IF (nstat/=1) THEN
   WRITE(*,*)"unable to write netcdf file : ",cfingrdname
   STOP
  ENDIF
  !
  CALL grid_deallocate(scoagrd)
  CALL grid_deallocate(sfingrd)
  CALL mixed_grid_deallocate(smixgrd)
  !
  !
  !
END PROGRAM create_coordinates


C NCLFORTSTART
      SUBROUTINE P2HYO(PI,MLON,NLAT,KLEVI,XI,PSFC
     +                 ,P0,HYAO,HYBO,KLEVO,XO,XMSG
     +                 ,IFLAG,KFLAG,IER)
      IMPLICIT NONE

c NCL: xo = p2hyo (p,xi,psfc,hyao,hybo)

c this routine interploates constant pres levels to hybrid
c     the formula for the pressure of a hybrid surface is;
c          phy(k) = pOut(k) = hya(k)*p0 + hyb(k)*psfc
c
c     input  ["i" input ... "o" output]
c          pi     - pressure level                     [input]
c          psfc   - is the surface pressure Pa         [input]
c          mlon   - longitude dimension
c          nlat   - latitude  dimension
c          klevi  - number of input  levels
c          hyao   - is the "a" or pressure hybrid coef
c          hybo   - is the "b" or sigma coeficient
c          klevo  - number of output levels
c          kflag  - specify how values outside the "pi" will be handled
c                   By "outside" I mean [pOut < pi(1)] or [pOut > pi(klevi)]
c                   Extrapolation is via log-linear extrapolation.
c                   =0   no extrapolation. Values set to _FillValue
c                   =1   values set to nearest valid value
c                   =2   values at pOut less    than pi(1) set to nearest value
c                        values at pOut greater than pi(klevi) are extrapolated
c                   =3   values at pOut less    than pi(1) are extrapolated
c                        values at pOut greater than pi(klevi) set to nearest value
c                   =4   values at pOut less    than pi(1) are extrapolated
c                        values at pOut greater than pi(klevi) are extrapolated
c
c          ier    - error code  [=0 no error detected]
c                               [.ne.0 error detected: one or both
c                                      pressure arrays not top->bot order]
c     output
c          iflag  - indicates whether missing values in output
c          xo     - pressure at hybrid levels [Pa]
c                                                 ! input
      INTEGER MLON,NLAT,KLEVI,KLEVO,IFLAG,KFLAG,IER
      DOUBLE PRECISION P0,PI(KLEVI),PSFC(MLON,NLAT),XI(MLON,NLAT,KLEVI),
     +                 HYAO(KLEVO),HYBO(KLEVO),XMSG
c                                                 ! output
      DOUBLE PRECISION XO(MLON,NLAT,KLEVO)
C NCLEND
c                                                 ! local (automatic)
      DOUBLE PRECISION PO(KLEVO)

      IFLAG = 0
c                                                 ! ? input asending order
      IER   = 0
      IF (PI(1).GT.PI(KLEVI)) THEN
          IER = 1
      END IF

      PO(1)     = HYAO(1)*P0     + HYBO(1)*PSFC(1,1)
      PO(KLEVO) = HYAO(KLEVO)*P0 + HYBO(KLEVO)*PSFC(1,1)
c                                                 ! ? output ascending order
      IF (PO(1).GT.PO(KLEVO)) THEN
          IER = 20 + IER
      END IF

      IF (IER.NE.0) RETURN

      CALL P2HYB(PI,MLON,NLAT,KLEVI,XI,PSFC,P0,HYAO,HYBO,KLEVO,XO,PO
     +          ,IFLAG, KFLAG, XMSG)
      RETURN
      END

C NCLFORTSTART
      SUBROUTINE P2HYB(PI,MLON,NLAT,KLEVI,XI,PSFC,P0,HYAO,HYBO,KLEVO
     +                ,XO,PO,IFLAG, KFLAG, XMSG)
      IMPLICIT NONE
c                                                 ! input
      INTEGER MLON,NLAT,KLEVI,KLEVO,IFLAG, KFLAG
      DOUBLE PRECISION P0,HYAI(KLEVI),HYBI(KLEVI),HYAO(KLEVO),
     +                 HYBO(KLEVO),PSFC(MLON,NLAT),XI(MLON,NLAT,KLEVI),
     +                 PI(KLEVI),PO(KLEVO),XMSG
c                                                 ! output
      DOUBLE PRECISION XO(MLON,NLAT,KLEVO)
C NCLEND
c                                                 ! local
      INTEGER NL,ML,KI,KO
      DOUBLE PRECISION PIMIN, PIMAX, POMIN, POMAX, DXDP
c f77
      PIMIN = PI(1)
      PIMAX = PI(KLEVI)

      DO NL = 1,NLAT
        DO ML = 1,MLON

          DO KO = 1,KLEVO
             PO(KO) = HYAO(KO)*P0 + HYBO(KO)*PSFC(ML,NL)
          END DO

          POMIN = PO(1)
          POMAX = PO(KLEVO)

          DO KO = 1,KLEVO
             XO(ML,NL,KO) = XMSG
            DO KI = 1,KLEVI-1
               IF (PO(KO).GE.PIMIN .AND. PO(KO).LE.PIMAX ) THEN

                   IF (PO(KO).GE.PI(KI) .AND. PO(KO).LT.PI(KI+1)) THEN
                       XO(ML,NL,KO) = XI(ML,NL,KI)
     +                              +(XI(ML,NL,KI+1)-XI(ML,NL,KI))*
     +                               (DLOG(PO(KO))  -DLOG(PI(KI)))/
     +                               (DLOG(PI(KI+1))-DLOG(PI(KI)))
                   END IF
               ELSE
                   IF (KFLAG.EQ.0) THEN
                       IFLAG = 1
                       GO TO 100
                   END IF

                   IF (KFLAG.EQ.1) THEN
                       IF (PO(KO).LT.PIMIN) THEN
                           XO(ML,NL,KO) = XI(ML,NL,1)
                       END IF
                       IF (PO(KO).GT.PIMAX) THEN
                           XO(ML,NL,KO) = XI(ML,NL,KLEVI)
                       END IF
                       GO TO 100
                   END IF

                   IF (KFLAG.EQ.2) THEN
                       IF (PO(KO).LT.PIMIN) THEN
                           XO(ML,NL,KO) = XI(ML,NL,1)
                       END IF
                       IF (PO(KO).GT.PIMAX) THEN
                           DXDP = (XI(ML,NL,KLEVI)-XI(ML,NL,KLEVI-1))*
     +                            (DLOG(PI(KLEVI))-DLOG(PI(KLEVI-1)))
                           XO(ML,NL,KO) = XI(ML,NL,KLEVI)
     +                            + (DLOG(PO(KO))-DLOG(PI(KLEVI)))*DXDP
                       END IF
                       GO TO 100
                   END IF

                   IF (KFLAG.EQ.3) THEN
                       IF (PO(KO).LT.PIMIN) THEN
                           DXDP = (XI(ML,NL,2)-XI(ML,NL,1))*
     +                            (DLOG(PI(2))-DLOG(PI(1)))
                           XO(ML,NL,KO) = XI(ML,NL,1)
     +                            + (DLOG(PO(KO))-DLOG(PI(1)))*DXDP
                       END IF
                       IF (PO(KO).GT.PIMAX) THEN
                           XO(ML,NL,KO) = XI(ML,NL,KLEVI)
                       END IF
                       GO TO 100
                   END IF

                   IF (KFLAG.EQ.4) THEN
                       IF (PO(KO).LT.PIMIN) THEN
                           DXDP = (XI(ML,NL,2)-XI(ML,NL,1))*
     +                            (DLOG(PI(2))-DLOG(PI(1)))
                           XO(ML,NL,KO) = XI(ML,NL,1)
     +                            + (DLOG(PO(KO))-DLOG(PI(1)))*DXDP
                       END IF
                       IF (PO(KO).GT.PIMAX) THEN
                           DXDP = (XI(ML,NL,KLEVI)-XI(ML,NL,KLEVI-1))*
     +                            (DLOG(PI(KLEVI))-DLOG(PI(KLEVI-1)))
                           XO(ML,NL,KO) = XI(ML,NL,KLEVI)
     +                            + (DLOG(PO(KO))-DLOG(PI(KLEVI)))*DXDP
                       END IF
c c c                  GO TO 100
                   END IF

  100              CONTINUE
               END IF
             END DO
          END DO

        END DO
      END DO

      RETURN
      END


module rzvv_grid
    use constants

    implicit none

    save

    real :: R_range, z_Range, vPer_range, vPar_range
    real :: R_binSize, z_binSize, vPer_binSize, vPar_binSize
    real, allocatable :: R_binEdges (:), &
            z_binEdges (:), &
            vPer_binEdges (:), &
            vPar_binEdges (: )
    real, allocatable :: R_binCenters (:), &
            z_binCenters (:), &
            vPer_binCenters (:), &
            vPar_binCenters (: )
    real :: z_min, z_max, R_min, R_max

    real, allocatable :: f_rzvv (:,:,:,:), f_rzvv_global(:,:,:,:)
    real, allocatable :: density (:,:)
    real :: normFac_
    real(kind=dbl) :: v_sigma, x_sigma

contains
    subroutine init_rzvv_grid ()
        use read_particle_list
        use eqdsk
        use constants
        use read_namelist
        use init_mpi
        implicit none

        integer :: i
        i = 0

        allocate ( R_binEdges ( R_nBins + 1 ), &
                   z_binEdges ( z_nBins + 1 ), &
                   vPer_binEdges ( vPer_nBins + 1 ), &
                   vPar_binEdges ( vPar_nBins + 1 ), &
                   R_binCenters ( R_nBins ), &
                   z_binCenters ( z_nBins ), &
                   vPer_binCenters ( vPer_nBins ), &
                   vPar_binCenters ( vPar_nBins ) )
        allocate ( f_rzvv ( R_nBins, z_nBins, vPer_nBins, vPar_nBins ) )
        allocate ( density ( R_nBins, z_nBins ) )

        R_min   = minVal ( rbbbs )
        R_max   = maxVal ( rbbbs )
        R_range = R_max - R_min
        R_binSize   = R_range / R_nBins
        R_binEdges  = (/ (i*R_binSize,i=0,R_nBins) /) + R_min
        R_binCenters    = R_binEdges(1:R_nBins) + R_binSize / 2.0

        z_min   = minVal ( zbbbs )
        z_max = maxVal ( zbbbs )
        z_range = ( z_max - z_min )
        z_binSize   = z_range / z_nBins
        z_binEdges  = (/ (i*z_binSize,i=0,z_nBins) /) + z_min
        z_binCenters    = z_binEdges(1:z_nBins) + z_binSize / 2.0

        if(mpi_pId==1) write(*,*) 'R_min: ', R_min
        if(mpi_pId==1) write(*,*) 'R_max: ', R_max
        if(mpi_pId==1) write(*,*) 'z_min: ', z_min
        if(mpi_pId==1) write(*,*) 'z_max: ', z_max

        vPer_range = vPerInRange / 100.0 * c
        vPer_binSize   = vPer_range / vPer_nBins
        vPer_binEdges   = (/ (i*vPer_binSize,i=0,vPer_nBins) /)
        vPer_binCenters    = vPer_binEdges(1:vPer_nBins) &
            + vPer_binSize / 2.0

        vPar_range  = vParInRange / 100.0 * c
        vPar_binSize    = 2.0 * vPar_range / vPar_nBins
        vPar_binEdges   = (/ (i*vPar_binSize,i=0,vPar_nBins) /) - vPar_range
        vPar_binCenters = vPar_binEdges(1:vPar_nBins) + vPar_binSize / 2.0

        f_rzvv  = 0.0

    end subroutine init_rzvv_grid

end module rzvv_grid


PROGRAM pg121
!-------------------------------------------------------------------------
!      Program 12.1 three dimensional analysis of an elastic solid
!      using 8-node brick elements, DEC, preconditioned conjugate gradient
!      solver; diagonal preconditioner diag_precon; parallel version
!      loaded_nodes only
!-------------------------------------------------------------------------
!USE mpi_wrapper  !remove comment for serial compilation
 USE precision; USE global_variables; USE mp_interface; USE input
 USE output; USE loading; USE timing; USE maths; USE gather_scatter
 USE steering; USE new_library; USE common_mod; USE geometry_mod;
 USE elasticity_mod
 IMPLICIT NONE
! neq,ntot are now global variables - must not be declared
 INTEGER,PARAMETER::nodof=3,ndim=3,nst=9
 INTEGER::loaded_nodes,iel,i,j,k,m,n,iters,limit,nn,nr,nip,nod,nels,ndof,    &
   npes_pp,node_end,node_start,nodes_pp,meshgen,partitioner,nlen
 REAL(iwp),PARAMETER::zero=0.0_iwp
 REAL(iwp)::e,v,det,tol,up,alpha,beta,q; LOGICAL::converged=.false.
 CHARACTER(LEN=50)::argv; CHARACTER(LEN=15)::element; CHARACTER(LEN=6)::ch
!---------------------------- dynamic arrays -----------------------------
 REAL(iwp),ALLOCATABLE::points(:,:),dee(:,:),val(:,:),                   &
   disp_pp(:),g_coord_pp(:,:,:),                                         &
   storkm_pp(:,:,:),diag_precon_pp(:),p_pp(:),r_pp(:),                   &
   x_pp(:),xnew_pp(:),u_pp(:),pmul_pp(:,:),utemp_pp(:,:),d_pp(:),        &
   timest(:),diag_precon_tmp(:,:),eld_pp(:,:),temp(:)
 INTEGER,ALLOCATABLE::rest(:,:),g_num_pp(:,:),g_g_pp(:,:),node(:)
!-- for DEC
 INTEGER :: n_smplx, pindx(4), findx(2), vindx
 INTEGER, ALLOCATABLE :: smplx(:,:)
 REAL(iwp):: B(3,3), star
 REAL(iwp), ALLOCATABLE :: A(:,:), C(:)
 LOGICAL :: found
!------------------------ input and initialisation -----------------------
 ALLOCATE(timest(20)); timest=zero; timest(1)=elap_time()
 CALL find_pe_procs(numpe,npes); CALL getname(argv,nlen)
 CALL read_p121(argv,numpe,e,element,limit,loaded_nodes,meshgen,nels,    &
   nip,nn,nod,nr,partitioner,tol,v)
 CALL calc_nels_pp(argv,nels,npes,numpe,partitioner,nels_pp)
 ndof=nod*nodof; ntot=ndof
 ALLOCATE(g_num_pp(nod, nels_pp),g_coord_pp(nod,ndim,nels_pp),           &
   rest(nr,nodof+1)); g_num_pp=0; g_coord_pp=zero; rest=0
 CALL read_g_num_pp(argv,iel_start,nn,npes,numpe,g_num_pp)
 IF(meshgen == 2) CALL abaqus2sg(element,g_num_pp)
 CALL read_g_coord_pp(argv,g_num_pp,nn,npes,numpe,g_coord_pp)
 CALL read_rest(argv,numpe,rest); timest(2)=elap_time()
 ALLOCATE(points(nip,ndim),dee(nst,nst),                                 &
   storkm_pp(ntot,ntot,nels_pp),pmul_pp(ntot,nels_pp),                   &
   utemp_pp(ntot,nels_pp),g_g_pp(ntot,nels_pp))
!----------  find the steering array and equations per process -----------
 CALL rearrange(rest); g_g_pp=0; neq=0
 elements_0: DO iel=1,nels_pp
   CALL find_g3(g_num_pp(:,iel),g_g_pp(:,iel),rest)
 END DO elements_0
 neq=MAXVAL(g_g_pp); neq=max_p(neq); CALL calc_neq_pp
 CALL calc_npes_pp(npes,npes_pp); CALL make_ggl(npes_pp,npes,g_g_pp)
 ALLOCATE(p_pp(neq_pp),r_pp(neq_pp),x_pp(neq_pp),xnew_pp(neq_pp),        &
   u_pp(neq_pp),d_pp(neq_pp),diag_precon_pp(neq_pp)); diag_precon_pp=zero
 p_pp=zero;  r_pp=zero;  x_pp=zero; xnew_pp=zero; u_pp=zero; d_pp=zero
!------ element stiffness using DEC and build the preconditioner -------
 CALL deemat_linelasticity(dee,e,v); storkm_pp=zero

 dim_cmplx = 3;  dim_embbd = 3;  k=dim_cmplx+1
 ALLOCATE(num_pelm_pp(1), A(3,8), C(8)); num_pelm_pp(1)=nod;  extra_pelm=0;  glb_offset=0
 glb_num_elm = (/ nod, 19, 18, 6 /);  num_elm=glb_num_elm
 ALLOCATE(lcl_complex(k));
 ALLOCATE(lcl_complex(1)%centers(nod,dim_embbd),&
   lcl_complex(k)%orientation(6),lcl_complex(k)%node_indx(6,k))
 lcl_complex(k)%orientation=0;  indx_offset = 0

 elements_1: DO iel=1,nels_pp
   !- split elements into simplices
   CALL elm2smplx(num_elm(dim_cmplx+1),lcl_complex(dim_cmplx+1)%node_indx,&
     g_coord_pp(:,:,iel),element,nod)

   !- Recursively compute element (co-)boundaries
   DO k=dim_cmplx+1,2,-1; CALL calc_bndry_cobndry(k); END DO

   !- setup connectivity
   DO k=1,dim_cmplx+1; lcl_complex(k)%lcl_node_indx = lcl_complex(k)%node_indx; END DO

   !- calc circumcenter
   lcl_complex(1)%centers = g_coord_pp(:,:,iel)
   DO k=2,dim_cmplx+1; CALL calc_circumcenters_WBC(k); END DO

   !- calc primal edge and dual area and primal direction
   CALL calc_prml_unsgnd_vlm(2); CALL calc_dual_vlm(1)
   CALL calc_prml_dir()

   DO i = 1, num_elm(2)
     IF (ABS(lcl_complex(2)%dual_volume(i) / &
        max(lcl_complex(2)%prml_volume(i),small))<smalls) CYCLE
     !-- end points of given edge
     pindx(1:2) = lcl_complex(2)% bndry(i)% indx(1:2)

     !-- find associated nodes, faces and volumes
     DO j = 1,lcl_complex(2)%num_cobndry(i)-1
       !-- select one face bounded by edge and loop over other possible faces
       findx(1) = lcl_complex(2)% cobndry(i)% indx(j)
       DO k = j+1,lcl_complex(2)%num_cobndry(i)
         found = .FALSE.; findx(2) = lcl_complex(2)% cobndry(i)% indx(k)
         !-- search for volume bounded by face 1 and 2
         DO m = 1, lcl_complex(3)% num_cobndry(findx(1))
           vindx = lcl_complex(3)% cobndry(findx(1))% indx(m)
           DO n = 1, lcl_complex(3)% num_cobndry(findx(2))
             IF (vindx == lcl_complex(3)% cobndry(findx(2))% indx(n)) THEN
               found = .TRUE.; EXIT; END IF
           END DO; IF (found) EXIT
         END DO

         IF (.NOT. found) THEN; CYCLE !-- no volume with face 1 and 2 - cycle
         ELSE !-- determine remaining points of volume
           DO m=1,3; pindx(3) = lcl_complex(3)% node_indx(findx(1),m)
             IF (pindx(3) /= pindx(1) .AND. pindx(3) /= pindx(2)) EXIT
           END DO
           DO m=1,3; pindx(4) = lcl_complex(3)% node_indx(findx(2),m)
             IF (pindx(4) /= pindx(1) .AND. pindx(4) /= pindx(2)) EXIT
           END DO
         END IF

         !-- create augmented boundary operators for edge
         A = 0.d0; A(1, pindx(1:2) ) = (/ -1, 1 /)
         A(2, pindx(1:2) ) = (/ -0.5d0, -0.5d0 /)
         A(3, pindx(1:2) ) = (/ -0.5d0, -0.5d0 /)
         A(2, lcl_complex(3)% node_indx(findx(1),:) ) = &
           A(2, lcl_complex(3)% node_indx(findx(1),:) ) + &
           lcl_complex(3)% b_coord(findx(1),:)
         A(3, lcl_complex(3)% node_indx(findx(2),:)) = &
           A(3, lcl_complex(3)% node_indx(findx(2),:)) + &
           lcl_complex(3)% b_coord(findx(2),:)

         !-- create flat musical isomorphism
         B = MATMUL(A,g_coord_pp(:,:,iel))

         !-- create local portion of discrete Hodge star
         C = 0.d0; C( pindx(1:2) ) = (/ -0.5d0, -0.5d0 /)
         C(lcl_complex(4)% node_indx(vindx,:)) = &
           C(lcl_complex(4)% node_indx(vindx,:)) + &
           lcl_complex(4)% b_coord(vindx,:)
         star = 0.5*(&
           norm(cross_product(MATMUL(C,g_coord_pp(:,:,iel)),B(2,:))) + &
           norm(cross_product(MATMUL(C,g_coord_pp(:,:,iel)),B(3,:)))) / &
           max(lcl_complex(2)%prml_volume(i),small)
         !-- update system matrix
         storkm_pp(:,:,iel)=storkm_pp(:,:,iel) +                             &
           MATMUL(kron_eye(MATMUL(TRANSPOSE(A(1:1,:)),star*B(1:1,:)),3),     &
           MATMUL(dee,kron_eye(MATMUL(matinv3(B),A),3)))
       END DO
     END DO
   END DO

   !- Deallocate variables
   DO k=1,dim_cmplx+1;
     IF (ALLOCATED(lcl_complex(k)%recv_indx))   DEALLOCATE(lcl_complex(k)%recv_indx)
     IF (ALLOCATED(lcl_complex(k)%num_bndry))   DEALLOCATE(lcl_complex(k)%num_bndry)
     IF (ALLOCATED(lcl_complex(k)%bndry))       DEALLOCATE(lcl_complex(k)%bndry)
     IF (ALLOCATED(lcl_complex(k)%num_cobndry)) DEALLOCATE(lcl_complex(k)%num_cobndry)
     IF (ALLOCATED(lcl_complex(k)%cobndry))     DEALLOCATE(lcl_complex(k)%cobndry)
     IF (ALLOCATED(lcl_complex(k)%node_indx))   DEALLOCATE(lcl_complex(k)%node_indx)
   END DO
 END DO elements_1

 ALLOCATE(diag_precon_tmp(ntot,nels_pp)); diag_precon_tmp=zero
 elements_2: DO iel=1,nels_pp ; DO i=1,ndof
   diag_precon_tmp(i,iel) = diag_precon_tmp(i,iel)+storkm_pp(i,i,iel)
 END DO;  END DO elements_2
 CALL scatter(diag_precon_pp,diag_precon_tmp); DEALLOCATE(diag_precon_tmp)
 IF(numpe==1)THEN
   OPEN(11,FILE=argv(1:nlen)//".res",STATUS='REPLACE',ACTION='WRITE')
   WRITE(11,'(A,I7,A)') "This job ran on ",npes," processes"
   WRITE(11,'(A,3(I12,A))') "There are ",nn," nodes", nr, &
                           " restrained and ",neq," equations"
   WRITE(11,'(A,F10.4)') "Time to read input is:",timest(2)-timest(1)
   WRITE(11,'(A,F10.4)') "Time after setup is:",elap_time()-timest(1)
 END IF
!----------------------------- get starting r ----------------------------
 IF(loaded_nodes>0) THEN
   ALLOCATE(node(loaded_nodes),val(ndim,loaded_nodes)); node=0; val=zero
   CALL read_loads(argv,numpe,node,val)
   CALL load(g_g_pp,g_num_pp,node,val,r_pp(1:)); q=SUM_P(r_pp(1:))
   IF(numpe==1) WRITE(11,'(A,E12.4)') "The total load is:",q
   DEALLOCATE(node,val)
 END IF
 DEALLOCATE(g_g_pp); diag_precon_pp=1._iwp/diag_precon_pp
 d_pp=diag_precon_pp*r_pp; p_pp=d_pp; x_pp=zero
!--------------------- preconditioned cg iterations ----------------------
 iters=0; timest(3)=elap_time()
 iterations: DO
   iters=iters+1; u_pp=zero; pmul_pp=zero; utemp_pp=zero
   CALL gather(p_pp,pmul_pp)
   elements_3: DO iel=1,nels_pp
     utemp_pp(:,iel) = MATMUL(storkm_pp(:,:,iel),pmul_pp(:,iel))
!    CALL dgemv('n',ntot,ntot,1.0_iwp,storkm_pp(:,:,iel),ntot,           &
!               pmul_pp(:,iel),1,0.0_iwp,utemp_pp(:,iel),1)
   END DO elements_3 ;CALL scatter(u_pp,utemp_pp)
!-------------------------- pcg equation solution ------------------------
   up=DOT_PRODUCT_P(r_pp,d_pp); alpha=up/DOT_PRODUCT_P(p_pp,u_pp)
   xnew_pp=x_pp+p_pp*alpha; r_pp=r_pp-u_pp*alpha
   d_pp=diag_precon_pp*r_pp; beta=DOT_PRODUCT_P(r_pp,d_pp)/up
   p_pp=d_pp+p_pp*beta; CALL checon_par(xnew_pp,tol,converged,x_pp)
   IF(converged.OR.iters==limit)EXIT
 END DO iterations
 IF(numpe==1)THEN
   WRITE(11,'(A,I6)')"The number of iterations to convergence was ",iters
   WRITE(11,'(A,F10.4)')"Time to solve equations was  :",                &
                         elap_time()-timest(3)
   WRITE(11,'(A,E12.4)')"The central nodal displacement is :",xnew_pp(1)
 END IF
 DEALLOCATE(p_pp,r_pp,x_pp,u_pp,d_pp,diag_precon_pp,storkm_pp,pmul_pp)
!--------------- recover stresses at centroidal gauss point --------------
 ALLOCATE(eld_pp(ntot,nels_pp)); eld_pp=zero; points=zero; nip=1; iel=1
 CALL gather(xnew_pp(1:),eld_pp); DEALLOCATE(xnew_pp)
 ! IF(numpe==1)WRITE(11,'(A)')"The Centroid point stresses for element 1 are"
 ! gauss_pts_2: DO i=1,nip
 !   CALL shape_der(der,points,i); jac=MATMUL(der,g_coord_pp(:,:,iel))
 !   CALL invert(jac); deriv=MATMUL(jac,der); CALL beemat(bee,deriv)
 !   eps=MATMUL(bee,eld_pp(:,iel)); sigma=MATMUL(dee,eps)
 !   IF(numpe==1.AND.i==1) THEN
 !     WRITE(11,'(A,I5)')"Point ",i ; WRITE(11,'(6E12.4)') sigma
 !   END IF
 ! END DO gauss_pts_2; DEALLOCATE(g_coord_pp)
!------------------------ write out displacements ------------------------
 CALL calc_nodes_pp(nn,npes,numpe,node_end,node_start,nodes_pp)
 IF(numpe==1) THEN;  WRITE(ch,'(I6.6)') numpe
   OPEN(12,file=argv(1:nlen)//".ensi.DISPL-"//ch,status='replace',       &
     action='write')
   WRITE(12,'(A)') "Alya Ensight Gold --- Vector per-node variable file"
   WRITE(12,'(A/A/A)') "part", "     1","coordinates"
 END IF
 ALLOCATE(disp_pp(nodes_pp*ndim),temp(nodes_pp)); disp_pp=zero; temp=zero
 CALL scatter_nodes(npes,nn,nels_pp,g_num_pp,nod,ndim,nodes_pp,          &
                    node_start,node_end,eld_pp,disp_pp,1)
 DO i=1,ndim ; temp=zero
   DO j=1,nodes_pp; k=i+(ndim*(j-1)); temp(j)=disp_pp(k); END DO
   CALL dismsh_ensi_p(12,1,nodes_pp,npes,numpe,1,temp)
 END DO ; IF(numpe==1) CLOSE(12)
 IF(numpe==1) WRITE(11,'(A,F10.4)')"This analysis took  :",              &
   elap_time()-timest(1)
 IF(numpe==1) CLOSE(11)
 CALL SHUTDOWN()
END PROGRAM pg121


SUBROUTINE neo_fourier
! Summation of Fourier Sums and Computation of Derived Quantities
!***********************************************************************
! Modules
!***********************************************************************
  USE neo_precision
  USE neo_input
  USE neo_work
  USE neo_exchange
  USE neo_parameters
  USE neo_control
  USE neo_units
!***********************************************************************
! Local definitions
!***********************************************************************
  IMPLICIT NONE

  INTEGER       :: i_alloc
  INTEGER       :: im, in, m, n, i, j
  INTEGER       :: it, ip, imn
  REAL(kind=dp) :: ri, zi, li, bi
  REAL(kind=dp) :: cosv, sinv
!***********************************************************************
! Allocation of arrays
!***********************************************************************
!  write(*,*) theta_n,phi_n
  ALLOCATE(r(theta_n,phi_n),                                           &
           z(theta_n,phi_n),                                           &
           l(theta_n,phi_n),                                           &
           stat = i_alloc)
  IF(i_alloc /= 0) STOP 'Allocation for sum-arrays failed!'
  ALLOCATE(r_tb(theta_n,phi_n),                                        &
           z_tb(theta_n,phi_n),                                        &
           p_tb(theta_n,phi_n),                                        &
           b_tb(theta_n,phi_n),                                        &
           stat = i_alloc)
  IF(i_alloc /= 0) STOP 'Allocation for sum-arrays failed!'
  ALLOCATE(r_pb(theta_n,phi_n),                                        &
           z_pb(theta_n,phi_n),                                        &
           p_pb(theta_n,phi_n),                                        &
           b_pb(theta_n,phi_n),                                        &
           stat = i_alloc)
  IF(i_alloc /= 0) STOP 'Allocation for sum-arrays failed!'
  ALLOCATE(gtbtb(theta_n,phi_n),                                       &
           gpbpb(theta_n,phi_n),                                       &
           gtbpb(theta_n,phi_n),                                       &
           isqrg(theta_n,phi_n),                                       &
           stat = i_alloc)
  IF(i_alloc /= 0) STOP 'Allocation for sum-arrays failed!'
!***********************************************************************
! Summation of Fourier components
!***********************************************************************
  r = 0
  z = 0
  l = 0
  b = 0

  r_tb = 0
  z_tb = 0
  p_tb = 0
  b_tb = 0
  r_pb = 0
  z_pb = 0
  p_pb = 0
  b_pb = 0

  DO imn=1,mnmax
     ri = rmnc(psi_ind,imn)
     zi = zmns(psi_ind,imn)
     li = lmns(psi_ind,imn)
     bi = bmnc(psi_ind,imn)
     m = ixm(imn)
     n = ixn(imn)
     im = pixm(imn)
     in = pixn(imn)
     IF (ABS(m) .LE. max_m_mode .AND. ABS(n) .LE. max_n_mode) THEN
        DO ip=1,phi_n
           DO it=1,theta_n
              cosv = cosmth(it,im) * cosnph(ip,in) + sinmth(it,im) * sinnph(ip,in)
              sinv = sinmth(it,im) * cosnph(ip,in) - cosmth(it,im) * sinnph(ip,in)

              r(it,ip) = r(it,ip) + ri*cosv
              z(it,ip) = z(it,ip) + zi*sinv
              l(it,ip) = l(it,ip) + li*sinv
              b(it,ip) = b(it,ip) + bi*cosv

              r_tb(it,ip) = r_tb(it,ip) - m*ri*sinv
              r_pb(it,ip) = r_pb(it,ip) + n*ri*sinv
              z_tb(it,ip) = z_tb(it,ip) + m*zi*cosv
              z_pb(it,ip) = z_pb(it,ip) - n*zi*cosv
              p_tb(it,ip) = p_tb(it,ip) - m*li*cosv
              p_pb(it,ip) = p_pb(it,ip) + n*li*cosv
              b_tb(it,ip) = b_tb(it,ip) - m*bi*sinv
              b_pb(it,ip) = b_pb(it,ip) + n*bi*sinv
           END DO
        END DO
     END IF
  END DO

  IF (lasym) THEN
     DO imn=1,mnmax
        ri = rmns(psi_ind,imn)
        zi = zmnc(psi_ind,imn)
        li = lmnc(psi_ind,imn)
        bi = bmns(psi_ind,imn)
        m = ixm(imn)
        n = ixn(imn)
        im = pixm(imn)
        in = pixn(imn)
        IF (ABS(m) .LE. max_m_mode .AND. ABS(n) .LE. max_n_mode) THEN
           DO ip=1,phi_n
              DO it=1,theta_n
                 cosv = cosmth(it,im) * cosnph(ip,in) + sinmth(it,im) * sinnph(ip,in)
                 sinv = sinmth(it,im) * cosnph(ip,in) - cosmth(it,im) * sinnph(ip,in)

                 r(it,ip) = r(it,ip) + ri*sinv
                 z(it,ip) = z(it,ip) + zi*cosv
                 l(it,ip) = l(it,ip) + li*cosv
                 b(it,ip) = b(it,ip) + bi*sinv

                 r_tb(it,ip) = r_tb(it,ip) + m*ri*cosv
                 r_pb(it,ip) = r_pb(it,ip) - n*ri*cosv
                 z_tb(it,ip) = z_tb(it,ip) - m*zi*sinv
                 z_pb(it,ip) = z_pb(it,ip) + n*zi*sinv
                 p_tb(it,ip) = p_tb(it,ip) + m*li*sinv
                 p_pb(it,ip) = p_pb(it,ip) - n*li*sinv
                 b_tb(it,ip) = b_tb(it,ip) + m*bi*cosv
                 b_pb(it,ip) = b_pb(it,ip) - n*bi*cosv
              END DO
           END DO
        END IF
     END DO
  END IF

! Compute Boozer-theta_b (tb), phi_b (pb) derivatives of the cylindrical phi angle (p)

  p_tb = p_tb * twopi / nfp
  p_pb = ONE + p_pb * twopi / nfp
! **********************************************************************
! Ensure periodicity boundaries to be the same
! **********************************************************************
  r(theta_n,:) = r(1,:)
  r(:,phi_n)   = r(:,1)
  z(theta_n,:) = z(1,:)
  z(:,phi_n)   = z(:,1)
  l(theta_n,:) = l(1,:)
  l(:,phi_n)   = l(:,1)
  b(theta_n,:) = b(1,:)
  b(:,phi_n)   = b(:,1)
  r_tb(theta_n,:) = r_tb(1,:)
  r_tb(:,phi_n)   = r_tb(:,1)
  r_pb(theta_n,:) = r_pb(1,:)
  r_pb(:,phi_n)   = r_pb(:,1)
  z_tb(theta_n,:) = z_tb(1,:)
  z_tb(:,phi_n)   = z_tb(:,1)
  z_pb(theta_n,:) = z_pb(1,:)
  z_pb(:,phi_n)   = z_pb(:,1)
  p_tb(theta_n,:) = p_tb(1,:)
  p_tb(:,phi_n)   = p_tb(:,1)
  p_pb(theta_n,:) = p_pb(1,:)
  p_pb(:,phi_n)   = p_pb(:,1)
  b_tb(theta_n,:) = b_tb(1,:)
  b_tb(:,phi_n)   = b_tb(:,1)
  b_pb(theta_n,:) = b_pb(1,:)
  b_pb(:,phi_n)   = b_pb(:,1)
! **********************************************************************
! Derived quantities
! NOTE: The radial coordinate used in these formulae is psi = (TOROIDAL FLUX)/TWOPI
! so that PHIP == d psi / ds = 1
! **********************************************************************
! metric tensor
  gtbtb = r_tb*r_tb + z_tb*z_tb + r*r*p_tb*p_tb
  gpbpb = r_pb*r_pb + z_pb*z_pb + r*r*p_pb*p_pb
  gtbpb = r_tb*r_pb + z_tb*z_pb + r*r*p_tb*p_pb
! $1/sqrt(g)$
  fac = curr_pol(psi_ind) + iota(psi_ind)*curr_tor(psi_ind)
  isqrg  = b*b / fac
! $sqrt(g^{11})$  == |grad-psi|
  sqrg11 = SQRT( gtbtb*gpbpb - gtbpb*gtbpb ) * isqrg
! geodesic curvature term $k_G |\nabla \psi|$
! proportional to v_drift * grad(psi) (radial drift velocity)         !!SPH
  kg = (curr_tor(psi_ind)*b_pb - curr_pol(psi_ind)*b_tb) / fac
! parallel derivative of mod-B
  pard = b_pb + iota(psi_ind)*b_tb
! quasi-toroidal phi component of b (only for parallel current)
  IF (calc_cur .EQ. 1) THEN
     bqtphi = isqrg * (p_pb + iota(psi_ind)*p_tb)
  END IF
! **********************************************************************
! Optional Output
! **********************************************************************
  IF (write_output_files .NE. 0) THEN
     IF (write_progress .NE. 0) WRITE (w_us,*) 'write b_s_arr.dat'
     OPEN(unit=w_u1,file='b_s_arr.dat',status='replace',form='formatted')
     DO i=1,theta_n
        DO j=1,phi_n
           WRITE(w_u1,*)  b(i,j)
        END DO
     ENDDO
     CLOSE(unit=w_u1)

     IF (write_progress .NE. 0) WRITE (w_us,*) 'write r_s_arr.dat'
     OPEN(unit=w_u1,file='r_s_arr.dat',status='replace',form='formatted')
     DO i=1,theta_n
        DO j=1,phi_n
           WRITE(w_u1,*)  r(i,j)
        END DO
     ENDDO
     CLOSE(unit=w_u1)

     IF (write_progress .NE. 0) WRITE (w_us,*) 'write z_s_arr.dat'
     OPEN(unit=w_u1,file='z_s_arr.dat',status='replace',form='formatted')
     DO i=1,theta_n
        DO j=1,phi_n
           WRITE(w_u1,*)  z(i,j)
        END DO
     ENDDO
     CLOSE(unit=w_u1)

     IF (write_progress .NE. 0) WRITE (w_us,*) 'write l_s_arr.dat'
     OPEN(unit=w_u1,file='l_s_arr.dat',status='replace',form='formatted')
     DO i=1,theta_n
        DO j=1,phi_n
           WRITE(w_u1,*)  l(i,j)
        END DO
     ENDDO
     CLOSE(unit=w_u1)

     IF (write_progress .NE. 0) WRITE (w_us,*) 'write isqrg_arr.dat'
     OPEN(unit=w_u1,file='isqrg_arr.dat',status='replace',form='formatted')
     DO i=1,theta_n
        DO j=1,phi_n
           WRITE(w_u1,*)  isqrg(i,j)
        END DO
     ENDDO
     CLOSE(unit=w_u1)

     IF (write_progress .NE. 0) WRITE (w_us,*) 'write sqrg11_arr.dat'
     OPEN(unit=w_u1,file='sqrg11_arr.dat',status='replace',form='formatted')
     DO i=1,theta_n
        DO j=1,phi_n
           WRITE(w_u1,*)  sqrg11(i,j)
        END DO
     ENDDO
     CLOSE(unit=w_u1)

     IF (write_progress .NE. 0) WRITE (w_us,*) 'write kg_arr.dat'
     OPEN(unit=w_u1,file='kg_arr.dat',status='replace',form='formatted')
     DO i=1,theta_n
        DO j=1,phi_n
           WRITE(w_u1,*)  kg(i,j)
        END DO
     ENDDO
     CLOSE(unit=w_u1)

     IF (write_progress .NE. 0) WRITE (w_us,*) 'write pard_arr.dat'
     OPEN(unit=w_u1,file='pard_arr.dat',status='replace',form='formatted')
     DO i=1,theta_n
        DO j=1,phi_n
           WRITE(w_u1,*)  pard(i,j)
        END DO
     ENDDO
     CLOSE(unit=w_u1)
  ENDIF
! **********************************************************************
!  Deallocation of unnecessary arrays
! **********************************************************************
  DEALLOCATE (r,z,l)
  DEALLOCATE (r_tb,z_tb,p_tb,b_tb)
  DEALLOCATE (r_pb,z_pb,p_pb,b_pb)
  DEALLOCATE (gtbtb,gpbpb,gtbpb,isqrg)
! **********************************************************************
  RETURN
END SUBROUTINE neo_fourier


program ppraxis_crt
implicit none
integer :: i
do i = 1, 1716
    if (mod(i,13) == 12 .and. mod(i,12) == 4 .and. mod(i,11) == 10) then
        write(*,*) i
        stop
    end if
end do
stop
end program ppraxis_crt


c     This function return the power of (1-x)
      real*8 function eepdf_tilde_power(Q2,n,partonid,beamid)
      implicit none
      real*8 me
      data me /0.511d-3/
      real*8 PI
      real*8 alphaem
c     In Gmu scheme
      data alphaem/0.007562397d0/
      real*8 beta,Q2
      integer n,partonid,beamid
      real*8 k
      real*8 apeak,aarm,abody
      real*8 anorm1,anorm2
      real*8 a2,a3,a4,a5
      data apeak/0.3388d0/, aarm/0.2371d0/, abody/0.1868d0/
      data a2/12.09d0/, a3/-0.678d0/, a4/11.56d0/, a5/-0.664d0/
      data anorm1/0.817243d0/,anorm2/0.873045d0/

      PI=4.D0*DATAN(1.D0)
      beta = alphaem/PI * (dlog(Q2/me/me)-1d0)

c     electron beam
      if (beamid .eq. 11) then
c     other partons are zero
        if (partonid .ne. 11) then
          k=0d0
        else
          if (n .eq. 1) then
            k=1d0-beta
          else if (n .eq. 2) then
            k=-beta-a3
          else if (n .eq. 3) then
            k=1d0-beta
          else if (n .eq. 4) then
            k=-beta-a5
          else
            k=0d0
          endif
        endif
      else if (beamid .eq. -11) then
        if (partonid .ne. -11) then
          k=0d0
        else
          if (n .eq. 1) then
            k=1d0-beta
          else if (n .eq. 2) then
            k=1d0-beta
          else if (n .eq. 3) then
            k=-beta-a3
          else if (n .eq. 4) then
            k=-beta-a5
          else
            k=0d0
          endif
        endif
      endif
      eepdf_tilde_power = k
      end

c     This is to calculate the factor for grid implementation
      real*8 function eepdf_tilde_factor(x,Q2,n,partonid,beamid)
      implicit none
      real*8 x,Q2
      real*8 me
      data me /0.511d-3/
      real*8 PI
      real*8 alphaem
c     In Gmu scheme
      data alphaem/0.007562397d0/
      real*8 beta
      integer n,partonid,beamid
      real*8 apeak,aarm,abody
      real*8 anorm1,anorm2
      real*8 a2,a3,a4,a5
      data apeak/0.3388d0/, aarm/0.2371d0/, abody/0.1868d0/
      data a2/12.09d0/, a3/-0.678d0/, a4/11.56d0/, a5/-0.664d0/
      data anorm1/0.817243d0/,anorm2/0.873045d0/
      real*8 tx,bpb,tmp
      real*8 res

      PI=4.D0*DATAN(1.D0)
      beta = alphaem/PI * (dlog(Q2/me/me)-1d0)

c     electron beam
      if (beamid .eq. 11) then
c     other partons are zero
        if (partonid .ne. 11) then
          res=1d0
        else
          if (n .eq. 1) then
            res = x**(-beta/5d0)
          else if (n .eq. 2) then
            res = x**(-beta/5d0)
          else if (n .eq. 3) then
            res = x**(-beta/5d0)
          else if (n .eq. 4) then
            res = x**(-beta/5d0)
          else
            res = 1d0
          endif
        endif
      else if (beamid .eq. -11) then
        if (partonid .ne. -11) then
          res = 1d0
        else
          if (n .eq. 1) then
            res = x**(-beta/5d0)
          else if (n .eq. 2) then
            res = x**(-beta/5d0)
          else if (n .eq. 3) then
            res = x**(-beta/5d0)
          else if (n .eq. 4) then
            res = x**(-beta/5d0)
          else
            res = 1d0
          endif
        endif
      endif
      eepdf_tilde_factor = res
      end


program main

   use omp_lib

   implicit none

   integer, parameter :: k15 = selected_real_kind(15)
   real(kind=k15) :: partial_prod, total_prod
   integer :: i
   real(kind=k15)    :: z=0.25

!$OMP PARALLEL PRIVATE(partial_prod) SHARED(total_prod)
   partial_prod = 1;
   total_prod = 1;
   !$OMP DO
   do i = 1, huge(i)
      partial_prod = partial_prod * (1.0 - z**2 / real(i)**2)
   end do
   !$OMP END DO

   !$OMP CRITICAL
   total_prod = total_prod * partial_prod
   !$OMP END CRITICAL

!$OMP END PARALLEL
   print *, "Total Prod: ", total_prod

end program


submodule(euler_interface_m) euler_prob_0034_m
    implicit none

contains

    module character(len=20) function euler0034()
        write (euler0034, "(i20)") ans(40585)
    end function euler0034

    integer function ans(n)
        integer, intent(in) :: n
        integer :: i, isum

        isum = 0
        do i = 1, n
            if (is_curious(i)) then
                isum = isum + i
            end if
        end do

        ans = isum
    end function ans

    logical function is_curious(n)
        integer, intent(in) :: n
        integer, allocatable :: arr(:)
        integer :: i, tmp

        if (n == 1 .or. n == 2) then
            is_curious = .false.
            return
        end if

        tmp = 0
        is_curious = .false.
        call int_2_arr(n, arr)

        do i = 1, size(arr)
            tmp = tmp + factorial(arr(i))
        end do

        if (tmp == n) is_curious = .true.
    end function is_curious

end submodule euler_prob_0034_m


subroutine bond_id(n,positions,r0,r1,bn,b0,b1)

    implicit none

    integer*4, intent(in)                    :: n,bn
    real*8,    intent(in)                    :: r0,r1
    real*8,    intent(in)                    :: positions(n,3)

    integer*4,dimension(bn), intent(out)     :: b0,b1

    integer*4 :: i,j,bnt

    real*8 :: xi,yi,zi,xj,yj,zj,dx,dy,dz,mdl

    bnt = 1

    print *,"Bond_id called with particles:",n

    do i = 1, (n - 1)
        xi = positions(i,1)
        yi = positions(i,2)
        zi = positions(i,3)

        do j = 1, n
            if (i .ge. j) cycle
            xj = positions(j,1)
            yj = positions(j,2)
            zj = positions(j,3)

            dx = abs(xj-xi)
            dy = abs(yj-yi)
            dz = abs(zj-zi)

            mdl = sqrt(dx*dx + dy*dy + dz*dz)

            if (mdl .ge. r0 .and. mdl .le. r1) then
                b0(bnt) = i - 1
                b1(bnt) = j - 1
                bnt = bnt + 1
            else
                cycle
            end if
        end do
    end do

!    do i = 1,n
!        if (couples(i,1) .le. r1 .and. couples(i,1) .ge. r0) then
!            b0(bnt) = int(couples(i,2))
!            b1(bnt) = int(couples(i,3))
!            bnt = bnt + 1
!        end if
!    end do

    print *,"Bond indexer: "
    print *,"Min: ",r0
    print *,"Max: ",r1
    print *,"Couples in this interval: ", bn
    print *,"Total couples: ",n*(n-1)/2
    print *,"--------------------------------"
    print *

    return
end subroutine bond_id


          program demo_atan
          use, intrinsic :: iso_fortran_env, only : real_kinds, &
          & real32, real64, real128
          implicit none
          real(kind=real64) :: x = 2.866_real64
             x = atan(x)
          end program demo_atan


program arraymem

   use iso_fortran_env

   implicit none

   integer, parameter :: n = 2*1024*1024 - 4096

   print *, 'Numeric Storage (bits): ', numeric_storage_size
   print *, 'Creating array N ', n

   call meanArray(n)

contains

   subroutine meanArray(n)
      integer, intent(in) :: n
      integer :: dumb
      integer, dimension(n) :: a
      a = 1
      print *, sum(a)
      read *, dumb
   end subroutine meanArray

end program arraymem


        subroutine amatrix
        parameter(nmx=24)
        common /matrix/ a(nmx,nmx),capd2
!       COMMON /POSIT/  XOLD,YOLD,XCORN,YCORN
        common /vect/rovect(nmx),xvect(nmx),yvect(nmx)
c
        PI180 = 4.*ATAN(1.0)/180.
!       yo=yold*pi180
!qliu        fact=cos(yo)
        fact=1.0
c       capd2=(3.15)*(3.15)
        capd2=(2.25)*(2.25)
        do 10 ip=1,nmx
        do 10 jp=ip,nmx
         dpij=(fact*(xvect(ip)-xvect(jp)))**2 +(yvect(ip)-yvect(jp))**2
          a(ip,jp)= exp(-dpij/capd2)
          a(jp,ip)= a(ip,jp)
10      continue
100     format(5f8.4)
        return
        end


      program test_uniax_tens_ht
        use tensor_operations

        implicit none
        double precision::  sig, eps, H, C, ome,alp, gam, sig_0, epsp_b,
     &      epsp_bn, D_epsp_b,A_c, f, Teps
        !Parameters GTN mode
        double precision:: xE, xnu, sigy0, q1, q2, q3, f_0, f_n, s_n,
     &   f_f, E_n, NU, mu, q_el, kap
        double precision :: d_sig_0_d_epsp_b, dsig_deps, df_deps,
     &        depsp_b_deps
        double precision :: dp_deps_v, df_deps_v, depsp_b_deps_v, epsv_y
        double precision, dimension(13):: mat_param
        double precision, dimension(10):: epsv_l, p_l, f_l
        double precision:: l0, uf, Teps_f, D_u ,u, Teps1, D_eps, eps_fi,
     &   l, lsi,lf, l_y
        double precision:: pi, steps
        double precision:: ph, eps_vf, epsv, epsv1, D_epsv, eps_y
        integer :: i, stat

        mat_param(1)   = 300.0*200.0              ! xE
        mat_param(2)   = 0.33                 ! xnu
        mat_param(3)   = 200.0 !200           ! xsigy0
        mat_param(4)   = 50.0*mat_param(3);   ! 50   ! xH
        mat_param(5)   = 100.0*mat_param(3);  ! 10  ! xh
        mat_param(6)   = 1.5                  ! q1
        mat_param(7)   = 1.0                  ! q2
        mat_param(8)   = 1.5                  ! q1=q3 Aricle G.Vadillo
        mat_param(9)   = 0.0                ! f_0
        mat_param(10)  = 0.04                  ! f_n
        mat_param(11)  = 0.1                  ! s_n
        mat_param(12)  = 0.2025               ! f_f
        mat_param(13)  = 0.3                  ! E_n

        xE       = mat_param(1)
        xnu      = mat_param(2)
        sigy0    = mat_param(3)
        q1       = mat_param(6)
        q2       = mat_param(7)
        q3       = q1**2
        f        = mat_param(9)
        f_n      = mat_param(10)
        s_n      = mat_param(11)
        f_f      = mat_param(12)
        E_n      = mat_param(13)
        mu       = xE/(2.0*(1.0+xnu))
        kap      = xE/(3.0*(1.0-2.0*xnu))
        q_el     = -0.5*(kap-2.0/3.0*mu)/(kap+1.0/3.0*mu)
        NU       = 0.1

        pi       = 4.D0*DATAN(1.D0)

c=======================================================================
c        Hydrostatic tension
c=======================================================================
c test on an 8-node brick element
c Equal displacement increments are used so that a logarithmic volumetric strain of 40 per cent is reached in 10 increments

        f=0.04
        D_u=0.2/10000.0

        l0=0.004  !0.25 Works !Dimenision initial test piece
        eps_vf=0.4  !0.4 Final volumetric strain
c Without include the strain until yield point
        epsv_l=(/0.042, 0.084, 0.126, 0.166, 0.207, 0.246, 0.285, 0.324,
     &          0.362, 0.400/)
        p_l=(/201.4, 172.8, 148.7, 128.8, 112.1, 98.1, 86.3, 76.3,
     &        67.8, 60.4/)
        f_l=(/0.0728, 0.1130, 0.1524, 0.1911, 0.2287, 0.2645, 0.2980,
     &       0.3290, 0.3575, 0.3838/)
        uf=(DEXP(eps_vf/3)-1)*l0
        lf=(DEXP(eps_vf/3)-1)*l0+uf !Final length
        steps=uf/D_u
        print*, "steps" , steps
        eps_fi=(lf-l0)/l0 !Final engineering strain
        u=0.0
        i=0
        eps_y=sigy0/xE !Strain at yield point
        l_y=eps_y*l0+l0  !Length at yied point
        epsv_y=3.0*dlog(1+eps_y)  !Volumetric strain
        !epsv=0.00  !Initial Volumetric strain
        epsv=epsv_y !<-----------------------------Alternative
        ph=sigy0 !0.1 !Initial hidrostatic stress. Here we supouse that start a yield point
        sig_0=sigy0 !Equivalent tensile flow stress
        epsp_b=0.0
        print*, "eps_y", eps_y,"eps_vol_y",epsv ,"Length at yied point",
     &         l, "Final lengt", lf, "eps max"
     &       ,eps_fi

        open(unit=1, iostat=stat, file='data_test_ht_vol.csv',
     $         status='old')
             if (stat == 0) close(1, status='delete')
        open(1, file = 'data_test_ht_vol.csv', status = 'new')
   20   if (u<uf) then
            i =i+ 1

            u=D_u*i
            !epsv1=3.0*dlog(1+u/l0)
            epsv1=3.0*dlog(1+u/l0+eps_y) !<-----------------------------Alternativ
            D_epsv=epsv1-epsv

            !ome=-3.0*ph/sig_0 Aravas
          ome=3.0*ph/sig_0 !Z.L. Zhang
          alp=0.5*q1*q2*f*sinh(0.5*q2*ome)
          !gam=q1*cosh(0.5*q2*ome)-q3*f !Aravas
          gam=q1*cosh(-1.5*q2*sig/sig_0)-q3*f !Z.L. Zhang
          print*, "ome", ome, "alp", alp,"gam" , gam
          d_sig_0_d_epsp_b=3.0*mu*NU*(sig_0/sigy0+3.0*mu*epsp_b/sigy0)
     &              **(NU-1.0)/(1.0-NU*(sig_0/sigy0+
     &              3.0*mu*epsp_b/sigy0)**(NU-1))
          A_c=f_n/(s_n*(2.0*pi)**0.5)*DEXP(-1.0/2.0*((epsp_b-E_n)/
     &           s_n)**2)
c            H=d_sig_0_d_epsp_b*alp*ome/(1.0-f)*(alp*ome-sig_0*A_c*gam)-
c     &         3.0*sig_0*(1.0-f)*alp*gam  !Aravas
          H=alp*ome/(1.0-f)*(d_sig_0_d_epsp_b*alp*ome-sig_0*A_c*gam)-
     &         3.0*sig_0*(1.0-f)*alp*gam   !Z.L. Zhang
          !print*, d_sig_0_d_epsp_b, "A_c", A_c, "H", H, "A_c", A_c

          !dp_deps_v=-kap*H/(H+9*alp**2*kap) Aravas
          dp_deps_v=kap*H/(H+9*alp**2*kap) !Z.L. Zhang
          depsp_b_deps_v=3*alp**2*kap/(H+9*alp**2*kap)*ome/(1-f)
          df_deps_v=9*alp**2*kap/(H+9*alp**2*kap)*(1-f+1.0/3.0*A_c*
     &          ome/(1-f))
          ph =ph+ dp_deps_v*D_epsv
          f =f+ df_deps_v*D_epsv
          epsp_bn =epsp_b
          epsp_b =epsp_b+ depsp_b_deps_v*D_epsv
          D_epsp_b=epsp_b-epsp_bn
          sig_0=sig_0+d_sig_0_d_epsp_b*D_epsp_b
          epsv=epsv1

c Figure 7, hydrostatic stress as a function of the logarithmic volumetric strain
c Figure 8, void volume fraction as a function of the logarithmic volumetric strain
            !output data into a file as follow:
              !epsv       = volumetric strain
              !ph = realation hidrostatic stress to yield stress
              !f         = void volume fraction
              !epsp_b    = equivalent plastic strain
            write(1,*) epsv, ph, f, epsp_b
            goto 20
        end if
        close(1)

c=======================================================================
c        Hydrostatic tension
c=======================================================================

      end program test_uniax_tens_ht