!  File profile_functions.f contains
!    FUNCTION pcurr
!    FUNCTION piota
!    FUNCTION pmass
!  (JDH 2010-03-30)
!******************************************************************************

      FUNCTION pcurr (xx)
!  Function to compute the current profile

!    Variables declared in vmec_input:
!  ac               array (0:20) of coefficients
!  ac_aux_s         Auxiliary array s, s-values used for splines
!  ac_aux_f         Auxiliary array f, function-values used for splines
!  bloat            used to expand the current profile
!  pcurr_type       character, specifies the parameterization of the profile
!                     | - X for parametrization of I-prime(s), _ for I(s)
!    gauss_trunc      X    Truncated Gaussian - I-prime
!    two_power        X    Two powers - ac(0) * (1 - s ** ac(1)) ** ac(2)
!    two_power_gs     X    Two powers with gaussian peaks -
!                          ac(0) * ((1 - s ** ac(1)) ** ac(2))*(1 + Sum[ac(i)*Exp(-(s - ac(i+1))/ac(i+2)) ** 2])
!    sum_atan         _    sum of arctangents
!    power_series_I   _    Power series for I(s) (NOT default)
!    Akima_spline_Ip  X    Akima spline for I-prime(s)
!    Akima_spline_I   _    Akima spline for I(s)
!    cubic_spline_Ip  X    cubic spline for I-prime(s)
!    cubic_spline_I   _    cubic spline for I(s)
!    pedestal         _    Pedestal profile
!    rational         _    Rational function (ratio of polynomials)
!    line_segment_Ip  X    Line segments for I-prime(s)
!    line_segment_I   _    Line segments for I(s)
!    power_series     X    Power Series for I-prime(s) (Default)

!    Local Variables
!  i                integer counter
!  ioff             offset for ac array. Should be zero
!  iflag            error flag for spline call
!  xx               real argument
!  x                constrained to be between 0 and 1
!  xp               variable for Gauss_legendre quadrature
!  pcurr_type_lc    character, pcurr_type -> lower case
!  gli              index for Gauss-Legendre quadrature loop
!  gln              order of Gauss-Legendre quadrature
!  glx              array of abscissa values for Gauss-Legendre quadrature
!  glw              array of wieghts for Gauss-Legendre quadrature

!  Note that the profile that is parameterized is often I-prime, whereas
!  I(x) (= Integral_from_0_to_x I-prime(s) ds) is the function that pcurr
!  returns. For the default case of a power series, the integral can be
!  computed analytically. For other cases, a numerical quadrature is done,
!  using a 10-point Gauss-Legendre quadrature.
      USE stel_kinds
      USE stel_constants, ONLY: zero, one, pi
      USE vmec_input, ONLY: ac, bloat, pcurr_type, ac_aux_s, ac_aux_f
      USE line_segment
      USE functions
      IMPLICIT NONE
! ac assumed to be dimensioned (0:n), with n >= 20
!-----------------------------------------------
      INTEGER     :: i, ioff, iflag
      REAL(rprec) :: xx, pcurr, x, xp, temp_num, temp_denom
      CHARACTER(len=20) :: pcurr_type_lc

      INTEGER, PARAMETER          :: gln = 10
      INTEGER                     :: gli
      REAL(rprec), DIMENSION(gln), PARAMETER :: glx = (/                       &
     &   0.01304673574141414, 0.06746831665550774, 0.1602952158504878,         &
     &   0.2833023029353764, 0.4255628305091844, 0.5744371694908156,           &
     &   0.7166976970646236, 0.8397047841495122, 0.9325316833444923,           &
     &   0.9869532642585859 /)
      REAL(rprec), DIMENSION(gln), PARAMETER :: glw = (/                       &
     &   0.03333567215434407, 0.0747256745752903, 0.1095431812579910,          &
     &   0.1346333596549982, 0.1477621123573764, 0.1477621123573764,           &
     &   0.1346333596549982, 0.1095431812579910, 0.0747256745752903,           &
     &   0.03333567215434407 /)
      REAL(rprec) :: g1,g2,g3,g4,a8,a12

!-----------------------------------------------
!
!     NOTE:  AC COEFFICIENTS OBTAINED IN THREED1 FILE
!            BY MATCHING TO <JTOR> * dV/dPHI ~ SUM[x^(i+1) * ac(i)/(i+1)], i=0...UBOUND(ac)
!
!  Start of executable code

      x = MIN (ABS(xx * bloat), one)
      ioff = LBOUND(ac,1)            ! Expected to be zero.

      pcurr = 0

!  Convert to Lower Case, to avoid typo issues
      pcurr_type_lc = pcurr_type
      CALL tolower(pcurr_type_lc)
      SELECT CASE(TRIM(pcurr_type_lc))

      CASE ('gauss_trunc')
!  Truncated Gaussian
!  I-prime(s) = ac(0) * (exp(-(s/ac(1))**2) - exp(-(1/ac(1))**2)
!  Gauss-Legendre Quadrature to get I(s)
         DO gli = 1,gln
            xp = x * glx(gli)
            pcurr = pcurr + glw(gli) * ac(0) * (exp(-(xp / ac(1)) ** 2)        &
     &         - exp(-(1 / ac(1)) ** 2))
         END DO
         pcurr = pcurr * x     ! correct for x interval

      CASE ('two_power')
!  Two power profile
!  I-prime(s) = [1 - s**ac(0)]**ac(1)            !! Old as of 2010-05-26
!  I-prime(s) = ac(0) * [1 - s**ac(1)]**ac(2)    !! Current as of 2010-05-26
!  Gauss-Legendre Quadrature to get I(s)
         !DO gli = 1,gln
         !   xp = x * glx(gli)
         !   pcurr = pcurr + glw(gli) * two_power(xp, ac)
         !END DO
         !pcurr = pcurr * x     ! correct for x interval
         DO gli = 1,gln
            xp = x * glx(gli)
            pcurr = pcurr + glw(gli) * ac(0) * ((1-xp**ac(1))**ac(2))
         END DO
         pcurr = pcurr * x     ! correct for x interval

!      CASE ('two_power_gs')
!!  Two power with Gaussian peak profile
!!  I-prime(s) = ac(0) * [1 - s**ac(1)]**ac(2) * (1 + Sum[ac(i)*Exp(-(s - ac(i+1))/ac(i+2)) ** 2])
!!  Gauss-Legendre Quadrature to get I(s)
!         DO gli = 1,gln
!            xp = x * glx(gli)
!            pcurr = pcurr + glw(gli) * two_power_gs(xp, ac)
!         END DO
!         pcurr = pcurr * x     ! correct for x interval

      CASE('sum_atan')
!  I(s)  - not I-prime(s)
!       pcurr = ac(0) +                                                         &
!     &         ac(1) * (2/pi) * atan(ac(2)*x**ac(3)/(1-x)**ac(4)) +            &
!     &         ac(5) * (2/pi) * atan(ac(6)*x**ac(7)/(1-x)**ac(8)) +            &
!     &         ac(9) * (2/pi) * atan(ac(10)*x**ac(11)/(1-x)**ac(12)) +         &
!     &         ac(13) * (2/pi) * atan(ac(14)*x**ac(15)/(1-x)**ac(16)) +        &
!     &         ac(17) * (2/pi) * atan(ac(18)*x**ac(19)/(1-x)**ac(20))
      IF (x .ge. one) THEN
         pcurr = ac(0) + ac(1) + ac(5) + ac(9) + ac(13) + ac(17)
      ELSE
          pcurr = ac(0) +                                                      &
     &       (2/pi) * (ac(1) * atan(ac(2)*x**ac(3)/(1-x)**ac(4)) +             &
     &                 ac(5) * atan(ac(6)*x**ac(7)/(1-x)**ac(8)) +             &
     &                 ac(9) * atan(ac(10)*x**ac(11)/(1-x)**ac(12)) +          &
     &                 ac(13) * atan(ac(14)*x**ac(15)/(1-x)**ac(16)) +         &
     &                 ac(17) * atan(ac(18)*x**ac(19)/(1-x)**ac(20)))
      ENDIF

      CASE('power_series_I','power_series_i') ! former ipcurr=3
!  I(s)  - not I-prime(s)
!  I(s) = Sum(i,0,-)[ac(i) * s ** (i + 1)]
!  Note that coefficient interpretation here is different from other
!    polynomial parameterizations, where the terms are a_(i) * s ** i
!  Note that I(0) = 0.
       DO i = UBOUND(ac,1), ioff, -1
        pcurr = (pcurr + ac(i))*x
       END DO

      CASE('Akima_spline_I','akima_spline_i') ! former ipcurr=11
!  I(s) with Akima splines
!  Akima-spline for current profile
!        i = minloc(scugrid(2:ndatafmax),dim=1)  ! this is where zeros are again
        i = minloc(ac_aux_s(2:),dim=1)  ! this is where zeros are again
        IF (i < 4) STOP 'pcurr: check s-grid for curr-grid values!'
!        call spline_akima(x,pcurr,scugrid,cugrid,i,iflag)
        CALL spline_akima(x,pcurr,ac_aux_s,ac_aux_f,i,iflag)
        IF(iflag < 0)                                                          &
     &       STOP 'pcurr: outside value from spline_akima requested'

      CASE('Akima_spline_Ip','akima_spline_ip') ! former ipcurr=12
!  I(s) from I-prime(s)-values
!  uses an integrated Akima-spline to deliver the values of the toroidal current
!        i = minloc(scdgrid(2:ndatafmax),dim=1)  ! this is where zeros are again
        i = minloc(ac_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4)STOP 'pcurr: check s-grid for curr.dens.-grid values!'
!        call spline_akima_int(x,pcurr,scdgrid,cdgrid,i,iflag)
        CALL spline_akima_int(x,pcurr,ac_aux_s,ac_aux_f,i,iflag)
        IF (iflag < 0) THEN
             WRITE(6,*)"x = ", x
             STOP 'pcurr: outside value from spline_akima_int requested'
        ENDIF
!  Note that spline_akima_int integrates with ac_aux_s(1) as the lower limit.
!  Assumption here is that lower limit is s = 0. Check this assumption.
        IF (ABS(ac_aux_s(1)) .gt. 0.0001) THEN
           WRITE(*,*) ' Error in profile_functions, Akima_spline_Ip'
           WRITE(*,*) ' ABS(ac_aux_s(1)) .gt. 0.0001'
           WRITE(*,*) ' Fix This. Stopping'
           STOP
        ENDIF

      CASE('cubic_spline_I','cubic_spline_i') ! former ipcurr=13
!  I(s) with Cubic splines
!  Cubic-spline for current profile
!        i = minloc(scugrid(2:ndatafmax),dim=1)  ! this is where zeros are again
        i = minloc(ac_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'pcurr: check s-grid for curr-grid values!'
!        call spline_cubic(x,pcurr,scugrid,cugrid,i,iflag)
        CALL spline_cubic(x,pcurr,ac_aux_s,ac_aux_f,i,iflag)
        IF (iflag < 0) THEN
          IF(iflag == -1) THEN
            STOP'pcurr: outside value from spline_cubic requested'
          ELSEIF(iflag == -2) THEN
            STOP 'pcurr: identical scugrid-values in spline_cubic'
          ELSE
            STOP 'pcurr: unknown error from spline_cubic'
          ENDIF
        ENDIF

      CASE('cubic_spline_Ip','cubic_spline_ip') ! former ipcurr=14
!  I(s) from I-prime(s)-values
!  uses an integrated Cubic-spline to deliver the values of the toroidal current
!        i = minloc(scdgrid(2:ndatafmax),dim=1)  ! this is where zeros are again
        i = minloc(ac_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'pcurr: check s-grid for curr.dens.-grid values!'
!        call spline_cubic_int(x,pcurr,scdgrid,cdgrid,i,iflag)
        CALL spline_cubic_int(x,pcurr,ac_aux_s,ac_aux_f,i,iflag)
        IF (iflag < 0)THEN
          IF (iflag == -1) THEN
            STOP'pcurr: outside value from spline_cubic_int requested'
          ELSEIF (iflag == -2) THEN
            STOP 'pcurr: identical scdgrid-values in spline_cubic_int'
          ELSE
            STOP 'pcurr: unknown error from spline_cubic_int'
          ENDIF
        ENDIF
!  Note that spline_cubic_int integrates with ac_aux_s(1) as the lower limit.
!  Assumption here is that lower limit is s = 0. Check this assumption.
        IF (ABS(ac_aux_s(1)) .gt. 0.0001) THEN
           WRITE(*,*) ' Error in profile_functions, cubic_spline_Ip'
           WRITE(*,*) ' ABS(ac_aux_s(1)) .gt. 0.0001'
           WRITE(*,*) ' Fix This. Stopping'
           STOP
        ENDIF

      CASE ('pedestal')
!  Parameterization for I(s)
!  Added by SPH 2010-05-26
         DO i = 7, ioff, -1
            pcurr = x*pcurr + ac(i)/(i-ioff+1)
         END DO
         pcurr = x*pcurr

         i=8
         IF (ac(i+3) .le. 0._dp ) THEN
            ac(i:i+4) = 0
            ac(i+3) = 1.0e30_dp
         ELSE
            ac(i+4) = 1.0_dp/
     1     (TANH(2*ac(i+2)/ac(i+3))-TANH(2*(ac(i+2)-1)/ac(i+3)))
         END IF

         a8 =MAX(ac(i+8),0.01_dp)
         a12=MAX(ac(i+12),0.01_dp)

         g1= (x-ac(i+7))/a8
         g3= (-ac(i+7))/a8
         g2= (x-ac(i+11))/a12
         g4= (-ac(i+11))/a12
         pcurr = pcurr + ac(i+4) * ac(i+0) *
     1 ( TANH( 2*ac(i+2)/ac(i+3) )
     2  -TANH( 2*(ac(i+2)-SQRT(x))/ac(i+3) ) )
     3  +ac(i+5)*( TANH(g1) - TANH(g3) )
     4  +ac(i+9)*( TANH(g2) - TANH(g4) )

      CASE('rational') !
!  I(s)  - not I-prime(s). No need for Gaussian quadrature.
!  Ratio of polynomials.
!  Numerator coefficients: ac(LBOUND) - ac(9)
!  Denominator coefficients: ac(10) - ac(UBOUND(ac,1))
         temp_num = zero
         temp_denom = zero
         DO i = 9, ioff, -1
            temp_num = x * temp_num + ac(i)
         END DO
         DO i = UBOUND(ac,1), 10, -1
            temp_denom = x * temp_denom + ac(i)
         END DO
         IF  (temp_denom .ne. zero) THEN
            pcurr = temp_num / temp_denom
         ELSE
            pcurr = HUGE(pcurr)
         ENDIF

      CASE('line_segment_Ip', 'line_segment_ip')
!!  I(s) from I-prime(s)-values. Integrated line segments to determine the plasma
!!  current.
         i = minloc(ac_aux_s(2:),dim=1)
         CALL line_seg_int(x,pcurr,ac_aux_s,ac_aux_f,i)

      CASE('line_segment_I', 'line_segment_i')
!!  I(s) values. Linearly interpolated line segments to determine the plasma
!!  current.
         i = minloc(ac_aux_s(2:),dim=1)
         CALL line_seg(x,pcurr,ac_aux_s,ac_aux_f,i)

      CASE DEFAULT
!  Power series
!  I-prime(s) = Sum(i,0,-)[ac(i) * s ** i]
!  Analytic integration to get I(s)
         DO i = UBOUND(ac,1), ioff, -1
            pcurr = x*pcurr + ac(i)/(i-ioff+1)
         END DO
         IF (TRIM(pcurr_type_lc) .ne. 'power_series') THEN
            WRITE(*,*) 'Unrecognized pcurr_type:', pcurr_type
            WRITE(*,*) ' *** CHECK YOUR INPUT ***'
            WRITE(*,*) 'Changing pcurr_type from ''',                          &
     &         TRIM(pcurr_type), '''to ''power_series''.'
            pcurr_type = 'power_series'
         END IF
         pcurr = x*pcurr
      END SELECT

      END FUNCTION pcurr

!******************************************************************************

      FUNCTION piota (x)
!  Function to compute the iota/q profile.

!    Variables declared in vmec_input:
!  ai               array (0:20) of coefficients
!  ai_aux_s         Auxiliary array s, s-values used for splines
!  ai_aux_f         Auxiliary array f, function-values used for splines
!  piota_type       character, specifies the parameterization of the profile
!    sum_atan        Sum of atan functions plus offset.
!    Akima_spline      Akima spline
!    cubic_spline      cubic spline
!    rational          rational (ratio of polynomials)
!    nice_quadratic    quadratic with rerranged coefficients.
!    line_segment      Linearly interpolated line segments
!    power_series      Power Series (Default)
!  lRFP             logical - Reversed Field Pinch
!    True -  ai parameterization specifies q-profile (= 1 / iota)
!    False - ai parameterization is for iota-profile

!    Local Variables
!  i                integer counter
!  iflag            error flag for spline call
!  x                real argument
!  x                constrained to be between 0 and 1
!  piota_type_lc    character, piota_type -> lower case

      USE stel_kinds
      USE stel_constants, ONLY: zero, one, pi
      USE vmec_input, ONLY: ai, piota_type, ai_aux_s, ai_aux_f, lRFP
      USE line_segment
      IMPLICIT NONE
! ai assumed to be dimensioned (0:n), with n >= 20
!-----------------------------------------------
      INTEGER     :: i, iflag, ioff
      REAL(rprec) :: x, piota, temp_num, temp_denom
      CHARACTER(len=20) :: piota_type_lc
!-----------------------------------------------
      piota = 0
      ioff = LBOUND(ai,1)            ! Expected to be zero.

!  Convert to Lower Case, to avoid typo issues
      piota_type_lc = piota_type
      CALL tolower(piota_type_lc)
      SELECT CASE(TRIM(piota_type_lc))

      CASE('sum_atan')
!  Sum atan functions mapped to  [0:1], with an ai(0) offset
!       piota = ai(0) +                                                         &
!     &         ai(1) * (2/pi) * atan(ai(2)*x**ai(3)/(1-x)**ai(4)) +            &
!     &         ai(5) * (2/pi) * atan(ai(6)*x**ai(7)/(1-x)**ai(8)) +            &
!     &         ai(9) * (2/pi) * atan(ai(10)*x**ai(11)/(1-x)**ai(12)) +         &
!     &         ai(13) * (2/pi) * atan(ai(14)*x**ai(15)/(1-x)**ai(16)) +        &
!     &         ai(17) * (2/pi) * atan(ai(18)*x**ai(19)/(1-x)**ai(20))
      IF (x .ge. one) THEN
         piota = ai(0) + ai(1) + ai(5) + ai(9) + ai(13) + ai(17)
      ELSE
          piota = ai(0) +                                                      &
     &       (2/pi) * (ai(1) * atan(ai(2)*x**ai(3)/(1-x)**ai(4)) +             &
     &                 ai(5) * atan(ai(6)*x**ai(7)/(1-x)**ai(8)) +             &
     &                 ai(9) * atan(ai(10)*x**ai(11)/(1-x)**ai(12)) +          &
     &                 ai(13) * atan(ai(14)*x**ai(15)/(1-x)**ai(16)) +         &
     &                 ai(17) * atan(ai(18)*x**ai(19)/(1-x)**ai(20)))
      ENDIF

      CASE('Akima_spline','akima_spline') ! former ipiota=11
! Akima-spline   (iogrid + siogrid)
!        i = minloc(siogrid(2:ndatafmax),dim=1)  ! this is where zeros are again
        i = minloc(ai_aux_s(2:),dim=1)  ! this is where zeros are again
        if(i < 4) stop 'piota: check s-grid for iota-grid values!'
!        call spline_akima(x,piota,siogrid,iogrid,i,iflag)
        call spline_akima(x,piota,ai_aux_s,ai_aux_f,i,iflag)
        if(iflag < 0)                                                          &
     &       stop'piota: outside value from spline_akima requested'

      CASE('cubic_spline') ! former ipiota=13
! cubic-spline   (iogrid + siogrid)
!        i = minloc(siogrid(2:ndatafmax),dim=1)  ! this is where zeros are again
        i = minloc(ai_aux_s(2:),dim=1)  ! this is where zeros are again
        if(i < 4) stop 'piota: check s-grid for iota-grid values!'
!        call spline_cubic(x,piota,siogrid,iogrid,i,iflag)
        call spline_cubic(x,piota,ai_aux_s,ai_aux_f,i,iflag)
        if(iflag < 0)then
          if(iflag == -1) then
            stop'piota: outside value from spline_cubic requested'
          elseif(iflag == -2) then
            stop'piota: identical siogrid-values in spline_cubic'
          else
            stop 'piota: unknown error from spline_cubic'
          endif
        endif

      CASE('rational') !
!  Ratio of polynomials.
!  Numerator coefficients: ai(LBOUND) - ai(9)
!  Denominator coefficients: ai(10) - ai(UBOUND)
         temp_num = zero
         temp_denom = zero
         DO i = 9, ioff, -1
            temp_num = x * temp_num + ai(i)
         END DO
         DO i = UBOUND(ai,1), 10, -1
            temp_denom = x * temp_denom + ai(i)
         END DO
         IF  (temp_denom .ne. zero) THEN
            piota = temp_num / temp_denom
         ELSE
            piota = HUGE(piota)
         ENDIF

      CASE('nice_quadratic') !
!  Quadratic with slightly rearranged coefficients.
!    iota(s) = a0(1-s) + a1 s + 4 a2 s (1 - s)
!       a0 is the iota value at s = 0
!       a1 is the iota value at s = 1
!       a2 is the shift of iota(1/2) from the straight line value
!          (Thus, a2 = 0 gives a linear iota profile.
         piota = ai(0) * (one - x) + ai(1) * x + 4 * ai(2) *                   &
     &      x * (one - x)

      CASE('line_segment')
!!  Linearly interpolated line segments to determine the iotabar profile.
         i = minloc(ai_aux_s(2:),dim=1)
         CALL line_seg(x,piota,ai_aux_s,ai_aux_f,i)

      CASE default
!  Power Series is the default
         DO i = UBOUND(ai,1), LBOUND(ai,1), -1
            piota = x*piota + ai(i)
         END DO
         IF (TRIM(piota_type_lc) .ne. 'power_series') THEN
            WRITE(*,*) 'Unrecognized piota_type:', piota_type
            WRITE(*,*) ' *** CHECK YOUR INPUT ***'
            WRITE(*,*) 'Changing piota_type from ''',                          &
     &         TRIM(piota_type), '''to ''power_series''.'
            piota_type = 'power_series'
         END IF
      END SELECT

      IF (lRFP) THEN
!     RFP/TOKAMAK: ai are coefficients of q_safety, NOT iota
         IF (piota .ne. zero) THEN
            piota = one / piota
         ELSE
            piota = HUGE(piota)
         END IF
      END IF

      END FUNCTION piota

!******************************************************************************

      FUNCTION pmass (xx)
!  Function to compute the mass (pressure) profile

!    Variables declared in vmec_input:
!  am               array (0:20) of coefficients
!  am_aux_s         Auxiliary array s, s-values used for splines
!  am_aux_f         Auxiliary array f, function-values used for splines
!  bloat            used to expand the profile
!  pmass_type       character, specifies the parameterization of the profile
!    gauss_trunc       Truncated Gaussian
!    two_power         am(0) * [1 - s**am(1)]**am(2)
!    two_power_gs      am(0) * [1 - s**am(1)]**am(2)*
!                      (1 + Sum[am(i)*Exp(-((x - am(i+1))/am(i+2))**2)])
!    two_Lorentz       two Lorentz-type functions, mapped to [0:1]
!    Akima_spline      Akima-spline (magrid[-> am_aux_f] + smagrid[-> am_aux_s])
!    cubic_spline      Cubic-spline (magrid[-> am_aux_f] + smagrid[-> am_aux_s])
!    pedestal          Pedestal profile
!    rational          rational (ratio of polynomials)
!    line_segment      Linearly interpolated line segments
!    power_series      Power Series (Default)

!    Local Variables
!  i                integer counter
!  iflag            error flag for spline call
!  xx               real argument
!  x                constrained to be between 0 and 1
!  pmass_type_lc    character, pmass_type -> lower case

      USE stel_kinds
      USE stel_constants, ONLY: zero, one
      USE vmec_input, ONLY: am, bloat, pres_scale, pmass_type,                 &
     &   am_aux_s, am_aux_f
!  am is assumed to be dimensioned starting at zero.
      USE vparams, ONLY: mu0
      USE line_segment
      USE functions
      IMPLICIT NONE
!-----------------------------------------------
      INTEGER     :: i, iflag, ioff
      REAL(rprec) :: xx, pmass, x, temp_num, temp_denom
      CHARACTER(len=20) :: pmass_type_lc
!-----------------------------------------------
!     NOTE: On entry, am is in pascals. pmass internal units are mu0*pascals (B**2 units)
      x = MIN (ABS(xx * bloat), 1._dp)

      pmass = 0
      ioff = LBOUND(am,1)            ! Expected to be zero.

!  Convert to Lower Case, to avoid typo issues
      pmass_type_lc = pmass_type
      CALL tolower(pmass_type_lc)
      SELECT CASE(TRIM(pmass_type_lc))

      CASE ('gauss_trunc')
!  Truncated Gaussian
!  p(s) = am(0) * (exp(-(s/am(1))**2) - exp(-(1/am(1))**2)
!  Above Old as of 2010-05-26
!  Below current as of 2010-05-26
!  p(s) = (am(0) / c) * (exp(-(s/am(1))**2) - exp(-(1/am(1))**2)
!  c =  (1 - exp(-(1/am(1))**2)     ! so that p(0) = am(0).
         pmass = (am(0)/(one - exp(-(one / am(1)) ** 2))) *                    &
     &      (exp(-(x / am(1)) ** 2) - exp(-(one / am(1)) ** 2))

      CASE ('two_power')
!  Two power profile
!  p(s) = [1 - s**am(0)]**am(1)          !! Old as of 2010-05-26
!  p(s) = am(0) * [1 - s**am(1)]**am(2)  !! Current as of 2010-05-26
         pmass = am(0) * ((one-x**am(1))**am(2))
         !pmass = two_power(x, am)

!      CASE ('two_power_gs')
!!  Two power profile with guassian peaks.
!         pmass = two_power_gs(x, am)

      CASE ('two_Lorentz','two_lorentz') ! former ipmass=1
       pmass = am(0)*(am(1)*(one/(one+(  x/am(2)**2)**am(3))**am(4)            &
     &                      -one/(one+(one/am(2)**2)**am(3))**am(4))/          &
     &                  (one-one/(one+(one/am(2)**2)**am(3))**am(4))+          &
     &          (one-am(1))*(one/(one+(  x/am(5)**2)**am(6))**am(7)            &
     &                      -one/(one+(one/am(5)**2)**am(6))**am(7))/          &
     &                  (one-one/(one+(one/am(5)**2)**am(6))**am(7)))          &

      CASE ('Akima_spline','akima_spline') ! former ipmass=11
!        i = minloc(smagrid(2:ndatafmax),dim=1)  ! this is where zeros are again
        i = minloc(am_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'pmass: check s-grid for mass-grid values!'
!        call spline_akima(x,pmass,smagrid,magrid,i,iflag)
        CALL spline_akima(x,pmass,am_aux_s,am_aux_f,i,iflag)
        IF(iflag < 0)                                                          &
     &       STOP 'pmass: outside value from spline_akima requested'

      CASE ('cubic_spline') ! former ipmass=13
!        i = minloc(smagrid(2:ndatafmax),dim=1)  ! this is where zeros are again
        i = minloc(am_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'pmass: check s-grid for mass-grid values!'
!        call spline_cubic(x,pmass,smagrid,magrid,i,iflag)
        CALL spline_cubic(x,pmass,am_aux_s,am_aux_f,i,iflag)
        IF (iflag < 0) THEN
          IF (iflag == -1) THEN
            STOP'pmass: outside value from spline_cubic requested'
          ELSEIF (iflag == -2) THEN
!            STOP'pmass: identical smagrid-values in spline_cubic'
            STOP'pmass: identical am_aux_s-values in spline_cubic'
          ELSE
            STOP 'pmass: unknown error from spline_cubic'
          ENDIF
        ENDIF

      CASE ('pedestal')    !PMV Texas group
!  Added by SPH 2010-05-26

         DO i = 15, LBOUND(am,1), -1
            pmass = x*pmass + am(i)
         END DO

         i = 16
         IF (am(i+3) .le. 0._dp ) THEN
            am(i:i+4) = 0
            am(i+3) = 1.0e30_dp
         ELSE
            am(i+4) = 1.0_dp/
     1     (TANH(2*am(i+2)/am(i+3))-TANH(2*(am(i+2)-1)/am(i+3)))
         END IF

         pmass = pmass + am(i+4) * am(i+1) *
     1 ( TANH( 2*(am(i+2)-SQRT(x))/am(i+3) )
     2  -TANH( 2*(am(i+2)-1._dp)  /am(i+3) ) )

      CASE('rational') !
!  Ratio of polynomials.
!  Numerator coefficients: am(LBOUND) - am(9)
!  Denominator coefficients: am(10) - am(UBOUND)
         temp_num = zero
         temp_denom = zero
         DO i = 9, ioff, -1
            temp_num = x * temp_num + am(i)
         END DO
         DO i = UBOUND(am,1), 10, -1
            temp_denom = x * temp_denom + am(i)
         END DO
         IF  (temp_denom .ne. zero) THEN
            pmass = temp_num / temp_denom
         ELSE
            pmass = HUGE(pmass)
         ENDIF

      CASE('line_segment')
!!  Linearly interpolated line segments to determine the pressure profile.
         i = minloc(am_aux_s(2:),dim=1)
         CALL line_seg(x,pmass,am_aux_s,am_aux_f,i)

      CASE DEFAULT
         DO i = UBOUND(am,1), LBOUND(am,1), -1
            pmass = x*pmass + am(i)
         END DO
         IF (TRIM(pmass_type_lc) .ne. 'power_series') THEN
            WRITE(*,*) 'Unrecognized pmass_type:', pmass_type
            WRITE(*,*) ' *** CHECK YOUR INPUT ***'
            WRITE(*,*) 'Changing pmass_type from ''',                          &
     &         TRIM(pmass_type), '''to ''power_series''.'
            pmass_type = 'power_series'
         END IF
      END SELECT

      pmass = mu0*pres_scale*pmass

      END FUNCTION pmass

      FUNCTION photp (xx)
      USE stel_kinds
      USE stel_constants, ONLY: zero, one
      USE vmec_input, ONLY: ah, bloat, ph_type, ah_aux_s, ah_aux_f
      USE line_segment
      IMPLICIT NONE
C-----------------------------------------------
      INTEGER     :: i, iflag, ioff
      REAL(rprec) :: xx, photp, x, temp_num, temp_denom
      CHARACTER(len=20) :: ph_type_lc
C-----------------------------------------------
!     ANIMEC
!     NOTE: On entry, ah is dimensionless
!     HOT PARTICLE PRESSURE (RATIO TO ISOTROPIC PRESSURE)

      x = MIN (ABS(xx * bloat), 1._dp)

      photp = 0
      ioff = LBOUND(ah,1)            ! Expected to be zero.

!  Convert to Lower Case, to avoid typo issues
      ph_type_lc = ph_type
      CALL tolower(ph_type_lc)
      SELECT CASE(TRIM(ph_type_lc))

      CASE ('gauss_trunc')
         photp = (ah(0)/(one - exp(-(one / ah(1)) ** 2))) *                    &
     &      (exp(-(x / ah(1)) ** 2) - exp(-(one / ah(1)) ** 2))
      CASE ('two_power')
         photp = ah(0) * ((one-x**ah(1))**ah(2))

      CASE ('two_Lorentz','two_lorentz')
       photp = ah(0)*(ah(1)*(one/(one+(  x/ah(2)**2)**ah(3))**ah(4)            &
     &                      -one/(one+(one/ah(2)**2)**ah(3))**ah(4))/          &
     &                  (one-one/(one+(one/ah(2)**2)**ah(3))**ah(4))+          &
     &          (one-ah(1))*(one/(one+(  x/ah(5)**2)**ah(6))**ah(7)            &
     &                      -one/(one+(one/ah(5)**2)**ah(6))**ah(7))/          &
     &                  (one-one/(one+(one/ah(5)**2)**ah(6))**ah(7)))

      CASE ('Akima_spline','akima_spline')
        i = minloc(ah_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'photp: check s-grid for ah-grid values!'
        CALL spline_akima(x,photp,ah_aux_s,ah_aux_f,i,iflag)
        IF(iflag < 0)                                                          &
     &       STOP 'photp: outside value from spline_akima requested'

      CASE ('cubic_spline')
        i = minloc(ah_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'photp: check s-grid for mass-grid values!'
        CALL spline_cubic(x,photp,ah_aux_s,ah_aux_f,i,iflag)
        IF (iflag < 0) THEN
          IF (iflag == -1) THEN
            STOP'photp: outside value from spline_cubic requested'
          ELSEIF (iflag == -2) THEN
            STOP'photp: identical ah_aux_s-values in spline_cubic'
          ELSE
            STOP 'photp: unknown error from spline_cubic'
          ENDIF
        ENDIF

      CASE ('pedestal')
         DO i = 15, LBOUND(ah,1), -1
            photp = x*photp + ah(i)
         END DO
         i = 16
         IF (ah(i+3) .le. 0._dp ) THEN
            ah(i:i+4) = 0
            ah(i+3) = 1.0e30_dp
         ELSE
            ah(i+4) = 1.0_dp/
     1     (TANH(2*ah(i+2)/ah(i+3))-TANH(2*(ah(i+2)-1)/ah(i+3)))
         END IF
         photp = photp + ah(i+4) * ah(i+1) *
     1 ( TANH( 2*(ah(i+2)-SQRT(x))/ah(i+3) )
     2  -TANH( 2*(ah(i+2)-1._dp)  /ah(i+3) ) )

      CASE('rational')
         temp_num = zero
         temp_denom = zero
         DO i = 9, ioff, -1
            temp_num = x * temp_num + ah(i)
         END DO
         DO i = UBOUND(ah,1), 10, -1
            temp_denom = x * temp_denom + ah(i)
         END DO
         IF  (temp_denom .ne. zero) THEN
            photp = temp_num / temp_denom
         ELSE
            photp = HUGE(photp)
         ENDIF

      CASE('line_segment')
         i = minloc(ah_aux_s(2:),dim=1)
         CALL line_seg(x,photp,ah_aux_s,ah_aux_f,i)

      CASE DEFAULT
         DO i = UBOUND(ah,1), LBOUND(ah,1), -1
            photp = x*photp + ah(i)
         END DO
         IF (TRIM(ph_type_lc) .ne. 'power_series') THEN
            WRITE(*,*) 'Unrecognized ph_type:', ph_type
            WRITE(*,*) ' *** CHECK YOUR INPUT ***'
            WRITE(*,*) 'Changing ph_type from ''',                          &
     &         TRIM(ph_type), '''to ''power_series''.'
            ph_type = 'power_series'
         END IF
      END SELECT

      photp = photp

      END FUNCTION photp

      FUNCTION ptrat (xx)
      USE stel_kinds
      USE stel_constants, ONLY: zero, one
      USE vmec_input, ONLY: at, bloat, pt_type, at_aux_s, at_aux_f
      USE line_segment
C-----------------------------------------------
      INTEGER     :: i, iflag, ioff
      REAL(rprec) :: xx, ptrat, x, temp_num, temp_denom
      CHARACTER(len=20) :: pt_type_lc
C-----------------------------------------------
!     ANIMEC
!     NOTE: On entry, at is dimensionless
!     HOT PARTICLE T-perp/T-par
!     FLOW
!     NOTE: On entry, at is in arbitrary units
!     Temperature Profile

      x = MIN (ABS(xx * bloat), 1._dp)

      ptrat = 0
      ioff = LBOUND(at,1)            ! Expected to be zero.

!  Convert to Lower Case, to avoid typo issues
      pt_type_lc = pt_type
      CALL tolower(pt_type_lc)
      SELECT CASE(TRIM(pt_type_lc))

      CASE ('gauss_trunc')
         ptrat = (at(0)/(one - exp(-(one / at(1)) ** 2))) *                    &
     &      (exp(-(x / at(1)) ** 2) - exp(-(one / at(1)) ** 2))
      CASE ('two_power')
         ptrat = at(0) * ((one-x**at(1))**at(2))

      CASE ('two_Lorentz','two_lorentz')
       ptrat = at(0)*(at(1)*(one/(one+(  x/at(2)**2)**at(3))**at(4)            &
     &                      -one/(one+(one/at(2)**2)**at(3))**at(4))/          &
     &                  (one-one/(one+(one/at(2)**2)**at(3))**at(4))+          &
     &          (one-at(1))*(one/(one+(  x/at(5)**2)**at(6))**at(7)            &
     &                      -one/(one+(one/at(5)**2)**at(6))**at(7))/          &
     &                  (one-one/(one+(one/at(5)**2)**at(6))**at(7)))

      CASE ('Akima_spline','akima_spline')
        i = minloc(at_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'ptrat: check s-grid for ah-grid values!'
        CALL spline_akima(x,ptrat,at_aux_s,at_aux_f,i,iflag)
        IF(iflag < 0)                                                          &
     &       STOP 'ptrat: outside value from spline_akima requested'

      CASE ('cubic_spline')
        i = minloc(at_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'ptrat: check s-grid for mass-grid values!'
        CALL spline_cubic(x,ptrat,at_aux_s,at_aux_f,i,iflag)
        IF (iflag < 0) THEN
          IF (iflag == -1) THEN
            STOP'ptrat: outside value from spline_cubic requested'
          ELSEIF (iflag == -2) THEN
            STOP'ptrat: identical ah_aux_s-values in spline_cubic'
          ELSE
            STOP 'ptrat: unknown error from spline_cubic'
          ENDIF
        ENDIF

      CASE ('pedestal')
         DO i = 15, LBOUND(at,1), -1
            ptrat = x*ptrat + at(i)
         END DO
         i = 16
         IF (at(i+3) .le. 0._dp ) THEN
            at(i:i+4) = 0
            at(i+3) = 1.0e30_dp
         ELSE
            at(i+4) = 1.0_dp/
     1     (TANH(2*at(i+2)/at(i+3))-TANH(2*(at(i+2)-1)/at(i+3)))
         END IF
         ptrat = ptrat + at(i+4) * at(i+1) *
     1 ( TANH( 2*(at(i+2)-SQRT(x))/at(i+3) )
     2  -TANH( 2*(at(i+2)-1._dp)  /at(i+3) ) )

      CASE('rational')
         temp_num = zero
         temp_denom = zero
         DO i = 9, ioff, -1
            temp_num = x * temp_num + at(i)
         END DO
         DO i = UBOUND(at,1), 10, -1
            temp_denom = x * temp_denom + at(i)
         END DO
         IF  (temp_denom .ne. zero) THEN
            ptrat = temp_num / temp_denom
         ELSE
            ptrat = HUGE(ptrat)
         ENDIF

      CASE('line_segment')
         i = minloc(at_aux_s(2:),dim=1)
         CALL line_seg(x,ptrat,at_aux_s,at_aux_f,i)

      CASE DEFAULT
         DO i = UBOUND(at,1), LBOUND(at,1), -1
            ptrat = x*ptrat + at(i)
         END DO
         IF (TRIM(pt_type_lc) .ne. 'power_series') THEN
            WRITE(*,*) 'Unrecognized pt_type:', pt_type
            WRITE(*,*) ' *** CHECK YOUR INPUT ***'
            WRITE(*,*) 'Changing pt_type from ''',                          &
     &         TRIM(pt_type), '''to ''power_series''.'
            pt_type = 'power_series'
         END IF
      END SELECT

      ptrat = ptrat

      END FUNCTION ptrat

      FUNCTION protf (xx)
      USE stel_kinds
      USE stel_constants, ONLY: zero, one
      USE vmec_input, ONLY: ah, bloat, ph_type, ah_aux_s, ah_aux_f
      USE line_segment
C-----------------------------------------------
      INTEGER     :: i, iflag, ioff
      REAL(rprec) :: xx, protf, x, temp_num, temp_denom
      CHARACTER(len=20) :: ph_type_lc
C-----------------------------------------------
!     FLOW
!     NOTE: On entry, ah is in arbitrary units
!     TOROIDAL ROTATIONAL FREQUENCY

      x = MIN (ABS(xx * bloat), 1._dp)

      protf = 0
      ioff = LBOUND(ah,1)            ! Expected to be zero.

!  Convert to Lower Case, to avoid typo issues
      ph_type_lc = ph_type
      CALL tolower(ph_type_lc)
      SELECT CASE(TRIM(ph_type_lc))

      CASE ('gauss_trunc')
         protf = (ah(0)/(one - exp(-(one / ah(1)) ** 2))) *                    &
     &      (exp(-(x / ah(1)) ** 2) - exp(-(one / ah(1)) ** 2))
      CASE ('two_power')
         protf = ah(0) * ((one-x**ah(1))**ah(2))

      CASE ('two_Lorentz','two_lorentz')
       protf = ah(0)*(ah(1)*(one/(one+(  x/ah(2)**2)**ah(3))**ah(4)            &
     &                      -one/(one+(one/ah(2)**2)**ah(3))**ah(4))/          &
     &                  (one-one/(one+(one/ah(2)**2)**ah(3))**ah(4))+          &
     &          (one-ah(1))*(one/(one+(  x/ah(5)**2)**ah(6))**ah(7)            &
     &                      -one/(one+(one/ah(5)**2)**ah(6))**ah(7))/          &
     &                  (one-one/(one+(one/ah(5)**2)**ah(6))**ah(7)))

      CASE ('Akima_spline','akima_spline')
        i = minloc(ah_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'protf: check s-grid for ah-grid values!'
        CALL spline_akima(x,protf,ah_aux_s,ah_aux_f,i,iflag)
        IF(iflag < 0)                                                          &
     &       STOP 'protf: outside value from spline_akima requested'

      CASE ('cubic_spline')
        i = minloc(ah_aux_s(2:),dim=1)  ! this is where zeros are again
        IF(i < 4) STOP 'protf: check s-grid for mass-grid values!'
        CALL spline_cubic(x,protf,ah_aux_s,ah_aux_f,i,iflag)
        IF (iflag < 0) THEN
          IF (iflag == -1) THEN
            STOP'protf: outside value from spline_cubic requested'
          ELSEIF (iflag == -2) THEN
            STOP'protf: identical ah_aux_s-values in spline_cubic'
          ELSE
            STOP 'protf: unknown error from spline_cubic'
          ENDIF
        ENDIF

      CASE ('pedestal')
         DO i = 15, LBOUND(ah,1), -1
            protf = x*protf + ah(i)
         END DO
         i = 16
         IF (ah(i+3) .le. 0._dp ) THEN
            ah(i:i+4) = 0
            ah(i+3) = 1.0e30_dp
         ELSE
            ah(i+4) = 1.0_dp/
     1     (TANH(2*ah(i+2)/ah(i+3))-TANH(2*(ah(i+2)-1)/ah(i+3)))
         END IF
         protf = protf + ah(i+4) * ah(i+1) *
     1 ( TANH( 2*(ah(i+2)-SQRT(x))/ah(i+3) )
     2  -TANH( 2*(ah(i+2)-1._dp)  /ah(i+3) ) )

      CASE('rational')
         temp_num = zero
         temp_denom = zero
         DO i = 9, ioff, -1
            temp_num = x * temp_num + ah(i)
         END DO
         DO i = UBOUND(ah,1), 10, -1
            temp_denom = x * temp_denom + ah(i)
         END DO
         IF  (temp_denom .ne. zero) THEN
            protf = temp_num / temp_denom
         ELSE
            protf = HUGE(protf)
         ENDIF

      CASE('line_segment')
         i = minloc(ah_aux_s(2:),dim=1)
         CALL line_seg(x,protf,ah_aux_s,ah_aux_f,i)

      CASE DEFAULT
         DO i = UBOUND(ah,1), LBOUND(ah,1), -1
            protf = x*protf + ah(i)
         END DO
         IF (TRIM(ph_type_lc) .ne. 'power_series') THEN
            WRITE(*,*) 'Unrecognized ph_type:', ph_type
            WRITE(*,*) ' *** CHECK YOUR INPUT ***'
            WRITE(*,*) 'Changing ph_type from ''',                          &
     &         TRIM(ph_type), '''to ''power_series''.'
            ph_type = 'power_series'
         END IF
      END SELECT

      protf = protf

      END FUNCTION protf
!!!!DEC$ ENDIF


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


      module e3if_diff_m
c
c----------------------------------------
c    aims to calculate the diffusive coefficient
c    matrix for interface elements
c----------------------------------------
        use e3if_param_m
c
        implicit none
c
      contains
c
        subroutine calc_stiff (prop,var,mater)
c
          type(prop_t), dimension(:), pointer, intent(inout) :: prop
          type(var_t),  dimension(:), pointer, intent(in)    :: var
          integer, intent(in) :: mater
c
          integer :: i,j
          real*8, dimension(npro) :: rmu, rlm, rlm2mu, con
          real*8, dimension(:), pointer :: u1, u2, u3
c
          call getdiff(rmu, rlm, rlm2mu, con, npro, mater)
c
c          rmu    => prop%rmu
c          rlm    => prop%rlm
c          rlm2mu => prop%rlm2mu
c          con    => prop%con
c
          u1     => var%y(2)
          u2     => var%y(3)
          u3     => var%y(4)
c
          do i = 1,nsd*nflow
            do j = 1,nsd*nflow
              prop%stiff(i,j) = zero
            enddo
          enddo
c
c.... K11
c
          prop%stiff(2, 2) = rlm2mu
          prop%stiff(3, 3) = rmu
          prop%stiff(4, 4) = rmu
          prop%stiff(5, 2) = rlm2mu * u1
          prop%stiff(5, 3) = rmu    * u2
          prop%stiff(5, 4) = rmu    * u3
          prop%stiff(5, 5) = con
c
c
c.... K12
c
          prop%stiff(2, 8) = rlm
          prop%stiff(3, 7) = rmu
          prop%stiff(5, 7) = rmu    * u2
          prop%stiff(5, 8) = rlm    * u1
c
c.... K13
c
          prop%stiff(2,14) = rlm
          prop%stiff(4,12) = rmu
          prop%stiff(5,12) = rmu    * u3
          prop%stiff(5,14) = rlm    * u1

c
c.... K21
c
          prop%stiff(7, 3) = rmu
          prop%stiff(8, 2) = rlm
          prop%stiff(10, 2) = rlm    * u2
          prop%stiff(10, 3) = rmu    * u1

c
c.... K22
c
          prop%stiff(7, 7) = rmu
          prop%stiff(8, 8) = rlm2mu
          prop%stiff(9, 9) = rmu
          prop%stiff(10, 7) = rmu    * u1
          prop%stiff(10, 8) = rlm2mu * u2
          prop%stiff(10, 9) = rmu    * u3
          prop%stiff(10,10) = con
c
c.... K23
c
          prop%stiff(8,14) = rlm
          prop%stiff(9,13) = rmu
          prop%stiff(10,13) = rmu    * u3
          prop%stiff(10,14) = rlm    * u2
c
c.... K31
c
          prop%stiff(12, 4) = rmu
          prop%stiff(14, 2) = rlm
          prop%stiff(15, 2) = rlm    * u3
          prop%stiff(15, 4) = rmu    * u1
c
c.... K32
c
          prop%stiff(13, 9) = rmu
          prop%stiff(14, 8) = rlm
          prop%stiff(15, 8) = rlm    * u3
          prop%stiff(15, 9) = rmu    * u2
c
c.... K33
c
          prop%stiff(12,12) = rmu
          prop%stiff(13,13) = rmu
          prop%stiff(14,14) = rlm2mu
          prop%stiff(15,12) = rmu    * u1
          prop%stiff(15,13) = rmu    * u2
          prop%stiff(15,14) = rlm2mu * u3
          prop%stiff(15,15) = con
c
        end subroutine calc_stiff
c
      end module e3if_diff_m


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

subroutine phenology(nfile,row,col,s,y,yfit,nlocal,startcutoff,minimum)

!  This routine extracts phenological parameters from processed data            !
!                                                                               !
!   1.  time for which the left edge has increased to the 20 % level            !
!   2.  time for which the right edge has decreased to the 20 % level           !
!   3.  length of the season                                                    !
!   4.  average of left and right minimum values (base level)                   !
!   5.  time for the peak of the season                                         !
!   6.  value for the peak                                                      !
!   7.  seasonal amplitude                                                      !
!   8.  approximate left slope                                                  !
!   9.  approximate right slope                                                 !
!  10.  large seasonal integral                                                 !
!  11.  small seasonal integral                                                 !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 1/11-2005                                                            !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: row,col,nyear,nptperyear,npt,nenvi,printflag,debugflag,win(3),nlocal
integer :: i,j,n,n1,n2,s(4*nyear+2),nfile,minposleft,minposright
integer :: maxposcenter,pos(1),maxminsum,minimum
real*4 :: dummy(11)
double precision :: wfact,y(npt),yfit(npt),minvalleft,minvalright,maxvalcenter,amplitude
double precision :: baseval,poscenter,posright20,posleft20,posright80,posleft80
double precision :: seasonlength,leftderivative,rightderivative,largeintegral,smallintegral
double precision :: valleft20,valleft80,valright20,valright80,startcutoff

common /parameters/ nyear,nptperyear,npt,nenvi,printflag,debugflag,wfact,win

n = nlocal + 2

if (minimum == 0) then       ! the position s(2) corresponds to a maximum
  n1 = 4
  n2 = n-2
else                         ! the position s(2) corresponds to a minimum
  n1 = 3
  n2 = n-3
end if

!---- Dump row, column and number of seasons on file ---------------------------
!    (n-4)/2 = number of seasons for which we have phenological metrics

write(nfile)  row,col,(n-4)/2

do i = n1,n2,2
  minvalleft = minval(yfit(s(i-2):s(i)))
  pos(1:1) = minloc(yfit(s(i-2):s(i)))
  minposleft = pos(1) + s(i-2) - 1

  minvalright = minval(yfit(s(i):s(i+2)))
  pos(1:1) = minloc(yfit(s(i):s(i+2)))
  minposright = pos(1) + s(i) - 1

  maxvalcenter = maxval(yfit(s(i-1):s(i+1)))
  pos(1:1) = maxloc(yfit(s(i-1):s(i+1)))
  maxposcenter = pos(1) + s(i-1) - 1

  amplitude = maxvalcenter - minvalleft

!---- Find left 80% level. Step from left min to max --------------------------

  valleft80 = minvalleft + 0.8d0*amplitude;
  posleft80 = 0.d0
  do j = minposleft,maxposcenter
    if (yfit(j) > valleft80) then
      posleft80 = j - 1.d0 + (valleft80 - yfit(j-1))/(yfit(j) - yfit(j-1))
!      posleft80 = j - 0.5d0
      exit
    end if
  end do

!---- Find left X % level. Step from max to left min --------------------------

  valleft20 = minvalleft + startcutoff*amplitude
  posleft20 = 0.d0
  do j = maxposcenter,minposleft,-1
    if (yfit(j) < valleft20) then
      posleft20 = j + (valleft20 - yfit(j))/(yfit(j+1) - yfit(j))
!      posleft20 = j + 0.5d0
	  exit
    end if
  end do

  amplitude = maxvalcenter - minvalright

!---- Find right 80% level. Step from right min to max ------------------------

  valright80 = minvalright + 0.8d0*amplitude
  posright80 = 0.d0
  do j = minposright,maxposcenter,-1
    if (yfit(j) > valright80) then
	  posright80 = j + 1.d0 - (valright80 - yfit(j+1))/(yfit(j) - yfit(j+1))
!      posright80 = j + 0.5d0
	  exit
    end if
  end do

!---- Find right X % level. Step from max to right min ------------------------

  valright20 = minvalright + startcutoff*amplitude
  posright20 = 0.d0
  do j = maxposcenter,minposright
    if (yfit(j) < valright20) then
      posright20 = j - (valright20 - yfit(j))/(yfit(j-1) - yfit(j));
!      posright20 = j - 0.5d0
	  exit
    end if
  end do

!--- Comment: We have added 0.01 in the denominator for the derivatives to ensure that
!    we never divide by zero

  if (posleft20*posleft80*posright20*posright80 > 0.d0) then
    seasonlength = posright20 - posleft20                                   ! 3) season length
    baseval = (minvalleft + minvalright)/2.d0                               ! 4) basevalue
    poscenter = (posleft80 + posright80)/2.d0                               ! 5) time for peak
    amplitude = maxvalcenter - baseval                                      ! 7) seasonal amplitude
    leftderivative = (valleft80 - valleft20)/(0.001 + posleft80 - posleft20) ! 8) left derivative
    rightderivative = -(valright80 - valright20)/(-0.001 + posright80 - posright20)  ! 9) right derivative
    largeintegral = sum(yfit(floor(posleft20):ceiling(posright20)))         ! 10) large integral
    smallintegral = sum(yfit(floor(posleft20):ceiling(posright20))-baseval) ! 11) small integral
  else
    posleft20 = 0.d0         ! 1)
    posright20 = 0.d0        ! 2)
    seasonlength = 0.d0      ! 3)
    baseval = 0.d0           ! 4)
    poscenter = 0.d0         ! 5)
    maxvalcenter = 0.d0      ! 6)
    amplitude = 0.d0         ! 7)
    leftderivative = 0.d0    ! 8)
    rightderivative = 0.d0   ! 9)
    largeintegral = 0.d0     ! 10)
    smallintegral = 0.d0     ! 11)
  end if
  dummy(1) = posleft20
  dummy(2) = posright20
  dummy(3) =   seasonlength
  dummy(4) =   baseval
  dummy(5) =   poscenter
  dummy(6) =   maxvalcenter
  dummy(7) =   amplitude
  dummy(8) =   leftderivative
  dummy(9) =   rightderivative
  dummy(10) =   largeintegral
  dummy(11) =   smallintegral
  write(nfile) dummy
end do

end subroutine phenology


           program demo_exp
           implicit none
             real :: x = 1.0
             x = exp(x)
           end program demo_exp


! Fortran95 code to determine the sum of two numbers
! given as user input.

PROGRAM addNumbers

    IMPLICIT NONE

    ! Executable statements

    REAL :: a,b, result

    print*, "Type the value of a -"

    read*, a

    print*, "Type the value of b -"

    read*, b

    result = a + b

    print*, "The sum of the given numbers = ", result

END PROGRAM addNumbers


MODULE nswcconstant
  ! Contains the NSWC functions IPMPAR, SPMPAR, DPMPAR, EPSLN, DEPSLN,
  ! EXPARG & DXPARG
  !-----------------------------------------------------------------------
  !     WRITTEN using F90 intrinsics by
  !        Alan Miller
  !        CSIRO Mathematical & Information Sciences
  !        CLAYTON, VICTORIA, AUSTRALIA 3169
  !     Latest revision - 1 February 1997
  !-----------------------------------------------------------------------
  IMPLICIT NONE
  INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
CONTAINS
  FUNCTION ipmpar (i) RESULT(fn_val)
    !-----------------------------------------------------------------------
    !     IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER
    !     THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER
    !     HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ...
    !  INTEGERS.
    !     ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM
    !               SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) )
    !               WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1.
    !     IPMPAR(1) = A, THE BASE (radix).
    !     IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS (digits).
    !     IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE (huge).
    !  FLOATING-POINT NUMBERS.
    !     IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING
    !     POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE
    !     NONZERO NUMBERS ARE REPRESENTED IN THE FORM
    !               SIGN (B**E) * (X(1)/B + ... + X(M)/B**M)
    !               WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M,
    !               X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX.
    !     IPMPAR(4) = B, THE BASE.
    !  SINGLE-PRECISION
    !     IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS.
    !     IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E.
    !     IPMPAR(7) = EMAX, THE LARGEST EXPONENT E.
    !  DOUBLE-PRECISION
    !     IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS.
    !     IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E.
    !     IPMPAR(10) = EMAX, THE LARGEST EXPONENT E.
    !-----------------------------------------------------------------------
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: i
    INTEGER             :: fn_val
    SELECT CASE(i)
    CASE( 1)
       fn_val = RADIX(i)
    CASE( 2)
       fn_val = DIGITS(i)
    CASE( 3)
       fn_val = HUGE(i)
    CASE( 4)
       fn_val = RADIX(1.0)
    CASE( 5)
       fn_val = DIGITS(1.0)
    CASE( 6)
       fn_val = MINEXPONENT(1.0)
    CASE( 7)
       fn_val = MAXEXPONENT(1.0)
    CASE( 8)
       fn_val = DIGITS(1.0D0)
    CASE( 9)
       fn_val = MINEXPONENT(1.0D0)
    CASE(10)
       fn_val = MAXEXPONENT(1.0D0)
    CASE DEFAULT
       RETURN
    END SELECT
    RETURN
  END FUNCTION ipmpar
  FUNCTION spmpar (i) RESULT(fn_val)
    !-----------------------------------------------------------------------
    !     SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR
    !     THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
    !     I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
    !     SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
    !     ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
    !        SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
    !        SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
    !        SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
    !-----------------------------------------------------------------------
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: i
    REAL                :: fn_val
    ! Local variable
    REAL                :: one = 1.0
    SELECT CASE (i)
    CASE (1)
       fn_val = EPSILON(one)
    CASE (2)
       fn_val = TINY(one)
    CASE (3)
       fn_val = HUGE(one)
    END SELECT
    RETURN
  END FUNCTION spmpar
  FUNCTION dpmpar (i) RESULT(fn_val)
    !-----------------------------------------------------------------------
    !     DPMPAR PROVIDES THE DOUBLE PRECISION MACHINE CONSTANTS FOR
    !     THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
    !     I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
    !     DOUBLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
    !     ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
    !        DPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
    !        DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
    !        DPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
    !-----------------------------------------------------------------------
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: i
    REAL (dp)           :: fn_val
    ! Local variable
    REAL (dp)    :: one = 1._dp
    SELECT CASE (i)
    CASE (1)
       fn_val = EPSILON(one)
    CASE (2)
       fn_val = TINY(one)
    CASE (3)
       fn_val = HUGE(one)
    END SELECT
    RETURN
  END FUNCTION dpmpar
  FUNCTION epsln () RESULT(fn_val)
    !--------------------------------------------------------------------
    !     THE EVALUATION OF LN(EPS) WHERE EPS IS THE SMALLEST NUMBER
    !     SUCH THAT 1.0 + EPS .GT. 1.0 .  L IS A DUMMY ARGUMENT.
    !--------------------------------------------------------------------
    IMPLICIT NONE
    REAL                :: fn_val
    ! Local variable
    REAL                :: one = 1.0
    fn_val = LOG( EPSILON(one) )
    RETURN
  END FUNCTION epsln
  FUNCTION exparg (l) RESULT(fn_val)
    !--------------------------------------------------------------------
    !     IF L = 0 THEN  EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
    !     EXP(W) CAN BE COMPUTED.
    !
    !     IF L IS NONZERO THEN  EXPARG(L) = THE LARGEST NEGATIVE W FOR
    !     WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO.
    !
    !     NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED.
    !--------------------------------------------------------------------
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: l
    REAL                :: fn_val
    ! Local variable
    REAL                :: one = 1.0
    IF (l == 0) THEN
       fn_val = LOG( HUGE(one) )
    ELSE
       fn_val = LOG( TINY(one) )
    END IF
    RETURN
  END FUNCTION exparg
  FUNCTION depsln () RESULT(fn_val)
    !--------------------------------------------------------------------
    !     THE EVALUATION OF LN(EPS) WHERE EPS IS THE SMALLEST NUMBER
    !     SUCH THAT 1.D0 + EPS .GT. 1.D0 .  L IS A DUMMY ARGUMENT.
    !--------------------------------------------------------------------
    IMPLICIT NONE
    REAL (dp)           :: fn_val
    ! Local variable
    REAL (dp)    :: one = 1._dp
    fn_val = LOG( EPSILON(one) )
    RETURN
  END FUNCTION depsln
  FUNCTION dxparg (l) RESULT(fn_val)
    !--------------------------------------------------------------------
    !     IF L = 0 THEN  DXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
    !     DEXP(W) CAN BE COMPUTED.
    !
    !     IF L IS NONZERO THEN  DXPARG(L) = THE LARGEST NEGATIVE W FOR
    !     WHICH THE COMPUTED VALUE OF DEXP(W) IS NONZERO.
    !
    !     NOTE... ONLY AN APPROXIMATE VALUE FOR DXPARG(L) IS NEEDED.
    !--------------------------------------------------------------------
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: l
    REAL (dp)           :: fn_val
    ! Local variable
    REAL (dp)    :: one = 1._dp
    IF (l == 0) THEN
       fn_val = LOG( HUGE(one) )
    ELSE
       fn_val = LOG( TINY(one) )
    END IF
    RETURN
  END FUNCTION dxparg
END MODULE nswcconstant


program closuretest
    ! Obtained from https://events.prace-ri.eu/event/694/attachments/627/918/advanced_fortran_handout.pdf

    integer :: z
    do z=1,10
        print *, apply(add_z, 1)
    end do

    contains

    function apply(fun,x) result(y)

    !procedure(intfun) :: fun
    integer :: x, y

    interface
        integer function fun(x)
        integer :: x
        end function fun
    end interface
    y = fun(x)
    end function

    function add_z(x) result(y)
    integer :: x, y
    y = x + z
    end function

end program


! automdiff.f90 --
!
!     Example belonging to "Modern Fortran in Practice" by Arjen Markus
!
!     This work is licensed under the Creative Commons Attribution 3.0 Unported License.
!     To view a copy of this license, visit http://creativecommons.org/licenses/by/3.0/
!     or send a letter to:
!     Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA.
!
!     Simple program to determine the performance differences between
!     using array-valued functions and ordinary do-loops
!
!     Module for automatic differentation:
!
!     With this module you can define a function that, when
!     evaluated returns both the value and the first derivative. The
!     independent variable should be of type AUTODERIV, as should be the
!     result.
!
module automatic_differentiation_type
    use select_precision
    implicit none

    type AUTODERIV
        real(wp) :: v
        real(wp) :: dv
    end type AUTODERIV
end module automatic_differentiation_type

module automatic_differentiation
    use automatic_differentiation_type
    implicit none

    interface sin
        module procedure sin_v
    end interface

    interface cos
        module procedure cos_v
    end interface

    interface tan
        module procedure tan_v
    end interface

    interface exp
        module procedure exp_v
    end interface

    interface log
        module procedure log_v
    end interface

    interface log10
        module procedure log10_v
    end interface

    interface sqrt
        module procedure sqrt_v
    end interface

    interface asin
        module procedure asin_v
    end interface

    interface acos
        module procedure acos_v
    end interface

    interface atan
        module procedure atan_v
    end interface

    interface sinh
        module procedure sinh_v
    end interface

    interface tanh
        module procedure tanh_v
    end interface

    interface cosh
        module procedure cosh_v
    end interface

    interface operator(+)
        module procedure add_cv
        module procedure add_vc
        module procedure add_vv
    end interface

    interface operator(-)
        module procedure sub_cv
        module procedure sub_vc
        module procedure sub_vv
        module procedure usub_v  ! Unary minus!
    end interface

    interface operator(*)
        module procedure mult_cv
        module procedure mult_vc
        module procedure mult_vv
    end interface

    interface operator(/)
        module procedure div_cv
        module procedure div_vc
        module procedure div_vv
    end interface

    interface operator(**)
        module procedure expon_cv
        module procedure expon_vc
        module procedure expon_vv
        module procedure expon_vn ! x ** n
    end interface

contains

! derivvar
!     Properly initialise an independent variable
! Arguments:
!     val        Value for the variable
! Result:
!     Independent variable with value ""val" and dervative 1
!
function derivvar( val ) result( x )
    real(wp)        :: val
    type(AUTODERIV) :: x

    x%v  = val
    x%dv = 1.0_wp
end function derivvar

! sin, cos, tan, log, exp, sqrt, sinh, cosh, tanh
!     Return the sine etc. of x
! Arguments:
!     x          Variable in question
! Result:
!     The function value and its first derivative at x
! Note:
!     Variables (not constant) need to be initialised as
!     x = autoderiv(x0,1.0). Use the function derivvar
!     for convenience.
!
elemental function sin_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = sin(x%v)
    y%dv = x%dv * cos(x%v)
end function sin_v

elemental function cos_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = cos(x%v)
    y%dv = -x%dv * sin(x%v)
end function cos_v

elemental function tan_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = tan(x%v)
    y%dv = x%dv / (1.0 + y%v**2 )
end function tan_v

elemental function exp_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = exp(x%v)
    y%dv = x%dv * y%v
end function exp_v

elemental function log_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = log(x%v)
    y%dv = x%dv / x%v
end function log_v

elemental function log10_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = log10(x%v)
    y%dv = x%dv / (log(10.0) * x%v)
end function log10_v

elemental function sqrt_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = sqrt(x%v)
    y%dv = 0.5 *x%dv / y%v
end function sqrt_v

elemental function sinh_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = sinh(x%v)
    y%dv = x%dv * cosh(x%v)
end function sinh_v

elemental function cosh_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = cosh(x%v)
    y%dv = x%dv * sinh(x%v)
end function cosh_v

elemental function tanh_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = tanh(x%v)
    y%dv = x%dv * (1.0 - y%v**2)
end function tanh_v

! asin, acos, atan
!     Return the arcsine etc. of x
! Arguments:
!     x          Variable in question
! Result:
!     The function value and its first derivative at x
! Note:
!     Variables (not constant) need to be initialised as
!     x = autoderiv(x0,1.0). Use the function derivvar
!     for convenience.
!
elemental function asin_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = asin(x%v)
    y%dv = x%dv * sqrt(1.0 - x%v ** 2)
end function asin_v

elemental function acos_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = acos(x%v)
    y%dv = -x%dv * sqrt(1.0 - x%v ** 2)
end function acos_v

elemental function atan_v( x ) result( y )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: y

    y%v  = atan(x%v)
    y%dv = x%dv / (1.0 + x%v ** 2)
end function atan_v

! +, -, *, /, **
!     Implementation of the arithmetic operations
! Arguments:
!     x          First operand (constant or variable)
!     y          Second operand (constant or variable)
! Result:
!     The sum, etc. and its first (total) derivative
! Note:
!     We need three versions to allow combinations
!     with constants.
!
elemental function add_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  + y%v
    z%dv = x%dv + y%dv
end function add_vv

elemental function add_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x    + y%v
    z%dv = y%dv
end function add_cv

elemental function add_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  + y
    z%dv = x%dv
end function add_vc

elemental function usub_v( x ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV)             :: z

    z%v  = -x%v
    z%dv = -x%dv
end function usub_v

elemental function sub_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  - y%v
    z%dv = x%dv - y%dv
end function sub_vv

elemental function sub_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x  - y%v
    z%dv =    - y%dv
end function sub_cv

elemental function sub_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  - y
    z%dv = x%dv
end function sub_vc

elemental function mult_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  * y%v
    z%dv = x%dv * y%v + x%v * y%dv
end function mult_vv

elemental function mult_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x * y%v
    z%dv = x * y%dv
end function mult_cv

elemental function mult_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  * y
    z%dv = x%dv * y
end function mult_vc

elemental function div_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  / y%v
    z%dv = (x%dv * y%v - x%v * y%dv) / y%v ** 2
end function div_vv

elemental function div_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x / y%v
    z%dv = -x * y%dv / y%v ** 2
end function div_cv

elemental function div_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  / y
    z%dv = x%dv / y
end function div_vc

elemental function expon_vv( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  ** y%v
    z%dv = (y%dv * log(x%v) + y%v/x%v * x%dv ) * z%v
end function expon_vv

elemental function expon_cv( x, y ) result( z )
    real(wp), intent(in)        :: x
    type(AUTODERIV), intent(in) :: y
    type(AUTODERIV)             :: z

    z%v  = x ** y%v
    z%dv = y%dv * log(x) * z%v
end function expon_cv

elemental function expon_vc( x, y ) result( z )
    type(AUTODERIV), intent(in) :: x
    real(wp), intent(in)        :: y
    type(AUTODERIV)             :: z

    z%v  = x%v  ** y
    z%dv = y/x%v * x%dv * z%v
end function expon_vc

elemental function expon_vn( x, n ) result( z )
    type(AUTODERIV), intent(in) :: x
    integer, intent(in)         :: n
    type(AUTODERIV)             :: z

    z%v  =            x%v ** n
    z%dv = n * x%dv * x%v ** (n-1)
end function expon_vn

! find_root
!     Find a root using Newton-Raphson
! Arguments:
!     f          Function whose root we want to find
!     xinit      Initial estimate
!     tolerance  Tolerance in finding root
!     root       Final estimate
!     found      Whether it was found or not
! Note:
!     If the iteration does not converge, we assume
!     that the iterate will grow indefinitely.
!
!     If you need a more general interface to the function,
!     consider using the implementation as a template
!
subroutine find_root( f, xinit, tolerance, root, found )
    interface
        function f(x)
            use automatic_differentiation_type
            type(AUTODERIV), intent(in) :: x
            type(AUTODERIV)             :: f
        end function
    end interface

    type(AUTODERIV), intent(in)  :: xinit
    type(AUTODERIV), intent(out) :: root
    real(wp)                     :: tolerance
    logical                      :: found

    integer                      :: iter
    integer, parameter           :: maxiter = 1000
    type(AUTODERIV)              :: fvalue

    found = .false.
    root  = xinit

    do iter = 1,maxiter

        fvalue = f(root)
        call find_root_iter( fvalue, root, tolerance, found )
        if ( found .or. abs(root%v) > huge(1.0_wp)/10.0 ) exit
    enddo

end subroutine find_root

! find_root_iter
!     Do one iteration in the Newton-Raphson method
! Arguments:
!     fvalue     Function value (plus derivative)
!     root       Current iterate
!     tolerance  Tolerance in finding root
!     found      Whether it was found or not
!
subroutine find_root_iter( fvalue, root, tolerance, found )
    type(AUTODERIV), intent(in)    :: fvalue
    type(AUTODERIV), intent(inout) :: root
    real(wp), intent(in)           :: tolerance
    logical, intent(out)           :: found

    type(AUTODERIV)                :: newroot

    newroot = root - fvalue%v / fvalue%dv
    found   = abs( newroot%v - root%v ) < tolerance
    root    = newroot

end subroutine find_root_iter

end module automatic_differentiation


program test_insert
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

n = 1
ntests = 12
call initialize_tests(tests,ntests)

tests(n) = assert(all(insert(2_int8,2,[1_int8,3_int8]) == [1,2,3]),&
                  'insert, int8')
n = n + 1

tests(n) = assert(all(insert(2_int16,2,[1_int16,3_int16]) == [1,2,3]),&
                  'insert, int16')
n = n + 1

tests(n) = assert(all(insert(2_int32,2,[1_int32,3_int32]) == [1,2,3]),&
                  'insert, int32')
n = n + 1

tests(n) = assert(all(insert(2_int64,2,[1_int64,3_int64]) == [1,2,3]),&
                  'insert, int64')
n = n + 1

tests(n) = assert(all(insert(2._real32,2,[1._real32,3._real32]) == [1,2,3]),&
                  'insert, real32')
n = n + 1

tests(n) = assert(all(insert(2._real64,2,[1._real64,3._real64]) == [1,2,3]),&
                  'insert, real64')
n = n + 1

tests(n) = assert(all(insert(2._real128,2,[1._real128,3._real128]) == [1,2,3]),&
                  'insert, real128')
n = n + 1

tests(n) = assert(all(insert(cmplx(2._real32,0._real32),2,&
                             [cmplx(1._real32,0._real32),cmplx(3._real32,0._real32)])&
                       == arange(cmplx(1._real32,0._real32),cmplx(3._real32,0._real32))),&
                  'insert, real32')
n = n + 1

tests(n) = assert(all(insert(cmplx(2._real64,0._real64),2,&
                             [cmplx(1._real64,0._real64),cmplx(3._real64,0._real64)])&
                       == arange(cmplx(1._real64,0._real64),cmplx(3._real64,0._real64))),&
                  'insert, real64')
n = n + 1

tests(n) = assert(all(insert(cmplx(2._real128,0._real128),2,&
                             [cmplx(1._real128,0._real128),cmplx(3._real128,0._real128)])&
                       == arange(cmplx(1._real128,0._real128),cmplx(3._real128,0._real128))),&
                  'insert, real128')
n = n + 1

tests(n) = assert(all(insert(1,1,arange(1,0)) == [1]),&
                  'insert into empty array')
n = n + 1

tests(n) = assert(all(insert(2,2,[1]) == [1,2]),&
                  'insert out of bounds')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_insert


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c ... visgeo.f
c
c     contains documentation and code for subroutine visgeo
c
      SUBROUTINE VISGEO (M,IDP,JDP,X,Y,Z,H,EYER,EYELAT,EYELON,
     1                          WORK,LWORK,IWORK,LIWORK,IERROR)
c
c     subroutine visgeo will display a function on the sphere
c     as a solid. ie. as a "lumpy" sphere. visgeo calls subroutine
c     vsurf to produce the visible surface rendering. X, Y, and Z
c     are the points on an icosahedral geodesic computed by
c     subroutine geopts available in spherepack.
c
c     requires routines visgeo1 ctos stoc vsurf vsurf1
c                       prjct box
c
c     visgeo uses the ncar graphics package.
c     compile with: ncargf77 (all programs above)
c
c     execute with:  a.out
c
c     on screen display with:  ctrans -d x11 gmeta
c
c     print with:  ctrans -d ps.color gmeta > gmeta.ps
c                  lpr -P(your printer) gmeta.ps
c
c
c     input parameters
c
c     m        the number of points on one edge of the icosahedron
c
c     idp,jdp  the first and second dimensions of the three
c              dimensional arrays x, y, z, and h.
c
c     x,y,z    the coordinates of the geodesic points on
c              the unit sphere computed by subroutine geopts.
c              the indices are defined on the unfolded
c              icosahedron as follows for the case m=3
c
c                north pole
c
c                 (5,1)          0      l
c        i     (4,1) (5,2)              a    (repeated for
c           (3,1) (4,2) (5,3)  theta1   t    k=2,3,4,5 in
c        (2,1) (3,2) (4,3)              i        -->
c     (1,1) (2,2) (3,3)        theta2   t    the longitudinal
c        (1,2) (2,3)                    u    direction)
c           (1,3)                pi     d
c      j                                e
c         south pole
c
c            total number of vertices is  10*(m-1)**2+2
c            total number of triangles is 20*(m-1)**2
c
c     h      a three dimensional array that contains the discrete
c            function to be displayed. h(i,j,k) is the distance from
c            the center of the sphere to the "lumpy" surface at the
c             point [x(i,j,k),y(i,j,k),z(i,j,k)] on the unit sphere.
c
c     eyer   the distance from the center of the sphere to the eye.
c
c     eyelat the colatitudinal coordinate of the eye (in degrees).
c
c     eyelon the longitudinal  coordinate of the eye (in degrees).
c
c     idp    the first dimension of the array h as it appears in
c            the program that calls visgeo
c
c     jdp    the second dimension of the array h as it appears in
c            the program that calls visgeo
c
c     work   a real work array
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls visgeo. lwork must be at least
c                       480*(m-1)**2.
c
c     iwork  an integer work array
c
c     liwork the dimension of the array iwork as it appears in the
c            program that calls visgeo. liwork must be at least
c                       140*(m-1)**2.
c
c     input parameter
c
c     ierror = 0    no error
c            = 1    h(i,j,k) is less than zero for some i,j,k.
c            = 2    eyer is less than h(i,j,k) for some i,k,k.
c            = 3    lwork  is less than 480*(m-1)**2
c            = 4    liwork is less than 140*(m-1)**2
c
      dimension h(idp,jdp,5),x(idp,jdp,5),y(idp,jdp,5),z(idp,jdp,5),
     1                                                        work(*)
      INTEGER IWORK(*)
      mmsq = (m-1)**2
      ierror = 3
      if(lwork .lt. 480*mmsq) return
      ierror = 4
      if(liwork .lt. 140*mmsq) return
      do 10 k=1,5
      do 10 j=1,m
      do 10 i=1,m+m-1
      if(h(i,j,k) .ge. 0.) go to 15
      ierror = 1
      return
   15 if(eyer .gt. h(i,j,k)) go to 10
      ierror = 2
      return
   10 continue
      ierror = 0
      lt = 20*(m-1)**2
      lg = 5*m*(m+m-1)
      i1 = 1
      i2 = i1+lt
      i3 = i2+lt
      i4 = i3+lt
      i5 = i4+lt
      i6 = i5+lt
      i7 = i6+lt
      i8 = i7+lt
      i9 = i8+lt
      i10 = i9+lt
      i11 = i10+lt
      i12 = i11
      i13 = i12+lg
      i14 = i13+lg
      call visgeo1 (m,idp,jdp,h,eyer,eyelat,eyelon,x,y,z,
     1work(i1),work(i2),work(i3),work(i4),work(i5),work(i6),
     2work(i7),work(i8),work(i9),IWORK(1),work(i11),
     3work(i12),work(i13),work(i14),IWORK(lt+1))
      return
      end
      SUBROUTINE VISGEO1(M,IDP,JDP,H,EYER,EYELAT,EYELON,
     1    XI,YI,ZI,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,ITYPE,WORK,X,Y,Z,IWORK)
      dimension h(idp,jdp,5),xi(idp,jdp,5),yi(idp,jdp,5),zi(idp,jdp,5),
     1x1(*),y1(*),z1(*),x2(*),y2(*),z2(*),x3(*),y3(*),z3(*),itype(*),
     2work(*),x(m+m-1,m,5),y(m+m-1,m,5),z(m+m-1,m,5)
      INTEGER IWORK(*)
c
c     the * above refers to 20*(m-1)**2 locations which is the
c     number of triangles
c
      do 10 k=1,5
      do 10 j=1,m
      do 10 i=1,m+m-1
      call ctos(xi(i,j,k),yi(i,j,k),zi(i,j,k),rad,theta,elambda)
      call stoc(h(i,j,k),theta,elambda,x(i,j,k),y(i,j,k),z(i,j,k))
   10 continue
      ntri = 0
      do 20 k=1,5
      do 20 j=1,m-1
      do 20 i=1,m+m-2
      ntri = ntri+1
      x1(ntri) = x(i,j,k)
      y1(ntri) = y(i,j,k)
      z1(ntri) = z(i,j,k)
      x2(ntri) = x(i+1,j+1,k)
      y2(ntri) = y(i+1,j+1,k)
      z2(ntri) = z(i+1,j+1,k)
      x3(ntri) = x(i+1,j,k)
      y3(ntri) = y(i+1,j,k)
      z3(ntri) = z(i+1,j,k)
      itype(ntri) = 13
      ntri = ntri+1
      x1(ntri) = x(i,j,k)
      y1(ntri) = y(i,j,k)
      z1(ntri) = z(i,j,k)
      x2(ntri) = x(i+1,j+1,k)
      y2(ntri) = y(i+1,j+1,k)
      z2(ntri) = z(i+1,j+1,k)
      x3(ntri) = x(i,j+1,k)
      y3(ntri) = y(i,j+1,k)
      z3(ntri) = z(i,j+1,k)
      itype(ntri) = 3
 20   continue
c      write(6,22) ntri
 22   format(i10)
c      write(6,23) (x1(l2),y1(l2),z1(l2),x2(l2),y2(l2),z2(l2),
c     1             x3(l2),y3(l2),z3(l2),l2=1,ntri)
c 23   format(9f10.7)
c
      pi = 4.*atan(1.)
      dtr = pi/180.
      xeye=eyer*sin(dtr*eyelat)
      yeye=xeye*sin(dtr*eyelon)
      xeye=xeye*cos(dtr*eyelon)
      zeye=eyer*cos(dtr*eyelat)
      CALL VSURF(XEYE,YEYE,ZEYE,NTRI,X1,Y1,Z1,X2,Y2,Z2,
     1                 X3,Y3,Z3,ITYPE,WORK,IWORK)
      return
      end
      subroutine ctos(x,y,z,r,theta,phi)
      r1 = x*x+y*y
      if(r1 .ne. 0.) go to 10
      phi = 0.
      theta = 0.
      if(z .lt. 0.) theta = 4.*atan(1.)
      return
   10 r = sqrt(r1+z*z)
      r1 = sqrt(r1)
      phi = atan2(y,x)
      theta = atan2(r1,z)
      return
      end
      subroutine stoc(r,theta,phi,x,y,z)
      st = sin(theta)
      x = r*st*cos(phi)
      y = r*st*sin(phi)
      z = r*cos(theta)
      return
      end
      SUBROUTINE VSURF(XEYE,YEYE,ZEYE,NTRI,X1,Y1,Z1,X2,Y2,Z2,
     1                 X3,Y3,Z3,ITYPE,WORK,IWORK)
c
c    subroutine vsurf is like subroutine hidel except the triangles
c    are categorized. vsurf is also like solid except triangles rather
c    than lines are covered.
c
c     written by paul n. swarztrauber, national center for atmospheric
c     research, p.o. box 3000, boulder, colorado, 80307
c
c    this program plots visible lines for the surface defined
c    by the input 3-d triangles with corners at (x1,y1,z1), (x2,y2,z2)
c    and (x3,y3,z3). the sides of these these triangles may or
c    may not be plotted depending on itype. if itype is 1 then the
c    side between points (x1,y1,z1) and (x2,y2,z2) is plotted if it
c    is visible. if itype is 2 then the side between (x2,y2,z2)
c    and (x3,y3,z3) is plotted. if itype is 3 then the visible portion
c    of the side between (x3,y3,z3) and (x1,y1,z1) is plotted.
c    any combination is possible by specifying itype to be one
c    of the following values: 0,1,2,3,12,13,23,123.
c
c    the length of real    array  work must be at least 14*ntri
c
c    the length of integer array iwork must be at least  6*ntri
c
c
c    the vertices of the triangles are renumbered by vsurf so that
c    their projections are orientated counterclockwise. the user need
c    only be aware that the vertices may be renumbered by vsurf.
c
      dimension x1(ntri),y1(ntri),z1(ntri),x2(ntri),y2(ntri),z2(ntri),
     1          x3(ntri),y3(ntri),z3(ntri),itype(ntri),work(14*ntri)
      INTEGER IWORK(6*NTRI)
c
      call vsurf1(xeye,yeye,zeye,ntri,x1,y1,z1,x2,y2,z2,x3,y3,z3,
     1 itype,work,work(ntri+1),work(2*ntri+1),work(3*ntri+1),
     2 work(4*ntri+1),work(5*ntri+1),work(6*ntri+1),work(7*ntri+1),
     3 work(8*ntri+1),work(9*ntri+1),work(10*ntri+1),work(11*ntri+1),
     3 work(12*ntri+1),work(13*ntri+1),IWORK,IWORK(NTRI+1),
     4 IWORK(2*NTRI+1),IWORK(4*NTRI+1))
      return
      end
      subroutine vsurf1(xeye,yeye,zeye,ntri,x1,y1,z1,x2,y2,z2,x3,y3,z3,
     1 itype,px1,py1,px2,py2,px3,py3,vx1,vy1,vx2,vy2,vx3,vy3,tl,tr,kh,
     2 next,istart,ifinal)
c
      dimension x1(ntri),y1(ntri),z1(ntri),x2(ntri),y2(ntri),z2(ntri),
     1          x3(ntri),y3(ntri),z3(ntri),itype(ntri),
     2          px1(ntri),py1(ntri),px2(ntri),py2(ntri),
     3          px3(ntri),py3(ntri),vx1(ntri),vy1(ntri),
     4          vx2(ntri),vy2(ntri),vx3(ntri),vy3(ntri),
     5          tl(ntri),tr(ntri),next(ntri),kh(ntri),
     6          istart(2*ntri),ifinal(2*ntri),ltp(3),
     7          ird(11),ip2(11),nct(11),ncv(11),last(11)
c
      real l2e
      double precision le2
c
c     compute projections of 3-d points
c
      le2 = .6931471805599453094172321d0
      l2e = 1.d0/le2
      fntri = ntri
      irmax = .5*l2e*log(fntri)
      irmax = min(irmax,10)
      irmp1 = irmax+1
      do 4 icv=1,11
      ncv(icv) = 0
    4 continue
      nct(1) = 0
      ip2(1) = 1
      ird(1) = 0
      isize = 4
      do 7 irp1=2,irmp1
      ir = irp1-1
      nct(irp1) = 0
      ip2(irp1) = 2**ir
      ird(irp1) = ird(ir)+isize
      isize = (ip2(irp1)+1)**2
    7 continue
      isxm = ird(irmp1)+isize+1
      do 8 isx=1,isxm
      istart(isx) = 0
      ifinal(isx) = 0
    8 continue
      do 6 i=1,ntri
      next(i) = 0
    6 continue
      call prjct(0,xeye,yeye,zeye,x,y,z,dum1,dum2)
c      write(6,127) ntri
  127 format(' ntri in hidel', i5)
      do 86 k=1,ntri
      call prjct(1,xeye,yeye,zeye,x1(k),y1(k),z1(k),px1(k),py1(k))
      call prjct(1,xeye,yeye,zeye,x2(k),y2(k),z2(k),px2(k),py2(k))
      call prjct(1,xeye,yeye,zeye,x3(k),y3(k),z3(k),px3(k),py3(k))
        if (k .lt. 3) then
c          write(6,333) xeye,yeye,zeye,x1(k),y1(k),z1(k),px1(k),py1(k)
  333     format(' xeye, etc.',8e8.1)
        endif
   86 continue
c
c     orientate triangles counter clockwise
c
      do 70 k=1,ntri
      cprod = (px2(k)-px1(k))*(py3(k)-py1(k))-(py2(k)-py1(k))
     1       *(px3(k)-px1(k))
c      if(cprod.eq.0.) write(6,79) k,px1(k),px2(k),px3(k),
c     -                              py1(k),py2(k),py3(k)
   79 format('  cprod=0 at k=', i5,6e9.2)
      if(cprod.ge.0.) go to 70
      px1h = px1(k)
      py1h = py1(k)
      px1(k) = px2(k)
      py1(k) = py2(k)
      px2(k) = px1h
      py2(k) = py1h
      x1hold = x1(k)
      y1hold = y1(k)
      z1hold = z1(k)
      x1(k) = x2(k)
      y1(k) = y2(k)
      z1(k) = z2(k)
      x2(k) = x1hold
      y2(k) = y1hold
      z2(k) = z1hold
      ityp = itype(k)
      if(ityp.eq.2) itype(k) = 3
      if(ityp.eq.3) itype(k) = 2
      if(ityp.eq.12) itype(k) = 13
      if(ityp.eq.13) itype(k) = 12
   70 continue
c
c     set screen limits
c
      pmax = px1(1)
      pmin = px1(1)
      do 87 k=1,ntri
      pmin = amin1(pmin,px1(k),py1(k),px2(k),py2(k),px3(k),py3(k))
      pmax = amax1(pmax,px1(k),py1(k),px2(k),py2(k),px3(k),py3(k))
   87 continue
      pmin = 1.1*pmin
      pmax = 1.1*pmax
      call set(0.,1.,0.,1.,pmin,pmax,pmin,pmax,1)
      xmin = amin1(px1(1),px2(1),px3(1))
      xmax = amax1(px1(1),px2(1),px3(1))
      ymin = amin1(py1(1),py2(1),py3(1))
      ymax = amax1(py1(1),py2(1),py3(1))
      do 1 i=2,ntri
      xmin = amin1(xmin,px1(i),px2(i),px3(i))
      xmax = amax1(xmax,px1(i),px2(i),px3(i))
      ymin = amin1(ymin,py1(i),py2(i),py3(i))
      ymax = amax1(ymax,py1(i),py2(i),py3(i))
    1 continue
      dmx = xmax-xmin
      dmy = ymax-ymin
      if(dmx .gt. dmy) go to 2
      c = ymin
      d = ymax
      xmid = .5*(xmin+xmax)
      hdy = .5*dmy
      a = xmid-hdy
      b = xmid+hdy
      go to 3
    2 a = xmin
      b = xmax
      ymid = .5*(ymin+ymax)
      hdx = .5*dmx
      c = ymid-hdx
      d = ymid+hdx
    3 hgr = b-a
c
c     categorize triangles
c
      do 100 i=1,ntri
      xmin = amin1(px1(i),px2(i),px3(i))
      xmax = amax1(px1(i),px2(i),px3(i))
      ymin = amin1(py1(i),py2(i),py3(i))
      ymax = amax1(py1(i),py2(i),py3(i))
      dxt = amax1(xmax-xmin,ymax-ymin)
      if(dxt .gt. 0.) go to 10
      ir = irmax
      go to 20
   10 ir = l2e*log(hgr/dxt)
      ir = min(ir,irmax)
   20 irp1 = ir+1
      nct(irp1) = nct(irp1)+1
      hr = hgr/ip2(irp1)
      xmid = .5*(xmin+xmax)
      id = (xmid-a)/hr+1.5
      ymid = .5*(ymin+ymax)
      jd = (ymid-c)/hr+1.5
      ijd = ip2(irp1)+1
      isx = id+(jd-1)*ijd+ird(irp1)
      ifx = ifinal(isx)
      if(ifx .gt. 0) go to 50
      istart(isx) = i
      go to 60
   50 next(ifx) = i
   60 ifinal(isx) = i
  100 continue
c      write(6,106) tcat,(irp1,nct(irp1),irp1=1,irmp1)
  106 format(' time to categorize   ', e15.6/(' ir+1',i3,' ntri',i7))
c
c     sort triangles into boxes
c
      l = 0
      do 30 irp1=1,irmp1
      if(nct(irp1) .eq. 0) go to 30
      ist = ird(irp1)+1
      isd = ip2(irp1)+1
      call box(isd,istart(ist),next,l,ifinal)
      last(irp1) = l+1
   30 continue
      do 35 irp1=1,irmp1
      il = ird(irp1)+(ip2(irp1)+1)**2+1
      if(istart(il) .eq. 0) istart(il) = last(irp1)
   35 continue
c      write(6,31) tsort,l,ntri
   31 format(' time to sort  ', e15.6,'   l', i8,'   ntri',i8)
      do 90 k=1,ntri
      vx1(k) = px2(k)-px1(k)
      vy1(k) = py2(k)-py1(k)
      vx2(k) = px3(k)-px2(k)
      vy2(k) = py3(k)-py2(k)
      vx3(k) = px1(k)-px3(k)
      vy3(k) = py1(k)-py3(k)
   90 continue
      tl1 = 0.
      tl2 = 0.
      maxs = 0
      do 500 ir2=1,irmp1
      if(nct(ir2) .eq. 0) go to 500
      ist = ird(ir2)
      isd = ip2(ir2)+1
      do 490 j2=1,isd
      do 480 i2=1,isd
      ist = ist+1
      ls = istart(ist)
      lf = istart(ist+1)-1
      if(lf .lt. ls) go to 480
c
c     define coverings
c
      kcv = 0
      i2m = i2-1
      j2m = j2-1
      do 300 ir1=1,irmp1
      if(nct(ir1) .eq. 0) go to 300
      if(ir1 .ge. ir2) go to 260
      irdp = 2**(ir2-ir1)
      i1s = (i2m-1)/irdp
      i1f = (i2m+1)/irdp
      if = i2m+1-i1f*irdp
      if(if .gt. 0) i1f = i1f+1
      j1s = (j2m-1)/irdp
      j1f = (j2m+1)/irdp
      jf = j2m+1-j1f*irdp
      if(jf .gt. 0) j1f = j1f+1
      go to 270
  260 irdp = 2**(ir1-ir2)
      i1s = irdp*(i2m-1)
      i1f = irdp*(i2m+1)
      j1s = irdp*(j2m-1)
      j1f = irdp*(j2m+1)
  270 ijd = ip2(ir1)+1
      i1s = max(i1s+1,1)
      i1f = min(i1f+1,ijd)
      j1s = max(j1s+1,1)
      j1f = min(j1f+1,ijd)
      ixh = (j1s-2)*ijd+ird(ir1)
      ixs = i1s+ixh
      ixf = i1f+ixh
      do 290 j1=j1s,j1f
      ixs = ixs+ijd
      kds = istart(ixs)
      ixf = ixf+ijd
      kdf = istart(ixf+1)-1
      if(kdf .lt. kds) go to 290
      do 280 kd=kds,kdf
      kcv = kcv+1
      kh(kcv) = ifinal(kd)
  280 continue
  290 continue
  300 continue
      do 310 icv=1,10
      if(kcv .le. ncv(icv)) go to 310
      ncv(icv) = kcv
      go to 320
  310 continue
c
c
  320 do 470 ldo=ls,lf
      l = ifinal(ldo)
      ith = itype(l)
      if(ith .eq. 0) go to 470
      ltp(1) = 0
      ltp(2) = 0
      ltp(3) = 0
      id1 = ith/100
      ith = ith-100*id1
      id2 = ith/10
      id3 = ith-10*id2
      if(id1 .ne. 0) ltp(id1) = 1
      if(id2 .ne. 0) ltp(id2) = 1
      if(id3 .ne. 0) ltp(id3) = 1
c     if((ith.eq.123) .or. (ith.eq.12) .or.(ith.eq.13)) ltp(1) = 1
c     if((ith.eq.123) .or. (ith.eq.23) .or.(ith.eq.12)) ltp(2) = 1
c     if((ith.eq.123) .or. (ith.eq.13) .or.(ith.eq.23)) ltp(3) = 1
      do 460 ns=1,3
      go to (101,102,103),ns
  101 if(ltp(ns) .eq. 0) go to 460
      px4 = px1(l)
      py4 = py1(l)
      px5 = px2(l)
      py5 = py2(l)
      x4 = x1(l)
      y4 = y1(l)
      z4 = z1(l)
      x5 = x2(l)
      y5 = y2(l)
      z5 = z2(l)
      go to 105
  102 if(ltp(ns) .eq. 0) go to 460
      px4 = px2(l)
      py4 = py2(l)
      px5 = px3(l)
      py5 = py3(l)
      x4 = x2(l)
      y4 = y2(l)
      z4 = z2(l)
      x5 = x3(l)
      y5 = y3(l)
      z5 = z3(l)
      go to 105
  103 if(ltp(ns) .eq. 0) go to 460
      px4 = px1(l)
      py4 = py1(l)
      px5 = px3(l)
      py5 = py3(l)
      x4 = x1(l)
      y4 = y1(l)
      z4 = z1(l)
      x5 = x3(l)
      y5 = y3(l)
      z5 = z3(l)
  105 x54 = px5-px4
      y54 = py5-py4
      nseg = 0
      do 440 kd=1,kcv
      k = kh(kd)
      c17 = vx1(k)*y54-vy1(k)*x54
      c27 = vx2(k)*y54-vy2(k)*x54
      c37 = vx3(k)*y54-vy3(k)*x54
      c14 = vy1(k)*(px4-px1(k))-vx1(k)*(py4-py1(k))
      c25 = vy2(k)*(px4-px2(k))-vx2(k)*(py4-py2(k))
      c36 = vy3(k)*(px4-px3(k))-vx3(k)*(py4-py3(k))
      tmin = 0.
      tmax = 1.
      if(c17) 151,152,153
  151 tmax = amin1(c14/c17,tmax)
      go to 154
  152 if(c14) 154,440,440
  153 tmin = amax1(c14/c17,tmin)
  154 if(c27) 155,156,157
  155 tmax = amin1(c25/c27,tmax)
      go to 158
  156 if(c25) 158,440,440
  157 tmin = amax1(c25/c27,tmin)
  158 if(c37) 159,160,161
  159 tmax = amin1(c36/c37,tmax)
      go to 162
  160 if(c36) 162,440,440
  161 tmin = amax1(c36/c37,tmin)
  162 if(tmax-tmin .lt. .00001) go to 440
      xpl = x4+tmin*(x5-x4)
      ypl = y4+tmin*(y5-y4)
      zpl = z4+tmin*(z5-z4)
      xpr = x4+tmax*(x5-x4)
      ypr = y4+tmax*(y5-y4)
      zpr = z4+tmax*(z5-z4)
c
c     the projections of line and plane intersect
c     now determine if plane covers line
c
      vx1t = x2(k)-x1(k)
      vy1t = y2(k)-y1(k)
      vz1t = z2(k)-z1(k)
      vx2t = x3(k)-x1(k)
      vy2t = y3(k)-y1(k)
      vz2t = z3(k)-z1(k)
      apl = vy1t*vz2t-vy2t*vz1t
      bpl = vx2t*vz1t-vx1t*vz2t
      cpl = vx1t*vy2t-vx2t*vy1t
      dpl = apl*x1(k)+bpl*y1(k)+cpl*z1(k)
      vx3t = xpl-xeye
      vy3t = ypl-yeye
      vz3t = zpl-zeye
      den = apl*vx3t+bpl*vy3t+cpl*vz3t
      til = 0.
      if(den .eq. 0.) go to 410
      til = (dpl-apl*xeye-bpl*yeye-cpl*zeye)/den
  410 vx3t = xpr-xeye
      vy3t = ypr-yeye
      vz3t = zpr-zeye
      den = apl*vx3t+bpl*vy3t+cpl*vz3t
      tir = 0.
      if(den .eq. 0.) go to 412
      tir = (dpl-apl*xeye-bpl*yeye-cpl*zeye)/den
  412 if(til.ge..99999.and.tir.ge..99999) go to 440
      if(til.lt.1..and.tir.lt.1.) go to 164
      vx3t = xpr-xpl
      vy3t = ypr-ypl
      vz3t = zpr-zpl
      den = apl*vx3t+bpl*vy3t+cpl*vz3t
      tim = 0.
      if(den .eq. 0.) go to 414
      tim = (dpl-apl*xpl-bpl*ypl-cpl*zpl)/den
  414 thold = tmin+tim*(tmax-tmin)
      if(til.ge.1.) go to 163
      tmax = thold
      go to 164
  163 tmin = thold
  164 nseg = nseg+1
      tl(nseg) = tmin
      tr(nseg) = tmax
  440 continue
      maxs = max0(maxs,nseg)
      if(nseg-1)171,180,172
  171 call line(px4,py4,px5,py5)
      go to 460
c
c     order the segments according to left end point tl(k)
c
  172 do 173 k=2,nseg
      do 173 i=k,nseg
      if(tl(k-1).le.tl(i)) go to 173
      tlh = tl(k-1)
      trh = tr(k-1)
      tl(k-1) = tl(i)
      tr(k-1) = tr(i)
      tl(i) = tlh
      tr(i) = trh
  173 continue
c
c     eliminate segment overlap
c
      k1 = 1
      k2 = 1
  174 k2 = k2+1
      if(k2.gt.nseg) go to 176
      if(tr(k1).lt.tl(k2)) go to 175
      tr(k1) = amax1(tr(k1),tr(k2))
      go to 174
  175 k1 = k1+1
      tl(k1) = tl(k2)
      tr(k1) = tr(k2)
      go to 174
  176 nseg = k1
c
c     plot all segments of the line
c
  180 do 181 ks =1,nseg
      kb = nseg-ks+1
      tl(kb+1) = tr(kb)
      tr(kb) = tl(kb)
  181 continue
      tl(1) = 0.
      tr(nseg+1) = 1.
      nsegp = nseg+1
      do 450 k=1,nsegp
      if(abs(tr(k)-tl(k)).lt..000001) go to 450
      xa = px4+tl(k)*(px5-px4)
      ya = py4+tl(k)*(py5-py4)
      xb = px4+tr(k)*(px5-px4)
      yb = py4+tr(k)*(py5-py4)
      call line(xa,ya,xb,yb)
  450 continue
  460 continue
  470 continue
  480 continue
  490 continue
  500 continue
c      write(6,903) tl1,tl2
  903 format(' time to cover', e15.6/
     1       ' time to test ', e15.6)
c      write(6,904) maxs
  904 format(' maximum number of segments', i5)
c      write(6,250) (ncv(icv),icv=1,10)
  250 format('  the ten largest coverings'/(10i5))
      call frame
      end
      subroutine prjct(init,xeye,yeye,zeye,x,y,z,px,py)
c
c     subroutine prjct projects the point x,y,z onto a plane through
c     the origin that is perpendicular to a line between the origin
c     and the eye. the projection is along the line between the eye
c     and the point x,y,z. px and py are the coordinates of the
c     projection in the plane.
c     (version 2 , 12-10-82)
c
      save
      if(init.ne.0) go to 1
      rads1 = xeye**2+yeye**2
      rads2 = rads1+zeye**2
      d1 = sqrt(rads1)
      d2 = sqrt(rads2)
      if(d1.ne.0.) go to 2
      cx1 = 1.
      cy1 = 0.
      cx2 = 0.
      cy2 = 1.
      cz2 = 0.
      cx3 = 0.
      cy3 = 0.
      cz3 = 1.
      return
    2 cx1 = -yeye/d1
      cy1 = xeye/d1
      cx2 = -xeye*zeye/(d1*d2)
      cy2 = -yeye*zeye/(d1*d2)
      cz2 = d1/d2
      cx3 = xeye/d2
      cy3 = yeye/d2
      cz3 = zeye/d2
      return
    1 x1 = cx1*x+cy1*y
      y1 = cx2*x+cy2*y+cz2*z
      z1 = cx3*x+cy3*y+cz3*z
      ratio = d2/(d2-z1)
      px = ratio*x1
      py = ratio*y1
      return
      end
      subroutine box(isd,istart,next,l,list)
      dimension istart(isd,isd),next(1),list(1)
      do 30 jd=1,isd
      do 10 id=1,isd
      idx = istart(id,jd)
      istart(id,jd) = l+1
      if(idx .eq. 0) go to 10
   20 l = l+1
      list(l) = idx
      if(next(idx) .eq. 0) go to 10
      idx = next(idx)
      go to 20
   10 continue
   30 continue
      return
      end


!===============================================================================
program CIJ_rotate_3
!===============================================================================
!  Program calling CIJ_rot3

   use anisotropy_ajn

   real(8) :: C(6,6), CR(6,6), a,b,g,rho
   character(len=250) :: file,arg
   integer :: iostatus,i,j

!  Check input arguments
   if (command_argument_count() < 3 .or. command_argument_count() > 4) then
      write(0,'(a)') 'Usage: CIJ_rot3 [alpha] [beta] [gamma] (ecfile)', &
                     '  Rotations are applied in order, clockwise about a,b,c axes looking down axis.',&
                     '  If no .ecs file specified, then ECs are read from stdin, 36 constants per line.'
      stop
   endif

!  Get input arguments
   call get_command_argument(1,arg) ;  read(arg,*) a
   call get_command_argument(2,arg) ;  read(arg,*) b
   call get_command_argument(3,arg) ;  read(arg,*) g

!  Get elastic constants
!  if reading from .ecs file, just output in same units: assumes density normalised
   if (command_argument_count() == 4) then
      call get_command_argument(4,file)
      call CIJ_load(file,C,rho)
      call CIJ_rot3(C,a,b,g,CR)
      write(*,*) CR
!  Otherwise, we're reading several constants from stdin
   else
      iostatus = 0
      do while (iostatus == 0)
         read(*,*,iostat=iostatus) ((C(i,j),j=1,6),i=1,6)
         if (iostatus < 0) exit
         if (iostatus > 0) then
            write(0,'(a)') 'CIJ_rot3: problem reading 36 input elastic constants from stdin.'
            stop
         endif
         call CIJ_rot3(C,a,b,g,CR)
         write(*,*) CR
      enddo
   endif

end program CIJ_rotate_3
!-------------------------------------------------------------------------------