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

      SUBROUTINE APALSM (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN, NNNOLD,
     &   NIT, TOL, RO, ALPHA, ERR)
C***********************************************************************

C  SUBROUTINE APALSM = AREA PULL AND LAPLACIAN MESH SMOOTHER

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

C  NOTE:
C     IN THIS SMOOTHER EACH NODE IS SUCCESSIVELY MOVED BY
C     AN AMOUNT GIVEN AS A WEIGHTED AVERAGE OF AN *AREA PULL*
C     VECTOR AND THE LAPLACIAN VECTOR (AVERAGE OF VECTORS POINTING
C     TO NEIGHBORS).  THE *AREA PULL* VECTOR IS OBTAINED BY LETTING
C     EACH ELEMENT PULL IN PERPENDICULARLY ON ITS SIDES WITH FORCE
C     PROPORTIONAL TO THE LENGTH OF THAT SIDE TIMES A FACTOR
C     INVOLVING THE AREAS OF THIS ELEMENT AND ITS NEIGHBOR SHARING
C     THAT SIDE.

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

C  VARIABLES USED:
C     NIT   = MAX ITERATIONS TO DO
C     TOL   = PERCENT OF SMALLEST CONNECTING LINE TO USE AS NODE MOVEMENT
C             CONVERGENCE TOLERANCE.
C     RO    = UNDER OR OVER-RELAXATION FACTOR.
C     ALPHA = WEIGHT GIVEN TO AREA PULL VECTOR.  USUALLY = 0.5.
C             WEIGHT GIVEN TO LAPLACIAN VECTOR = 1.-ALPHA.

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

      DIMENSION LXK(4, MXND), KXL(2, 3*MXND), NXL(2, 3*MXND)
      DIMENSION LXN(4, MXND), XN(MXND), YN(MXND)
      DIMENSION LINES(20), NS1(4), NS2(4)
      DIMENSION KLIB(8), NLIB(4, 8), ALIB(8), XCLIB(8), YCLIB(8)

      LOGICAL BIG, ERR

      ERR = .FALSE.
      TOL2 = TOL**2
      BETA = 1. - ALPHA

C  ITERATION LOOP

      DO 160 IT = 1, NIT
         BIG = .FALSE.

C  NODE LOOP

         NNT = 0
         DO 150 NODE = NNNOLD  +  1, NNN

C  CHECK FOR CONTINUATIONS,  BOUNDARY,  OR RELAXED NODE

            IF ((LXN(3, NODE) .GE.  0) .AND. (LXN(2, NODE) .GT. 0)
     &         .AND. (LXN(1, NODE) .GT. 0)) THEN
               NNT = NNT + 1

C  INITIALIZE

               KNUM = 0
               XA = 0.
               YA = 0.
               XL = 0.
               YL = 0.

C  PROCESS EACH LINE CONNECTED TO THIS NODE

               CALL GETLXN (MXND, LXN, NODE, LINES, KOUNT, ERR)
               IF (ERR) RETURN
               DO 100 IL = 1, KOUNT
                  L = LINES(IL)
                  N1 = NXL(1, L)
                  N2 = NXL(2, L)

C  FETCH ELEMENT DATA

                  IF (KXL(1, L) .GT. 0) CALL APALIB (MXND, XN, YN, LXK,
     &               NXL, KXL(1, L), NS1, AREA1, XCEN1, YCEN1, KNUM,
     &               KLIB, NLIB, ALIB, XCLIB, YCLIB)
                  IF (KXL(2, L) .GT. 0) CALL APALIB (MXND, XN, YN, LXK,
     &               NXL, KXL(2, L), NS2, AREA2, XCEN2, YCEN2, KNUM,
     &               KLIB, NLIB, ALIB, XCLIB, YCLIB)

C  GET FORCE DIRECTION MODULO PI RADIANS.
C  CORRECT FOR WRONG DIRECTION BY ALIGNING WITH THE VECTOR
C  FROM (XCEN1, YCEN1) TO (XCEN2, YCEN2).

                  XF = -(YN(N2) - YN(N1))
                  YF = XN(N2) - XN(N1)
                  DOT = XF*(XCEN2 - XCEN1) + YF*(YCEN2 - YCEN1)
                  IF (DOT  .LT.  0.) THEN
                     XF = -XF
                     YF = -YF
                  END IF

C  TAKE CARE OF ZERO AREAS

                  IF ((AREA1  .LE.  0) .OR. (AREA2  .LE.  0)) THEN
                     AREA1 = 1.0
                     AREA2 = 1.0
                  END IF

C  UPDATE AREA PULL VECTOR SUM

                  WEIGHT = (AREA2 - AREA1)/(AREA2 + AREA1)
                  XA = XA  +  WEIGHT*XF
                  YA = YA  +  WEIGHT*YF

C  UPDATE LAPLACIAN VECTOR SUM

                  NOE = N1 + N2 - NODE
                  DX = XN(NOE) - XN(NODE)
                  DY = YN(NOE) - YN(NODE)
                  XL = XL + DX
                  YL = YL + DY

C  UPDATE LEAST LENGTH

                  DIST2 = DX*DX  +  DY*DY
                  IF (IL .EQ. 1) DMIN2 = DIST2
                  DMIN2 = MIN(DMIN2, DIST2)
  100          CONTINUE

C  COMPUTE NET MOVEMENT VECTOR

               RK = 1.0/DBLE(KOUNT)
               XNET = (ALPHA*XA  +  BETA*XL)*RK
               YNET = (ALPHA*YA  +  BETA*YL)*RK

C  MOVE THE NODE

               YN(NODE) = YN(NODE)  +  YNET * RO
               XN(NODE) = XN(NODE)  +  XNET * RO

C  CHECK FOR SIGNIFICANT MOVEMENT

               IF (XNET*XNET + YNET*YNET .GT. TOL2*DMIN2) THEN

C  SIGNIFICANT MOVEMENT - REMOVE RELAXATION FLAGS

C  FIRST FROM DIRECTLY CONNECTED NODES

                  DO 110 IL = 1, KOUNT
                     L = LINES(IL)
                     NOE = NXL(1, L) + NXL(2, L) - NODE
                     LXN(3, NOE) = ABS(LXN(3, NOE))
  110             CONTINUE

C  NEXT FROM DIAGONALLY OPPOSITE NODES (MAX 8)

                  DO 140 IK = 1, KNUM
                     DO 120 I = 1, 4
                        IF (NLIB(I, IK) .EQ. NODE) THEN
                           IDIAG = I + 2
                           IF (IDIAG .GE.  5) IDIAG = IDIAG - 4
                           NDIAG = NLIB(IDIAG, IK)
                           LXN(3, NDIAG) = ABS(LXN(3, NDIAG))
                           GO TO 130
                        END IF
  120                CONTINUE
                     CALL MESSAGE('ERROR IN APALSM')
                     ERR = .TRUE.
                     RETURN
  130                CONTINUE
  140             CONTINUE

C  INSIGNIFICANT MOVEMENT
C  INSERT RELAXATION FLAG

               ELSE
                  LXN(3, NODE) = -ABS(LXN(3, NODE))
               END IF

            END IF
  150    CONTINUE
         IF (.NOT.BIG) GO TO 170
  160 CONTINUE
      IT = NIT

C  REMOVE ALL FLAGS

  170 CONTINUE
      DO 180 NODE = NNNOLD  +  1, NNN
         LXN(3, NODE) = ABS(LXN(3, NODE))
  180 CONTINUE

      RETURN
      END


module trig

double precision, parameter :: pi = datan(1.0d0)*4.0d0
double precision, parameter :: r2d = 180.0d0/pi
double precision, parameter :: d2r = pi/180.0d0

public :: pi, r2d, d2r

end module


program PlanarInterpConvergence

use NumberKindsModule
use LoggerModule
use PolyMesh2dModule
use ParticlesModule
use EdgesModule
use FacesModule
use STDIntVectorModule
use FieldModule
use TriScatteredInterpModule
use PSEModule

implicit none

type(Logger) :: exeLog

type(PolyMesh2d) :: triMesh
integer(kint), parameter :: meshSeed = TRI_HEX_SEED
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: amrLimit
real(kreal) :: ampFactor

type(Field) :: scalar
type(Field) :: estGrad, exactGrad, gradError
type(Field) :: est2ndPartials, exact2ndPartials, partialsError
type(Field) :: estLap, exactLap, lapError

type(TriScatteredInterp) :: interp

real(kreal), parameter :: b = 3.0_kreal
real(kreal), parameter :: xc = 0.0_kreal, yc = 0.0_kreal
real(kreal), parameter :: maxAbsLap = 36.0_kreal

type(PSE) :: pseSetup

integer(kint) :: i, j

integer(kint), parameter :: nn = 501
real(kreal), parameter :: dx = 8.0_kreal / real( nn - 1, kreal)
real(kreal), parameter :: xmin = -4.0_kreal
real(kreal), parameter :: xmax = 4.0_kreal
real(kreal), parameter :: ymin = xmin
real(kreal), parameter :: ymax = xmax

real(kreal) :: x(nn), y(nn)
real(kreal) :: interpScalar(nn,nn), exactScalar(nn,nn)
real(kreal) :: interpGradX(nn,nn), interpGradY(nn,nn), exactGradX(nn,nn), exactGradY(nn,nn)
real(kreal) :: interpLap(nn,nn), exactLapUnif(nn,nn)
real(kreal) :: xVecA(3), xVecB(3), maxGradMag

real(kreal) :: estGradError(9), estLapError(9), interpError(9), meshSize(9)
real(kreal) :: testStart, testEnd

character(len=MAX_STRING_LENGTH) :: logstring

!
!----------------
! PROGRAM START
!----------------
!

call New(exeLog, DEBUG_LOGGING_LEVEL)
amrLimit = 0
ampFactor = 3.0_kreal

do initNest = 0, 8

	call cpu_time(testStart)

	write(logstring,'(A,I3,A)') "test ", initNest+1, ", of 9..."
	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,"Interpolation Convergence : ", logString)

	!
	! build a mesh
	!
	maxNest = initNest

	call New(triMesh, meshSeed, initNest, maxNest, amrLimit, ampFactor)
	! define a scalar field on the mesh
	call New(scalar, 1, triMesh%particles%N, "gaussScalar", "n/a")
	call New(estGrad,2, triMesh%particles%N, "estGradient", "n/a")
	call New(exactGrad,2,triMesh%particles%N,"exactGradient","n/a")
	call New(gradError,1,triMesh%particles%N, "gradError", "n/a")
	call New(est2ndPartials,3,triMesh%particles%N, "estPartials","n/a")
	call New(exact2ndPartials,3,triMesh%particles%N,"exactPartials","n/a")
	call New(partialsError,3,triMesh%particles%N, "partialsError","n/a")
	call New(estLap, 1, triMesh%particles%N, "estLaplacian","n/a")
	call New(exactLap,1, triMesh%particles%N,"exactLaplacian", "n/a")
	call New(lapError,1, triMesh%particles%N,"lapError","n/a")

	do i = 1, triMesh%particles%N
		call InsertScalarToField( scalar, Gaussian( [triMesh%particles%x(i), triMesh%particles%y(i)], b) )
		call InsertVectorToField(exactGrad, GaussGrad( [triMesh%particles%x(i), triMesh%particles%y(i)], b))
		call InsertVectorToField(exact2ndPartials, Gauss2ndDerivs([triMesh%particles%x(i), triMesh%particles%y(i)], b))
		call InsertScalarToField(exactLap, GaussLap([triMesh%particles%x(i), triMesh%particles%y(i)],b) )
	enddo

	!
	! set up interpolation, estimate derivatives
	!
	call New(interp, triMesh)
	call generateFaceUVs(interp, triMesh)
	call New(pseSetup, triMesh)
	call estimatePartialDerivatives( interp, triMesh, scalar, estGrad, est2ndPartials)
!	call SetPlanarCoefficients(interp, triMesh, scalar, estGrad, est2ndPartials)
	call SetPlanarCoefficients(interp, triMesh, scalar, exactGrad, exact2ndPartials)

	!
	! calculate derivative error at particles
	!
	do i = 1, triMesh%particles%N
		xVecA = 0.0_kreal
		xVecB = 0.0_kreal
		xVecA(1:2) = [estGrad%xComp(i), estGrad%yComp(i)]
		xVecB(1:2) = GaussGrad( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
		call InsertScalarToField( gradError, sqrt(sum( xVecA - xVecB)))
		call InsertScalarToField( estLap, est2ndPartials%xComp(i) + est2ndPartials%zComp(i))
		call InsertScalarToField( lapError, estLap%scalar(i) - exactLap%scalar(i))
		xVecA = [est2ndPartials%xComp(i), est2ndPartials%yComp(i), est2ndPartials%zComp(i)]
		xVecB = Gauss2ndDerivs( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
		call InsertVectorToField( partialsError, xVecA - xVecB )
	enddo

	!
	! interpolate to uniform mesh
	!
	do i = 1, nn
		x(i) = xmin + dx * (i-1)
		y(i) = ymin + dx * (i-1)
	enddo

	xVecA = 0.0_kreal
	do j = 1, nn
		do i = 1, nn
			exactScalar(i,j) = Gaussian( [x(j), y(i)], b )
			xVecA(1:2) = GaussGrad([x(j),y(i)], b)
			exactGradX(i,j) = xVecA(1)
			exactGradY(i,j) = xVecA(2)
			exactLapUnif(i,j) = GaussLap( [x(j), y(i)], b)

			interpScalar(i,j) = InterpolateScalar( interp, triMesh, [x(j),y(i)])
			xVecA(1:2) = InterpolateGradient( interp, triMesh, [x(j), y(i)])
			interpGradX(i,j) = xVecA(1)
			interpGradY(i,j) = xVecA(2)
			interpLap(i,j) = InterpolateLaplacian(interp, triMesh, [x(j), y(i)])
		enddo
	enddo

	maxGradMag = MaxMagnitude(exactGrad)
	meshSize(initNest+1) = MaxEdgeLength(triMesh%edges, triMesh%particles)
	estGradError(initNest+1) = maxval(gradError%scalar)/maxGradMag
	estLapError(initNest+1) = maxval(abs(lapError%scalar))/maxAbsLap
	interpError(initNest+1) = maxval(abs(interpScalar-exactScalar))

	write(6,'(4A24)') "dx", "gradErr-particles", "lapErr-particles", "interp error"
	write(6,'(4F24.10)') meshSize(initNest+1), estGradError(initNest+1), estLapError(initNest+1), interpError(initNest+1)

	!
	! reset for next iteration
	!
	call cpu_time(testEnd)
	write(6,'(A,I8,A,F12.2,A)') "nParticles = ", triMesh%particles%N, ": elapsed time = ", testEnd-testStart, " seconds."

	call Delete(pseSetup)
	call Delete(interp)
	call Delete(lapError)
	call Delete(exactLap)
	call Delete(estLap)
	call Delete(partialsError)
	call Delete(exact2ndPartials)
	call Delete(est2ndPartials)
	call Delete(gradError)
	call Delete(exactGrad)
	call Delete(estGrad)
	call Delete(scalar)
	call Delete(triMesh)

	call LogMessage(exeLog,TRACE_LOGGING_LEVEL, "test complete for initNest = ", initNest)
enddo

write(6,'(4A24)') "dx", "gradErr-particles", "lapErr-particles", "interp error"
do i = 1, 9
	write(6,'(4F24.10)') meshSize(i), estGradError(i), estLapError(i), interpError(i)
enddo

contains

function Gaussian( xy, b )
	real(kreal) :: Gaussian
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b

	Gaussian = exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc)))
end function

function GaussGrad(xy, b)
	real(kreal) :: GaussGrad(2)
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	GaussGrad(1) = xy(1)-xc
	GaussGrad(2) = xy(2)-yc
	GaussGrad = -2.0_kreal * GaussGrad * b * b * exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

function GaussLap(xy, b)
	real(kreal) :: GaussLap
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	GaussLap = ( b*b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ) - 1.0_kreal ) * 4.0_kreal * b * b * &
			exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

function Gauss2ndDerivs( xy, b)
	real(kreal) :: Gauss2ndDerivs(3)
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	Gauss2ndDerivs(1) = 2.0_kreal * b * b *(2.0_kreal * b*b *(xy(1)-xc)*(xy(1)-xc) - 1.0_kreal)
	Gauss2ndDerivs(2) = 4.0_kreal * b**4 * (xy(1)-xc)*(xy(2)-yc)
	Gauss2ndDerivs(3) = 2.0_kreal * b * b *(2.0_kreal * b*b * (xy(2)-yc)*(xy(2)-yc) - 1.0_kreal)
	Gauss2ndDerivs = Gauss2ndDerivs * exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

end program


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine error_norm(rms)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     this function computes the norm of the difference between the
c     computed solution and the exact solution
c---------------------------------------------------------------------

      include 'header.h'
       interface
         pure extrinsic (hpf_local)
     >     subroutine exact_solution(xi,eta,zeta,dtemp)
           include 'cnst.h'
           double precision, intent(in) ::  xi, eta, zeta
           double precision, intent(out), dimension(:) :: dtemp
         end subroutine
       end interface
      double precision rmsa( 0:grid_points(3)-1, 5)
      integer i, j, k, m, d
      double precision xi, eta, zeta, u_exact(5), rms(5), add

      do m = 1, 5
         rms(m) = 0.0d0
      enddo

!HPF$ independent new(add,zeta,eta,xi)
      do k = 0, grid_points(3)-1
         do m = 1, 5
            rmsa(k, m) = 0.0d0
         enddo
         zeta = dble(k) * dnzm1
         do j = 0, grid_points(2)-1
            eta = dble(j) * dnym1
            do i = 0, grid_points(1)-1
               xi = dble(i) * dnxm1
               call exact_solution(xi, eta, zeta, u_exact)

               do m = 1, 5
                  add = u(m,i,j,k)-u_exact(m)
                  rmsa(k, m) = rmsa(k,m) + add*add
               enddo
            enddo
          enddo
       enddo

      do m = 1, 5
         rms(m) = sum( rmsa(:,m))
         do d = 1, 3
            rms(m) = rms(m) / dble(grid_points(d)-2)
         enddo
         rms(m) = dsqrt(rms(m))
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine rhs_norm(rms)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      include 'header.h'

      integer d, m
      double precision rms(5), add

      do m = 1, 5
         rms(m) = sum( rhs(m,1:grid_points(1)-2,
     >                 1:grid_points(2)-2,1:grid_points(3)-2)**2)
      enddo

      do m = 1, 5
         do d = 1, 3
            rms(m) = rms(m) / dble(grid_points(d)-2)
         enddo
         rms(m) = dsqrt(rms(m))
      enddo

      return
      end


 SUBROUTINE gentbs(isidf,lnods,bottom,top,coorb,coort,ifact,t3,thnew,phin,nnode)

 ! GENerates Top and Bottom Surfaces of the shell for contact analysis
 ! for three node shell elements (rotation free) LBST,CBST,NBST

 IMPLICIT NONE
 ! dummy arguments
 INTEGER(kind=4), INTENT(IN) :: nnode        !number of nodes
 INTEGER(kind=4), INTENT(IN) :: lnods(nnode) !connectivities
 LOGICAL, INTENT(IN)  :: isidf(nnode),     & !side boundary condition
                         bottom,top          !flags to indicate generation
 REAL(kind=8), INTENT(IN) :: t3(3),        & !element normal
                             thnew,        & !present element thickness
                             phin(3,nnode)   !symmetry plane normal
 INTEGER(kind=4), INTENT(IN OUT) :: ifact(:)
 REAL(kind=8), INTENT(IN OUT) :: coorb(:,:),coort(:,:)
 !local variables
 INTEGER(kind=4) :: i,n
 REAL(kind=8) :: aux,tn(3,3)

     IF( ALL(.NOT.isidf))THEN     !no clamped sides
       DO i=1,nnode               !for each node
         n = lnods(i)             !node
         IF(bottom) coorb(:,n) = coorb(:,n) - t3*thnew !bottom surface
         IF(top   ) coort(:,n) = coort(:,n) + t3*thnew !top surface
         ifact(n) = ifact(n) + 2  !increase weigthing factor
       END DO
     ELSE                         !one or more clamped sides
       n = 0                      !initializes number of clamped sides
       DO i=1,nnode               !loop over each side
         IF( isidf(i) )THEN       !if side clamped
           n = n+1                !increase number of clamped sides
           tn(:,n) = phin(:,i)/2d0  !normal to plane of symmetry
         END IF
       END DO
       IF( n == 1)THEN            !for one clamped side (or symmetry plane)
         CALL vecuni(3,tn(1,1),aux)
         aux = DOT_PRODUCT(tn(:,1),t3)    !proyect normal over plane
         tn(:,3) = t3 - aux*tn(:,1)       !proyect normal over plane
       ELSE                       !for two clamped side (or symmetry planes)
         CALL vecpro(tn(1,1),tn(1,2),tn(1,3)) !normal to both planes
       END IF
       CALL vecuni(3,tn(1,3),aux)             !unit vector
       DO i=1,nnode               !for each node
         n = lnods(i)        !node
         IF(bottom) coorb(:,n) = coorb(:,n) - tn(:,3)*thnew !bottom surface
         IF(top   ) coort(:,n) = coort(:,n) + tn(:,3)*thnew !top surface
         ifact(n) = ifact(n) + 2  !increase weigthing factor
       END DO
     END IF
 RETURN
 END SUBROUTINE gentbs


subroutine r_spiola_elastic(det,xot,ge,iq,ne,cstr_element)
  use solid_variables, only: nsd_solid,nen_solid,ne_solid,nquadpad_solid
  use r_common
  implicit none

  real(8),intent(in) :: det
  real(8) xot(nsd_solid,nsd_solid)
  real(8) :: cstr_element(nsd_solid*2),ge(nsd_solid*2,ne_solid,nquadpad_solid)  !...Cauchy stress
  integer :: isd,jsd,ksd,iq,ne
  real(8) :: cstr(nsd_solid,nsd_solid)
  real(8) :: tempC, tempD, tempE
! Xingshi May 2008
!======================================
  real(8) detf ! determninat of deformation gradient matrix
  real(8) xot_temp(nsd_solid,nsd_solid)
  detf=0.0d0
  xot_temp(:,:)=0.0d0
  xot_temp(:,:)=xot(:,:)
  call determinant(xot_temp,nsd_solid,nsd_solid,detf)
!=====================================
  cstr(:,:) = 0.0d0

  threedim: if (nsd_solid .eq. 3) then

  tempC= young_mod*(1-Poisson)/((1+Poisson)*(1-2*Poisson))
  tempD= Poisson/(1-Poisson)
  tempE= (1-2*Poisson)/(2*(1-Poisson))

  cstr_element(1)= tempC*(ge(1,ne,iq)+tempD*ge(2,ne,iq)+tempD*ge(3,ne,iq))
  cstr_element(2)= tempC*(tempD*ge(1,ne,iq)+ge(2,ne,iq)+tempD*ge(3,ne,iq))
  cstr_element(3)= tempC*(tempD*ge(1,ne,iq)+tempD*ge(2,ne,iq)+ge(3,ne,iq))
  cstr_element(4)= tempC*tempE*ge(4,ne,iq)
  cstr_element(5)= tempC*tempE*ge(5,ne,iq)
  cstr_element(6)= tempC*tempE*ge(6,ne,iq)

  do isd=1,3
    cstr(isd,isd)=cstr_element(isd)
  enddo
  cstr(2,3)=cstr_element(4)
  cstr(3,2)=cstr_element(4)
  cstr(1,3)=cstr_element(5)
  cstr(3,1)=cstr_element(5)
  cstr(1,2)=cstr_element(6)
  cstr(2,1)=cstr_element(6)

  do isd = 1,3
     do jsd = 1,3
        PK1str_tens(isd,jsd) = 0.0d0
        do ksd = 1,3
!           PK1str_tens(isd,jsd) = PK1str_tens(isd,jsd) + det*xot(isd,ksd)*cstr(ksd,jsd)
! according to 2-D formulation detf is the determinant of jacobi to initial
           PK1str_tens(isd,jsd) = PK1str_tens(isd,jsd) + xot(isd,ksd)*cstr(ksd,jsd)/detf

        enddo
     enddo
  enddo

  endif  threedim

  twodim: if (nsd_solid .eq. 2) then

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !Mickael Plane stress
	cstr_element(1)= (young_mod/(1-Poisson**2))*(ge(1,ne,iq)+Poisson*ge(2,ne,iq))
	cstr_element(2)= (young_mod/(1-Poisson**2))*(ge(2,ne,iq)+Poisson*ge(1,ne,iq))
    cstr_element(3)= (young_mod/(1+Poisson))*ge(3,ne,iq)
    cstr_element(4)= 0.0
! write(*,*) 'xot', xot(:,:)
  do isd=1,2
    cstr(isd,isd)=cstr_element(isd)
  enddo
  cstr(1,2)= cstr_element(3)
  cstr(2,1)= cstr_element(3)

! write(*,*)'stress', cstr(:,:)
	do isd = 1,nsd_solid
     do jsd = 1,nsd_solid
        PK1str_tens(isd,jsd) = 0.0d0
        do ksd = 1,nsd_solid
!           PK1str_tens(isd,jsd) = PK1str_tens(isd,jsd) + det*xot(isd,ksd)*cstr(ksd,jsd)
! Use detf instead of det which is the detminant of jacobi to inintial
           PK1str_tens(isd,jsd) = PK1str_tens(isd,jsd) + xot(isd,ksd)*cstr(ksd,jsd)/detf
	    enddo
     enddo
  enddo
! write(*,*) 'PK1str' , PK1str_tens(:,:)
! write(*,*) 'DET F', det
  endif twodim

end subroutine


SUBROUTINE CGGGLM_F95( A, B, D, X, Y, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => SP
    USE LA_AUXMOD, ONLY: ERINFO
    USE F77_LAPACK, ONLY: GGGLM_F77 => LA_GGGLM
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:), D(:)
    COMPLEX(WP), INTENT(OUT) :: X(:), Y(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!        LA_GGGLM solves the general (Gauss-Markov) linear model (GLM)
! problem:
!      min ||y||2  subject to d=A*x + B*y
!       x
! where A and B are real or complex rectangular matrices and d is a real
! or complex vector. Further, A is n by m, B is n by p, and d is n by 1,
! and it is assumed that m <= n <= m+p, rank(A) = m, rank(A, B) = n.
! These conditions ensure that the GLM problem has unique solution
! vectors x and y. The problem is solved using the generalized QR
! factorization of A and B.
!        If matrix B is square and nonsingular, then the GLM problem is
! equivalent to the weighted linear least squares problem
!         min ||B^-1 * (d-A*x)||2
! 	   x
!
! =========
!
!       SUBROUTINE LA_GGGLM( A, B, D, X, Y, INFO=info )
!           <type>(<wp>), INTENT( INOUT ) :: A( :, : ), B(:,:), D(:)
!           <type>(<wp>), INTENT( OUT ) :: X(:), Y(:)
!           INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!           <type> ::= REAL | COMPLEX
!           <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
!
! Arguments
! =========
!
! A     (input/output) REAL or COMPLEX array, shape (:,:) with
!       size(A,1) = n and size(A,2) = m.
!       On entry, the matrix A.
!       On exit, the contents of A are destroyed.
! B     (input/output) REAL or COMPLEX array, shape (:,:) with
!       size(B,1) = n and size(B,2) = p.
!       On entry, the matrix B.
!       On exit, the contents of B are destroyed.
! D     (input/output) REAL or COMPLEX array, shape (:) with
!       size(D) = n.
!       On entry, the vector d.
!       On exit, the contents of D are destroyed.
! X     (output) REAL or COMPLEX array, shape (:) with size(X) = m.
!       The solution vector x.
! Y     (output) REAL or COMPLEX array, shape (:) with size(Y) = p.
!       The solution vector y.
! INFO  Optional (output) INTEGER.
!       = 0: successful exit
!       < 0: if INFO = -i, the i-th argument had an illegal value.
!       If INFO is not present and an error occurs, then the program is
!       terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GGGLM'
!   .. LOCAL SCALARS ..
    INTEGER :: LINFO, ISTAT, ISTAT1, N, M, MN, P
!   .. LOCAL SAVE SCALARS ..
    INTEGER, SAVE :: LWORK = 0
!   .. LOCAL POINTERS ..
    COMPLEX(WP), POINTER :: WORK(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, MAX, MIN
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; N = SIZE(A,1); M = SIZE(A,2); P = SIZE(B,2)
    MN = MIN(M,N)
!   .. TEST THE ARGUMENTS
    IF( M < 0 .OR. N < M ) THEN; LINFO = -1
    ELSE IF( P < 0 .OR. P < N-M .OR. SIZE(B,1) /= N ) THEN; LINFO = -2
    ELSE IF( SIZE(D) /= N ) THEN; LINFO = -3
    ELSE IF( SIZE(X) /= M ) THEN; LINFO = -4
    ELSE IF( SIZE(Y) /= P ) THEN; LINFO = -5
    ELSE
       LWORK = MAX( 1, M + N + P , LWORK )
       ALLOCATE( WORK(LWORK), STAT = ISTAT )
       IF( ISTAT /= 0 ) THEN
          DEALLOCATE( WORK, STAT=ISTAT1 )
          LWORK = MAX( 1, M + N + P )
          ALLOCATE( WORK(LWORK), STAT = ISTAT )
          IF( ISTAT == 0 ) CALL ERINFO( -200, SRNAME, LINFO )
       END IF
       IF ( ISTAT == 0 ) THEN
!      .. CALL LAPACK77 ROUTINE
          CALL GGGLM_F77( N, M, P, A, MAX(1,N), B, MAX(1,N), &
                          D, X, Y, WORK, LWORK, LINFO )
          IF( LINFO == 0 ) LWORK = INT( WORK(1) )
       ELSE; LINFO = -100; END IF
       DEALLOCATE(WORK, STAT = ISTAT1 )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
 END SUBROUTINE CGGGLM_F95


!aggregate.f90

!Algoritmo para deteccao de comunidades em rede, baseado no artigo:
!------------------------------------------------------------------
!Paper: Fast unfolding of communities in large networks
!Authors: Vincent D Blondel, Jean-Loup Guillaume, Renaud Lambiotte and Etienne Lefebvre
!doi:10.1088/1742-5468/2008/10/P10008
!------------------------------------------------------------------
!Este programa eh composto de tres partes: louvain.f90; move_nodes.f90; aggregate.f90

      subroutine aggregate()
      use variaveis
      integer*8 i, j, n

      n=numb_comun    !Este n nao eh o mesmo do louvain.f90

!----Renumerar comunidades-----------------
      C1 = -1
      numb_comun = 1
      do i=1, n
        where( (C2.eq.C2(i)).and.(C1.lt.0) )
          C1 = numb_comun
        end where
        numb_comun = maxval(C1)+1
      end do

      numb_comun = maxval(C1)
      write(*,*)'Comunidade nova do no C(i):'
      do i=1,n
        write(*,*) 'C1(',i,')=', C1(i)
      end do

!---------Agregar comunidades-----------
      allocate (G2(numb_comun, numb_comun))
      G2 = 0
      do i=1,n
        do j=1,n
              G2(C1(i),C1(j)) = G2(C1(i),C1(j)) + G1(i,j)
        end do
      end do
!------------------------------------------
      deallocate (G1)
      allocate (G1(numb_comun, numb_comun))
!------------Novo Grafo (G1)-----------
      G1 = G2
      deallocate (G2)
      end subroutine aggregate


c$Header: /data/petsun4/data1/src_solaris/interp_4dfp/RCS/pbutt1dc.f,v 1.1 2012/04/16 03:05:45 avi Exp $
c$Log: pbutt1dc.f,v $
c Revision 1.1  2012/04/16  03:05:45  avi
c Initial revision
c
      subroutine pbutt1dc_rcs
      write (*,"('$Id: pbutt1dc.f,v 1.1 2012/04/16 03:05:45 avi Exp $')")
      return
      end

      subroutine pbutt1dcs(data,n0,n,delta,fhalf_lo,iorder_lo,fhalf_hi,iorder_hi,a,b)
c     version of pbutt1dc with scratch arrays a and b passed by pointer
      real*4 data(n)
      real*4 a(n/2+1),b(n/2+1)

      if(mod(n,2).ne.0)then
        write(*,"('pbutt1dcs: illegal odd input array length',i6)")n
        call exit(-1)
      endif
      if(iorder_lo.lt.0.or.iorder_hi.lt.0)then
        write(*,"('pbutt1dcs: negative Butterworth filter orders not allowed')")
        call exit(-1)
      endif

      i=1
      do 21 k=1,n,2
      a(i)=data(k)
      b(i)=data(k+1)
   21 i=i+1

      call FFT  (a,b,1,n/2,1,-1)
      call REALT(a,b,1,n/2,1,-1)
      do 31 i=1,n/2+1
      f=float(i-1)/(float(n0)*delta)
      if(iorder_lo.gt.0)then
        r_lo=(f/fhalf_lo)**(2*iorder_lo)
        factor_lo=sqrt(r_lo/(1.0+r_lo))
      else
        factor_lo=1.0
      endif
      if(iorder_hi.gt.0)then
        r_hi=(f/fhalf_hi)**(2*iorder_hi)
        factor_hi=sqrt(1.0/(1.0+r_hi))
      else
        factor_hi=1.0
      endif
      a(i)=factor_lo*factor_hi*a(i)
   31 b(i)=factor_lo*factor_hi*b(i)
      call REALT(a,b,1,n/2,1,+1)
      call FFT  (a,b,1,n/2,1,+1)

      i=1
      do 41 k=1,n,2
      data(k)  =a(i)
      data(k+1)=b(i)
   41 i=i+1

      return
      end

      subroutine pbutt1dca(data,n0,n,delta,fhalf_lo,iorder_lo,fhalf_hi,iorder_hi)
c     version of pbutt1dc that allocates buffers on each call
      real*4 data(n)
      real*4 a(1),b(1)
      pointer (pa,a),(pb,b)

      if(mod(n,2).ne.0)then
        write(*,"('pbutt1dca: illegal odd input array length',i6)")n
        call exit(-1)
      endif
      if(iorder_lo.lt.0.or.iorder_hi.lt.0)then
        write(*,"('pbutt1dca: negative Butterworth filter orders not allowed')")
        call exit(-1)
      endif

      pa=malloc(4*(n/2+1))
      pb=malloc(4*(n/2+1))
      if(pa.eq.0.or.pb.eq.0)then
        write(*,"('pbutt1dca: memory allocation error')")
        call exit(-1)
      endif

      i=1
      do 21 k=1,n,2
      a(i)=data(k)
      b(i)=data(k+1)
   21 i=i+1

      call FFT  (a,b,1,n/2,1,-1)
      call REALT(a,b,1,n/2,1,-1)
      do 31 i=1,n/2+1
      f=float(i-1)/(float(n0)*delta)
      if(iorder_lo.gt.0)then
        r_lo=(f/fhalf_lo)**(2*iorder_lo)
        factor_lo=sqrt(r_lo/(1.0+r_lo))
      else
        factor_lo=1.0
      endif
      if(iorder_hi.gt.0)then
        r_hi=(f/fhalf_hi)**(2*iorder_hi)
        factor_hi=sqrt(1.0/(1.0+r_hi))
      else
        factor_hi=1.0
      endif
      a(i)=factor_lo*factor_hi*a(i)
   31 b(i)=factor_lo*factor_hi*b(i)
      call REALT(a,b,1,n/2,1,+1)
      call FFT  (a,b,1,n/2,1,+1)

      i=1
      do 41 k=1,n,2
      data(k)  =a(i)
      data(k+1)=b(i)
   41 i=i+1

      call free(pa)
      call free(pb)
      return
      end


!> Author:   Jabir Ali Ouassou
!> Category: Foundation
!>
!> This file defines functions that perform some common matrix operations.

module evaluate_m
  use :: math_m
  use :: stdio_m
  private

  ! Declare which routines to export
  public :: evaluate

  ! Declare public interfaces
  interface evaluate
    !! Public interface for various routines that evaluate mathematical expressions.
    module procedure evaluate_scalar_value,  evaluate_scalar_field, &
                     evaluate_vector_value,  evaluate_vector_field, &
                     evaluate_logical_value, evaluate_integer_value
  end interface
contains
  impure subroutine evaluate_logical_value(expression, value)
    !! This subroutine takes a scalar logical expression as input, and returns the value.
    !!
    !! Usage:
    !!
    !!     call evaluate_logical_value('F', output)
    !!     call evaluate_logical_value('T', output)
    !!

    character(*), intent(in)  :: expression !! Either the character 'T' or 'F'
    logical,      intent(out) :: value      !! Result of parsing the expression

    select case(expression)
      case ('T', 't')
        value = .true.
      case ('F', 'f')
        value = .false.
      case default
        call error('Invalid logical expression: "' // trim(expression) // '"')
    end select
  end subroutine

  impure subroutine evaluate_integer_value(expression, value)
    !! This subroutine takes a scalar integer expression as input, and returns the value.
    !!
    !! Usage:
    !!
    !!     call evaluate_integer_value('10', output)
    !!

    character(*), intent(in)  :: expression !! String containing an integer
    integer,      intent(out) :: value      !! Result of parsing the expression
    integer                   :: iostat     !! Error status from the parsing

    read(expression,*,iostat=iostat) value

    if (iostat /= 0) then
      call error('Invalid integer expression: "' // trim(expression) // '"')
    end if
  end subroutine

  impure subroutine evaluate_scalar_value(expression, value)
    !! This subroutine takes a scalar mathematical expression as input, and returns the value.
    !!
    !! Usage:
    !!
    !!     call evaluate_scalar_value('0',                    output)
    !!     call evaluate_scalar_value('sin(0.3*pi)*exp(-pi)', output)
    !!
    use :: fparser

    character(*), intent(in)  :: expression  !! Scalar-valued mathematical expression
    real(wp),     intent(out) :: value       !! Result of parsing the expression

    ! Make sure the expression is non-empty
    if (scan(expression, '0123456789pi') <= 0) then
      call error('Invalid scalar expression: "' // trim(expression) // '"')
    end if

    ! Initialize the function parser
    call initf(1)
    call parsef(1, expression, ['pi'])

    ! Evaluate the parsed function
    value = evalf(1, [pi])
  end subroutine

  impure subroutine evaluate_scalar_field(expression, domain, value)
    !! This subroutine takes a scalar mathematical function of some variable 'z' as input,  along
    !! with an array with discrete values for that variable 'z'.  It parses the provided function,
    !! evaluates it at each 'z'-value in the array, and then returns the discretized scalar field.
    !!
    !! Usage:
    !!
    !!     call evaluate_scalar_value('0',                    input(1:n), output(1:n))
    !!     call evaluate_scalar_value('sin(pi*z)*exp(-pi*z)', input(1:n), output(1:n))
    !!
    use :: fparser

    character(*),           intent(in)  :: expression   !! Scalar-valued function of position 'z'
    real(wp), dimension(:), intent(in)  :: domain       !! Domain of the independent variable 'z'
    real(wp), dimension(:), allocatable :: value        !! Result of evaluating the field at each point of the domain
    integer                  :: n

    ! Make sure the expression is non-empty
    if (scan(expression, '0123456789piz') <= 0) then
      call error('Invalid scalar expression: "' // trim(expression) // '"')
    end if

    ! Initialize the function parser
    call initf(1)
    call parsef(1, expression, ['pi', 'z '])

    ! Allocate memory for the output
    allocate(value(size(domain)))

    ! Evaluate the parsed function
    do n=1,size(domain)
      value(n) = evalf(1, [pi, domain(n)])
    end do
  end subroutine

  impure subroutine evaluate_vector_value(expression, value)
    !! This subroutine takes a vector mathematical expression as input, and returns the value.
    !!
    !! Usage:
    !!
    !!     call evaluate_scalar_value('[0,0,0]',                     output(1:3))
    !!     call evaluate_scalar_value('[sin(0.3*pi),0,cos(0,3*pi)]', output(1:3))
    !!
    use :: fparser

    character(*),           intent(in)  :: expression  !! Vector-valued mathematical expression
    real(wp), dimension(3), intent(out) :: value       !! Result of parsing the expression
    integer,  dimension(4)              :: sep

    ! Find the vector delimiters
    sep(1) = scan(expression, '[', back=.false.)
    sep(2) = scan(expression, ',', back=.false.)
    sep(3) = scan(expression, ',', back=.true. )
    sep(4) = scan(expression, ']', back=.true. )

    ! Make sure the expressions are non-empty
    if (sep(1) <= 0 .or. any(sep(2:4)-sep(1:3) <= 1)) then
      call error('Invalid vector expression: "' // trim(expression) // '"')
    end if
    if (scan(expression(sep(1)+1:sep(2)-1), '0123456789pi') <= 0 .or. &
        scan(expression(sep(2)+1:sep(3)-1), '0123456789pi') <= 0 .or. &
        scan(expression(sep(3)+1:sep(4)-1), '0123456789pi') <= 0) then
      call error('Invalid vector expression: "' // trim(expression) // '"')
    end if

    ! Initialize the function parser
    call initf(3)
    call parsef(1, expression(sep(1)+1:sep(2)-1), ['pi'])
    call parsef(2, expression(sep(2)+1:sep(3)-1), ['pi'])
    call parsef(3, expression(sep(3)+1:sep(4)-1), ['pi'])

    ! Evaluate the parsed function
    value(1) = evalf(1, [pi])
    value(2) = evalf(2, [pi])
    value(3) = evalf(3, [pi])
  end subroutine

  impure subroutine evaluate_vector_field(expression, domain, value)
    !! This subroutine takes a vector mathematical function of some variable 'z' as input,  along
    !! with an array with discrete values for that variable 'z'.  It parses the provided function,
    !! evaluates it at each 'z'-value in the array, and then returns the discretized scalar field.
    !!
    !! Usage:
    !!
    !!     call evaluate_scalar_value('[0,0,0]',                     input(1:n), output(1:3,1:n))
    !!     call evaluate_scalar_value('[sin(pi*z/2),0,cos(pi*z/2)]', input(1:n), output(1:3,1:n))
    !!
    use :: fparser

    character(*),             intent(in)  :: expression   !! Vector-valued function of position 'z'
    real(wp), dimension(:),   intent(in)  :: domain       !! Domain of the independent variable 'z'
    real(wp), dimension(:,:), allocatable :: value        !! Result of evaluating the field at each point of the domain
    integer,  dimension(4)                :: sep
    integer                               :: n

    ! Allocate memory for the output
    allocate(value(3,size(domain)))

    ! Find the vector delimiters
    sep(1) = scan(expression, '[', back=.false.)
    sep(2) = scan(expression, ',', back=.false.)
    sep(3) = scan(expression, ',', back=.true. )
    sep(4) = scan(expression, ']', back=.true. )

    ! Make sure the expressions are non-empty
    if (sep(1) <= 0 .or. any(sep(2:4)-sep(1:3) <= 1)) then
      call error('Invalid vector expression: "' // trim(expression) // '"')
    end if
    if (scan(expression(sep(1)+1:sep(2)-1), '0123456789piz') <= 0 .or. &
        scan(expression(sep(2)+1:sep(3)-1), '0123456789piz') <= 0 .or. &
        scan(expression(sep(3)+1:sep(4)-1), '0123456789piz') <= 0) then
      call error('Invalid vector expression: "' // trim(expression) // '"')
    end if

    ! Initialize the function parser
    call initf(3)
    call parsef(1, expression(sep(1)+1:sep(2)-1), ['pi', 'z '])
    call parsef(2, expression(sep(2)+1:sep(3)-1), ['pi', 'z '])
    call parsef(3, expression(sep(3)+1:sep(4)-1), ['pi', 'z '])

    ! Evaluate the parsed function
    do n=1,size(domain)
      value(1,n) = evalf(1, [pi, domain(n)])
      value(2,n) = evalf(2, [pi, domain(n)])
      value(3,n) = evalf(3, [pi, domain(n)])
    end do
  end subroutine
end module


!*robodoc*f* cgca_m3clvg/m3clvg_sm2
!  NAME
!    m3clvg_sm2
!  SYNOPSIS

!$Id: m3clvg_sm2.f90 380 2017-03-22 11:03:09Z mexas $

submodule ( cgca_m3clvg ) m3clvg_sm2

!  DESCRIPTION
!    Submodule with aux routine for checking the misorientation
!    thereshold.
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  CONTAINS
!    cgca_tchk
!  USES
!    Variables and routines of module cgca_m3clvg by host
!    association.
!  USED BY
!    Module cgca_m3clvg
!  SOURCE

implicit none

contains

!*roboend*

!*robodoc*s* m3clvg_sm2/cgca_tchk
!  NAME
!    cgca_tchk
!  SYNOPSIS

module procedure cgca_tchk

!  DESCRIPTION
!    Generate num random unit normal vectors.
!    Calculate the MAX of the MIN for all 26 cell
!    neighbourhood unit vectors.
!    Find the maximum value of all num normal vectors
!    and return it as maxmin.
!    And the opposite - calculate the MIN of the MAX for
!    all 26 cell neighbourhood unit vectors.
!    Find the min value of all num normal vectors
!    and return as minmax.
!  NOTE
!    Any image can call this routine
!  SOURCE

real(    kind=rlrg ) :: n(3), mag, prod, prodmax, prodmin
integer( kind=ilrg ) :: i, x1, x2, x3

maxmin = 0.0_rlrg
minmax = 1.0_rlrg

do i=1,num
  prodmin = 1.0_rlrg
  prodmax = 0.0_rlrg
  call random_number(n)
  mag = sqrt( sum( n**2 ) )
  n = n / mag
  do x3 = -1, 1
  do x2 = -1, 1
  do x1 = -1, 1
    if ( x1 .eq. 0 .and. x2 .eq. 0 .and. x3 .eq. 0) cycle
    prod = abs( dot_product( e(:,x1,x2,x3), n ) )
    if ( prod .lt. prodmin ) prodmin = prod
    if ( prod .gt. prodmax ) prodmax = prod
  end do
  end do
  end do

  if ( prodmin .gt. maxmin) maxmin = prodmin
  if ( prodmax .lt. minmax) minmax = prodmax

end do

end procedure cgca_tchk

!*roboend*

end submodule m3clvg_sm2


      SUBROUTINE CGECO(A,LDA,N,IPVT,RCOND,Z)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 CGECO  Krogh   Added external statement.
C>> 1992-05-18 CLL
C>> 1987-08-20 CGECO  Lawson  Initial code.
C
c     Given an Nth order matrix, A, this subroutine does the following
c     three steps:
c     1. Compute a norm of A for internal use at Step 3.
c     2. Call _GEFA to compute an LU factorization of A that overwrites
c        A in the array A().
c     3. Compute RCOND, an estimate of the reciprocal of the condition
c        number of A.
C     The total computing time for Steps 1 and 3 is relatively
c     economical, being about (9/N) times the time needed for Step 2.
c     ------------------------------------------------------------------
c                        Subroutine arguments
C
C     A(,)  [inout]  An array of size at least N x N.  On entry must
c            contain an N x N matrix, A, to be factored.  On return will
c            contain the LU factors of A.
C
C     LDA  [in]  Leading dimensioning parameter for the array A(,).
C
C     N  [in]  The order of the matrix, A.
C
C     IPVT()  [out]  An integer array of length at least N into which
c           will be stored record of the row interchanges made during
c           factorization of A.
c
C     RCOND  [out]  An estimate of the reciprocal of the condition
c           number of the original matrix, A.
c           Will satisfy ZERO .le. RCOND .le. ONE.
C           For the system  A*X = B , relative perturmations
C           in  A  and  B  of size  EPSILON  may cause
C           relative perturbations in  X  of size  EPSILON/RCOND .
C           If RCOND is so small that the expression
C                           ONE + RCOND
c           truncated to working precision is not distinguishable from
c           ONE, then A is singular to working precision.
C           In particular, RCOND will be returned as ZERO if  exact
c           singularity is detected or if the estimate underflows.
C
C     Z()  [out]  An array of length at least N.  Needed in this
c           subroutine as work space.  On return will contain a vector
c           Z satisfying NORM(A*Z) = RCOND * NORM(A) * NORM(Z) .
C           If A is close to a singular matrix, then Z will be
C           an approximate null vector.
c     ------------------------------------------------------------------
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
c     Ref: LINPACK Users' Guide, by J. J. Dongarra, C. B. Moler,
c     J. R. Bunch, and G. W. Stewart, publ by Soc. for Indust. and Appl.
c     Math, Philadelphia, 1979.
c     Adapted from LINPACK for the JPL Math77 library by
c     C. L. Lawson, JPL, Aug 1987.
c     ------------------------------------------------------------------
C     Subprograms referenced directly:  CGEFA, CAXPY,CDOTC,CSSCAL,SCASUM
c     ------------------------------------------------------------------
      EXTERNAL CDOTC, SCASUM
      INTEGER LDA,N,IPVT(N)
      COMPLEX A(LDA,N),Z(N),CZERO,CONE
      PARAMETER(CZERO=(0.E0,0.E0),CONE=(1.E0,0.E0))
      REAL RCOND
      COMPLEX CDOTC,EK,T,WK,WKM
      REAL ANORM,S,SCASUM,SM,YNORM,ZERO,ONE
      INTEGER INFO,J,K,KP1,L
      PARAMETER(ZERO=0.E0, ONE=1.E0)
C
      COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1
      REAL CABS1
c     ------------------------------------------------------------------
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
      CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2))
c     ------------------------------------------------------------------
C
C     COMPUTE 1-NORM OF A
C
      ANORM = ZERO
      DO 10 J = 1, N
         ANORM = MAX(ANORM,SCASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL CGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE CTRANS(U)*W = E
C
      EK = CONE
      DO 20 J = 1, N
         Z(J) = CZERO
   20 CONTINUE
      DO 100 K = 1, N
c        5/18/92 CLL The following stmt rewritten to avoid a bug in
c        the current SUN Fortran compiler.
c        IF (Z(K) .NE. CZERO) EK = CSIGN1(EK,-Z(K))
         if(real(Z(K)) .ne. 0.0e0 .or. aimag(Z(K)) .ne. 0.0e0)
     *      EK = CSIGN1(EK,-Z(K))
          IF (CABS1(EK-Z(K)) .GT. CABS1(A(K,K))) THEN
            S = CABS1(A(K,K))/CABS1(EK-Z(K))
            CALL CSSCAL(N,S,Z,1)
            EK = S * EK
         END IF
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = CABS1(WK)
         SM = CABS1(WKM)
c        5/18/92 CLL The following stmt rewritten to avoid a bug in
c        the current SUN Fortran compiler.
c        IF (A(K,K) .NE. CZERO) THEN
         if(real(A(K,K)) .ne. 0.0e0 .or. aimag(A(K,K)) .ne. 0.0e0) then
            WK = WK/CONJG(A(K,K))
            WKM = WKM/CONJG(A(K,K))
         ELSE
            WK = CONE
            WKM = CONE
         END IF
         KP1 = K + 1
            DO 60 J = KP1, N
               SM = SM + CABS1(Z(J)+WKM*CONJG(A(K,J)))
               Z(J) = Z(J) + WK*CONJG(A(K,J))
               S = S + CABS1(Z(J))
   60       CONTINUE
            IF (S .LT. SM) THEN
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*CONJG(A(K,J))
   70          CONTINUE
            END IF
         Z(K) = WK
  100 CONTINUE
      S = ONE/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
C     SOLVE CTRANS(L)*Y = W
C
      DO 120 K = N,1,-1
         IF (K .LT. N) Z(K) = Z(K) + CDOTC(N-K,A(K+1,K),1,Z(K+1),1)
         IF (CABS1(Z(K)) .GT. ONE) THEN
            S = 1.0E0/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
         END IF
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = ONE/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
      YNORM = ONE
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL CAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (CABS1(Z(K)) .GT. ONE) THEN
            S = 1.0E0/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
         END IF
  140 CONTINUE
      S = ONE/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 K = N,1,-1
         IF (CABS1(Z(K)) .GT. CABS1(A(K,K))) THEN
            S = CABS1(A(K,K))/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
         END IF
c        5/18/92 CLL The following stmt rewritten to avoid a bug in
c        the current SUN Fortran compiler.
c        IF (A(K,K) .NE. CZERO) THEN
         if(real(A(K,K)) .ne. 0.0e0 .or. aimag(A(K,K)) .ne. 0.0e0) then
           Z(K) = Z(K)/A(K,K)
         ELSE
           Z(K) = CONE
         END IF
         T = -Z(K)
         CALL CAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = ONE/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .EQ. 0.0E0) THEN
        RCOND = 0.0E0
      ELSE
        RCOND = YNORM/ANORM
      END IF
      RETURN
      END


!===============================================================================
program test
!===============================================================================
!  Test that (a) set(s) of elastic constants are dynamically stable; i.e., they
!  are represented by a real, symmetrical, positive definite Voigt matrix.
!  Either read ECs from a .ecs file, or take sets of ECs from stdin.
!  When stable, output is 'T'.  When unstable, output is 'F'

   use anisotropy_ajn

   implicit none

   integer, parameter :: rs = 8
   real(rs) :: C(6,6), rho
   integer :: iostat = 0, i, j
   character(len=250) :: file
   integer :: necs = 36
   logical :: read_ecs_stdin = .true.

   call get_args

   if (read_ecs_stdin) then
      do while (iostat == 0)
         if (necs == 36) then
            read(*,*,iostat=iostat) C
         else
            read(*,*,iostat=iostat) ((C(i,j), j=i,6), i=1,6)
            do i = 1, 6
               do j = i+1, 6
                  C(j,i) = C(i,j)
               enddo
            enddo
         endif
         if (iostat < 0) exit
         if (iostat > 0) then
            write(0,'(a,i0,a)') 'CIJ_is_stable: Error: Problem reading ', necs, &
               ' ecs from stdin'
            stop
         endif
         call CIJ_is_stable_out
      enddo
   else
      call CIJ_load(file, C, rho)
      call CIJ_is_stable_out
   endif

contains
   !============================================================================
   subroutine CIJ_is_stable_out
   !============================================================================
      write(*,*) CIJ_is_stable(C)
   end subroutine CIJ_is_stable_out
   !----------------------------------------------------------------------------

   !============================================================================
   subroutine get_args()
   !============================================================================
      integer :: iarg, narg
      character(len=250) :: arg
      narg = command_argument_count()
      iarg = 1
      do while (iarg <= narg)
         call get_command_argument(iarg, arg)
         select case(arg)
            case('-21')
               necs = 21
               iarg = iarg + 1
            case('-f')
               call get_command_argument(iarg+1, file)
               read_ecs_stdin = .false.
               iarg = iarg + 2
            case default
               write(0,'(a)') 'CIJ_is_stable: Error: Urecognised option "'//trim(arg)//'"'
               call usage
         end select
      enddo
   end subroutine get_args
   !----------------------------------------------------------------------------

   !============================================================================
   subroutine usage
   !============================================================================
      write(0,'(a)') &
         'Usage: CIJ_is_stable (options) < [ecs from stdin]', &
         '   or: CIJ_is_stable (options) -f [.ecs file]', &
         'Options:', &
         '   -f  : Read ecs from file [stdin]', &
         '   -21 : Set necs from stdin to 21 [36]'
      stop
   end subroutine usage
   !----------------------------------------------------------------------------
end program test
!-------------------------------------------------------------------------------


      PROGRAM MAIN

C     RESULT REPORTING
C     CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(F18.15)"
      CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(E12.6)"

C     ----------------------------------------------
C     Variables and data for GMF
C     ----------------------------------------------
      DOUBLE PRECISION GMFH, GMFW

      CALL GMF(55055D0, 0.6708665767D0, -1.393397187D0, 844.715D0,
     . 1.278564131D0, GMFH, GMFW)

C     REPORT RESULTS
      PRINT *, '----------------------------------------'
      PRINT *, '> GMF Results:'
      PRINT *, '----------------------------------------'
      WRITE(*, FMT1) DABS(GMFH-3.425245519339138678D0)
      WRITE(*, FMT1) DABS(GMFW-3.449589116182419257D0)

C     ALL DONE
      END


      subroutine tdmev(fv1,fv2,fv3,n,ndim,ev,efn,m,kerr,work)
c
c  driver to find larger eigenvalues of a real symmetric
c  tridiagonal matrix
c
c  calls tridib,tinvit from eispack
c
      implicit double precision (a-h,o-z)
      dimension fv1(ndim),fv2(ndim),fv3(ndim),efn(ndim,m),ev(m),
     $          work(1)
      nndim=ndim
      mm=m
      nn=n
      nv4=1
      nv5=nn+nv4
      nv6=nn+nv5
      nv7=nn+nv6
      nv8=nn+nv7
      iv1=nn+nv8
c
c  compute the m largest eigenfunctions efn and associated
c  eigenvalues of the symmetric tridiagonal matrix
c  input is in fv1,fv2,fv3 in usual eispack form, see 2.1.17
c
      eps1=0.
      m11=n-m+1
      call tridib(nn,eps1,fv1,fv2,fv3,evlb,evub,m11,mm,ev,
     $            work(iv1),ierr,work(nv4),work(nv5))
      if(ierr.ne.0)kerr=1
      call tinvit(nndim,nn,fv1,fv2,fv3,mm,ev,work(iv1),efn,ierr,
     $            work(nv4),work(nv5),work(nv6),work(nv7),work(nv8))
      if(ierr.ne.0)kerr=2
      return
      end

c $Id$


c-----------------------------------------------------------------------
c  routine to generate Clebsch-Gordan coefficients, in the form of
c  cg(l1,l2,L,m1,m2) = <l1,m1;l2,m2|L,m1+m2>, according to Rose's
c  'Elementary Theory of Angular Momentum', p. 39, Wigner's formula.
c  those coefficients listed are only those for which l1.ge.l2.
c  coefficients known to be zero because of either the L or M
c  selection rules are not computed, and should not be sought.

        subroutine clebschgordan(nel,nl,cg)

        implicit real*8 (a-h,o-z)
        parameter (iorbs=33,iside=600)
        parameter (io2=iorbs*(iorbs+1)/2)
        parameter (ijive=io2*(io2+1)/2)
        parameter (lmax=4,ihmax=20,nrmax=4000,ntmax=10,npmax=60)
        dimension nl(iorbs)
        dimension cg(0:6,0:6,0:12,-6:6,-6:6),si(0:32),fa(0:32)

        lmx=0
        do i=1,nel
          if (nl(i).gt.lmx) lmx=nl(i)
        enddo

        si(0)=1.d0
        fa(0)=1.d0
        do i=1,32
          si(i)=-si(i-1)
          fa(i)=dfloat(i)*fa(i-1)
        enddo

        do 100 l1=0,lmx
        do 100 l2=0,l1
 52     format (1x,i3,a3,i3)
        do 100 m1=-l1,l1
        do 100 m2=-l2,l2
        m3=m1+m2
        lmin=iabs(l1-l2)
        if (lmin.lt.iabs(m3)) lmin=iabs(m3)
        do 100 l3=lmin,l1+l2
        prefactor=dfloat(2*l3+1)
        prefactor=prefactor*fa(l3+l1-l2)/fa(l1+l2+l3+1)
        prefactor=prefactor*fa(l3-l1+l2)/fa(l1-m1)
        prefactor=prefactor*fa(l1+l2-l3)/fa(l1+m1)
        prefactor=prefactor*fa(l3+m3)/fa(l2-m2)
        prefactor=prefactor*fa(l3-m3)/fa(l2+m2)
        prefactor=dsqrt(prefactor)
        sum=0.d0
        numax=l3-l1+l2
        if ((l3+m3).lt.numax) numax=l3+m3
        numin=0
        if (l1-l2-m3.lt.numin) numin=-(l1-l2-m3)
        do nu=numin,numax
          sum=sum+(si(nu+l2+m2)/fa(nu))*fa(l2+l3+m1-nu)*fa(l1-m1+nu)
     1            /fa(l3-l1+l2-nu)/fa(l3+m3-nu)/fa(nu+l1-l2-m3)
        enddo
        cg(l1,l2,l3,m1,m2)=prefactor*sum
        cg(l2,l1,l3,m2,m1)=si(l1+l2+l3)*prefactor*sum
 100    continue

        return
        end


      function  UxcMik(d,Uxc2)
      implicit double precision (a-h,o-z)
      parameter (a0=.4581652932831429d0,a1=2.40875407d0,
     $           a2=.88642404d0,a3=.02600342d0)
      parameter (b1=1.0d0,b2=4.91962865d0,b3=1.34799453d0,
     $           b4=.03120453d0)
      parameter (c1=4.d0*a0*b1/3.0d0,  c2=5.0d0*a0*b2/3.0d0+a1*b1,
     $         c3=2.0d0*a0*b3+4.0d0*a1*b2/3.0d0+2.0d0*a2*b1/3.0d0,
     $      c4=7.0d0*a0*b4/3.0d0+5.0d0*a1*b3/3.0d0+a2*b2+a3*b1/3.0d0,
     $        c5=2.0d0*a1*b4+4.0d0*a2*b3/3.0d0+2.0d0*a3*b2/3.0d0,
     $        c6=5.0d0*a2*b4/3.0d0+a3*b3,c7=4.0d0*a3*b4/3.0d0)
      parameter (pi4=3.1415926d0*4)
      parameter (rsfac=0.62035 04908 994000d0)
      real*8 UxcMik,d

       rh=max(d,1.d-16)
       rs=rsfac*rh**(-.3333333333333333d0)
       excnum=-(a0+rs*(a1+rs*(a2+rs*a3)))
       excden=rs*(b1+rs*(b2+rs*(b3+rs*b4)))
       exc=excnum/excden
       vxcnum=-rs*(c1+rs*(c2+rs*(c3+rs*(c4+rs*(c5+rs*(c6+rs*c7))))))
       vxc=vxcnum/(excden*excden)
       Uxc1=vxc
       Uxc2=exc

       UxcMik=Uxc1

       return
       end


module mod_cheb
!=============================================================================
   use mod_prec
   use mod_field,  only: field, set_level
   use mod_io,     only: set_arr
   use mod_params, only: tables_dir, R_max, nx, ny, min_m, max_m

!=============================================================================
! for use in fftw
   use, intrinsic :: iso_c_binding, only: c_int, c_double

   implicit none
!=============================================================================
   include 'fftw3.f03'
!=============================================================================
   private

   real(rp) :: dx_over_dR

   integer(ip) :: N

   ! fftw3 objects
   type(c_ptr) :: plan_dct

   ! radial points
   real(rp), allocatable, protected, public :: Rvec(:)
   real(rp), allocatable, protected, public :: Rarr(:,:)

   ! filter array
   real(rp), allocatable :: filter_arr(:,:)

   ! subroutines
   public :: cheb_init, compute_DR, cheb_filter, cheb_test

   public :: cheb_real_to_coef

   interface compute_DR
      module procedure compute_DR_arr, compute_DR_field
   end interface
!=============================================================================
contains
!=============================================================================
   subroutine cheb_init()
      integer :: j
      complex(rp), allocatable :: test_in(:), test_out(:)

      dx_over_dR = 2.0_rp / R_max
      N = nx - 1

      allocate(Rvec(nx))
      allocate(Rarr(nx,ny))
      allocate(filter_arr(nx,ny))

      call set_arr('cheb_pts.txt', nx, Rvec)

      Rvec = (R_max/2.0_rp) * (Rvec + 1.0_rp)

      do j=1,ny
         Rarr(:,j) = Rvec
      end do

      ! setup dct fftw plan
      allocate(test_in( nx))
      allocate(test_out(nx))

      call dfftw_plan_r2r_1d( &
         plan_dct, &
         nx, &
         test_in,test_out, &
         FFTW_REDFT00,FFTW_PATIENT)

      do j=1,nx
         filter_arr(j,:) = exp(-40.0_rp*(real(j-1,rp)/real(nx-1,rp))**16)
      end do

   end subroutine cheb_init
!=============================================================================
   subroutine cheb_real_to_coef(m_ang,vals,coefs,re_v,im_v,re_c,im_c)
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: vals
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: coefs
      real(rp),    dimension(nx,ny,min_m:max_m), intent(inout) :: re_v, im_v, re_c, im_c

      integer(ip) :: i,j

      do j=1,ny
         re_v(:,j,m_ang) = real( vals(:,j,m_ang),kind=rp)
         im_v(:,j,m_ang) = aimag(vals(:,j,m_ang))

         call dfftw_execute_r2r(plan_dct,re_v(:,j,m_ang),re_c(:,j,m_ang))
         call dfftw_execute_r2r(plan_dct,im_v(:,j,m_ang),im_c(:,j,m_ang))

         re_c(1,j,m_ang) = re_c(1,j,m_ang)/(2.0_rp*N)
         im_c(1,j,m_ang) = im_c(1,j,m_ang)/(2.0_rp*N)

         re_c(nx,j,m_ang) = re_c(nx,j,m_ang)/(2.0_rp*N)
         im_c(nx,j,m_ang) = im_c(nx,j,m_ang)/(2.0_rp*N)

         do i=2,N
            re_c(i,j,m_ang) = re_c(i,j,m_ang)/N
            im_c(i,j,m_ang) = im_c(i,j,m_ang)/N
         end do

         coefs(:,j,m_ang) = cmplx(re_c(:,j,m_ang),im_c(:,j,m_ang),kind=rp)
      end do

   end subroutine cheb_real_to_coef
!=============================================================================
   subroutine cheb_coef_to_real(m_ang,coefs,vals,re_v,im_v,re_c,im_c)
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: coefs
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: vals
      real(rp),    dimension(nx,ny,min_m:max_m), intent(inout) :: re_v, im_v, re_c, im_c

      integer(ip) :: i, j

      do j=1,ny
         re_c(:,j,m_ang) = real( coefs(:,j,m_ang),kind=rp)
         im_c(:,j,m_ang) = aimag(coefs(:,j,m_ang))

         do i=2,N
            re_c(i,j,m_ang) = re_c(i,j,m_ang) / 2.0_rp
            im_c(i,j,m_ang) = im_c(i,j,m_ang) / 2.0_rp
         end do

         call dfftw_execute_r2r(plan_dct,re_c(:,j,m_ang),re_v(:,j,m_ang))
         call dfftw_execute_r2r(plan_dct,im_c(:,j,m_ang),im_v(:,j,m_ang))

         vals(:,j,m_ang) = cmplx(re_v(:,j,m_ang),im_v(:,j,m_ang),kind=rp)
      end do

   end subroutine cheb_coef_to_real
!=============================================================================
   subroutine compute_DR_arr(m_ang,vals,coefs,DR,re_v,im_v,re_c,im_c)
      integer(ip), intent(in) :: m_ang
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: vals
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: coefs
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: DR
      real(rp),    dimension(nx,ny,min_m:max_m), intent(inout) :: re_v, im_v, re_c, im_c

      integer(ip) :: i

      call cheb_real_to_coef(m_ang,vals,coefs,re_v,im_v,re_c,im_c)

      ! Any error incurred by setting the last two cheb coefs to zero
      ! should converge away with higher resolution.
      coefs(nx,  :,m_ang) = 0
      coefs(nx-1,:,m_ang) = 0

      ! use D_vals as a temporary array
      DR(:,:,m_ang) = coefs(:,:,m_ang)

      ! note fortran indexing 1..nx (and not 0..nx-1)
      do i=nx-1, 2, -1
         coefs(i-1,:,m_ang) = 2.0_rp*(i-1)*DR(i,:,m_ang) + coefs(i+1,:,m_ang)
      end do

      coefs(1,:,m_ang) = coefs(1,:,m_ang) / 2.0_rp

      call cheb_coef_to_real(m_ang,coefs,DR,re_v,im_v,re_c,im_c)

      DR(:,:,m_ang) = dx_over_dR * DR(:,:,m_ang)

   end subroutine compute_DR_arr
!=============================================================================
   subroutine compute_DR_field(step,m_ang,f)
      integer(ip), intent(in) :: step, m_ang
      type(field), intent(inout) :: f

      call set_level(step,m_ang,f)
      call compute_DR_arr(m_ang,f%level,f%coefs_cheb,f%DR, &
         f%re,f%im, &
         f%coefs_cheb_re,f%coefs_cheb_im &
      )
   end subroutine compute_DR_field
!=============================================================================
! Low pass filter. A smooth filter appears to help prevent Gibbs-like ringing
!=============================================================================
   subroutine cheb_filter(m_ang, f)
      integer(ip), intent(in)    :: m_ang
      type(field), intent(inout) :: f

      call cheb_real_to_coef(m_ang,f%np1,f%coefs_cheb, &
         f%re,f%im, &
         f%coefs_cheb_re,f%coefs_cheb_im &
      )
      f%coefs_cheb(:,:,m_ang) = filter_arr*f%coefs_cheb(:,:,m_ang)

      call cheb_coef_to_real(m_ang,f%coefs_cheb,f%np1, &
         f%re,f%im, &
         f%coefs_cheb_re,f%coefs_cheb_im &
      )
   end subroutine cheb_filter
!=============================================================================
   subroutine cheb_test()
      complex(rp), dimension(nx,ny,min_m:max_m) :: &
         vals, coefs, DR_vals, computed_DR_vals
      real(rp), dimension(nx,ny,min_m:max_m) :: re, im, re_c, im_c
      integer(ip) :: i
      integer(ip) :: m_ang = 0_ip

      do i=1,nx
         vals(i,:,:)    = sin(Rvec(i))**2
         DR_vals(i,:,:) = 2*sin(Rvec(i))*cos(Rvec(i))
      end do

      call compute_DR(m_ang, vals, coefs, computed_DR_vals, re, im, re_c, im_c)

      do i=1,nx
         write (*,*) computed_DR_vals(i,:,m_ang) - DR_vals(i,:,m_ang)
      end do

   end subroutine cheb_test
!=============================================================================
end module mod_cheb


	subroutine gamma_errors(s,t,p,gamma,a,n,along,alat,
     &					s0,t0,p0,sns,tns,pns,kns,
     &				    gamma_ns,pth_error,scv_l_error,scv_h_error)
ccc
ccc
ccc
ccc	DESCRIPTION :	Find the p-theta and the scv errors associated
ccc			with the basic neutral surface calculation
ccc
ccc	PRECISION :	Double
ccc
ccc	INPUT :		s(n)		array of Levitus cast salinities
ccc			t(n)		array of cast in situ temperatures
ccc			p(n)		array of cast pressures
ccc			gamma(n)	array of cast neutral densities
ccc			a(n)		array of cast quadratic coefficients
ccc			n		length of cast
ccc			along		longitude of Levitus cast
ccc			alat		latitude of Levitus cast
ccc			s0		bottle salinity
ccc			t0		bottle temperature
ccc			p0		bottle pressure
ccc			sns		salinity of neutral surface on cast
ccc			tns		temperature of neutral surface on cast
ccc			pns		pressure of neutral surface on cast
ccc			kns		index of neutral surface on cast
ccc			gamma_ns	gamma value of neutral surface on cast
ccc
ccc	OUTPUT :	pth_error	p-theta gamma error bar
ccc			scv_l_error	lower scv gamma error bar
ccc			scv_h_error	upper scv gamma error bar
ccc
ccc	UNITS :		salinity	psu (IPSS-78)
ccc			temperature	degrees C (IPTS-68)
ccc			pressure	db
ccc			gamma		kg m-3
ccc
ccc
ccc	AUTHOR :	David Jackett
ccc
ccc	CREATED :	March 1995
ccc
ccc	REVISION :	1.1		9/3/95
ccc
ccc
ccc
	parameter(nscv_max=50)

	implicit double precision (a-h,o-z)

	dimension s(n),t(n),p(n),gamma(n),a(n)

	dimension sscv_m(nscv_max),tscv_m(nscv_max),pscv_m(nscv_max)

	data pr0/0.0/, Tb/2.7e-8/, gamma_limit/26.845/, test_limit/0.1/

ccc
ccc		p-theta error
ccc

	th0 = theta(s0,t0,p0,pr0)
	thns = theta(sns,tns,pns,pr0)

	sdum = svan(sns,tns,pns,sig_ns)
	rho_ns = 1000+sig_ns

	call sig_vals(s(kns),t(kns),p(kns),s(kns+1),t(kns+1),p(kns+1),
     &								sig_l,sig_h)

	b = (gamma(kns+1)-gamma(kns))/(sig_h-sig_l)

	dp = pns-p0
	dth = thns-th0

	pth_error = rho_ns*b*Tb*abs(dp*dth)/6

ccc
ccc		scv error
ccc

	scv_l_error = 0.0
	scv_h_error = 0.0

	if(alat.le.-60.0.or.gamma(1).ge.gamma_limit) then

	  drldp = (sig_h-sig_l)/(rho_ns*(p(kns+1)-p(kns)))

	  test = Tb*dth/drldp

cc
cc		approximation
cc

	  if(abs(test).le.test_limit) then

	    if(dp*dth.ge.0.0) then
	      scv_h_error = (3*pth_error)/(1.0-test)
	    else
	      scv_l_error = (3*pth_error)/(1.0-test)
	    end if

	  else

cc
cc		explicit scv solution, when necessary
cc

	    call depth_scv(s,t,p,n,s0,t0,p0,sscv_m,tscv_m,pscv_m,nscv)

	    if(nscv.eq.0) then

	      continue

	    else

	      if(nscv.eq.1) then

		pscv = pscv_m(1)

	      else

		pscv_mid = pscv_m((1+nscv)/2)

		if(p0.le.pscv_mid) then
	          pscv = pscv_m(1)
		else
	          pscv = pscv_m(nscv)
		end if

	      end if

	      call indx(p,n,pscv,kscv)
	      call gamma_qdr(p(kscv),gamma(kscv),a(kscv),
     &				p(kscv+1),gamma(kscv+1),pscv,gamma_scv)

	      if(pscv.le.pns) then
		scv_l_error = gamma_ns-gamma_scv
	      else
		scv_h_error = gamma_scv-gamma_ns
	      end if

	    end if

	  end if

	else

	  continue

	end if

ccc
ccc		check for positive gamma errors
ccc

	if(pth_error.lt.0.0.or.
     &	    	scv_l_error.lt.0.0.or.
     &			scv_h_error.lt.0.0) then

	  stop 'ERROR 1 in gamma-errors: negative scv error'

	end if

	return
	end


      DOUBLE PRECISION FUNCTION betaln(a0,b0)
C-----------------------------------------------------------------------
C     EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
C-----------------------------------------------------------------------
C     E = 0.5*LN(2*PI)
C--------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a0,b0
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a,b,c,e,h,u,v,w,z
      INTEGER i,n
C     ..
C     .. External Functions ..
      DOUBLE PRECISION algdiv,alnrel,bcorr,gamln,gsumln
      EXTERNAL algdiv,alnrel,bcorr,gamln,gsumln
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dlog,dmax1,dmin1
C     ..
C     .. Data statements ..
      DATA e/.918938533204673D0/
C     ..
C     .. Executable Statements ..
C--------------------------
      a = dmin1(a0,b0)
      b = dmax1(a0,b0)
      IF (a.GE.8.0D0) GO TO 100
      IF (a.GE.1.0D0) GO TO 20
C-----------------------------------------------------------------------
C                   PROCEDURE WHEN A .LT. 1
C-----------------------------------------------------------------------
      IF (b.GE.8.0D0) GO TO 10
      betaln = gamln(a) + (gamln(b)-gamln(a+b))
      RETURN

   10 betaln = gamln(a) + algdiv(a,b)
      RETURN
C-----------------------------------------------------------------------
C                PROCEDURE WHEN 1 .LE. A .LT. 8
C-----------------------------------------------------------------------
   20 IF (a.GT.2.0D0) GO TO 40
      IF (b.GT.2.0D0) GO TO 30
      betaln = gamln(a) + gamln(b) - gsumln(a,b)
      RETURN

   30 w = 0.0D0
      IF (b.LT.8.0D0) GO TO 60
      betaln = gamln(a) + algdiv(a,b)
      RETURN
C
C                REDUCTION OF A WHEN B .LE. 1000
C
   40 IF (b.GT.1000.0D0) GO TO 80
      n = a - 1.0D0
      w = 1.0D0
      DO 50 i = 1,n
          a = a - 1.0D0
          h = a/b
          w = w* (h/ (1.0D0+h))
   50 CONTINUE
      w = dlog(w)
      IF (b.LT.8.0D0) GO TO 60
      betaln = w + gamln(a) + algdiv(a,b)
      RETURN
C
C                 REDUCTION OF B WHEN B .LT. 8
C
   60 n = b - 1.0D0
      z = 1.0D0
      DO 70 i = 1,n
          b = b - 1.0D0
          z = z* (b/ (a+b))
   70 CONTINUE
      betaln = w + dlog(z) + (gamln(a)+ (gamln(b)-gsumln(a,b)))
      RETURN
C
C                REDUCTION OF A WHEN B .GT. 1000
C
   80 n = a - 1.0D0
      w = 1.0D0
      DO 90 i = 1,n
          a = a - 1.0D0
          w = w* (a/ (1.0D0+a/b))
   90 CONTINUE
      betaln = (dlog(w)-n*dlog(b)) + (gamln(a)+algdiv(a,b))
      RETURN
C-----------------------------------------------------------------------
C                   PROCEDURE WHEN A .GE. 8
C-----------------------------------------------------------------------
  100 w = bcorr(a,b)
      h = a/b
      c = h/ (1.0D0+h)
      u = - (a-0.5D0)*dlog(c)
      v = b*alnrel(h)
      IF (u.LE.v) GO TO 110
      betaln = (((-0.5D0*dlog(b)+e)+w)-v) - u
      RETURN

  110 betaln = (((-0.5D0*dlog(b)+e)+w)-u) - v
      RETURN

      END


************************************************************************
*
*     Subroutine DLIVMU                               Called by: DGQTST
*
*     solve L*X = Y, where L is an NxN lower triangular matrix stored
*     compactly by rows.  X and Y may occupy the same storage.
*
************************************************************************
      SUBROUTINE DLIVMU(N,X,L,Y)
*
*     subroutine arguments
*
      INTEGER*4 N
      DOUBLE PRECISION X(*),L(*),Y(*)
*
*     local vars
*
      INTEGER*4 I,J,K
      DOUBLE PRECISION T
*
*     function declaration
*
      DOUBLE PRECISION DDOT
*
*
*
      DO 10 K=1,N
         IF (Y(K) .NE. 0.D0) GOTO 20
         X(K) = 0.D0
 10   CONTINUE
      RETURN
 20   J = K*(K+1)/2
      X(K) = Y(K) / L(J)
      IF (K .GE. N) RETURN
      K = K + 1
      DO 30 I = K,N
         T = DDOT(I-1,L(J+1),X)
         J = J + I
         X(I) = (Y(I) - T)/L(J)
 30   CONTINUE

      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine excited_electron_k_resolved(nex0th_kz,nex1st_kz,nex2nd_kz,it)
  use global_variables
  implicit none
  real(8),intent(out) :: nex0th_kz(-NKz:NKz)
  real(8),intent(out) :: nex1st_kz(-NKz:NKz)
  real(8),intent(out) :: nex2nd_kz(-NKz:NKz)
  integer,intent(in) :: it
  real(8) :: lambda_v,lambda_c,theta_p,theta_m,eps_p,eps_m,dlambda
  real(8) :: Etz0,Etz1,alpha,ss,dEt_dt
  complex(8) :: zx,zy
  integer :: ikr,ikz
  complex(8) :: zeig_vec_v(2), zeig_vec_c(2)
  complex(8) :: zeig_vec_acc_v(2), zeig_vec_acc_c(2)
  real(8) :: lambda_acc_v,lambda_acc_c
  real(8) :: xx, xx_dot, ff, ff_dot, eta, eta_dot
  real(8) :: deps_dot(NKr,-NKz:NKz)

  Etz0 = -0.5d0*(Act(it+1)-Act(it-1))/dt
  dEt_dt = -(Act(it+1)-2d0*Act(it) + Act(it-1))/dt**2
  nex0th_kz = 0d0
  nex1st_kz = 0d0
  nex2nd_kz = 0d0

!$omp parallel

!=== deps_int, deps ====
!$omp do private(ikz, ikr)
  do ikz = -NKz,NKz
    kz(ikz) = kz0(ikz) + Act(it)*fact_intra
    do ikr = 1,NKr
      deps(ikr,ikz) = eps_g + 0.5d0/mass_r*(kr(ikr)**2+kz(ikz)**2)
      deps_dot(ikr,ikz) = -1d0/mass_r*kz(ikz)*Etz0*fact_intra
    end do
  end do
!=== deps_int, deps ====

!$omp do private(ikz,ikr,alpha,lambda_v,lambda_c,zx,zy,ss,zeig_vec_c,zeig_vec_v, &
!$omp& eta,eta_dot,xx,xx_dot,lambda_acc_v,lambda_acc_c,zeig_vec_acc_v,zeig_vec_acc_c)
  do ikz = -NKz,NKz
  do ikr = 1,NKr

    alpha = piz_vc*Etz0/deps(ikr,ikz)
    lambda_v = 0.5d0*(deps(ikr,ikz)-sqrt(deps(ikr,ikz)**2+4d0*alpha**2))
    lambda_c = 0.5d0*(deps(ikr,ikz)+sqrt(deps(ikr,ikz)**2+4d0*alpha**2))
    zx = zi*alpha/(deps(ikr,ikz)-lambda_v)
    zy = zi*alpha/lambda_c

    ss = 1d0/sqrt(1d0+abs(zx)**2)
    zeig_vec_v(1) = ss; zeig_vec_v(2) = zx*ss

    ss = 1d0/sqrt(abs(zy)**2+1d0)
    zeig_vec_c(1) = zy*ss; zeig_vec_c(2) = ss

    zx = sum(conjg(zeig_vec_v(:))*zCt(:,ikr,ikz))
    zy = sum(conjg(zeig_vec_c(:))*zCt(:,ikr,ikz))

    nex1st_kz(ikz) = nex1st_kz(ikz) + abs(zy)**2*kr(ikr)
    nex0th_kz(ikz) = nex0th_kz(ikz) + abs(zCt(2,ikr,ikz))**2*kr(ikr)

! real carrier
    eta = 2d0*piz_vc*Etz0/deps(ikr,ikz)
    eta_dot = 2d0*piz_vc*(dEt_dt*deps(ikr,ikz) -2d0*Etz0*deps_dot(ikr,ikz) )/deps(ikr,ikz)**3
    xx = eta/(1d0 + sqrt(1d0 + eta**2))
    xx_dot = eta_dot/(1d0 + sqrt(1d0 + eta**2))/sqrt(1d0 + eta**2)

    alpha = xx_dot/(1d0 + xx**2)

    lambda_acc_v = (lambda_v + lambda_c) &
      - sqrt((lambda_c - lambda_v)**2 + 4d0*alpha**2)
    lambda_acc_v = 0.5d0 * lambda_acc_v

    lambda_acc_c = (lambda_v + lambda_c) &
      + sqrt((lambda_c - lambda_v)**2 + 4d0*alpha**2)
    lambda_acc_c = 0.5d0 * lambda_acc_c

    zx = alpha/(lambda_acc_c - lambda_v)
    zy = -alpha/(lambda_c - lambda_acc_v)

    zeig_vec_acc_v = zeig_vec_v + zy*zeig_vec_c
    zeig_vec_acc_c = zx*zeig_vec_v + zeig_vec_c

    ss = sum(abs(zeig_vec_acc_v)**2); zeig_vec_acc_v = zeig_vec_acc_v/sqrt(ss)
    ss = sum(abs(zeig_vec_acc_c)**2); zeig_vec_acc_c = zeig_vec_acc_c/sqrt(ss)

    zy = sum(conjg(zeig_vec_acc_c(:))*zCt(:,ikr,ikz))

    nex2nd_kz(ikz) = nex2nd_kz(ikz) + abs(zy)**2*kr(ikr)

  end do
  end do
!$omp end parallel

  nex0th_kz = nex0th_kz*2d0/((2d0*pi)**3)*(2d0*pi*dkr)
  nex1st_kz = nex1st_kz*2d0/((2d0*pi)**3)*(2d0*pi*dkr)
  nex2nd_kz = nex2nd_kz*2d0/((2d0*pi)**3)*(2d0*pi*dkr)

end subroutine excited_electron_k_resolved


c=======================================================================
c
c     subroutine KATAVEP
c
c     This function calibrates a symmetric matrix with positive eigenvalues
c     ( > eps-kato ) by average Kato
c
c-----------------------------------------------------------------------
      SUBROUTINE katavep ( n, X, epskat, iwork, dwork,
     &                     Y, spectr, eigsor, eigave,
     &                     nbkgrp, grpkat, info)
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : symmetric matrix (n*n)                      double
c            epskat : Kato sensibility parameter                  double
c
c     WORKSPACE
c            iwork  : vector ( 12*n )                            integer
c            dwork  : vector ( n*(4*n + 26) )                     double
c
c     OUTPUT
c            Y      : calibrate matrix (n*n)                      double
c            spectr : initial spectrum (n)                        double
c            eigsor : sorted eigenvalues (n)                      double
c            eigave : average eigenvalues (n)                     double
c            nbkgrp : number of Kato groups                      integer
c            grpkat : Kato groups (n) output size (nbkgrp)       integer
c            info   : dignostic argument                         integer
c
c     CALL
c            KATP   : Kato decomposition of a symmetric matrix
c                     with positive eigenvalues ( > eps kato )
c            OMCDMCT: computing M*D*M'
c                     (M square matrix n*n, D vector n of diagonal matrix,
c                      gives square matrix n*n )
c            ZMCMC  : symmetrises a vectorized full square matrix
c                     and gives a vectorized full square matrix A=(A+A')/2
c
c     METHOD
c            for Kato groups vector
c            for an example of eigenvalues vector ( size = 7 ) :
c            eigval = [ 5.2, 5.1, 3.5, 3.4, 3.3, 1.7 1.3 ]
c            and eps = 0.15, the routine computes
c            nbkgrp = 4
c            grpvec = [ 2, 3, 1, 1 ]
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, nbkgrp, info
      INTEGER grpkat(*)
      DOUBLE PRECISION epskat
      DOUBLE PRECISION X(n,*), Y(n,*), spectr(*), eigsor(*), eigave(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER iev, nbev, ig, i, piw, pmat, pvs, pdw
      DOUBLE PRECISION som, mean
c
c     external subroutines
      EXTERNAL katp, OMCDMCT, ZMCMC
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw   : pointer for KAT who needs  ( 12*n )
c     pinext = piw + ( 12*n ) (next pointer iwork array)
c
c     Total size of iwork array = ( 12*n )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pmat = 1
c     pmat  : pointer for a work matrix , so (n*n) more
      pvs = pmat + ( n * n )
c     pvs   : pointer eigenvectors matrix, so (n*n) more
      pdw = pvs + ( n * n )
c     pdw   : pointer for workspaces,
c             KAT needs ( n *(2*n+26) )
c             OMCDMCT needs (n*n)
c             so n*(2*n+26) more
c     pdnext = pdw + n*(2*n+26) (next pointer dwork array)
c
c     Total size of dwork array = ( n*(4*n + 26) )
c
c------------------------------------------------------------------
c
c     Kato decomposition
      CALL katp ( n, X, epskat, iwork(piw), dwork(pdw),
     &            spectr, eigsor, dwork(pvs), nbkgrp, grpkat, info )
      IF (info .LT. 0) RETURN
c
c     averages eigenvalues in Kato groups and up to espkat
      iev = 0
      DO ig = 1,nbkgrp
         nbev = grpkat(ig)
         som  = 0.0
         DO i = 1,nbev
            som = som + eigsor(iev+i)
         ENDDO
         mean = som / nbev
         DO i = 1,nbev
            eigave(iev+i) = mean
         ENDDO
         iev = iev + nbev
      ENDDO
c
c     reconstruction of the covariance matrix = Z*T*Z'
      CALL OMCDMCT ( n, dwork(pvs), eigave, dwork(pdw), dwork(pmat) )
c
c     assures the symmetry of the matrix (to computer precision)
      CALL ZMCMC ( n, dwork(pmat), Y )
c
      RETURN
      END


subroutine grey_gas(nlev, beta, sigma, T, tau, Tsurf, lwflx, up, down)

!-------------------------------------!
!  Computes heating rate in a column  !
!  using grey gas approximation.      !
!  tau(nu,p) = tau(p)                 !
!  J.L. Mitchell 10Mar05              !
!_____________________________________!

integer nlev,k
! Heating rate and T are defined at midlevel
real, dimension(nlev)     :: T
! Tau and Up/Down LW fluxes are defined at level interfaces
real,dimension(0:nlev)   :: tau,lwflx,up,down
real Tsurf,sigma,beta

! Compute LW flux
call compute_longwave(nlev, beta, sigma, T, tau, Tsurf, up, down)

! Net LW flux at interfaces
lwflx = up - down

end subroutine grey_gas

! - - - > midlevel
! ----- > surface/interface

!- - - - - - - - - - - - kappa(0),T(0)                  TOP OF ATMOSPHERE
!----------------------- press(0),tau(0),up/down(0)
!- - - - - - - - - - - - kappa(1),T(1)
!----------------------- press(1)
!- - - - - - - - - - - -   ..
!-----------------------   ..
!- - - - - - - - - - - -   ..
!-----------------------   ..
!- - - - - - - - - - - - kappa(nlev)
!----------------------- press(nlev)
!- - - - - - - - - - - - kappa(nlev+1)                  SURFACE


module modResidual

    use modValues
    implicit none

    contains

    subroutine seeMonitor
        implicit none

        real(8) :: maxvalue,minvalue

                !resiP = 0.d0
                !resiU = 0.d0
                !resiR = 0.d0
                !resiT = 0.d0
                !do i=nCellStr,nCellEnd
                !    resiP=resiP+cDp(i)**2.d0
                !    resiU=resiU+cDu(i)**2.d0
                !    resiR=resiR+cDr(i)**2.d0
                !    resiT=resiT+cDT(i)**2.d0
                !enddo
                !resiP = dsqrt(resiP)
                !resiU = dsqrt(resiU)
                !resiR = dsqrt(resiR)
                !resiT = dsqrt(resiT)

                !> Pressure Residual
                resiP = 0.d0
                maxvalue = -1.d8
                minvalue = 1.d8
                do i=nCellStr,nCellEnd
                    resiP = resiP + cDp(i)**2.d0
                    maxvalue = dmax1(maxvalue,cP(i))
                    minvalue = dmin1(minvalue,cP(i))
                enddo
                resiP = dsqrt(resiP) / (dmax1(maxvalue,0.d0)-dmin1(minvalue,0.d0)+1.d-15)

                !> Velocity Residual
                resiU = 0.d0
                maxvalue = -1.d8
                minvalue = 1.d8
                do i=nCellStr,nCellEnd
                    resiU = resiU + cDU(i)**2.d0
                    maxvalue = dmax1(maxvalue,cU(i))
                    minvalue = dmin1(minvalue,cU(i))
                enddo
                resiU = dsqrt(resiU) / (dmax1(maxvalue,0.d0)-dmin1(minvalue,0.d0)+1.d-15)

                !> Density Residual
                resiR = 0.d0
                maxvalue = -1.d8
                minvalue = 1.d8
                do i=nCellStr,nCellEnd
                    resiR = resiR + cDR(i)**2.d0
                    maxvalue = dmax1(maxvalue,cRho(i))
                    minvalue = dmin1(minvalue,cRho(i))
                enddo
                resiR = dsqrt(resiR) / (dmax1(maxvalue,0.d0)-dmin1(minvalue,0.d0)+1.d-15)

                !> Temp. Residual
                resiT = 0.d0
                maxvalue = -1.d8
                minvalue = 1.d8
                do i=nCellStr,nCellEnd
                    resiT = resiT + cDT(i)**2.d0
                    maxvalue = dmax1(maxvalue,cT(i))
                    minvalue = dmin1(minvalue,cT(i))
                enddo
                resiT = dsqrt(resiT) / (dmax1(maxvalue,0.d0)-dmin1(minvalue,0.d0)+1.d-15)

            !if( mod(nstep,4) == 0 ) then
                write(*,100) nstep,iterSIMPLE,iterPISO,resiP,resiU,resiR,resiT
                !stop
                !/////////////////////////////////
                open(20,file='residual.txt',status='old',position='append')
                WRITE( 20, '(i5,1X,20(F20.9, 1X))' ) nstep,log(resiP),&
                    log(resiU),log(resiR),log(resiT)
                close(20)
                !/////////////////////////////////
            if( mod(nstep,1000) == 0 ) then
                !OPEN(20, FILE = 'residual.txt', STATUS = 'REPLACE')
                close(20)
            endif

            !endif
                !=======================================================

100 format(i7,1x,i7,1x,i7,1x,6(1pe10.2))

    endsubroutine

endmodule


module sky_util
	implicit none
	integer, parameter :: imax=1000,jmax=1000
	real, parameter :: dx=10.0,dy=10.0,pie=3.1415927
	real,dimension(imax,jmax) :: DEM,DVIEW
        real,dimension(1600,1600) :: DEM2,DVIEW2
! VISIT :: dummy

contains
    real function eangle(j,k,m)
	integer j,k,m
	real z1,z2
	if(k == m) then
		eangle=0.0; return
	else
		z1=DEM2(k,j)
		z2=DEM2(m,j)
		eangle=(z2-z1)/(m-k); return
	end if
    end function eangle

    subroutine suihei()
	integer,dimension(1600) :: dline
	integer i,j,k,m,found
	real z0,z1,tmp1,tmp2
	dline(1600)=1600-1
	do j=1,1600
		i=1600-2
		z0=DEM2(i,j)
		do while ((z0 == 0.0) .and. (i > 0))
			dline(i)=i
			DVIEW2(i,j)=0
			i=i-1
			z0=DEM2(i,j)
		enddo
		do while (i > 0)
			k=i+1
			found = 1
			do while (found == 1)
				tmp1=eangle(j,i,k)
 				m = dline(k)
        			tmp2 = eangle(j,k,m)
        			if ((tmp1 < tmp2) .and. (m .ne. k)) then
					 k = m
        			else
          				found = 0
          				if (tmp1 > tmp2) then
						dline(i) = k
          				else
						dline(i) = m
					endif
				endif
			enddo
      			DVIEW2(i,j) = tmp1/10.0
      			i = i - 1
 		enddo
	enddo
    end subroutine suihei

    subroutine view(angle)
	real angle
	integer i,j,ii,jj
	DEM2=0
        DVIEW=0
	angle=angle*pie/180.0
	do j=1,1600
	do i=1,1600
		ii=nint(cos(angle)*(i-1600/2.0)-sin(angle)*(j-1600/2.0)+imax/2.0)
		jj=nint(sin(angle)*(i-1600/2.0)+cos(angle)*(j-1600/2.0)+jmax/2.0)
		if ((ii < 1) .or. (jj < 1) .or. (ii > imax) .or. (jj > jmax)) then
			DEM2(i,j)=0
		else
			DEM2(i,j)=DEM(ii,jj)
		endif
	enddo
	enddo
        call suihei()
	do j=1,jmax
	do i=1,imax
		ii=nint(cos(angle)*(i-imax/2.0)+sin(angle)*(j-jmax/2.0)+1600/2.0)
		jj=nint(-sin(angle)*(i-imax/2.0)+cos(angle)*(j-jmax/2.0)+1600/2.0)
		if (ii < 1) ii=1
		if (jj < 1) jj=1
		if (ii > 1600) ii=1600
		if (jj > 1600) jj=1600
		DVIEW(i,j)=DVIEW2(ii,jj)
	enddo
	enddo

    end subroutine view

end module sky_util


      SUBROUTINE Q4GMGS (MID,FACTOR,G)
C     &    ENTRY Q4GMGD (MID,FACTOD,D)
C
C
C     MATERIAL PROPERTY MATRIX GENERATOR ROUTINE FOR QUAD4 ELEMENT
C
C     THIS ROUTINE BUILDS THE MATERIAL PROPERTY MATRIX, G, USING THE
C     OUTPUT OF SUBROUTINE 'MAT' (/MATOUT/).
C
C     ALL THE MATERIAL OPTIONS, ISOTROPIC, ORTHOTROPIC, AND ANISOTROPIC,
C     ARE AVAILABLE.
C
C     OUTPUT WILL BE G(9) OR D(9) FOR MID1, MID2 AND MID4.
C     FOR MID3,  G(4) OR D(4) IS SENT BACK.
C
      REAL             FACTOR,G(9),CONST,MTYPE,NU12,NU21
      DOUBLE PRECISION FACTOD,D(9),DONST
      COMMON  /MATOUT/ RMTOUT(25)
      EQUIVALENCE      (RMTOUT(1),E1),(RMTOUT(2),NU12),(RMTOUT(3),E2)
C
C     SINGLE PRECISION SECTION -
C
      DO 10 I=1,9
   10 G(I) = 0.0
      MTYPE= RMTOUT(25)
      MTYP = IFIX(MTYPE+.05) - 2
      IF (MTYP) 20,30,80
C
C     ISOTROPIC MATERIALS (MAT1)
C
   20 IF (MID .NE. 3) GO TO 40
      G(1) = RMTOUT(6)
      G(4) = G(1)
      GO TO 100
C
C     ANISOTROPIC MATERIALS (MAT2)
C
   30 IF (MID .EQ. 3) GO TO 60
   40 DO 50 I=1,3
   50 G(I) = RMTOUT(I)
      G(4) = G(2)
      G(5) = RMTOUT(4)
      G(6) = RMTOUT(5)
      G(7) = G(3)
      G(8) = G(6)
      G(9) = RMTOUT(6)
      GO TO 100
C
   60 DO 70 I=1,4
   70 G(I) = RMTOUT(I)
      G(3) = G(2)
      GO TO 100
C
C     ORTHOTROPIC MATERIALS (MAT8)
C
   80 IF (MID .EQ. 3) GO TO 90
      NU21 = NU12 * E2 / E1
      CONST= 1.0 - (NU21*NU12)
      G(1) = E1 / CONST
      G(2) = NU12 * E2 / CONST
      G(4) = G(2)
      G(5) = E2 / CONST
      G(9) = RMTOUT(4)
      GO TO 100
C
   90 G(1) = RMTOUT(6)
      G(4) = RMTOUT(5)
      IF (G(1).EQ.0.0 .AND. G(4).EQ.0.0) GO TO 120
C
C     STANDARD RETURN
C
  100 DO 110 I=1,9
  110 G(I) = G(I)*FACTOR
      GO TO 310
C
C     FATAL RETURN
C
  120 MID = -MID
      GO TO 310
C
      ENTRY Q4GMGD (MID,FACTOD,D)
C     ===========================
C
      DO 200 I=1,9
  200 D(I) = 0.0D0
      MTYPE= RMTOUT(25)
      MTYP = IFIX(MTYPE+.05) - 2
      IF (MTYP) 210,220,270
C
C     ISOTROPIC MATERIALS (MAT1)
C
  210 IF (MID .NE. 3) GO TO 230
      D(1) = RMTOUT(6)
      D(4) = D(1)
      GO TO 290
C
C     ANISOTROPIC MATERIALS (MAT2)
C
  220 IF (MID .EQ. 3) GO TO 250
  230 DO 240 I=1,3
  240 D(I) = RMTOUT(I)
      D(4) = D(2)
      D(5) = RMTOUT(4)
      D(6) = RMTOUT(5)
      D(7) = D(3)
      D(8) = D(6)
      D(9) = RMTOUT(6)
      GO TO 290
C
  250 DO 260 I=1,4
  260 D(I) = RMTOUT(I)
      D(3) = D(2)
      GO TO 290
C
C     ORTHOTROPIC MATERIALS (MAT8)
C
  270 IF (MID .EQ. 3) GO TO 280
      NU21 = NU12 * E2 / E1
      DONST= 1.0D0 - DBLE(NU21*NU12)
      D(1) = E1 / DONST
      D(2) = NU12 * E2 / DONST
      D(4) = D(2)
      D(5) = E2 / DONST
      D(9) = RMTOUT(4)
      GO TO 290
C
  280 D(1) = RMTOUT(6)
      D(4) = RMTOUT(5)
      IF (D(1).EQ.0.0D0 .AND. D(4).EQ.0.0D0) GO TO 120
C
C     STANDARD RETURN
C
  290 DO 300 I=1,9
  300 D(I) = D(I)*FACTOD
C
  310 RETURN
      END


PROGRAM read_generators
IMPLICIT NONE
  INTEGER, PARAMETER :: ROWS = 4, COLS = 6

  REAL, DIMENSION(COLS) :: get_col_totals

  REAL, DIMENSION(ROWS, COLS) :: gens
  REAL, DIMENSION(ROWS) :: avgs
  REAL, DIMENSION(COLS) :: totals
  REAL :: g_sum, t_sum
  INTEGER :: i, j
  OPEN (1, FILE='gendat.txt', STATUS='OLD', ACTION='READ')
  READ(1, *) gens

  ! Get the total power for each time
  DO i = 1, COLS
    t_sum = 0.0
    DO j = 1, ROWS
      t_sum = t_sum + gens(j, i)
    END DO
    totals(i) = t_sum
  END DO

  ! Get average power of each generator
  DO i = 1, ROWS
    g_sum = 0.0
    DO j = 1, COLS
      g_sum = g_sum + gens(i, j)
    END DO
    avgs(i) = g_sum / COLS
  END DO
  WRITE(*, '(A, 6F8.2)') "TOTALS:", totals
  WRITE(*, '(A, 4F8.2)') "AVGS:  ", avgs
  !WRITE(*, '(6F5.1)') ((gens(i, j), j=1,COLS), i=1,ROWS)
  !WRITE(*, *) get_col_totals(ROWS, COLS, gens)
END PROGRAM read_generators

FUNCTION get_col_totals(r, c, arr)
  INTEGER, INTENT(IN) :: r, c
  REAL, DIMENSION(r, c), INTENT(IN) :: arr
  REAL, DIMENSION(c) :: totals
  REAL, DIMENSION(c) :: get_col_totals
  totals = 1
  get_col_totals = totals
END FUNCTION get_col_totals


      SUBROUTINE rz_surf(theta, phi, rw, zw, kmodes, rmn, zmn, m_num,
     1   n_num, nfp)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE stel_constants
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER kmodes, nfp
      INTEGER, DIMENSION(kmodes) :: m_num, n_num
      REAL(rprec) :: theta, phi, rw, zw
      REAL(rprec), DIMENSION(kmodes) :: rmn, zmn
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: i
!-----------------------------------------------

      rw = zero
      zw = zero

! 2/16/98 WHM The NESCOIL sign convention is used here

      DO i=1,kmodes
         rw = rw + rmn(i)*COS(m_num(i)*theta+nfp*n_num(i)*phi)
         zw = zw + zmn(i)*SIN(m_num(i)*theta+nfp*n_num(i)*phi)
      END DO

      END SUBROUTINE rz_surf


*DECK R9GMIC
      FUNCTION R9GMIC (A, X, ALX)
C***BEGIN PROLOGUE  R9GMIC
C***SUBSIDIARY
C***PURPOSE  Compute the complementary incomplete Gamma function for A
C            near a negative integer and for small X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9GMIC-S, D9GMIC-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the complementary incomplete gamma function for A near
C a negative integer and for small X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNGAM, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9GMIC
      SAVE EULER, EPS, BOT
      DATA EULER / .5772156649 015329 E0 /
      DATA EPS, BOT / 2*0.0 /
C***FIRST EXECUTABLE STATEMENT  R9GMIC
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
      IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1))
C
      IF (A .GT. 0.0) CALL XERMSG ('SLATEC', 'R9GMIC',
     +   'A MUST BE NEAR A NEGATIVE INTEGER', 2, 2)
      IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'R9GMIC',
     +   'X MUST BE GT ZERO', 3, 2)
C
      MA = A - 0.5
      FM = -MA
      M = -MA
C
      TE = 1.0
      T = 1.0
      S = T
      DO 20 K=1,200
        FKP1 = K + 1
        TE = -X*TE/(FM+FKP1)
        T = TE/FKP1
        S = S + T
        IF (ABS(T).LT.EPS*S) GO TO 30
 20   CONTINUE
      CALL XERMSG ('SLATEC', 'R9GMIC',
     +   'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 4, 2)
C
 30   R9GMIC = -ALX - EULER + X*S/(FM+1.0)
      IF (M.EQ.0) RETURN
C
      IF (M.EQ.1) R9GMIC = -R9GMIC - 1.0 + 1.0/X
      IF (M.EQ.1) RETURN
C
      TE = FM
      T = 1.0
      S = T
      MM1 = M - 1
      DO 40 K=1,MM1
        FK = K
        TE = -X*TE/FK
        T = TE/(FM-FK)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 50
 40   CONTINUE
C
 50   DO 60 K=1,M
        R9GMIC = R9GMIC + 1.0/K
 60   CONTINUE
C
      SGNG = 1.0
      IF (MOD(M,2).EQ.1) SGNG = -1.0
      ALNG = LOG(R9GMIC) - ALNGAM(FM+1.0)
C
      R9GMIC = 0.0
      IF (ALNG.GT.BOT) R9GMIC = SGNG*EXP(ALNG)
      IF (S.NE.0.0) R9GMIC = R9GMIC + SIGN (EXP(-FM*ALX+LOG(ABS(S)/FM))
     1  , S)
C
      IF (R9GMIC .EQ. 0.0 .AND. S .EQ. 0.0) CALL XERMSG ('SLATEC',
     +   'R9GMIC', 'RESULT UNDERFLOWS', 1, 1)
      RETURN
C
      END