!     Standalone HEALPix subroutine converted to f77 by J C Hill 07/13/06
!     Get the original at http://healpix.jpl.nasa.gov
!     a f 'f88 pix2vecnest.f'

      !=========================================================================
      subroutine pix2vecnest(nside, ipix, vector_x, vector_y,
     & vector_z, vertex_n_x, vertex_n_y, vertex_n_z, vertex_e_x,
     & vertex_e_y, vertex_e_z, vertex_s_x, vertex_s_y, vertex_s_z,
     & vertex_w_x, vertex_w_y, vertex_w_z)
      !=========================================================================
      !     renders vector (x,y,z) coordinates of the nominal pixel center
      !     for the pixel number ipix (NESTED scheme)
      !     given the map resolution parameter nside
      !     also returns the (x,y,z) position of the 4 pixel vertices (=corners)
      !     in the order N,E,S,W
      !=========================================================================
      IMPLICIT none
      INTEGER ipix, nside
      REAL*8 vector_x, vector_y, vector_z, vertex_n_x,
     & vertex_n_y, vertex_n_z, vertex_e_x, vertex_e_y,
     & vertex_e_z, vertex_s_x, vertex_s_y, vertex_s_z,
     & vertex_w_x, vertex_w_y, vertex_w_z

      INTEGER npix, npface, ipf, ip_low, ip_trunc, ip_med,
     & ip_hi, jrt, jr, nr, jpt, jp, kshift, nl4, ns_max
      parameter(ns_max=8192) ! 2^13 : largest nside allowed
      REAL*8 z, fn, fact1, fact2, sth, phi, PI
      parameter(PI=3.141592653589793238462643383279502884197d0)
      INTEGER pix2x(0:1023), pix2y(0:1023)
      INTEGER ix, iy, face_num
      ! common /xy_nest/ ix, iy, face_num ! can be useful to calling routine

      INTEGER jrll(1:12)
      INTEGER jpll(1:12)

      REAL*8 phi_nv, phi_wv, phi_sv, phi_ev, phi_up, phi_dn,
     & z_nv, z_sv, sth_nv, sth_sv, hdelta_phi
      INTEGER iphi_mod, iphi_rat, kpix, jpix, ix_mk,
     & iy_mk, ip_mk, id_mk, i
      ! LOGICAL do_vertex    ! this is unnecessary, since we will always want the vertices
      !------------------------------------------------------------------------
      if (nside.lt.1 .or. nside.gt.ns_max) stop 'nside out of range'
      npix = 12*nside**2     ! total number of pixels
      if (ipix.lt.0 .or. ipix.gt.npix-1) stop 'ipix out of range'

      do 10 i = 0, 1023
         pix2x(i) = 0
         pix2y(i) = 0
 10   continue

      ! coordinate of the lowest corner of each face, in unit of nside
      jrll(1) = 2
      jrll(2) = 2
      jrll(3) = 2
      jrll(4) = 2
      jrll(5) = 3
      jrll(6) = 3
      jrll(7) = 3
      jrll(8) = 3
      jrll(9) = 4
      jrll(10) = 4
      jrll(11) = 4
      jrll(12) = 4

      ! coordinate of the lowest corner of each face, in unit of nside/2
      jpll(1) = 1
      jpll(2) = 3
      jpll(3) = 5
      jpll(4) = 7
      jpll(5) = 0
      jpll(6) = 2
      jpll(7) = 4
      jpll(8) = 6
      jpll(9) = 1
      jpll(10) = 3
      jpll(11) = 5
      jpll(12) = 7

      !     initializes the array for the pixel number -> (x,y) mapping
      if (pix2x(1023).le.0) then
         ! constructs the array giving x and y in the face from pixel number
         ! for the nested (quad-cube like) ordering of pixels
         !
         ! the bits corresponding to x and y are interleaved in the pixel number
         ! one breaks up the pixel number by even and odd bits

         ! cc cf block data      data      pix2x(1023) /0/
         !
         !      print *, 'initiate pix2xy'
         do kpix = 0,1023               ! pixel number
            jpix = kpix
            ix_mk = 0
            iy_mk = 0
            ip_mk = 1                 ! bit position (in x and y)
         ! do while (jpix/=0)         ! go through all the bits
            do
               if (jpix.eq.0) exit    ! go through all the bits
!               id_mk = jpix           ! this and the next 4 lines are equivalent to id_mk=MODULO(jpix,2)
! 10            continue
!                  if (id_mk.ge.2) id_mk = id_mk - 2
!                  if (id_mk.lt.0) id_mk = id_mk + 2
!               if (id_mk.ge.2 .or. id_mk.lt.0) goto 10  ! bit value (in kpix), goes in ix_mk
               id_mk = MOD(jpix,2)
               jpix = jpix/2
               ix_mk = id_mk*ip_mk + ix_mk

!               id_mk = jpix           ! this and the next 4 lines are equivalent to id_mk=MODULO(jpix,2)
! 20            continue
!                  if (id_mk.ge.2) id_mk = id_mk - 2
!                  if (id_mk.lt.0) id_mk = id_mk + 2
!               if (id_mk.ge.2 .or. id_mk.lt.0) goto 20  ! bit value (in kpix), goes in iy_mk
               id_mk = MOD(jpix,2)
               jpix = jpix/2
               iy_mk = id_mk*ip_mk + iy_mk

               ip_mk = 2*ip_mk        ! next bit (in x and y)
            enddo
            pix2x(kpix) = ix_mk       ! in 0,31
            pix2y(kpix) = iy_mk       ! in 0,31
         enddo
      endif

      fn = DBLE(nside)
      fact1 = 1.0d0/(3.0d0*fn*fn)
      fact2 = 2.0d0/(3.0d0*fn)
      nl4   = 4*nside

      !    finds the face, and the number in the face
      npface = nside**2

      face_num = ipix/npface  ! face number in {0,11}
      ipf = MOD(ipix,npface)  ! pixel number in the face {0,npface-1}

      !     finds the x,y on the face (starting from the lowest corner)
      !     from the pixel number
      ip_low = MOD(ipf,1024)          ! content of the last 10 bits
      ip_trunc = ipf/1024             ! truncation of the last 10 bits
      ip_med = MOD(ip_trunc,1024)     ! content of the next 10 bits
      ip_hi = ip_trunc/1024           ! content of the high weight 10 bits

      ix = 1024*pix2x(ip_hi) + 32*pix2x(ip_med) + pix2x(ip_low)
      iy = 1024*pix2y(ip_hi) + 32*pix2y(ip_med) + pix2y(ip_low)

      !     transforms this in (horizontal, vertical) coordinates
      jrt = ix + iy  ! 'vertical' in {0,2*(nside-1)}
      jpt = ix - iy  ! 'horizontal' in {-nside+1,nside-1}

      !     computes the z coordinate on the sphere
      jr = jrll(face_num+1)*nside - jrt - 1  ! ring number in {1,4*nside-1}

      nr = nside                 ! equatorial region (the most frequent)
      z = (2*nside-jr)*fact2
      kshift = MOD(jr - nside, 2)

      z_nv = (2*nside-jr+1)*fact2
      z_sv = (2*nside-jr-1)*fact2
      if (jr.eq.nside) then ! northern transition
         z_nv = 1.0d0 - (nside-1)**2 * fact1
      elseif (jr.eq.3*nside) then  ! southern transition
         z_sv = -1.0d0 + (nside-1)**2 * fact1
      endif

      if (jr.lt.nside) then     ! north pole region
         nr = jr
         z = 1.0d0 - nr*nr*fact1
         kshift = 0
         z_nv = 1.0d0 - (nr-1)**2 * fact1
         z_sv = 1.0d0 - (nr+1)**2 * fact1
      elseif (jr.gt.3*nside) then ! south pole region
         nr = nl4 - jr
         z = -1.0d0 + nr*nr*fact1
         kshift = 0
         z_nv = -1.0d0 + (nr+1)**2 * fact1
         z_sv = -1.0d0 + (nr-1)**2 * fact1
      endif

      !     computes the phi coordinate on the sphere, in [0,2Pi]
      jp = (jpll(face_num+1)*nr + jpt + 1 + kshift)/2  ! 'phi' number in the ring in {1,4*nr}
      if (jp.gt.nl4) jp = jp - nl4
      if (jp.lt.1)   jp = jp + nl4

      phi = (jp - (kshift+1)*0.5d0) * (PI/(2.0d0*nr))

      sth = SQRT((1.0d0-z)*(1.0d0+z))
      vector_x = sth * COS(phi)
      vector_y = sth * SIN(phi)
      vector_z = z

      phi_nv = phi
      phi_sv = phi

      phi_up = 0.0d0
      iphi_mod = MOD(jp-1,nr) ! in {0,1,... nr-1}
      iphi_rat = (jp-1) / nr  ! in {0,1,2,3}
      if (nr.gt.1) phi_up=(PI/2.0d0)*(iphi_rat+iphi_mod/(DBLE(nr-1)))
      phi_dn         =(PI/2.0d0)*(iphi_rat+(iphi_mod+1)/(DBLE(nr+1)))
      if (jr.lt.nside) then          ! North polar cap
         phi_nv = phi_up
         phi_sv = phi_dn
      elseif (jr.gt.3*nside) then    ! South polar cap
         phi_nv = phi_dn
         phi_sv = phi_up
      elseif (jr.eq.nside) then      ! North transition
         phi_nv = phi_up
      elseif (jr.eq.3*nside) then    ! South transition
         phi_sv = phi_up
      endif

      hdelta_phi = PI / (4.0d0*nr)

      ! west vertex
      phi_wv     = phi - hdelta_phi
      vertex_w_x = sth * COS(phi_wv)
      vertex_w_y = sth * SIN(phi_wv)
      vertex_w_z = z

      ! east vertex
      phi_ev     = phi + hdelta_phi
      vertex_e_x = sth * COS(phi_ev)
      vertex_e_y = sth * SIN(phi_ev)
      vertex_e_z = z

      ! north vertex
      sth_nv = SQRT((1.0d0-z_nv)*(1.0d0+z_nv))
      vertex_n_x = sth_nv * COS(phi_nv)
      vertex_n_y = sth_nv * SIN(phi_nv)
      vertex_n_z = z_nv

      ! south vertex
      sth_sv = SQRT((1.0d0-z_sv)*(1.0d0+z_sv))
      vertex_s_x = sth_sv * COS(phi_sv)
      vertex_s_y = sth_sv * SIN(phi_sv)
      vertex_s_z = z_sv

      return
      end subroutine pix2vecnest ! pix2vecnest


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      real*8 function calc_residual_tee(pt1,Tt1,xflow1,xflow2,
     &pt2,Tt2,A1,A2,zeta_fac,kappa,R,ider,iflag,zeta)
!
!     Function for calculating the residual of both branches of a tee
!
!     author: Yannick Muller
!
      implicit none
!
      integer
!     Isothermal/adiabatic
     &icase,
!     Residual/Derivatives
     &ider,
!     Critical conditions at inlet or outlet
     &icrit1,
     &icrit2,
!     Where we are in the program
     &iflag
!
      real*8
!     Residual
     &f,
!     Kappa stuff
     &kappa,
     &R,
!     State variables
     &pt1,
     &pt2,
     &Tt1,
     &Tt2,
     &Ts0,
     &Ts1,
     &Ts2,
     &xflow1,
     &xflow2,
!
     &pt2_lim,
!
     &zeta,
     &zeta_fac,
!
!     Areas
     &A1,
     &A2,
!     Reduced mass flows
     &Q0,
     &Q1,
     &Q2,
     &Q_crit,
!     Pressure ratios
     &pspt_crit,
     &pspt0,
     &pspt1,
     &pspt2,
!     Flow velocities
     &w1,
     &w2,
     &w1w2,
     &w2w1,
!    Mach numbers,
     &M1,
     &M2
!
      icrit1 = 0
      icrit2 = 0
!     setting icase (always adiabatic)
      icase=0;
!
!     Critical values
      Q_crit = dsqrt(kappa/R)*
     &   (1+0.5d0*(kappa-1))**(-0.5d0*(kappa+1)/(kappa-1))
      pspt_crit = (2/(kappa+1)) ** (kappa/(kappa-1))
!
!     These reduced mass flows are equivalent
!     (reduced mass flow at inlet)
      Q0 = xflow1*dsqrt(Tt1)/pt1/A1
      Q1 = xflow2*dsqrt(Tt1)/pt1/A2
      if(Q1.ge.Q_crit) then
         Q1 = Q_crit
         icrit1 = 1
         write(*,*)'*WARNING in Tee:'
         write(*,*)'Critical conditions at 1'
      endif
!     Reduced mass flow at outlet
      Q2 = xflow2*dsqrt(Tt1)/pt2/A2
      if(Q2.ge.Q_crit) then
         Q2 = Q_crit
         icrit2 = 1
         write(*,*)'*WARNING in Tee:'
         write(*,*)'Critical conditions at 2'
      endif
!
!     Flow velocity at inlet
!     Static temperature
      Ts0=Tt1
      call ts_calc(xflow1,Tt1,pt1,kappa,r,A1,Ts0,icase)
!     Pressure ratio
      pspt0 = (Ts0/Tt1)**(kappa/(kappa-1))
!     Velocity
      call wpi(w1, pspt0, Q0,
     &      dsqrt(Tt1),kappa,R)
!
!     Flow velocity at outlet
!     Static temperature
      call ts_calc(xflow2,Tt1,pt1,kappa,r,A2,Ts1,icase)
!     Pressure ratio
      pspt1 = (Ts1/Tt1)**(kappa/(kappa-1))
!     Velocity
      call wpi(w2, pspt1, Q1,
     &      dsqrt(Tt1),kappa,R)
!
!     Velocity ratio
c      w2w1=w2/w1
c      w1w2=w1/w2
      if(w2.eq.0.d0)then
         w1w2=1d30
      else
         w1w2=w1/w2
      endif
      if(w1.eq.0.d0)then
         w2w1=1d30
      else
         w2w1=w2/w1
      endif
!
!     Zeta calculation
      zeta=1.d0+0.3d0*W2W1**2
      zeta=zeta*(W1W2)**2
!
      zeta = zeta_fac*zeta
!
!     Residual calculation
      if(icrit2.ne.1) then
         if(icrit1.ne.1) then
            f = pt2 - pt1*pspt1**zeta
         else
            f = xflow2*dsqrt(Tt1)/pt1/A2-Q_crit
         endif
      else
         f = xflow2*dsqrt(Tt1)/pt2/A2-Q_crit
      endif
!
      if(iflag.eq.3) then
!
         write(1,57)'             zeta= ',zeta
 57      format(1x,a,f9.4)
!
      else if (iflag.eq.4) then

!        Calculate Mach numbers
         call machpi(M1,pspt0,kappa,R)
         call ts_calc(xflow2,Tt2,pt2,kappa,r,A2,Ts2,icase)
!        Pressure ratio
         pspt2 = (Ts2/Tt2)**(kappa/(kappa-1))
         call machpi(M2,pspt2,kappa,R)

!         write(1,80)'Inlet: Tt1= ',Tt1,
!     &              ', pt1= ',pt1,', M1= ',M1
!
!         write(1,77)'mass flow = ',xflow2,', kappa = ',kappa,
!     &              ', zeta= ',zeta
!
!         write(1,80)'Outlet: Tt2= ',Tt2,
!     &              ', pt2= ',pt2,', M2= ',M2
!
! 80   format(3x,a,f10.6,a,f10.2,a,f10.6)
! 77   format(3x,a,f10.6,a,f10.2,a,f10.6)
      endif
!
      calc_residual_tee=f
!
      return
      end


      REAL*8 FUNCTION dsexpo()
c mods by ML, double precision, dranf
	IMPLICIT INTEGER (I-N), REAL*8 (A-H, O-Z)
C**********************************************************************C
C                                                                      C
C                                                                      C
C     (STANDARD-)  E X P O N E N T I A L   DISTRIBUTION                C
C                                                                      C
C                                                                      C
C**********************************************************************C
C**********************************************************************C
C                                                                      C
C     FOR DETAILS SEE:                                                 C
C                                                                      C
C               AHRENS, J.H. AND DIETER, U.                            C
C               COMPUTER METHODS FOR SAMPLING FROM THE                 C
C               EXPONENTIAL AND NORMAL DISTRIBUTIONS.                  C
C               COMM. ACM, 15,10 (OCT. 1972), 873 - 882.               C
C                                                                      C
C     ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM       C
C     'SA' IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION)       C
C                                                                      C
C     Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of   C
C     SUNIF.  The argument IR thus goes away.                          C
C                                                                      C
C**********************************************************************C
C
      DIMENSION q(8)
      EQUIVALENCE (q(1),q1)
C
C     Q(N) = SUM(ALOG(2.0)**K/K!)    K=1,..,N ,      THE HIGHEST N
C     (HERE 8) IS DETERMINED BY Q(N)=1.0 WITHIN STANDARD PRECISION
C
      DATA q/.6931472,.9333737,.9888778,.9984959,.9998293,.9999833,
     +     .9999986,.9999999/
C
   10 a = 0.0
      u = dranf()
      GO TO 30

   20 a = a + q1
   30 u = u + u
      IF (u.LE.1.0) GO TO 20
   40 u = u - 1.0
      IF (u.GT.q1) GO TO 60
   50 dsexpo = a + u
      RETURN

   60 i = 1
      ustar = dranf()
      umin = ustar
   70 ustar = dranf()
      IF (ustar.LT.umin) umin = ustar
   80 i = i + 1
      IF (u.GT.q(i)) GO TO 70
   90 dsexpo = a + umin*q1
      RETURN

      END


C Copyright (C) 2000, International Business Machines
C Corporation and others.  All Rights Reserved.
*
*
*
      SUBROUTINE GETNP( IPOLY, POLY, LPOLY, N, KAPPA, G, H)

*
*     collects  the coefficient of the polynomial IPOLY into
*     doefficient of a quadratic kappa+g'x+0.5 x'H'x

C     INPUT
C     POLY   = Newton polynomials
C     IPOLY  = The index of the polynomial we are processing

C     OUTPUT
C     KAPPA = the constant of the polynomail
C     G     = the linear coeffitients
C     H     = the n by n matrix of quadratic doeffitients
      INTEGER           IPOLY, LPOLY, N

      DOUBLE PRECISION  POLY(LPOLY), KAPPA,  G(N), H(N,N)
*
*     Local variables
*

      DOUBLE PRECISION  ZERO
      PARAMETER        (ZERO=0.0D0)
      INTEGER           I, J, KBEG, K, NP1, DD

      NP1=N+1
      DD=(NP1)*(N+2)/2

      KAPPA=ZERO
      DO 10 I=1,N
        G(I)=ZERO
        DO 20 J=1,N
          H(I,J)=ZERO
 20    CONTINUE
 10   CONTINUE

      IF (IPOLY.EQ.1) THEN
        KAPPA=POLY(1)
      ELSEIF (IPOLY .LE. NP1) THEN
        KBEG=2+(IPOLY-2)*(NP1)
        KAPPA=POLY(KBEG)
        DO 30 I=1, N
         G(I)=POLY(KBEG+I)
 30     CONTINUE
      ELSE
        KBEG=2+N*NP1+(IPOLY-NP1-1)*DD
        KAPPA=POLY(KBEG)
        DO 40 I=1, N
          G(I)=POLY(KBEG+I)
 40     CONTINUE
        K=KBEG+N+1
        DO 50 I=1, N
          H(I,I)=2*POLY(K)
          K=K+1
          DO 60 J=I+1,N
            H(I,J)=POLY(K)
            H(J,I)=POLY(K)
            K=K+1
 60       CONTINUE
 50     CONTINUE
      ENDIF

      RETURN
      END


      FUNCTION SPLINE_INTEGRAL(X,Y,A,B,C,N,MODE)
      REAL X(N),Y(N),A(N),B(N),C(N)
C
C-----COMPUTATION OF CUBIC SPLINE INTEGRAL FROM X(1) TO X(N)
C-----IF MODE=1, COMPUTE SPLINE COEFFICIENTS FIRST
      IF (MODE.EQ.1) CALL SPLINE(X,Y,A,B,C,N)
      S=.0
      DO 10 I=1,N-1
      D=X(I+1)-X(I)
   10 S=S+D*(Y(I)+D*(A(I)/2.+D*(B(I)/3.+D*C(I)/4.)))
      SPLINE_INTEGRAL=S
C
      RETURN
      END


      FUNCTION JULDAY(MM,ID,IYYY)
      PARAMETER (IGREG=15+31*(10+12*1582))
      IF (IYYY.EQ.0) PAUSE 'There is no Year Zero.'
      IF (IYYY.LT.0) IYYY=IYYY+1
      IF (MM.GT.2) THEN
        JY=IYYY
        JM=MM+1
      ELSE
        JY=IYYY-1
        JM=MM+13
      ENDIF
      JULDAY=INT(365.25*JY)+INT(30.6001*JM)+ID+1720995
      IF (ID+31*(MM+12*IYYY).GE.IGREG) THEN
        JA=INT(0.01*JY)
        JULDAY=JULDAY+2-JA+INT(0.25*JA)
      ENDIF
      RETURN
      END


program main

  USE OMP_LIB
  use Structure
  use Matrix_op
  use gnuplot_fortran
  use bar
  use Time_matrices
  !use Elastic_sol
  use Elastic_sol_PGD
  use global_stage
  use local_stage
  !use local_stage_vec
  use LATIN_indicator
  use NR_module

  !include 'solver.f03' !use funcion

  implicit none

  real :: start, finish

  ! Solution fields:
  double precision, dimension(:,:), allocatable :: U ! Displacement.
  double precision, dimension(:,:), allocatable :: eps ! Strain.
  double precision, dimension(:,:), allocatable :: sigma ! Stress.

  ! Other fields:
  integer :: nelm
  double precision, dimension(:), allocatable :: plot_vec
  double precision :: x
  double precision, dimension(3, 3) :: m,minv
  double precision, dimension(5) :: v ! vector
  !integer, dimension(10) :: inc ! vector
  integer, dimension(:,:), allocatable :: inc ! vector
  integer :: j,max_iter=15

  ! Latin definitions:
  double precision :: LATIN_error
  integer :: nL = 0 ! Latin iteration

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call cpu_time(start)

  print*, (' ')
  print*, (' ')
  print*, (' ')
  print*, (' ')
  print*, (' ######     ######    ####    ####    ll                    ')
  print*, (' ##    ##  ##    ##   #####  #####    ll                    ')
  print*, (' ##    ##  ##    ##   ##   ##   ##    ll            bb      ')
  print*, (' ########  ##    ##   ##        ##    ll   aaaa     bb      ')
  print*, (' ##    ##  ##    ##   ##        ##    ll  aa  aa    bbbbb   ')
  print*, (' ##    ##  ##    ##   ##        ##    ll  aa  aaa   bb  bb  ')
  print*, (' ##    ##   ######    ##        ##    ll   aaaa aa   bbbb   ')
  print*, (' ')

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call Input_assign  ! Constructor of the structure "I"
  call Time_op_assign(I) ! Constructor of the structure "Top"
  call Space_elm_matrices(I)  ! Creation of structure Sop (containing the space elemental matrices)

  !!$OMP PARALLEL

  if (I%solver == "Newton-Raphson") then  ! NR

    print*, ('NEWTON RAPHSON SOLVER')
    call NR_solver(I,Sop)

    ! Plots:
    allocate( plot_vec( I%ntNR )  ) ! vector used to plot.
    nelm = I%Nx ! Element chose to plot.
    plot_vec = reshape( NR%d_Ep(1,1,nelm,:) , (/I%ntNR/) )  ! Plastic deformation
    call plot(plot_vec)

  else ! LATIN-PGD

    print*, ('LATIN-PGD SOLVER')

    !call solve_init(I,Sop)  ! Creation of Elast and solve of the initial elastic problem.
    call solve_init_PGD(I,Sop,Top)  ! Creation of Elast and solve of the initial elastic problem.

    ! Initialization of the LATIN iterations:
    LATIN_error = 100

    call assign_elastic(Elast,I) ! Assignation of the elastic solution to the global_stage quantities.

    !call local_stage_vp(I,Sop,G%sigma)
    allocate( plot_vec( I%Tngpt )  ) ! vector used to plot.

    do while (I%LATIN_error_min <= LATIN_error )

        nL = nL + 1

        ! Local stage:
        call local_stage_vp(I,Sop,G%sigma)
        !call local_stage_vp_vec(I,Sop,G%sigma)

        ! Global stage:
        call global_stage_vp(Elast,Top,Sop,L,I,nL)

        if (I%PGD_eval) then !(.true.) then
          ! Calculate the error of the solver:
          LATIN_error= indicator1(G,L)
          print*, "LATIN ERROR [%]:" , LATIN_error, "ITERATION:", nL
        end if

    end do

    ! Plots:
    nelm = I%Nx ! Element chose to plot.
    plot_vec = reshape( L%d_Ep(1,1,nelm,:) , (/I%Tngpt/) )  ! Plastic deformation
    !plot_vec = reshape( Elast%sigma(1,1,nelm,:) , (/I%Tngpt/) )   ! stress Elastic solution
    call plot(plot_vec)

  end if ! NR or LATIN-PGD

  print*, " "
  print*, "PROBLEM CONVERGED."

  call cpu_time(finish)
  !print '("RESOLUTION TIME = ",f6.3," seconds.")', finish-start

  print '("RESOLUTION TIME = ",f12.3," seconds.")', finish-start

  !!$OMP END PARALLEL

end program main


program igrf_driver

use igrf, only : igrf13syn
use, intrinsic:: iso_fortran_env, only: stderr=>error_unit, dp=>real64

implicit none (type, external)

real(dp) :: yeardec  !< decimal year e.g. 2015.82
real(dp) :: utsec !< UTC second of day
real(dp) :: alt_km  !< altitude [km]
real(dp) :: glat, glon !< geodetic latitude, longitude [deg]
integer :: isv, itype

character(80) :: argv

real(dp) :: x, y, z, f

! --- command line input
if (command_argument_count() /= 6) then
  write(stderr,*) 'need input parameters: YearDecimal glat glon alt_km isv itype'
  stop 1
endif

call get_command_argument(1, argv)
read(argv,*) yeardec

call get_command_argument(2, argv)
read(argv,*) glat

call get_command_argument(3, argv)
read(argv,*) glon

call get_command_argument(4, argv)
read(argv,*) alt_km

call get_command_argument(5, argv)
read(argv, '(I1)') isv

call get_command_argument(6, argv)
read(argv, '(I1)') itype

! --- execute program
call igrf13syn(isv=isv, date=yeardec, itype=itype, alt=alt_km, colat=90. - glat, elong=glon, &
  x=x, y=y, z=z, f=f)

print '(4ES15.7)', x, y, z, f

end program


! Calculate P(k, mu) power spectrum from Fourier transformed data along pencils. The input data here is called "overdensity" but
! it's actually any scalar field in the form f(x) = (x/x_bar) - 1 where x_bar is the mean value.

subroutine calc_k_mu_ps1d (overdensity_fft_real, overdensity_fft_imag, &
                           lo, hi, ng, dir, domain_length, &
                           num_k_bins, k_bin_edges, &
                           num_mu_bins, mu_bin_edges, &
                           bin_count, power_weighted_k_sum, power_weighted_mu_sum, power_sum)

  use, intrinsic :: iso_c_binding
  implicit none

  integer(c_int), intent(in) :: lo(3), hi(3), ng, num_k_bins, num_mu_bins, dir
  real(c_double), intent(in), target :: overdensity_fft_real (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
  real(c_double), intent(in), target :: overdensity_fft_imag (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
  real(c_double), intent(in) :: k_bin_edges (num_k_bins+1)
  real(c_double), intent(in) :: mu_bin_edges (num_mu_bins+1)
  real(c_double), intent(in) :: domain_length

  integer(c_int), intent(out) :: bin_count (num_k_bins*num_mu_bins)
  real(c_double), intent(out) :: power_weighted_k_sum (num_k_bins*num_mu_bins)
  real(c_double), intent(out) :: power_weighted_mu_sum (num_k_bins*num_mu_bins)
  real(c_double), intent(out) :: power_sum (num_k_bins*num_mu_bins)

  integer(c_int) :: i
  integer(c_int) :: k
  integer(c_int) :: k_bin_index
  integer(c_int) :: mu_bin_index
  integer(c_int) :: i_bin
  integer(c_int) :: k_index(3)

  real(c_double) :: k_fund
  real(c_double) :: k_mag
  real(c_double) :: k_max
  real(c_double) :: mu_min
  real(c_double) :: mu_max
  real(c_double) :: k_min
  real(c_double) :: k_nyquist
  real(c_double) :: p_i
  real(c_double) :: pi
  real(c_double) :: k_para
  real(c_double) :: mu

  real(c_double), pointer :: overdensity_fft_real_pencil (:)
  real(c_double), pointer :: overdensity_fft_imag_pencil (:)

  complex(c_double_complex), allocatable :: overdensity_fft_pencil (:)

  pi = acos(-1.0)

  ! Align array pointers along pencil direction. We use 1-D pointers here in order to simplify the indices in the calculations
  ! below.
  if (dir == 0) then
      overdensity_fft_real_pencil => overdensity_fft_real (lo(1):hi(1), lo(2), lo(3), 1)
      overdensity_fft_imag_pencil => overdensity_fft_imag (lo(1):hi(1), lo(2), lo(3), 1)
  else if (dir == 1) then
      overdensity_fft_real_pencil => overdensity_fft_real (lo(1), lo(2):hi(2), lo(3), 1)
      overdensity_fft_imag_pencil => overdensity_fft_imag (lo(1), lo(2):hi(2), lo(3), 1)
  else if (dir == 2) then
      overdensity_fft_real_pencil => overdensity_fft_real (lo(1), lo(2), lo(3):hi(3), 1)
      overdensity_fft_imag_pencil => overdensity_fft_imag (lo(1), lo(2), lo(3):hi(3), 1)
  end if

  allocate(overdensity_fft_pencil(size(overdensity_fft_real_pencil)))

  ! Combine the real and imaginary parts into a single complex array.
  do i = 1, size(overdensity_fft_pencil)
    overdensity_fft_pencil(i) = cmplx(overdensity_fft_real_pencil(i), overdensity_fft_imag_pencil(i), c_double_complex)
  end do

  k_fund = 2.0 * pi / domain_length

  k_nyquist = k_fund * size(overdensity_fft_pencil)/2

  k_min = minval(k_bin_edges)
  k_max = maxval(k_bin_edges)

  mu_min = minval(mu_bin_edges)
  mu_max = maxval(mu_bin_edges)

  if (k_min < 0.0 .or. k_max > k_nyquist) then
    print *, "(k_min, k_max, k_nyquist) = ", k_min, k_max, k_nyquist
    stop
  end if

  bin_count (:) = 0
  power_weighted_k_sum (:) = 0.0
  power_weighted_mu_sum (:) = 0.0
  power_sum (:) = 0.0

  do i = lbound(overdensity_fft_pencil, 1), ubound(overdensity_fft_pencil, 1)
    if (i <= size(overdensity_fft_pencil)/2+1) then
      k_index(dir+1) = i-1
    else
      k_index(dir+1) = i-1 - size(overdensity_fft_pencil)
    end if

    ! Assign wavenumber indices from the non-pencil grid directions. For the 2 non-pencil-pointing directions, lo() = hi() (since
    ! the pencils are only 1 cell thick) so there's nothing special about choosing lo() here.
    if (dir == 0) then
      if (lo(2) <= size(overdensity_fft_pencil)/2) then
        k_index(2) = lo(2)
      else
        k_index(2) = lo(2) - size(overdensity_fft_pencil)
      end if
      if (lo(3) <= size(overdensity_fft_pencil)/2) then
        k_index(3) = lo(3)
      else
        k_index(3) = lo(3) - size(overdensity_fft_pencil)
      end if
    else if (dir == 1) then
      if (lo(1) <= size(overdensity_fft_pencil)/2) then
        k_index(1) = lo(1)
      else
        k_index(1) = lo(1) - size(overdensity_fft_pencil)
      end if
      if (lo(3) <= size(overdensity_fft_pencil)/2) then
        k_index(3) = lo(3)
      else
        k_index(3) = lo(3) - size(overdensity_fft_pencil)
      end if
    else if (dir == 2) then
      if (lo(1) <= size(overdensity_fft_pencil)/2) then
        k_index(1) = lo(1)
      else
        k_index(1) = lo(1) - size(overdensity_fft_pencil)
      end if
      if (lo(2) <= size(overdensity_fft_pencil)/2) then
        k_index(2) = lo(2)
      else
        k_index(2) = lo(2) - size(overdensity_fft_pencil)
      end if
    end if

    ! Skip the zero mode.
    if (k_index(1) == 0 .and. k_index(2) == 0 .and. k_index(3) == 0) cycle

    k_para = k_fund * real(abs(k_index(dir+1)), c_double)
    ! Get magnitude of k vector.
    k_mag = k_fund * sqrt(real(k_index(1)*k_index(1) + k_index(2)*k_index(2) + k_index(3)*k_index(3), c_double))
    mu = k_para / k_mag

    ! Skip wavenumbers and angles outside the requested range.
    if (k_mag < k_min .or. k_mag >= k_max .or. mu < mu_min .or. mu > mu_max) cycle

    ! Match k bin.
    k_bin_index = -1
    do k = 1, num_k_bins
      if (k_mag >= k_bin_edges(k) .and. k_mag < k_bin_edges(k+1)) then
        k_bin_index = k
        exit
      end if
    end do
    if (k_bin_index < 0) stop 'COULD NOT MATCH K BIN'

    ! Match mu bin.
    mu_bin_index = -1
    do k = 1, num_mu_bins
      if (mu >= mu_bin_edges(k) .and. mu < mu_bin_edges(k+1)) then
        mu_bin_index = k
        exit
      end if
    end do
    if (mu == mu_max) mu_bin_index = num_mu_bins
    if (mu_bin_index < 0) stop 'COULD NOT MATCH MU BIN'

    ! Flatten index for (k, mu) arrays.
    i_bin = (k_bin_index-1)*num_mu_bins + mu_bin_index

    ! VOLUME DENOMINATOR ASSUMES CUBIC DOMAIN
    p_i = (abs(overdensity_fft_pencil(i)))**2 / domain_length**3

    bin_count             (i_bin) = bin_count             (i_bin) + 1
    power_weighted_k_sum  (i_bin) = power_weighted_k_sum  (i_bin) + p_i * k_mag
    power_weighted_mu_sum (i_bin) = power_weighted_mu_sum (i_bin) + p_i * mu
    power_sum             (i_bin) = power_sum             (i_bin) + p_i

  end do

  deallocate(overdensity_fft_pencil)

end subroutine calc_k_mu_ps1d


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine e_c3d_vlhs(lakonl,sm,nelem,ipvar,var)
!
!     computation of the velocity element matrix for the element with
!     the topology in konl
!
      implicit none
!
      character*8 lakonl
!
      integer nelem,i,j,k,nope,mint3d,ipvar(*),index
!
      real*8 shp(4,20),sm(8,8),weight,var(*)
!
      if(lakonl(4:4).eq.'8') then
         nope=8
      elseif(lakonl(4:4).eq.'4') then
         nope=4
      elseif(lakonl(4:4).eq.'6') then
         nope=6
      endif
!
      if(lakonl(4:5).eq.'8R') then
         mint3d=1
      elseif(lakonl(4:4).eq.'8') then
        mint3d=8
      elseif(lakonl(4:4).eq.'4') then
         mint3d=1
      elseif(lakonl(4:5).eq.'6 ') then
         mint3d=2
      endif
!
!     initialisation of sm
!
      do i=1,nope
         do j=1,nope
            sm(i,j)=0.d0
         enddo
      enddo
!
!     computation of the matrix: loop over the Gauss points
!
      index=ipvar(nelem)
      do k=1,mint3d
!
!        copying the shape functions, their derivatives and the
!        Jacobian determinant from field var
!
         do j=1,nope
            do i=1,4
               index=index+1
               shp(i,j)=var(index)
            enddo
         enddo
         index=index+1
         weight=var(index)
!
         index=index+1
!
         do j=1,nope
            do i=1,j
!
!              lhs velocity matrix
!
               sm(i,j)=sm(i,j)
     &              +shp(4,i)*shp(4,j)*weight
            enddo
         enddo
      enddo
!
      return
      end


      SUBROUTINE INTRP1(XPOSNS,YPOSNS,ZPOSNS,NPNTS,XPOS,YPOS,
     &                  RADIUS,TOL,VALUE,IREPLY)
C
C          ------------------------------------------------
C          ROUTINE NO. ( 129)   VERSION (A7.1)    11:FEB:85
C          ------------------------------------------------
C
C          THIS ESTIMATES THE HEIGHT AT A GIVEN POINT OF A SURFACE
C          DEFINED BY A SET OF HEIGHTS AT ARBITRARY X-Y POSITIONS.
C
C
C          THE ARGUMENTS ARE AS FOLLOWS:
C
C          [XPOSNS] THE SET OF SURFACE POINT X-COORDINATES,
C          [YPOSNS] THE SET OF SURFACE POINT Y-COORDINATES,
C          [ZPOSNS] THE SET OF SURFACE POINT Z-COORDINATES,
C          <NPNTS>  THE NUMBER OF DATA POINTS PROVIDED (AND THE
C                   MIN. SIZE OF EACH OF THE PRECEDING ARRAYS),
C          <XPOS>   THE INTERPOLATION POINT X-COORDINATE,
C          <YPOS>   THE INTERPOLATION POINT Y-COORDINATE,
C          <RADIUS> THE RADIUS OF ACCEPTANCE OF DATA POINTS,
C          <TOL>    THE CAPTURE RADIUS OF A SINGLE DATA POINT,
C          <VALUE>  THE (RETURNED) ESTIMATED HEIGHT VALUE,
C          <IREPLY> THE (RETURNED) REPLY CODE:
C                   = 0, THE INTERPOLATION VALUE IS VALID,
C                   = 1, THE INTERPOLATION WAS UNSUCCESSFUL.
C
C
C          THE SURFACE IS APPROXIMATED BY A SECOND-DEGREE POLYNOMIAL
C
C          P(U,V)= C1*(U*U+V*V) + C2*U + C3*V + C4
C
C          WHERE U= X-XPOS, V= Y-YPOS. THE REQUIRED SURFACE HEIGHT AT
C          (XPOS,YPOS) IS THEN GIVEN BY THE VALUE OF THE POLYNOMIAL
C          AT THAT POINT, NAMELY C4. THE COEFFICIENTS C1..C4 ARE
C          FOUND BY A DISTANCE-WEIGHTED LEAST-SQUARES FIT TO ALL
C          DATA POINTS WITHIN A GIVEN RADIUS OF (XPOS,YPOS). THE
C          LEAST-SQUARES CALCULATION IS ACHIEVED BY MEANS OF A QR-
C          FACTORISATION OF THE DATA MATRIX USING FAST GIVENS-
C          TRANSFORMATIONS. WITH THIS METHOD EACH ROW OF THE DATA
C          MATRIX IS CREATED AND TRANSFORMED IN TURN; THERE IS NO
C          NEED TO STORE THE FULL MATRIX. IF THE POSITION (XPOS,YPOS)
C          IS WITHIN A CAPTURE RADIUS OF ONE OF THE DATA POINTS,
C          THE HEIGHT VALUE OF THAT DATA POINT IS USED DIRECTLY.
C
C          REFERENCES:
C
C          K.J. FALCONER 'A GENERAL PURPOSE ALGORITHM FOR CONTOURING
C          OVER SCATTERED DATA POINTS' NPL REPORT DNAC6 (1971).
C
C          D.H. MCLAIN 'DRAWING CONTOURS FROM ARBITRARY DATA POINTS'
C          COMPUTER JOURNAL, VOL. 17, PAGE 318 (1974).
C
C          J.H. WILKINSON 'NUMERICAL LINEAR ALGEBRA',
C          IN 'STATE OF THE ART IN NUMERICAL ANALYSIS'
C          EDITOR D.A.H. JACOBS, ACADEMIC PRESS (1977).
C
C
      REAL    XPOSNS(NPNTS),YPOSNS(NPNTS),ZPOSNS(NPNTS),RSCALE(4),
     &        TRIANG(14),WORK(5)
C
      COMMON /T3LIMS/ IMAXI,RMAXI,RMINI
C
C
C          <CRMIN> IS A MACHINE-DEPENDENT CONSTANT WHICH IS SET
C          TO 100 TIMES THE SMALLEST REPRESENTABLE REAL NUMBER.
C
      CRMIN= 100.0*RMINI
C
C          THE VARIABLE <NUSED> COUNTS THE NUMBER OF DATA
C          POINTS INCLUDED IN THE LEAST-SQUARES CALCULATION.
C
      NUSED= 0
      RADSQ= RADIUS*RADIUS
      TOLSQ= TOL*TOL
C
C          THE MAJOR LOOP BEGINS HERE. EACH DATA POINT IS EXAMINED
C          IN TURN AND IF ITS POSITION IS LESS THAN <RADIUS> FROM THE
C          INTERPOLATION POINT, IT IS INCLUDED IN THE CALCULATION.
C          THE CORRESPONDING ROW OF THE DATA MATRIX IS FORMED IN
C          [WORK], AND THEN TRANSFORMED USING A SEQUENCE OF
C          GIVENS-ROTATIONS. THE FACTOR 'Q' OF THE QR-TRANSFORMATION
C          IS NOT STORED, BUT THE UPPER TRIANGULAR MATRIX 'R' IS
C          BUILT UP IN THE ONE-DIMENSIONAL ARRAY [TRIANG]. THE SCALE
C          FACTORS FOR THE ROWS OF [TRIANG] ARE STORED IN [RSCALE].
C
      DO 100 ISCAN= 1,NPNTS
        XDIFF= XPOSNS(ISCAN)-XPOS
        YDIFF= YPOSNS(ISCAN)-YPOS
        DISTSQ= XDIFF*XDIFF+YDIFF*YDIFF
        IF (DISTSQ.GE.RADSQ) GO TO 100
C
C          IF THE DATA POINT IS LESS THAN <TOL> FROM (<XPOS>,<YPOS>),
C          THE CORRESPONDING HEIGHT VALUE IS RETURNED DIRECTLY.
C
        IF (DISTSQ.GT.TOLSQ) GO TO 1
        VALUE= ZPOSNS(ISCAN)
        IREPLY= 0
        RETURN
C
C          THE WEIGHT FACTOR <WEIGHT> ASSOCIATED WITH THE POINT IS
C          SET. IF IT IS VERY SMALL, THE POINT IS NOT INCLUDED.
C
    1   DIST= SQRT(DISTSQ)
        WEIGHT= (RADIUS-DIST)*(RADIUS-DIST)/DISTSQ
        IF (WEIGHT.LE.CRMIN) GO TO 100
C
        NUSED= NUSED+1
        WORK(1)= XDIFF*XDIFF+YDIFF*YDIFF
        WORK(2)= XDIFF
        WORK(3)= YDIFF
        WORK(4)= 1.0
        WORK(5)= ZPOSNS(ISCAN)
        KPIVOT= 1
C
C          THE FIRST ROW IS COPIED DIRECTLY TO [TRIANG]. OTHER
C          ROWS ARE TRANSFORMED USING GIVENS-ROTATIONS TO DELETE
C          ELEMENTS: THE GIVENS-TRANSFORMATION USES ROW <KROW> OF
C          THE R-MATRIX AND THE NEW ROW TO ANNIHILATE THE <KROW>-TH
C          ELEMENT OF THE NEW ROW. THE PIVOT VALUE IS STORED IN THE
C          ELEMENT <KPIVOT> OF [TRIANG] AND THE REMAINDER OF THE
C          <KROW>-TH ROW IN THE NEXT (5-<KROW>) ELEMENTS. A CHECK
C          IS FIRST MADE TO SEE IF ANY TRANSFORMATION IS NEEDED.
C
        IF (NUSED.EQ.1) GO TO 5
C
        KLIM= MIN0(NUSED-1,4)
        DO 200 KROW= 1,KLIM
          IF (ABS(WORK(KROW)).LT.CRMIN) GO TO 4
          KROWP1= KROW+1
C
C          TWO FORMS OF THE GIVENS-ROTATION ARE POSSIBLE (SEE 3RD.
C          REFERENCE ABOVE). A CHOICE IS MADE BETWEEN THE TWO
C          FORMS (TYPE-A AND TYPE-B) TO AVOID POSSIBILITIES OF
C          DIVISION BY ZERO AND UNDERFLOW. THE INITIAL SELECTION
C          IS MADE ON COMPARISON OF WORK(KROW) AND TRIANG(KPIVOT).
C
          IF (ABS(TRIANG(KPIVOT)).LE.ABS(WORK(KROW))) GO TO 3
C
C          THIS SECTION IS FOR TRANSFORMATION TYPE-A. IF
C          <SCALA3> < 2.0 THIS ONE IS USED. OTHERWISE THE
C          TYPE-B TRANSFORMATION BELOW IS USED INSTEAD.
C
    2     SCALA1= WORK(KROW)/TRIANG(KPIVOT)
          SCALA2= SCALA1*WEIGHT/RSCALE(KROW)
          SCALA3= SCALA1*SCALA2+1.0
C
          IF (SCALA3.GT.2.0) GO TO 3
C
C          <WEIGHT>, [RSCALE], THE PIVOT VALUE AND ROWS ARE REVISED.
C
          RSCALE(KROW)= RSCALE(KROW)/SCALA3
          WEIGHT= WEIGHT/SCALA3
C
          TRIANG(KPIVOT)= TRIANG(KPIVOT)+SCALA2*WORK(KROW)
C
          IEXT= KPIVOT
          DO 300 IREV= KROWP1,5
            IEXT= IEXT+1
            RNEW= TRIANG(IEXT)+SCALA2*WORK(IREV)
            WORK(IREV)= -SCALA1*TRIANG(IEXT)+WORK(IREV)
            TRIANG(IEXT)= RNEW
  300     CONTINUE
          GO TO 4
C
C          THIS SECTION IS FOR TRANSFORMATION TYPE-B. IF
C          <SCALB3> > 2.0 THIS ONE IS USED. OTHERWISE THE
C          TYPE-A TRANSFORMATION ABOVE IS USED INSTEAD.
C
    3     SCALB1= TRIANG(KPIVOT)/WORK(KROW)
          SCALB2= SCALB1*RSCALE(KROW)/WEIGHT
          SCALB3= 1.0+SCALB1*SCALB2
C
          IF (SCALB3.GT.2.0) GO TO 2
C
C          <WEIGHT>, [RSCALE], THE PIVOT VALUE AND ROWS ARE REVISED.
C
          VK= WEIGHT/SCALB3
          WEIGHT= RSCALE(KROW)/SCALB3
          RSCALE(KROW)= VK
C
          TRIANG(KPIVOT)= SCALB2*TRIANG(KPIVOT)+WORK(KROW)
C
          IEXT= KPIVOT
          DO 400 IREV= KROWP1,5
            IEXT= IEXT+1
            RNEW= SCALB2*TRIANG(IEXT)+WORK(IREV)
            WORK(IREV)= TRIANG(IEXT)-SCALB1*WORK(IREV)
            TRIANG(IEXT)= RNEW
  400     CONTINUE
C
C          THE POSITION OF THE PIVOT ELEMENT IS THEN UPDATED.
C
    4     KPIVOT= KPIVOT-KROW+6
  200   CONTINUE
        IF (NUSED.GT.4) GO TO 100
C
C          THIS COMPLETES THE SEQUENCE OF GIVENS-TRANSFORMATIONS. IF
C          THE R-MATRIX IS NOT COMPLETE, THE NEW ROW [WORK] IS ADDED.
C          <KPIVOT> IS THE START POSITION IN [TRIANG] OF THE NEW ROW.
C
    5   IEXT= KPIVOT
        DO 500 KOPY= NUSED,5
          TRIANG(IEXT)= WORK(KOPY)
          IEXT= IEXT+1
  500   CONTINUE
        RSCALE(NUSED)= WEIGHT
C
  100 CONTINUE
C
C          <IREPLY> IS SET TO 1 IF LESS THAN 4 DATA POINTS
C          WERE USED OR IF THE DATA POINTS ARE SUCH THAT
C          THE MATRIX OF EQUATIONS IS SINGULAR (EG. IF THE
C          POINTS ALL LIE ALONG ONE OR TWO STRAIGHT LINES).
C
      IREPLY= 1
      IF (NUSED.LT.4)               RETURN
      IF (ABS(TRIANG(13)).LT.CRMIN) RETURN
C
C          SOLUTION OF THE EQUATIONS YIELDS THE C-COEFFICIENTS.
C          THE RETURNED VALUE IS SET TO THAT OF COEFFICIENT C4.
C
      IREPLY= 0
      VALUE= TRIANG(14)/TRIANG(13)
C
      RETURN
      END


      SUBROUTINE slvsm2(u,rhs)
      DOUBLE PRECISION rhs(3,3),u(3,3)
CU    USES fill0
      DOUBLE PRECISION disc,fact,h
      call fill0(u,3)
      h=.5d0
      fact=2./h**2
      disc=sqrt(fact**2+rhs(2,2))
      u(2,2)=-rhs(2,2)/(fact+disc)
      return
      END

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


      subroutine sgefa(a,lda,n,ipvt,info)
      integer lda,n,ipvt(1),info
      real a(lda,1)
c
c     sgefa factors a real matrix by gaussian elimination.
c
c     sgefa is usually called by sgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for sgeco) = (1 + 9/n)*(time for sgefa) .
c
c     on entry
c
c        a       real(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that sgesl or sgedi will divide by zero
c                     if called.  use  rcond  in sgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy,sscal,isamax
c
c     internal variables
c
      real t
      integer isamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = isamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0e0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0e0/a(k,k)
            call sscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call saxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0e0) info = n
      return
      end


*DECK POCH1
      FUNCTION POCH1 (A, X)
C***BEGIN PROLOGUE  POCH1
C***PURPOSE  Calculate a generalization of Pochhammer's symbol starting
C            from first order.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1, C7A
C***TYPE      SINGLE PRECISION (POCH1-S, DPOCH1-D)
C***KEYWORDS  FIRST ORDER, FNLIB, POCHHAMMER, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate a generalization of Pochhammer's symbol for special
C situations that require especially accurate values when X is small in
C        POCH1(A,X) = (POCH(A,X)-1)/X
C                   = (GAMMA(A+X)/GAMMA(A) - 1.0)/X .
C This specification is particularly suited for stably computing
C expressions such as
C        (GAMMA(A+X)/GAMMA(A) - GAMMA(B+X)/GAMMA(B))/X
C             = POCH1(A,X) - POCH1(B,X)
C Note that POCH1(A,0.0) = PSI(A)
C
C When ABS(X) is so small that substantial cancellation will occur if
C the straightforward formula is used, we  use an expansion due
C to Fields and discussed by Y. L. Luke, The Special Functions and Their
C Approximations, Vol. 1, Academic Press, 1969, page 34.
C
C The ratio POCH(A,X) = GAMMA(A+X)/GAMMA(A) is written by Luke as
C        (A+(X-1)/2)**X * polynomial in (A+(X-1)/2)**(-2) .
C In order to maintain significance in POCH1, we write for positive A
C        (A+(X-1)/2)**X = EXP(X*LOG(A+(X-1)/2)) = EXP(Q)
C                       = 1.0 + Q*EXPREL(Q) .
C Likewise the polynomial is written
C        POLY = 1.0 + X*POLY1(A,X) .
C Thus,
C        POCH1(A,X) = (POCH(A,X) - 1) / X
C                   = EXPREL(Q)*(Q/X + Q*POLY1(A,X)) + POLY1(A,X)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  COT, EXPREL, POCH, PSI, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  POCH1
      DIMENSION BERN(9), GBERN(10)
      LOGICAL FIRST
      EXTERNAL COT
      SAVE BERN, PI, SQTBIG, ALNEPS, FIRST
      DATA BERN( 1) /   .8333333333 3333333E-01 /
      DATA BERN( 2) /  -.1388888888 8888889E-02 /
      DATA BERN( 3) /   .3306878306 8783069E-04 /
      DATA BERN( 4) /  -.8267195767 1957672E-06 /
      DATA BERN( 5) /   .2087675698 7868099E-07 /
      DATA BERN( 6) /  -.5284190138 6874932E-09 /
      DATA BERN( 7) /   .1338253653 0684679E-10 /
      DATA BERN( 8) /  -.3389680296 3225829E-12 /
      DATA BERN( 9) /   .8586062056 2778446E-14 /
      DATA PI / 3.1415926535 8979324 E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  POCH1
      IF (FIRST) THEN
         SQTBIG = 1.0/SQRT(24.0*R1MACH(1))
         ALNEPS = LOG(R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X.EQ.0.0) POCH1 = PSI(A)
      IF (X.EQ.0.0) RETURN
C
      ABSX = ABS(X)
      ABSA = ABS(A)
      IF (ABSX.GT.0.1*ABSA) GO TO 70
      IF (ABSX*LOG(MAX(ABSA,2.0)).GT.0.1) GO TO 70
C
      BP = A
      IF (A.LT.(-0.5)) BP = 1.0 - A - X
      INCR = 0
      IF (BP.LT.10.0) INCR = 11.0 - BP
      B = BP + INCR
C
      VAR = B + 0.5*(X-1.0)
      ALNVAR = LOG(VAR)
      Q = X*ALNVAR
C
      POLY1 = 0.0
      IF (VAR.GE.SQTBIG) GO TO 40
      VAR2 = (1.0/VAR)**2
C
      RHO = 0.5*(X+1.0)
      GBERN(1) = 1.0
      GBERN(2) = -RHO/12.0
      TERM = VAR2
      POLY1 = GBERN(2)*TERM
C
      NTERMS = -0.5*ALNEPS/ALNVAR + 1.0
      IF (NTERMS .GT. 9) CALL XERMSG ('SLATEC', 'POCH1',
     +   'NTERMS IS TOO BIG, MAYBE R1MACH(3) IS BAD', 1, 2)
      IF (NTERMS.LT.2) GO TO 40
C
      DO 30 K=2,NTERMS
        GBK = 0.0
        DO 20 J=1,K
          NDX = K - J + 1
          GBK = GBK + BERN(NDX)*GBERN(J)
 20     CONTINUE
        GBERN(K+1) = -RHO*GBK/K
C
        TERM = TERM * (2*K-2.-X)*(2*K-1.-X)*VAR2
        POLY1 = POLY1 + GBERN(K+1)*TERM
 30   CONTINUE
C
 40   POLY1 = (X-1.0)*POLY1
      POCH1 = EXPREL(Q)*(ALNVAR + Q*POLY1) + POLY1
C
      IF (INCR.EQ.0) GO TO 60
C
C WE HAVE POCH1(B,X).  BUT BP IS SMALL, SO WE USE BACKWARDS RECURSION
C TO OBTAIN POCH1(BP,X).
C
      DO 50 II=1,INCR
        I = INCR - II
        BINV = 1.0/(BP+I)
        POCH1 = (POCH1-BINV)/(1.0+X*BINV)
 50   CONTINUE
C
 60   IF (BP.EQ.A) RETURN
C
C WE HAVE POCH1(BP,X), BUT A IS LT -0.5.  WE THEREFORE USE A REFLECTION
C FORMULA TO OBTAIN POCH1(A,X).
C
      SINPXX = SIN(PI*X)/X
      SINPX2 = SIN(0.5*PI*X)
      TRIG = SINPXX*COT(PI*B) - 2.0*SINPX2*(SINPX2/X)
C
      POCH1 = TRIG + (1.0 + X*TRIG) * POCH1
      RETURN
C
 70   POCH1 = (POCH(A,X) - 1.0) / X
      RETURN
C
      END


      SUBROUTINE POWELL(P,XI,N,NP,FTOL,ITER,FRET)
      PARAMETER (NMAX=20,ITMAX=200)
      DIMENSION P(NP),XI(NP,NP),PT(NMAX),PTT(NMAX),XIT(NMAX)
      FRET=FUNC(P)
      DO 11 J=1,N
        PT(J)=P(J)
11    CONTINUE
      ITER=0
1     ITER=ITER+1
      FP=FRET
      IBIG=0
      DEL=0.
      DO 13 I=1,N
        DO 12 J=1,N
          XIT(J)=XI(J,I)
12      CONTINUE
        CALL LINMIN(P,XIT,N,FRET)
        IF(ABS(FP-FRET).GT.DEL)THEN
          DEL=ABS(FP-FRET)
          IBIG=I
        ENDIF
13    CONTINUE
      IF(2.*ABS(FP-FRET).LE.FTOL*(ABS(FP)+ABS(FRET)))RETURN
      IF(ITER.EQ.ITMAX) PAUSE 'Powell exceeding maximum iterations.'
      DO 14 J=1,N
        PTT(J)=2.*P(J)-PT(J)
        XIT(J)=P(J)-PT(J)
        PT(J)=P(J)
14    CONTINUE
      FPTT=FUNC(PTT)
      IF(FPTT.GE.FP)GO TO 1
      T=2.*(FP-2.*FRET+FPTT)*(FP-FRET-DEL)**2-DEL*(FP-FPTT)**2
      IF(T.GE.0.)GO TO 1
      CALL LINMIN(P,XIT,N,FRET)
      DO 15 J=1,N
        XI(J,IBIG)=XIT(J)
15    CONTINUE
      GO TO 1
      END


! ::: -----------------------------------------------------------
! ::: This routine is called at problem setup time and is used
! ::: to initialize values of physical constants used by the
! ::: radiation package.
! ::: -----------------------------------------------------------

subroutine ca_initradconstants(p, c, h, k, s, a, m, J_is_used) bind(C, name="ca_initradconstants")

  use fundamental_constants_module, only : c_fcm=>c_light, h_fcm=>hplanck, &
       k_fcm=>k_B, s_fcm=>sigma_SB, a_fcm=>n_A, ev2erg_fcm=>ev2erg

  use rad_params_module, only: pi, clight, hplanck
  use rad_params_module, only: kboltz, stefbol, arad, avogadro
  use rad_params_module, only: Hz2MeV, mev2erg, tiny
  use rad_params_module, only: radtoE  !, radtoJ, Etorad, radfluxtoF
  use rad_params_module, only: etafactor

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)         p, c, h, k, s, a, m
  integer J_is_used

  c = c_fcm
  h = h_fcm
  k = k_fcm
  s = s_fcm
  a = a_fcm
  m = 1.e6_rt * ev2erg_fcm

  pi       = p
  clight   = c
  hplanck  = h
  kboltz   = k
  stefbol  = s
  arad     = 4.*stefbol/clight
  avogadro = a
  mev2erg  = m
  Hz2MeV   = h / m
  tiny     = 1.e-50_rt

  if (J_is_used > 0) then
     radtoE = 4.e0_rt*pi/clight
     !           radtoJ = 1.0e0_rt
     !           Etorad = 1.e0_rt/radtoE
     !           radfluxtoF = 4.e0_rt*pi
     etafactor = 1.e0_rt
  else
     radtoE = 1.0e0_rt
     !           radtoJ = clight/(4.e0_rt*pi)
     !           Etorad = 1.0e0_rt
     !           radfluxtoF = 1.e0_rt
     etafactor = 4.e0_rt*pi/clight
  end if

end subroutine ca_initradconstants

! For single group, let set ngroups to 1.
subroutine ca_initsinglegroup(ngr) bind(C, name="ca_initsinglegroup")

  use rad_params_module, only : ngroups, nugroup, dnugroup, ng0, ng1
  use amrex_fort_module, only : rt => amrex_real
  implicit none
  integer ngr

  ! Local variables
  integer   :: i

  ng0 = 0
  ng1 = 0

  allocate(nugroup( 0:ngroups-1))
  allocate(dnugroup(0:ngroups-1))

  do i = 0, ngroups-1
     nugroup(i)  = 1.e0_rt  ! dummy
     dnugroup(i) = 1.e0_rt
  enddo
end subroutine ca_initsinglegroup

! ::: -----------------------------------------------------------
! ::: This routine is called at problem setup time and is used
! ::: to initialize the arrays nugroup and dnugroup in
! ::: probdata with the neutrino group energies and widths.
! :::
! ::: The widths are used to derive neutrino spectrum for plot files
! ::: -----------------------------------------------------------
subroutine ca_initgroups(nugr, dnugr, ngr, ngr0, ngr1)

  use rad_params_module, only: ngroups, ng0, ng1, nugroup, dnugroup

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)         nugr(0:ngr-1), dnugr(0:ngr-1)
  integer ngr, ngr0, ngr1

  ! Local variables
  integer   :: i

  ng0     = ngr0
  ng1     = ngr1

  allocate(nugroup( 0:ngroups-1))
  allocate(dnugroup(0:ngroups-1))

  do i = 0, ngroups-1
     nugroup(i)  = nugr(i)
     dnugroup(i) = dnugr(i)
  enddo

end subroutine ca_initgroups

subroutine ca_initgroups2(nugr, dnugr, xnugr, ngr)

  use rad_params_module, only: ngroups, nugroup, dnugroup, xnu, dlognu, lognugroup

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , intent(in) :: nugr(0:ngr-1), dnugr(0:ngr-1), xnugr(0:ngr)
  integer ngr

  ! Local variables
  integer   :: i

  allocate(nugroup( 0:ngroups-1))
  allocate(dnugroup(0:ngroups-1))
  allocate(xnu(0:ngroups))
  allocate(dlognu(0:ngroups-1))
  allocate(lognugroup(0:ngroups-1))

  nugroup(:) = nugr(:)
  dnugroup(:) = dnugr(:)
  xnu(:) = xnugr(:)
  lognugroup(:) = log(nugroup)

  dlognu(0:ngroups-1) = log(xnu(1:ngroups)) - log(xnu(0:ngroups-1))

end subroutine ca_initgroups2

subroutine ca_initgroups3(nugr, dnugr, dlognugr, xnugr, ngr, ngr0, ngr1)
  ! used by MGFLDSolver

  use rad_params_module, only: ngroups, ng0, ng1, nnuspec, nradspec, nugroup, dnugroup, &
       xnu, dlognu, lognugroup, erg2rhoYe, avogadro, hplanck

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , intent(in) :: nugr(0:ngr-1), dnugr(0:ngr-1), dlognugr(0:ngr-1), xnugr(0:ngr+2)
  integer ngr, ngr0, ngr1

  ! Local variables
  integer   :: i

  ng0     = ngr0
  ng1     = ngr1

  if (ng0 > 0) then
     if (ng1 .eq. 0) then
        nnuspec = 1  ! one neutrino species
     else if (ngroups .eq. ng0+ng1) then
        nnuspec = 2  ! two neutrino species
     else
        nnuspec = 3  ! three neutrino species
     end if
  else
     nnuspec = 0
  end if

  nradspec = max(nnuspec, 1)

  allocate(nugroup( 0:ngroups-1))
  allocate(dnugroup(0:ngroups-1))
  allocate(xnu(0:ngroups+2))
  allocate(dlognu(0:ngroups-1))
  allocate(erg2rhoYe(0:ngroups-1))
  allocate(lognugroup( 0:ngroups-1))

  nugroup(:) = nugr(:)
  dnugroup(:) = dnugr(:)
  xnu(:) = xnugr(:)
  dlognu(:) = dlognugr(:)
  lognugroup(:) = log(nugroup)

  erg2rhoYe = 0.e0_rt
  if (ng0 > 0) then
     erg2rhoYe(0:ng0-1) = 1.e0_rt / (avogadro*hplanck*nugroup(0:ng0-1))
     if (ng1 > 0) then
        erg2rhoYe(ng0:ng0+ng1-1) = -1.e0_rt / (avogadro*hplanck*nugroup(ng0:ng0+ng1-1))
     end if
  end if

end subroutine ca_initgroups3

! ::: -----------------------------------------------------------

subroutine ca_setgroup(igroup)

  use rad_params_module, only: current_group

  use amrex_fort_module, only : rt => amrex_real
  implicit none
  integer igroup

  current_group = igroup

end subroutine ca_setgroup

! ::: -----------------------------------------------------------

subroutine ca_inelastic_sct (lo, hi, &
     uu,uu_lo,uu_hi, &
     Er,Er_lo,Er_hi, &
     ks,ks_lo,ks_hi, &
     dt) bind(C)

  use meth_params_module, only : NVAR, UEDEN, UEINT, UTEMP
  use rad_params_module, only : ngroups, nugroup, dlognu
  use radhydro_nd_module, only: inelastic_scatter
  use amrex_fort_module, only : rt => amrex_real
  implicit none
  integer, intent(in) :: lo(3), hi(3)
  integer, intent(in) :: uu_lo(3),uu_hi(3)
  integer, intent(in) :: Er_lo(3),Er_hi(3)
  integer, intent(in) :: ks_lo(3),ks_hi(3)
  real(rt), intent(inout) :: uu(uu_lo(1):uu_hi(1),uu_lo(2):uu_hi(2),uu_lo(3):uu_hi(3),NVAR)
  real(rt), intent(inout) :: Er(Er_lo(1):Er_hi(1),Er_lo(2):Er_hi(2),Er_lo(3):Er_hi(3),0:ngroups-1)
  real(rt), intent(in   ) :: ks(ks_lo(1):ks_hi(1),ks_lo(2):ks_hi(2),ks_lo(3):ks_hi(3))
  real(rt), intent(in) :: dt

  integer :: i, j, k
  real(rt)         :: Ertotold, Ertmp(0:ngroups-1), dEr
  real(rt)         :: Erscale(0:ngroups-1)

  Erscale = nugroup*dlognu

  do       k = lo(3), hi(3)
     do    j = lo(2), hi(2)
        do i = lo(1), hi(1)
           Ertmp = Er(i,j,k,:)
           Ertotold = sum(Ertmp)
           Ertmp = Ertmp / Erscale

           call inelastic_scatter(uu(i,j,k,UTEMP), Ertmp, ks(i,j,k), dt, (/i,j,k/))

           Ertmp = Ertmp * Erscale
           dEr = sum(Ertmp) - Ertotold
           Er(i,j,k,:) = Ertmp
           uu(i,j,k,UEINT) = uu(i,j,k,UEINT) - dEr
           uu(i,j,k,UEDEN) = uu(i,j,k,UEDEN) - dEr
        end do
     end do
  end do

end subroutine ca_inelastic_sct

! ::: -----------------------------------------------------------

subroutine ca_compute_scattering(lo, hi, &
     kps,kps_lo,kps_hi, &
     sta,sta_lo,sta_hi)

  use rad_params_module, only : ngroups, nugroup
  use opacity_table_module, only : get_opacities
  use network, only : naux
  use meth_params_module, only : NVAR, URHO, UTEMP, UFX

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer, intent(in) :: lo(3), hi(3)
  integer, intent(in) :: kps_lo(3),kps_hi(3)
  integer, intent(in) :: sta_lo(3),sta_hi(3)
  real(rt), intent(inout) :: kps(kps_lo(1):kps_hi(1),kps_lo(2):kps_hi(2),kps_lo(3):kps_hi(3))
  real(rt), intent(in   ) :: sta(sta_lo(1):sta_hi(2),sta_lo(2):sta_hi(2),sta_lo(3):sta_hi(3),NVAR)

  integer :: i, j, k
  real(rt)         :: kp, kr, nu, rho, temp, Ye
  logical, parameter :: comp_kp = .true.
  logical, parameter :: comp_kr = .true.

  ! scattering is assumed to be independent of nu.

  nu = nugroup(0)

  do k = lo(3), hi(3)
     do j = lo(2), hi(2)
        do i = lo(1), hi(1)

           rho = sta(i,j,k,URHO)
           temp = sta(i,j,k,UTEMP)
           if (naux > 0) then
              Ye = sta(i,j,k,UFX)
           else
              Ye = 0.e0_rt
           end if

           call get_opacities(kp, kr, rho, temp, Ye, nu, comp_kp, comp_kr)

           kps(i,j,k) = max(kr - kp, 0.e0_rt)
        end do
     end do
  end do

end subroutine ca_compute_scattering

subroutine ca_compute_scattering_2(lo, hi, &
     kps,kps_lo,kps_hi, &
     sta,sta_lo,sta_hi, &
     k0_p, m_p, n_p, &
     k0_r, m_r, n_r, &
     Tfloor, kfloor)

  use rad_params_module, only : ngroups, nugroup
  use meth_params_module, only : NVAR, URHO, UTEMP

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer, intent(in) :: lo(3), hi(3)
  integer, intent(in) :: kps_lo(3),kps_hi(3)
  integer, intent(in) :: sta_lo(3),sta_hi(3)
  real(rt), intent(inout) :: kps(kps_lo(1):kps_hi(1),kps_lo(2):kps_hi(2),kps_lo(3):kps_hi(3))
  real(rt), intent(in   ) :: sta(sta_lo(1):sta_hi(2),sta_lo(2):sta_hi(2),sta_lo(3):sta_hi(3),NVAR)
  real(rt), intent(in) :: k0_p, m_p, n_p
  real(rt), intent(in) :: k0_r, m_r, n_r
  real(rt), intent(in) :: Tfloor, kfloor

  integer :: i, j, k
  real(rt)        , parameter :: tiny = 1.0e-50_rt
  real(rt)         :: Teff, k_p, k_r

  ! scattering is assumed to be independent of nu.

  if ( m_p.eq.0.e0_rt .and. n_p.eq.0.e0_rt .and. &
       m_r.eq.0.e0_rt .and. n_r.eq.0.e0_rt ) then
     do k = lo(3), hi(3)
        do j = lo(2), hi(2)
           do i = lo(1), hi(1)
              kps(i,j,k) = k0_r - k0_p
           end do
        end do
     end do
  else
     do k = lo(3), hi(3)
        do j = lo(2), hi(2)
           do i = lo(1), hi(1)
              Teff = max(sta(i,j,k,UTEMP), tiny)
              Teff = Teff + Tfloor * exp(-Teff / (Tfloor + tiny))
              k_p = k0_p * (sta(i,j,k,URHO) ** m_p) * (Teff ** (-n_p))
              k_r = k0_r * (sta(i,j,k,URHO) ** m_r) * (Teff ** (-n_r))
              kps(i,j,k) = max(k_r-k_p, kfloor)
           end do
        end do
     end do
  end if

end subroutine ca_compute_scattering_2


*********************************************************************
*Simulation of 2D Ising model using MC method
*********************************************************************

      program xy2dModel
	use randomSeed, only : getRandom
	use constantClass, only : LDIM, RANLSTSZE, CHKSTP, AVGEQSTP
	use crysProcClass, only : writeChainIsing1d
	use statProcClass, only : isingCluster
	use dataProcClass, only : getLatticeFile
	implicit none

	integer*2, dimension(:), allocatable :: crys(:)
	double precision, dimension(:), allocatable :: rLst(:)
	double precision, dimension(:) :: expDif(0 : LDIM)
	integer, dimension(:) :: local(1 : (2 * LDIM))
	character(len=64) :: arg
	integer :: lSze, lVol,
     $	           stpNum, eqStp, calStp,
     $	           pos, ergDif,
     $	           crysID,
     $	           rPos,
     $	           i, j, k,
     $	           success
	double precision :: temp, rVal

*********************************************************************
c	Get command-line argument
*********************************************************************
	i = iargc()
	if(i .ne. 4) then
	  call commandError()
	endif

	call getarg(1, arg)
	read(arg, *) lSze
	if(lSze .lt. 1) then
	  call commandError()
	endif

	call getarg(2, arg)
	read(arg, *) temp
	if(temp .le. 0.0) then
	  call commandError()
	endif

	call getarg(3, arg)
	read(arg, *) stpNum
	call getarg(4, arg)
	read(arg, *) calStp
	if((stpNum .lt. 1) .or. (calStp .gt. stpNum)) then
	  call commandError()
	endif

*********************************************************************
c	initialization
*********************************************************************
	crysID = 20
	lVol = lSze ** LDIM
	eqStp = stpNum / 2
	if(eqStp .lt. (AVGEQSTP * lVol)) then
	  eqStp = AVGEQSTP * lVol
	endif
	stpNum = stpNum + eqStp

	write(*,*), lSze, temp, stpNum, eqStp

	expDif(0) = 1 - exp(-2.0 / temp)
	do i = 1, LDIM
	  expDif(i) = exp(-4.0 * i / temp)
	enddo

	allocate(rLst(1 : lVol))
	rPos = lVol

	success = 0

*********************************************************************
c	Create lattice
*********************************************************************
	allocate(crys(1:lVol))

*********************************************************************
c	Initialize spin
*********************************************************************
c	Randomize spin
	do i = 1, lVol
	  call getRandom(rVal, rPos, rLst)
	  if(rVal .ge. 0.5) then
	    crys(i) = 1
	  else
	    crys(i) = -1
	  endif
	enddo

	deallocate(rLst)
	allocate(rLst(1 : RANLSTSZE))
	rPos = RANLSTSZE

*********************************************************************
c	Energy evaluation
*********************************************************************
c	call energyIsing2d(l, erg)

*********************************************************************
c	MC simulation
*********************************************************************
	call getLatticeFile(lSze, temp, crysID)

	do i = 1, stpNum
	  call isingCluster(crys, lSze, rLst, rPos, expDif(0))
c	  call isingMetropolis(crys, lSze, rLst, rPos, expDif(1:LDIM))
	  if(i .gt. eqStp) then
	    if(mod(i, calStp) .eq. 0) then
	      call writeChainIsing1d(crys, crysID)
	    endif
	  endif
	enddo

	write(*,*), (real(success) / (stpNum * lVol)), lSze, lVol, temp

	close(crysID)
	deallocate(crys)
	deallocate(rLst)

      contains

	subroutine commandError()
	  write(*,*) 'Invalid command-line arguments'
	  write(*,*) 'Usage:'
	  write(*,*) './(programName) (latticeSize) (temperature) ',
     $	             '(stepNumber) (stepPerMeasure)'
	  write(*,*) '(latticeSize) must be even'
	  write(*,*) '(temperature) must be positive'
	  write(*,*) '(stepNumber) must be positive'
	  call exit(1)
	end subroutine
      end program


	SUBROUTINE GDRGRD  ( dellat, dellon, lblfrq, blat, blon,
     +                       ifrmat, iret )
C************************************************************************
C* GDRGRD								*
C* 									*
C* This subroutine draws a uniform latitude/longitude grid.  The map 	*
C* projection must be defined before GDRGRD is called. The current 	*
C* color, line and text attributes will be used.  The latitude and 	*
C* longitude intervals are given in degrees.				*
C* 									*
C* GDRGRD  ( DELLAT, DELLON, LBLFRQ, BLAT, BLON, IFRMAT, IRET )		*
C* 									*
C* Input parameters:							*
C*	DELLAT		REAL  		Latitude interval 		*
C*	DELLON		REAL		Longitude interval 		*
C*	LBLFRQ (2)	INTEGER		Label frequency			*
C*				  	  0 = no grid labels		*
C*				   	  1 = every grid line		*
C*				   	  2 = every other grid line	*
C*				   	  n = every n-th line		*
C*	BLAT		REAL		Longitude label locations	*
C*	BLON		REAL		Latitiude label locations	*
C*	IFRMAT		INTEGER		Lat/lon format			*
C*					  1 = +/- value			*
C*					  2 = N,S,E,W added, no '-'	*
C*					  Defaults to 1 if not set to 2 *
C* 									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 3/82						*
C* M. Vilardo/RDS	 6/84	GEMPLT Version 3.0			*
C* M. Vilardo/RDS	 7/85	GEMPLT Version 3.1			*
C* I. Graffman/RDS	 8/86	Added grid line annotation		*
C* M. desJardins/GSFC	 5/88	Eliminated call to GFLUSH		*
C* K. F. Brill/GSC	 4/89   Fixed labelling; extended parallels	*
C* K. Brill/GSC          1/90   Use PRNLON for longitude labels		*
C* K. Brill/GSC          1/90   Check for cut for conic projections	*
C* K. Brill/GSC          1/90   Label meridians at north for SH maps	*
C* K. Brill/NMC          8/90   Fix parallels gap; remove left meridian *
C* K. Brill/NMC          8/90   Fix labelling problems			*
C* K. Brill/NMC          9/90   Increase resolution from 2 to .25 deg	*
C* K. Brill/NMC		 1/91   Decimal lon>100; remove bottom lat line;*
C*                              shift lat labels.			*
C* J. Whistler/SSAI	 8/91	Changed LBFREQ to a 2-D array		*
C* S. Jacobs/EAI	 1/93	Added check for South Pole; Cleaned up	*
C* S. Jacobs/EAI	10/93	Changed CLABEL --> GR_LABL		*
C* K. Brill/NMC		 1/94	Check to stop the DO WHILE (.not. done) *
C*				loops by checking too big lat or lon	*
C* S. Jacobs/EAI	 2/94	Added check for satellite projections	*
C* J. Cowie/COMET	 3/95   Added MCGOES and MCGVAR to sat proj	*
C* S. Jacobs/NMC	 6/95	Check for missing values from GTRANS	*
C*				for computing the line vertices		*
C* M. Linda/GSC		12/95	Removed navtyp = NPGS 			*
C* L. Sager/NCEP 	12/95   Fixed error in lat/lon plotting		*
C* K. Brill/EMC		 3/96	Changes for general rotated projections *
C* S. Jacobs/NCEP	 3/97	Added check for UTF and VG drivers	*
C* T. Lee/GSC		 9/97	Fixed typo, ILLON -> IILON		*
C* A. Hardy/GSC          9/98   Added check for RBK driver              *
C* S. Danz/AWC           5/99   Added check for date-line crossover     *
C* T. Piper/GSC		12/99	Slight change to dmin calculation	*
C* A. Hardy/GSC		12/00   Added lat/lon label locations, format	*
C* J. Cowie/COMET	12/00	Added MCRADR projection type		*
C* S. Jacobs/NCEP	 2/01	Changed label for 0 lat & 0,180 lon	*
C* S. Chiswell/Unidata	 2/02	Added MCMSAT, MCGMSX, MCMOLL projection	*
C* T. Lee/SAIC		 4/03	Fixed latitude plot when pole is in view*
C* S. Jacobs/NCEP	 9/05	Check both X & Y for lat/lon label loc	*
C* M. James/Unidata	10/14	Added MCRECT projection	                *
C* M. James/Unidata	02/18	Added MCABIN fixed grid projection	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERROR.PRM'
	INCLUDE 	'XYDEF.CMN'
	INCLUDE 	'DEVCHR.CMN'
C*
	PARAMETER	( MXPTS = 1442 )
C*
	INTEGER		lblfrq (*)
C*
	REAL		alat ( MXPTS ), alon ( MXPTS )
	REAL		alatl ( MXPTS ), alonl ( MXPTS )
	REAL		xp (2), yp (2)
	CHARACTER 	string*20, proj*4, drct*1
	CHARACTER	navtyp*8, imgnam*80
	LOGICAL		done, hvnpol, hvspol, notcut, needdl, drawit
	LOGICAL		topole
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	If the device is UTF, VG or RBK, do not draw the lat/lon lines.
C
	IF  ( ( ddev .eq. 'UTF' ) .or. ( ddev .eq. 'VG' ) .or.
     +        ( ddev .eq. 'RBK' ) )  RETURN
C*
	needdl = .true.
	imxpm1 = MXPTS - 1
C
C*	Check for map mode.
C
	igmode = 1
	IF ( igmode .ne. 1 ) THEN
C*
	    iret = nimode
C*
	ELSE
C
C*	    Query map projection setup to get center longitude.
C
	    CALL GQMPRJ ( proj, angl1, clon, angl3,
     +			  dlatmn, dlonmn, dlatmx, dlonmx, iret )
C
C*	    Check for satellite navigation.
C
	    IF  ( iret .ne. NORMAL )  THEN
		CALL GQSATN ( navtyp, imgnam, ier )
		IF  ( ( navtyp .ne. 'MCIDAS' ) .and.
     +			( navtyp .ne. 'MCGOES' ) .and.
     +			( navtyp .ne. 'MCGOE4' ) .and.
     +			( navtyp .ne. 'MCGVAR' ) .and.
     +			( navtyp .ne. 'MCMSAT' ) .and.
     +			( navtyp .ne. 'MCGMSX' ) .and.
     +			( navtyp .ne. 'MCMOLL' ) .and.
     +			( navtyp .ne. 'MCRECT' ) .and.
     +			( navtyp .ne. 'MCABIN' ) .and.
     +			( navtyp .ne. 'MCRADR' ) ) RETURN
	    END IF
C
C*	    Query the boundaries in map coordinates.
C*
	    CALL GQBND ( 'M', rlatmn, rlonmn, dlatmx, dlonmx, iret )
	    IF  ( iret .ne. NORMAL )  RETURN
C
C*	    Check  for possible wrap around the date line
C
	    IF  ( dlonmx .lt. rlonmn )  dlonmx = 360 + dlonmx
C
C*	    Query plot region.
C
	    CALL GQBND ( 'P', vlp, vbp, vrp, vtp, iret)
	    IF  ( iret .ne. NORMAL )  RETURN
C
C*          Find out if poles are visible and find fractional position.
C
	    CALL GPTVIS ( 'M', 1, 90.0, 0.0, hvnpol, iret )
	    IF  ( iret .ne. NORMAL )  RETURN
	    IF  ( hvnpol )  THEN
		CALL GTRANS ( 'M', 'N', 1, 90.0, 0.0, xnp, ynp, ier )
		fractn = ( ynp - vbp ) / ( vtp - vbp )
	    END IF
	    CALL GPTVIS ( 'M', 1, -90.0, 0.0, hvspol, iret )
	    IF  ( iret .ne. NORMAL )  RETURN
	    IF  ( hvspol )  THEN
		CALL GTRANS ( 'M', 'N', 1, -90.0, 0.0, xnp, ynp, ier )
		frctn2 = ( ynp - vbp ) / ( vtp - vbp )
	    END IF
C
C*	    Query symbol sizes.
C
	    CALL GQSYSZ ( wm, hm, wt, ht, wb, hb, iret )
	    IF  ( iret .ne. NORMAL )  RETURN
C
C*	    Compute tolerances for determining endpts of
C*	    lat & lon lines. (Leave space for labels.)
C
	    tollat = .5 * ht * ( dlatmx - rlatmn ) / ( vtp - vbp )
	    tollon = .5 * wt * ( dlonmx - rlonmn ) / ( vrp - vlp )
C
C*	    Calculate the starting, ending and number of parallels.
C
	    IF  ( rlatmn .lt. 0.0 .or. MOD(rlatmn,dellat) .eq. 0 )  THEN
		slat = INT ( rlatmn / dellat ) * dellat
	    ELSE
		slat = ( INT ( rlatmn / dellat ) + 1 ) * dellat
	    END IF
	    IF  ( dlatmx .gt. 0.0 .or. MOD(dlatmx,dellat) .eq. 0 )  THEN
		elat = INT ( dlatmx / dellat ) * dellat
	    ELSE
		elat = ( INT ( dlatmx / dellat ) - 1 ) * dellat
	    END IF
	    nlat = ( elat - slat ) / dellat
C
C*	    Determine where to start the labeling so that the first
C*          label is a whole number if possible.
C
	    IF  ( lblfrq(1) .gt. 1 )  THEN
		done = .false.
		iilat = 0
		DO  WHILE ( .not. done .and. iilat .gt. -11 )
		    iilat = iilat - 1
		    rqlat = slat - FLOAT ( iilat + 1 ) * dellat
		    tstlt = FLOAT ( INT ( rqlat ) )
		    IF  ( ABS(tstlt-rqlat) .lt. 10e-5 )  done = .true.
		END DO
		IF ( IABS (iilat) .gt. lblfrq(1) ) iilat = -1
	    ELSE
		iilat = -1
	    END IF
C
C*	    Loop thru latitude range.
C
	    IF  ( slat .le. rlatmn )  THEN
		ist01 = 1
	    ELSE
		ist01 = 0
	    END IF
	    DO  ilat = ist01, nlat
		iilat = iilat + 1
		rqlat = slat + ilat * dellat
		dlonmn = rlonmn
		IF  ( lblfrq(1) .gt. 0 )  THEN
		    dlt = rqlat
		    done = .false.
		    DO  WHILE (.not. done)
C
C*			Find location of west lon and latitude.
C
			dln = dlonmn
			CALL GTRANS ( 'M', 'N', 1, dlt, dln,
     +				      dmnln, dnly, ier )
C
C*	                Find min, calc location and compare.
C
			IF ( ERMISS ( dmnln ) ) THEN
			    dmin = vlp
			ELSE
			    dmin = dmnln - 4. * wt
			END IF
			IF  ( dmin .lt. vlp )  THEN
			    IF  ( .not. hvnpol .and. .not. hvspol ) THEN
				dlonmn = dlonmn + tollon
			      ELSE
				done = .true.
			    END IF
C
			    IF ( dlonmn .gt. 360. ) THEN
				dlonmn = 360.
			        done = .true.
			    END IF
			ELSE
			    done = .true.
			END IF
		    END DO
		END IF
C
C*	        Calculate the number of line segemets required to draw
C*		a parallel. Parallels must be split up into line
C*		segemnts of .25 degrees longitude to be sure that any
C*		curvature in the parallel is correctly displayed.
C
		nlons = ABS(   dlonmx - dlonmn ) / .250 + 1.0
		dlons = ABS( ( dlonmx - dlonmn ) / FLOAT( nlons - 1 ) )
C
C*	        Loop thru .25 degree longitude segments.
C*		Calculate coordinates.
C
		IF ( nlons .gt. imxpm1 ) nlons = imxpm1
		DO  ilons = 0, nlons
		    alat( ilons + 1 ) = rqlat
		    alon( ilons + 1 ) = dlonmn + ilons * dlons
		END DO
C
C*		Move latitudes and longitudes into plotting arrays.
C
		CALL PRNLON ( nlons, alon, ier )
		DO  i = 1, nlons
		    alatl( i ) = alat( i )
		    alonl( i ) = alon( i )
		    IF ( i .ne. 1 ) THEN
			IF  ( alonl (i)   .lt. 0.0 .and.
     +                    alonl (i-1) .gt. 0.0 )  THEN
			    alonl (i-1) = 180.
			    alonl (i) = -180.
			END IF
		    END IF
		END DO
C
C*		Plot line for parallel.
C
		IF  ( mclass .ne. 3 )  THEN
C
C*		    Line will be continuous.
C
		    CALL GLINE  ( 'M', nlons, alatl, alonl, ierr )
		ELSE
C
C*                  If the line crosses the conic cut, it must be
C*                  done in pieces.
C
		    cutang = clon + 180.
		    CALL PRNLON ( 1, cutang, ier )
		    istrt = 1
		    indx  = 1
		    DO  WHILE ( indx .lt. nlons )
			notcut = .true.
			icnt = 0
			DO  WHILE ( notcut )
			    icnt = icnt + 1
			    inm1 = indx
			    indx = indx + 1
			    pxll = alonl (inm1) * alonl (indx)
			    IF  ( alonl (indx) .eq. cutang   .or.
     +			          ( alonl (inm1) .gt. cutang .and.
     +                              alonl (indx) .lt. cutang ) .or.
     +                            ( alonl (inm1) .lt. cutang .and.
     +                              alonl (indx) .gt. cutang ) .or.
     +                            ( cutang .eq. 180. .and.
     +				    pxll .lt. 0. )            .or.
     +                            ( cutang .eq. -180. .and.
     +                              pxll .lt. 0. )         )  THEN
				IF  ( alonl (istrt) .eq. cutang )  THEN
				    istrt = istrt + 1
				    icnt  = icnt - 1
				END IF
				IF  ( alonl(istrt+icnt-1) .eq. cutang )
     +				    icnt = icnt - 1
				IF  ( icnt .gt. 1 )
     +				    CALL GLINE ( 'M', icnt,
     +						 alatl(istrt),
     +						 alonl (istrt), ierr )
C*
				notcut = .false.
				istrt  = indx
			    ELSE IF  ( indx .eq. nlons )  THEN
				icnt = icnt + 1
				IF  ( alonl (istrt) .eq. cutang )  THEN
				    istrt = istrt + 1
				    icnt  = icnt - 1
				END IF
				IF  ( alonl(istrt+icnt-1) .eq. cutang )
     +				    icnt = icnt - 1
				IF  ( icnt .gt. 1 )
     +				    CALL GLINE ( 'M', icnt,
     +						 alatl (istrt),
     +						 alonl (istrt), ierr )
				notcut = .false.
			    END IF
			END DO
		    END DO
		END IF
C
C*		If label is requested for this parallel begin label
C*		processing.
C
		IF  ( lblfrq(1) .gt. 0 .and. iilat .ge. 0 .and.
     +		      MOD ( iilat, lblfrq(1) ) .eq. 0 )  THEN
		    al =  slat + ilat * dellat
C
C*		    If the pole is less than six tenths of the way
C*		    between the bottom and top of the plot, then the
C*		    labelling is done along the central longitude on
C*		    the opposite side of the pole.
C
 		    IF (  ERMISS ( blon )  ) THEN
		        IF  ( hvnpol .and. mclass .ne. 1 )  THEN
			    IF  ( fractn .lt. 0.6 )  THEN
			        a180 = 180.
			      ELSE
			        a180 = 0.0
			    END IF
			    IF  ( clon .lt. 0. )  THEN
			        bot = clon + a180
			      ELSE
			        bot = clon - a180
			    END IF
		          ELSE IF  ( hvspol .and. mclass .ne. 1 )  THEN
			    IF  ( frctn2 .lt. 0.6 )  THEN
			        a180 = 180.
			      ELSE
			        a180 = 0.0
			    END IF
			    IF  ( clon .lt. 0. )  THEN
			        bot = clon + a180
			      ELSE
			        bot = clon - a180
			    END IF
		          ELSE
			    bot = dlonmn
		        END IF
                      ELSE
                        bot = blon
                    END IF
C
C*                  Use 'N' and 'S' for encoding the label string.
C
                    IF ( ifrmat .eq. 2 ) THEN
                        IF ( al .lt. 0. ) THEN
			    al2 = ABS ( al )
                            drct = 'S'
        		  ELSE IF ( al .gt. 0. ) THEN
			    al2 = al
                            drct = 'N'
        		  ELSE
			    al2 = al
                            drct = ' '
                        END IF
		        CALL GR_LABL ( al2, 0, 0, string, len, ier )
                        len = len + 1
                        string (len:len) = drct
		        ishft = (-len) * 2
                      ELSE
		        CALL GR_LABL ( al, 0, 0, string, len, ier )
		        ishft = (-len) * 2
		    END IF
C
C*		    Plot the label.
C
		    CALL GTRANS ( 'M', 'V', 1, al, bot, x, y, ier )
		    IF  ( ( x .gt. vlp .and. x .lt. vrp ) .and.
     +			  ( y .gt. vbp .and. y .lt. vtp ) )
     +			CALL GTEXT ( 'V', x, y, string (1:len), 0.,
     +				     ishft, 0, ier )
		 END IF
	    END DO
C
C*	    Calculate the starting, ending and number of meridians.
C
	    IF  ( rlonmn .lt. 0.0 .or. MOD(rlonmn,dellon) .eq. 0 )  THEN
		slon = INT ( rlonmn / dellon ) * dellon
	    ELSE
		slon = ( INT ( rlonmn / dellon ) + 1 ) * dellon
	    END IF
	    IF  ( dlonmx .gt. 0.0 .or. MOD(dlonmx,dellon) .eq. 0 )  THEN
		elon = INT ( dlonmx / dellon ) * dellon
	    ELSE
		elon = ( INT ( dlonmx / dellon ) - 1 ) * dellon
	    END IF
	    nlon = ( elon - slon ) / dellon
C
C*	    Determine where to start the labeling so that the first
C*          label is a whole number if possible.
C
	    IF  ( lblfrq(2) .gt. 1 )  THEN
		done = .false.
		iilon = 0
		DO  WHILE ( .not. done .and. iilon .gt. -11 )
		    iilon = iilon - 1
		    rqlon = slon - FLOAT ( iilon ) * dellon
		    tstln = FLOAT ( INT ( rqlon ) )
		    IF  ( ABS(tstln-rqlon) .lt. 10e-5 )  done = .true.
		END DO
		IF  ( IABS ( iilon ) .gt. lblfrq(2) )  iilon = 0
	    ELSE
		iilon = 0
	    END IF
	    test = ABS ( slon - rlonmn )
	    IF  ( test .lt. ( .5 * dellon ) )  THEN
		ist01 = 1
	    ELSE
		ist01 = 0
	    END IF
	    DO  ilon = ist01, nlon
		iilon  = iilon + 1
		rqlon  = slon + ilon * dellon
		dlatmn = rlatmn
		dmxlat = dlatmx
		IF  ( lblfrq(2) .gt. 0 )  THEN
		    done = .false.
		    dln = rqlon
		    DO  WHILE ( .not. done )
C
C*	                Find location in N coordinates of
C*			longitude and South lat.
C
			dlt = dlatmn
			CALL GTRANS ( 'M', 'N', 1, dlt, dln,
     +				      wlx, dmnlt, iret )
C
C*			Find minimum, calc location and compare to
C*			view region.
C
			IF ( ERMISS ( dmnlt ) ) THEN
			    dmin = vbp
			ELSE
			    dmin = dmnlt -  ht
			END IF
			IF  ( dmin .lt. vbp )  THEN
				dlatmn = dlatmn + tollat
				IF ( dlatmn .gt. 90. ) done = .true.
			ELSE
				done = .true.
			END IF
		    END DO
		END IF
C
C*		Calculate the number of line segemets required to
C*		draw a meridian. Meridians must be split up into
C*		line segemnts of .25 degrees latitude to be sure
C*		that any curvature in the meridian is correctly
C*		displayed.
C
C*		Loop thru longitude range.
C*		Loop thru .25 degree latitude segments.
C
		altmx = dlatmx
		altmn = dlatmn
		qmer0 = angle1 + angle3
		IF  ( proj .eq. 'MCD' )  THEN
		    topole = .true.
		  ELSE
		    topole = ((qmer0 .eq. 0) .and. (mclass .eq. 1))
		END IF
	  	IF ( dlatmx .gt. 80. .and. .not. topole ) THEN
		    xp (1) = 90.
		    yp (1) = slon
		    xp (2) = 90.
		    yp (2) = elon
		    CALL GTRANS ( 'M', 'N', 2, xp, yp, xp, yp, ier )
		    dx = ABS ( xp (2) - xp (1) )
		    IF ( dx .lt. .01 ) THEN
		        nlats = ABS( 80.0 - altmn ) / .250 + 1.0
		        dlats = ABS( ( 80.0 - altmn ) /
     +				FLOAT( nlats - 1 ) )
		    END IF
		    altmx = 80.0
		END IF
		IF ( rlatmn .lt. -80. .and. .not. topole ) THEN
		    xp (1) = -90.
		    yp (1) = slon
		    xp (2) = -90.
		    yp (2) = elon
		    CALL GTRANS ( 'M', 'N', 2, xp, yp, xp, yp, ier )
		    dx = ABS ( xp (2) - xp (1) )
		    IF ( dx .lt. .01 ) THEN
		        nlats = ABS( altmx - (-80.0) ) / .250 + 1.0
		        dlats = ABS( ( altmx - (-80.0) ) /
     +				FLOAT( nlats - 1 ) )
		    END IF
		    altmn = -80.
		END IF
		IF ( ( .not. ( rlatmn .lt. -80. ) .and.
     +		       .not. ( dlatmx .gt. +80. ) ) .or.
     +			topole ) THEN
		    nlats = ABS( altmx - altmn ) / .250 + 1.0
		    dlats = ABS( ( altmx - altmn ) /
     +				FLOAT( nlats - 1 ) )
		END IF
C
C*		Loop thru .25 degree latitude segments.
C*		Calculate coordinates.
C
		IF ( nlats .gt. imxpm1 ) nlats = imxpm1
		DO  ilats = 0, nlats
		    alat( ilats + 1 ) = altmn + ilats * dlats
		    alon( ilats + 1 ) = rqlon
		END DO
C
C*		Move latitudes and longitudes into plotting arrays.
C
		DO  i = 1, nlats
		    alatl( i ) = alat( i )
		    alonl( i ) = alon( i )
		END DO
C
C*	    	Plot line for meridian.
C
		CALL GLINE ( 'M', nlats, alatl, alonl, ierr )
C
C*		If label is requested for this meridian begin label
C*		processing.
C
		at = rqlon
		CALL PRNLON ( 1, at, ier )
C
C*		Only label the dateline one time.
C
		naint = nint ( at )
		IF  ( naint .eq. 180 .or. naint .eq. -180 )  THEN
		    IF  ( needdl )  THEN
			drawit = .true.
		    ELSE
			drawit = .false.
		    END IF
		    needdl = .false.
		ELSE
		    drawit = .true.
		END IF
		IF  ( ( lblfrq(2) .gt. 0 ) .and. ( iilon .ge. 0 ) .and.
     +                ( MOD( iilon, lblfrq(2) ) .eq. 0 ) .and.
     +		      ( drawit ) )  THEN
                    IF ( ERMISS ( blat ) ) THEN
		        side = altmn
		        IF  ( side .lt. -89.9 )  side = altmx
                      ELSE
                        side = blat
                    END IF
C
C*                  Use 'E' and 'W' for encoding the label string.
C
		    IF ( ifrmat .eq. 2 ) THEN
                        IF ( at .lt. 0. ) THEN
                            at2 = ABS (at)
			    IF  ( at .eq. -180. )  THEN
				drct = ' '
			      ELSE
				drct = 'W'
			    END IF
                          ELSE IF ( at .gt. 0. ) THEN
                            at2 = at
			    IF  ( at .eq. 180. )  THEN
				drct = ' '
			      ELSE
				drct = 'E'
			    END IF
                          ELSE
                            at2 = at
                            drct = ' '
 			END IF
		        CALL GR_LABL ( at2, 0, 0, string, len, ier )
                        len = len + 1
			string ( len:len ) = drct
		        jshft = -len
		      ELSE
		        CALL GR_LABL ( at, 0, 0, string, len, ier )
		        jshft = -len
		    END IF
C
C*		    Plot the label.
C
		    CALL GTRANS ( 'M', 'V', 1,  side, at, x, y, ier)
		    IF  ( ( x .gt. vlp .and. x .lt. vrp ) .and.
     +			  ( y .gt. vbp .and. y .lt. vtp ) )
     +			CALL GTEXT ( 'V', x, y, string (1:len), 0.,
     +				     jshft, -1, ier )
		END IF
	    END DO
	END IF
C*
	RETURN
	END


      SUBROUTINE LUMLLP(SLAT,SLON,PLAT,PLON,RPOL,REQU,RANGE,RLAT,RLON,
     *  TG,CG,CI,CE,LUMLAT,LUMLON,MODE,ifirst)

C  SLAT,SLON= SUBSOLAR POINT , WEST
C  PLAT,PLON= SUBSPACECRAFT POINT , WEST
C  RLAT,RLON = PIXEL POSITION , WEST
C  RPOL,REQU = PLANET RADIUS (KM)
C  ALL VALUES IN RADIANS
C  RANGE = S.C. TO PLANET CENTER DISTANSE (KM)   IF(RANGE)=0. MEANS=INFI
C  RETURNS TG=TAN PHASE ANGLE ,MAX VALUE LIMITED TO 1000.
C  RETURNS CG=COSINE PHASE ANGLE
C  RETURNS CI=COSINE INCIDENCE ANGLE
C  RETURNS CE=COSINE EMISSION ANGLE
C  IF RANGE=0.0 CE IS COMPUTED FOR RANGE=INFINITY
C  RETURNS LUMLAT,LUMLON = LUMINANCE LATITUDE,LONGITUDE  IF(MODE.NE.0)
C  LUMLON IS EAST LONGITUDE
C  MODE =0 FOR RETURN WITHOUT LUMLAT,LUMLON COMPUTED

      SAVE  ! SAVE VARIABLES BETWEEN SUCCESSIVE CALLS

      REAL AS(3),AL(3),C(10),HR(3,3),PI,PI2
      REAL LUMLAT,LUMLON,PIO2
      INTEGER FIRST
      DATA PI/3.141592654/,PI2/6.283185308/
      DATA PIO2/1.570796327/
      DATA FIRST/1/
C==================================================================
      IF (IFIRST.EQ.1) FIRST=1
      IF(FIRST.NE.1) GO TO 10

C  SET UP INITIALIZATION FOR FIRST PASS ONLY
      FIRST=0
      C(1)=COS(SLAT)
      C(2)=COS(PI2-SLON)
      C(3)=SIN(SLAT)
      C(4)=SIN(PI2-SLON)
      C(5)=COS(PLAT)
      C(6)=COS(PI2-PLON)
      C(7)=SIN(PLAT)
      C(8)=SIN(PI2-PLON)
      C(9)=C(5)*C(6)*C(1)*C(2)+C(5)*C(8)*C(1)*C(4)+C(7)*C(3)
      U=ACOS(C(9))
      IF(AMOD(SLON-PLON +4.*PI,PI2).GT.PI) U=-U
      C(10)=SIN(U)
      X=C(1)*C(4)*C(7)-C(5)*C(8)*C(3)
      Y=C(5)*C(6)*C(3)-C(1)*C(2)*C(7)
      Z=C(1)*C(2)*C(5)*C(8)-C(5)*C(6)*C(1)*C(4)
      AAA=0.0
      IF(X.NE.0.0.OR.Y.NE.0.0) AAA=ATAN2(Y,X)
      BBB=ASIN(Z/SQRT(X*X+Y*Y+Z*Z))
      CCC=PI2-PLON
      COSB=COS(BBB)
      SINB=SIN(BBB)
      COSA=COS(AAA)
      SINA=SIN(AAA)
      SINCA=SIN(CCC-AAA)
      COSCA=COS(CCC-AAA)
      IF(COSCA.EQ.0.) GO TO 411
      TANPSI=SINB*SINCA/COSCA
      COSPSI=-COSB*C(7)+SINB*C(5)*COSCA
      SINPSI=TANPSI*COSPSI
      GO TO 412
411   IF(SINB.EQ.0.) GO TO 413
      COSPSI=0.0
      SINPSI=SIGN(1.,SINB)
      GO TO 412
413   COSPSI=0.0
      SINPSI=1.0
      IF(AAA.NE.0.) SINPSI=-1.
412   HR(1,1)=COSPSI*SINB*COSA-SINPSI*SINA
      HR(1,2)=COSPSI*SINB*SINA+SINPSI*COSA
      HR(1,3)=-COSPSI*COSB
      HR(2,1)=-SINPSI*SINB*COSA-COSPSI*SINA
      HR(2,2)=-SINPSI*SINB*SINA+COSPSI*COSA
      HR(2,3)=SINPSI*COSB
      HR(3,1)=COSB*COSA
      HR(3,2)=COSB*SINA
      HR(3,3)=SINB
      RP=RPOL*RPOL
      RE=REQU*REQU
      RAD=RPOL
10    CONTINUE
      CA=COS(RLAT)
      CO=COS(PI2-RLON)
      SA=SIN(RLAT)
      SO=SIN(PI2-RLON)
      IF(RPOL.EQ.REQU) GO TO 11
      RAD=RE/SQRT(RE*CA*CA+RP*SA*SA)
11    CI=CA*CO*C(1)*C(2)+CA*SO*C(1)*C(4)+SA*C(3)
      CT=CA*CO*C(5)*C(6)+CA*SO*C(5)*C(8)+SA*C(7)
      CE=CT
      IF(RANGE.NE.0.) GO TO 20
      CG=C(9)
      GO TO 50
20    IF (CT.GT.1.0) CT=1.0
      IF (CT.LT.-1.0) CT=-1.0
      TH=ACOS(CT)
      ST=SIN(TH)
      IF(AMOD(CCC-(PI2-RLON)+4.*PI,PI2).GT.PI) ST=-ST
      DENOM=CT-RAD/RANGE
      IF(DENOM.NE.0.) GO TO 30
      CE=0.
      SE=SIGN(1.,ST)
      GO TO 40
30    E=ATAN2(ST,DENOM)
      CE=COS(E)
      SE=SIN(E)
40    if(st.eq.0.0)st=0.00001 ! try to avoid divide by zero
      CG=CI*CE+SE*(C(9)-CI*CT)/ST
50    TG=1000.
      G=ACOS(CG)
C  G LIES BETWEEN 0 AND PI
      IF(ABS(G-PIO2).GT..001) TG=TAN(G)
      IF(MODE.EQ.0) RETURN
      AS(1)=RAD*CO*CA
      AS(2)=RAD*SO*CA
      AS(3)=RAD*SA
      DO 70 I=1,3
          AL(I)=0.
          DO 71 II=1,3
71           AL(I)=AL(I)+AS(II)*HR(II,I)
70    CONTINUE
      LUMLON=ATAN2(AL(2),AL(1))*57.29578
      LUMLAT= ASIN(AL(3)/RAD)*57.29578
      RETURN
      END


!*****************************************************************************80
! Calculates feedback spatially dependent reactivity coeffecient
! for doppler and fuel expansion
!
!
! Input: n - node number, nl_iter - nonlinear iteration, current_time - time
!
! Output: temp_reactivity_feedback - spatial value of temperature feedback
!         Density_reactivity_feedback - spatial density feedback value
!
!*****************************************************************************80

subroutine temperature_feedback(n, nl_iter, current_time, Temp_Reactivity_Feedback)

    USE global_parameters_M
    USE solution_vectors_M
    USE mesh_info_M

    implicit none

!---Dummy
    integer, intent(in) :: n
    integer, intent(in) :: nl_iter
    integer, intent(in) :: current_time
    real(dp), intent(out) :: Temp_Reactivity_Feedback

!---Local
    real(dp) :: Temperature_Coefficient_Reactivity
    real(dp) :: avg_temperature_current
    real(dp) :: total_temperature_current
    real(dp) :: fuel_elem_len
    integer  :: i, j

    !---Temp Coefficient
    Temperature_Coefficient_Reactivity = -1.15796E-3_dp/407.0_dp

    !---Initialize
    total_temperature_current  = 0.0
    !---Calculate current average temperature across fuel
    do i = Fuel_Inlet_Start, Fuel_Outlet_End
        do j = 1, nodes_per_elem
            total_temperature_current = total_temperature_current + &
                                       elem_vol_int_fe(j)*temperature_soln_new(i,j)
        end do
    end do

    !---Total Length of the fuel
    fuel_elem_len = global_coord(Fuel_Outlet_End,3) - global_coord(Fuel_Inlet_Start,1)

    avg_temperature_current  = total_temperature_current/fuel_elem_len

    Temp_Reactivity_Feedback = Temperature_Coefficient_Reactivity * &
                               (avg_temperature_current - avg_temperature_initial)

end subroutine temperature_feedback

!---Calculate density feedback <==> fuel expansion
!
!
subroutine density_feedback( n, j, current_time, Den_Feedback )

    USE global_parameters_M
    USE solution_vectors_M
    USE mesh_info_M

    implicit none

!---Dummy
    integer, intent(in)   :: n
    integer, intent(in)   :: j
    integer, intent(in)   :: current_time
    real(dp), intent(inout) :: Den_Feedback

!---Local
    real(dp) :: Temperature_Coefficient_Reactivity
    real(dp) :: Density_Coefficient_Reactivity
    integer  :: i
    real(dp) :: Total_Density_Current

    !---Density Coeffecien
    Density_Coefficient_Reactivity = 2.94877E-3_dp/&
                    (0.99_dp*Avg_Density_Initial)

    !---Initialize
    total_density_current = 0.0

    !Den_Feedback = Density_Coefficient_Reactivity * &
    !                           (Avg_Density_Current - Avg_Density_Initial)

end subroutine density_feedback


C****************************************************************
C BISP_TO_MOD.FOR
C Program to extract the square modulus from the bispectrum
C
C JLP
C Version: 20-11-92
C****************************************************************
	PROGRAM BISP_TO_MOD

C  POUR IR=25
        PARAMETER(IRMAX=25,MIRMAX=-IRMAX)
        PARAMETER(NBMAX=980,NGMAX=187566,NULL=0)

C  POUR IR=30
C	PARAMETER(IRMAX=30,MIRMAX=-IRMAX)
C	PARAMETER(NBMAX=1410,NGMAX=388400,NULL=0)

	PARAMETER(IDIM=256)

	REAL IMAGE(IDIM,IDIM),MODSQ(NBMAX),BISP(NGMAX,3)
	INTEGER NGT,NG1,NG2,NB,NBETA,NGAMMA
	CHARACTER BISP_NAME*60,MODSQ_NAME,COMMENTS*80
        INTEGER KLM,NBCOUV,IXY
        INTEGER NX,NY,NX_MIN,NY_MIN
        REAL XR(NULL:NBMAX),XI(NULL:NBMAX)

C NBCOUV( X DE -IRMAX A IRMAX,  Y DE 0 A IRMAX )
C IXY( 1 POUR X ; 2 POUR Y,  NB DE 0 A NBMAX )
        COMMON /C1/NBCOUV(MIRMAX:IRMAX,NULL:IRMAX),IXY(2,NULL:NBMAX)

C KLM(1,.) POUR K ; KLM(2,.) POUR L ; KLM(3,.) POUR M ;
        COMMON /C2/KLM(3,NGMAX)

	COMMON /C5/NGT(NBMAX)

	CALL JLP_BEGIN
	CALL JLP_INQUIFMT
C
	WRITE(6,22) IDIM,IDIM
22	FORMAT(' Program BISP_TO_MOD Version 04-11-92',/,
     1   ' To extract the square modulus from the bispectrum ',/,
     1   '  (images up to ',I4,'x',I4,')')

C UV coverage:
	WRITE(6,*) ' Radius (IR) of uv-coverage?'
	READ(5,*) IR
	CALL COVERA(IR,NBETA,NGAMMA)

C Bispectrum:
	WRITE(6,41)
41	FORMAT(' Input bispectrum (phasor and snr)')
	BISP_NAME=' '
	CALL JLP_READIMAG(BISP,NX1,NY1,NGMAX,BISP_NAME,COMMENTS)
	IF((NY1.LT.3).OR.(NX1.NE.NGAMMA))THEN
	   WRITE(6,45)
45	   FORMAT(' FATAL ERROR: Size of bispectrum inconsistent',
     1	' with IRMAX')
	   STOP
        ENDIF

C Output size of square modulus:
        NX_MIN=2*IR+2
        NY_MIN=NX_MIN
        WRITE(6,51) NX_MIN,NY_MIN
51	FORMAT(' Size of the output 2-D file containing the',
     1  ' square modulus: NX,NY ',/,
     1  '(larger than ',I5,'x',I5,')')
        READ(5,*) NX,NY

C First erases image:
        DO J=1,NY
          DO I=1,NX
	   IMAGE(I,J)=0.
          END DO
	END DO

C Computes the square modulus for each value of  the spectral list:
	NG1=1
	DO 1 NB=3,NBETA
	  NG2=NGT(NB)
	  INDX=0
	  DO NG=NG1,NG2
            K1=KLM(1,NG)
            K2=KLM(2,NG)
            K3=KLM(3,NG)
C Here K1<K2 so:
            IF(K1.EQ.1)PRINT *,' NB=',NB,' NG=',NG,' NG1=',NG1,'NG2 =',NG2
C K1=0 is not allowed!!!!!!!!
C i.e. zero frequency is not allowed!!!!!!!!
          END DO
         NG1=NG2+1
1	CONTINUE

        IF(I.NE.123)STOP
C Copies back the square modulus (spectral list) to 2-D image:
        DO NB=0,NBETA
C IXY(1,NB) and IXY(2,NB) are the X,Y coordinates of the
C element NB of the spectral list.
C As they (i.e. IXY) can be negative, and that zero frequency is at (0,0),
C we do the following transformation:
          IIX=MOD(IXY(1,NB)+NX,NX)+1
          IIY=MOD(IXY(2,NB)+NY,NY)+1
          IMAGE(IIX,IIY)=MODSQ(NB)
C Writes symmetrical also:
          IMAGE(IXC-IIX,IYC-IIY)=MODSQ(NB)
        END DO

C Output of the 2D image:
	WRITE(6,42)
42	FORMAT(' Output of the 2-D file with the square modulus')
	WRITE(COMMENTS,43) BISP_NAME(1:40)
43	FORMAT(' Extracted square modulus from ',A)
	MODSQ_NAME=' '
	CALL JLP_WRITEIMAG(IMAGE,NX,NY,IDIM,MODSQ_NAME,COMMENTS)

	CALL JLP_END
	STOP
	END
C**********************************************************************
	INCLUDE 'jlp_cover.for'


MODULE GeometryComputationModule_Beta

  USE KindModule, ONLY: &
    DP, Zero, Half, One, SqrtTiny
  USE ProgramHeaderModule, ONLY: &
    nDOFX
  USE ReferenceElementModuleX, ONLY: &
    NodesLX_q
  USE ReferenceElementModuleX_Lagrange, ONLY: &
    LX_L2G
  USE MeshModule, ONLY: &
    MeshX
  USE GeometryFieldsModule, ONLY: &
    CoordinateSystem, &
    iGF_h_1, &
    iGF_h_2, &
    iGF_h_3, &
    iGF_Gm_dd_11, &
    iGF_Gm_dd_22, &
    iGF_Gm_dd_33, &
    iGF_SqrtGm, &
    iGF_Alpha, &
    iGF_Psi, &
    nGF

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: ComputeGeometryX
  PUBLIC :: ComputeGeometryX_FromScaleFactors

CONTAINS

  SUBROUTINE ComputeGeometryX( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass_Option )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(inout) :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in), OPTIONAL :: &
      Mass_Option

    REAL(DP) :: Mass

    Mass = Zero
    IF( PRESENT( Mass_Option ) ) &
      Mass = Mass_Option

    SELECT CASE ( TRIM( CoordinateSystem ) )

      CASE ( 'CARTESIAN' )

        CALL ComputeGeometryX_CARTESIAN &
               ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

      CASE ( 'SPHERICAL' )

        CALL ComputeGeometryX_SPHERICAL &
               ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

      CASE ( 'CYLINDRICAL' )

        CALL ComputeGeometryX_CYLINDRICAL &
               ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

      CASE DEFAULT

        WRITE(*,*)
        WRITE(*,'(A5,A27,A)') &
          '', 'Invalid Coordinate System: ', TRIM( CoordinateSystem )
        STOP

    END SELECT

  END SUBROUTINE ComputeGeometryX

  SUBROUTINE ComputeGeometryX_CARTESIAN &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(inout) :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      Mass

    INTEGER :: iX1, iX2, iX3

    DO iX3 = iX_B0(3), iX_E0(3)
      DO iX2 = iX_B0(2), iX_E0(2)
        DO iX1 = iX_B0(1), iX_E0(1)

          G(:,iX1,iX2,iX3,iGF_h_1) = One
          G(:,iX1,iX2,iX3,iGF_h_2) = One
          G(:,iX1,iX2,iX3,iGF_h_3) = One

          CALL ComputeGeometryX_FromScaleFactors( G(:,iX1,iX2,iX3,:) )

        END DO
      END DO
    END DO

  END SUBROUTINE ComputeGeometryX_CARTESIAN

  SUBROUTINE ComputeGeometryX_SPHERICAL &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(inout) :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      Mass

    INTEGER  :: iX1, iX2, iX3, iNodeX
    REAL(DP) :: XC(3), dX(3), xL_q(3), xG_q(3)
    REAL(DP) :: G_L(nDOFX,nGF)

    DO iX3 = iX_B1(3), iX_E1(3)
      DO iX2 = iX_B1(2), iX_E1(2)

        XC(2) = MeshX(2) % Center(iX2)
        dX(2) = MeshX(2) % Width (iX2)

        DO iX1 = iX_B1(1), iX_E1(1)

          XC(1) = MeshX(1) % Center(iX1)
          dX(1) = MeshX(1) % Width (iX1)

          ! --- Compute Geometry Fields in Lobatto Points ---

          DO iNodeX = 1, nDOFX

            ! --- Local Coordinates (Lobatto Points) ---

            xL_q = NodesLX_q(1:3,iNodeX)

            ! --- Global Coordinates ---

            xG_q = XC + dX * xL_q

            ! --- Compute Lapse Function and Conformal Factor ---

            G_L(iNodeX,iGF_Alpha) &
              = LapseFunction  ( xG_q(1), Mass )
            G_L(iNodeX,iGF_Psi) &
              = ConformalFactor( xG_q(1), Mass )

            ! --- Set Geometry in Lobatto Points ---

            G_L(iNodeX,iGF_h_1) &
              = G_L(iNodeX,iGF_Psi)**2
            G_L(iNodeX,iGF_h_2) &
              = G_L(iNodeX,iGF_Psi)**2 * ABS( xG_q(1) )
            G_L(iNodeX,iGF_h_3) &
              = G_L(iNodeX,iGF_Psi)**2 * ABS( xG_q(1) * SIN( xG_q(2) ) )

          END DO

          ! --- Interpolate from Lobatto to Gaussian Points ---

          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_h_1), 1, Zero, G(:,iX1,iX2,iX3,iGF_h_1), 1 )
          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_h_2), 1, Zero, G(:,iX1,iX2,iX3,iGF_h_2), 1 )
          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_h_3), 1, Zero, G(:,iX1,iX2,iX3,iGF_h_3), 1 )

          CALL ComputeGeometryX_FromScaleFactors( G(:,iX1,iX2,iX3,:) )

          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_Alpha), 1, Zero, G(:,iX1,iX2,iX3,iGF_Alpha), 1 )

          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_Psi),   1, Zero, G(:,iX1,iX2,iX3,iGF_Psi),   1 )

        END DO
      END DO
    END DO

  END SUBROUTINE ComputeGeometryX_SPHERICAL

  SUBROUTINE ComputeGeometryX_CYLINDRICAL &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(inout) :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      Mass

    REAL(DP) :: XC(3), dX(3), xL_q(3), xG_q(3)
    REAL(DP) :: G_L(nDOFX,nGF)
    INTEGER  :: iX1, iX2, iX3, iNodeX

    PRINT*, "ComputeGeometryX_CYLINDRICAL"

    DO iX3 = iX_B0(3), iX_E0(3)
      DO iX2 = iX_B0(2), iX_E0(2)
        DO iX1 = iX_B0(1), iX_E0(1)

          XC(1) = MeshX(1) % Center(iX1)
          dX(1) = MeshX(1) % Width (iX1)

          DO iNodeX = 1, nDOFX

            ! --- Local Coordinates (Lobatto Points) ---

            xL_q = NodesLX_q(1:3,iNodeX)

            ! --- Global Coordinates ---

            xG_q = XC + dX * xL_q

            ! --- Set Geometry in Lobatto Points ---

            G_L(iNodeX,iGF_h_1) = One
            G_L(iNodeX,iGF_h_2) = One
            G_L(iNodeX,iGF_h_3) = xG_q(1)

          END DO

          ! --- Interpolate from Lobatto to Gaussian Points ---

          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_h_1), 1, Zero, G(:,iX1,iX2,iX3,iGF_h_1), 1 )
          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_h_2), 1, Zero, G(:,iX1,iX2,iX3,iGF_h_2), 1 )
          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_h_3), 1, Zero, G(:,iX1,iX2,iX3,iGF_h_3), 1 )

          CALL ComputeGeometryX_FromScaleFactors( G(:,iX1,iX2,iX3,:) )

        END DO
      END DO
    END DO

  END SUBROUTINE ComputeGeometryX_CYLINDRICAL

  SUBROUTINE ComputeGeometryX_FromScaleFactors( G )

    REAL(DP), INTENT(inout) :: G(1:,1:)

    G(:,iGF_Gm_dd_11) = G(:,iGF_h_1)**2
    G(:,iGF_Gm_dd_22) = G(:,iGF_h_2)**2
    G(:,iGF_Gm_dd_33) = G(:,iGF_h_3)**2

    G(:,iGF_SqrtGm) = G(:,iGF_h_1) * G(:,iGF_h_2) * G(:,iGF_h_3)

  END SUBROUTINE ComputeGeometryX_FromScaleFactors

  PURE REAL(DP) FUNCTION LapseFunction( R, M )

    REAL(DP), INTENT(in) :: R, M

    ! --- Schwarzschild Metric in Isotropic Coordinates ---

    LapseFunction &
      = ( One - Half * M / MAX( R, SqrtTiny ) ) &
        / ( One + Half * M / MAX( R, SqrtTiny ) )

    RETURN
  END FUNCTION LapseFunction

  PURE REAL(DP) FUNCTION ConformalFactor( R, M )

    REAL(DP), INTENT(in) :: R, M

    ! --- Schwarzschild Metric in Isotropic Coordinates ---

    ConformalFactor &
      = One + Half * M / MAX( R, SqrtTiny )

    RETURN
  END FUNCTION ConformalFactor

END MODULE GeometryComputationModule_Beta