subroutine sky_to_patch(inmap,npix,npatch,patch,numpa,lp)
Implicit none

integer, intent (inout) :: npatch,npix,lp,numpa
real, intent (in) :: inmap(npix)
Real ,intent (out) :: patch(numpa,lp,lp)
integer :: nside,i,j,nn,boi,np,nf,pow,n,xp,yp,pa
integer,allocatable :: a(:),p(:),q(:)
real  ns,base,di,x,y

base=2.0
di=npatch     !tedade morabbaA dar zelE
pa=di**2        !tedade morabbaA dar face
!numpa=12*pa
!npix=12*nside**2
nside = int(sqrt(npix/12.))
ns=nside
np=nside**2
!lp=ns/di        !tedad pixele zelE har morabba
n=log(ns)/log(base)

allocate(a(n),p(n),q(n))
do i=0,npix-1
	boi=i
	x=0 ;y=0
	nf=int(boi/np)+1
	boi=boi-(nf-1)*np
	do j=1,n
		pow=np/(4**(j-1))
		a(j)=int((boi*4)/pow)
		boi=boi-(a(j)*pow/4)
		if (a(j)==0) then
		  p(j)=1
		  q(j)=1
		end if
		if (a(j)==1) then
		  p(j)=1
		  q(j)=2
		end if
		if (a(j)==2) then
		  p(j)=2
		  q(j)=1
		end if
		if (a(j)==3) then
		  p(j)=2
		  q(j)=2
		end if
		x=x+(nside/2**j)*(p(j)-1)
		y=y+(nside/2**j)*(q(j)-1)

	end do   ! j
	!           call pix2xy_nest(nside,x,y,nf,i)
	!		  x=x
	!		  y=y
	! x & y are positions in face 'nf'
	npatch=int(x/real(lp))+di*int(y/real(lp))+1  !the number of patch in face
	nn=(nf-1)*pa+npatch  !the number of patch
	xp=MOD(x,real(lp))+1.0   !position in patch
	yp=MOD(y,real(lp))+1.0

	patch(nn,xp,yp)=inmap(i)

end do  !i

end


!***********************************************************************
! This file is part of project ISFRC.                                  *
! ISFRC is an Integrated Simulation code for Field-Reversed            *
! Configuration.                                                       *
!                                                                      *
! Developers:                                                          *
! Shuying SUN, Yang LI, Huasheng XIE, ...                              *
!                                                                      *
! ENN Sci. & Tech. Development Coorporation, 2008-2019.                *
! (c) All rights reserved.                                             *
!***********************************************************************

!***********************************************************************
! subprogram description:                                              *
!                                                                      *
!                                                                      *
! calling arguments:                                                   *
!                                                                      *
!***********************************************************************
subroutine splitcoil(rcoil,zcoil,wcoil,hcoil,a1coil,a2coil, &
    nsr,nsz,rsplit_rz,zsplit_rz)
  use consta,only:pi
  implicit none
  real*8,   intent(in) :: rcoil,zcoil,wcoil,hcoil,a1coil,a2coil
  integer*4,intent(in) :: nsr,nsz
  real*8,dimension(nsr,nsz),intent(out) :: rsplit_rz,zsplit_rz
  real*8 :: frd,dw,dh,dr1,dz1,dr2,dz2,rstrt,zstrt
  integer :: ii,jj

  frd=pi/180.0d0
  dw=wcoil/nsr
  dh=hcoil/nsz
  dr1=dw*dcos(frd*a1coil)
  dz1=dh*dcos(frd*a2coil)
  dr2=dh*dsin(frd*a2coil)
  dz2=dw*dsin(frd*a1coil)
  rstrt=rcoil-0.5d0*(wcoil*dcos(frd*a1coil)+hcoil*dsin(frd*a2coil)) &
    +0.5d0*(dr1+dr2)
  zstrt=zcoil-0.5d0*(hcoil*dcos(frd*a2coil)+wcoil*dsin(frd*a1coil)) &
    +0.5d0*(dz1+dz2)
  do jj=1,nsz
    do ii=1,nsr
      rsplit_rz(ii,jj)=rstrt+(ii-1)*dr1+(jj-1)*dr2
      zsplit_rz(ii,jj)=zstrt+(jj-1)*dz1+(ii-1)*dz2
    enddo
  enddo

  return
end subroutine splitcoil
!      ^ R coordinate
!      |              /<
!      |      |a1coil/`---_
!      |      |     /      ``---_hcoil
!      |      |    /             ``---_
!      |      |   /                    ``---_ >/
!      |      |  /                           `/`--_
! rcoil| _ _ _|_/ _ _ _ _ _ _ _              /
!      |      |/______________|____         /
!      |        `---_         |            /
!      |             ``---_   | a2coil    / wcoil
!      |                   ``---_        /
!      |                      |  ``---_ /
!      |                      |        ``--_
!      |                      |
!------|-------------------------------------------------------------->
!     O|                     zcoil                         Z coordinate

!***********************************************************************
! subprogram description:                                              *
!      mutpsi computes mutual inductance/2/pi between two              *
!      circular filaments of radii a1 and r1 and                       *
!      separation of z1, for mks units multiply returned               *
!      value by 2.0e-07.                                               *
!                                                                      *
! calling arguments:                                                   *
!   a1..............filament radius                                    *
!   r1..............radius of calcuated points                         *
!   z1..............vertical separation                                *
!***********************************************************************
real*8 function mutpsi(a1,r1,z1)
  use consta,only:small
  implicit none
  real*8,intent(in) :: a1,r1,z1
  real*8 :: a,r,z,tmp1,ksq,kk,ee

  a=a1
  r=r1
  z=z1
  tmp1=(a+r)*(a+r)+z*z
  !tmp2=(a-r)*(a-r)+z*z
  ksq=4.0d0*a*r/tmp1
  if(ksq<small) ksq=small
  call comelp(ksq,kk,ee)

  mutpsi=dsqrt(a*r)*((2.0d0-ksq)*kk-2.0d0*ee)/dsqrt(ksq)
  return
end function mutpsi

!***********************************************************************
! subprogram description:                                              *
!      mutbr computes mutual inductance/2/pi between two               *
!      circular filaments of radii a1 and r1 and                       *
!      separation of z1, for mks units multiply returned               *
!      value by 2.0e-07.                                               *
!                                                                      *
! calling arguments:                                                   *
!   a1..............filament radius                                    *
!   r1..............radius of calcuated points                         *
!   z1..............vertical separation                                *
!***********************************************************************
real*8 function mutbr(a1,r1,z1)
  use consta,only:small
  implicit none
  real*8,intent(in) :: a1,r1,z1
  real*8 :: a,r,z,tmp1,tmp2,ksq,kk,ee

  a=a1
  r=r1
  z=z1
  tmp1=(a+r)*(a+r)+z*z
  tmp2=(a-r)*(a-r)+z*z
  if(tmp2<small) tmp2=small
  ksq=4.0d0*a*r/tmp1
  call comelp(ksq,kk,ee)

  mutbr=z/(r*dsqrt(tmp1))*((a*a+r*r+z*z)/tmp2*ee-kk)
  return
end function mutbr

!***********************************************************************
! subprogram description:                                              *
!      mutbz computes mutual inductance/2/pi between two               *
!      circular filaments of radii a1 and r1 and                       *
!      separation of z1, for mks units multiply returned               *
!      value by 2.0e-07.                                               *
!                                                                      *
! calling arguments:                                                   *
!   a1..............filament radius                                    *
!   r1..............radius of calcuated points                         *
!   z1..............vertical separation                                *
!***********************************************************************
real*8 function mutbz(a1,r1,z1)
  use consta,only:small
  implicit none
  real*8,intent(in) :: a1,r1,z1
  real*8 :: a,r,z,tmp1,tmp2,ksq,kk,ee

  a=a1
  r=r1
  z=z1
  tmp1=(a+r)*(a+r)+z*z
  tmp2=(a-r)*(a-r)+z*z
  if(tmp2<small) tmp2=small
  ksq=4.0d0*a*r/tmp1
  call comelp(ksq,kk,ee)

  mutbz=((a*a-r*r-z*z)/tmp2*ee+kk)/dsqrt(tmp1)
  return
end function mutbz


c Calculate residual statistics

	subroutine resstat(log, idata, ndt, nev, d, w, idx,
     &	rms_cc, rms_ct, rms_cc0, rms_ct0,
     &	rms_ccold, rms_ctold, rms_cc0old, rms_ct0old,
     &                   dum)

	implicit none

	include "hypoDD.inc"

c	Parameters:
	integer	log
	integer	idata
	integer	ndt
	integer	nev
	real	d(MAXDATA)	! (1..ndt)
	real	w(MAXDATA)	! (1..ndt)
	integer	idx(MAXDATA)	! (1..ndt)
	real	rms_cc
	real	rms_ct
	real	rms_cc0
	real	rms_ct0
	real	rms_ccold
	real	rms_ctold
	real	rms_cc0old
	real	rms_ct0old
	real	dum

c	Local variables:
	real	av_cc
	real	av_cc0
	real	av_ct
	real	av_ct0
	real	dav
	real	dav0
	real	dav1
	real	dav1old
	real	davold
	real	dvar
	real	dvar1
	real	dvar1old
	real	dvarold
	real	f
	real	f_cc
	real	f_ct
	integer	i, j
	real	s
	real	s1
	real	ss
	real	ss1
	real	sw
	real	sw_cc
	real	sw_ct

c--- get rms:
      rms_cc0old= rms_cc0
      rms_ct0old= rms_ct0
      rms_ccold= rms_cc
      rms_ctold= rms_ct
      j= 0
      sw_cc= 0
      sw_ct= 0
      do i= 1,ndt
         if(idx(i).le.2) then
             sw_cc= sw_cc + w(i)
             j= j+1
         else
             sw_ct= sw_ct + w(i)
         endif
      enddo
      f_cc= j/sw_cc  ! factor to scale weights for rms value
      f_ct= (ndt-j)/sw_ct  ! factor to scale weights for rms value

      rms_cc0= 0
      rms_ct0= 0
      av_cc0= 0
      av_ct0= 0
      rms_cc= 0
      rms_ct= 0
      av_cc= 0
      av_ct= 0
      j= 0
      do i= 1,ndt
         if(idx(i).le.2) then
             rms_cc0= rms_cc0 + d(i)**2
             av_cc0= av_cc0 + d(i)
             rms_cc= rms_cc + (f_cc*w(i)*d(i))**2	! weighted and scaled
             av_cc= av_cc + f_cc*w(i)*d(i)   	! weighted and scaled
             j= j+1
         else
             rms_ct0= rms_ct0 + d(i)**2
             av_ct0= av_ct0 + d(i)
             rms_ct= rms_ct + (f_ct*w(i)*d(i))**2	! weighted and scaled
             av_ct= av_ct + f_ct*w(i)*d(i)   	! weighted and scaled
         endif
      enddo
      av_cc0= av_cc0/j
      av_ct0= av_ct0/(ndt-j)
      rms_cc0= sqrt( (rms_cc0 - av_cc0**2/j) / (j-1) )
      rms_ct0= sqrt( (rms_ct0 - av_ct0**2/(ndt-j)) / (ndt-j-1) )
      av_cc= av_cc/j
      av_ct= av_ct/(ndt-j)
      rms_cc= sqrt( (rms_cc - av_cc**2/j) / (j-1) )
      rms_ct= sqrt( (rms_ct - av_ct**2/(ndt-j)) / (ndt-j-1) )

c--- more: residual average, rms, and variance:
      davold= dav
      dvarold= dvar
      dav1old= dav1
      dvar1old= dvar1
      dav= 0    ! unweighted
      dvar= 0   ! unweighted
      dav1= 0   ! weighted
      dvar1= 0  ! weighted
      sw= 0
      dav0= 0    ! unweighted

      do i= 1,ndt
         sw= sw + w(i)
      enddo
      f= ndt/sw  ! factor to scale weights for rms value

      do i= 1,ndt
         dav= dav + d(i)		! unweighted
         dav0= dav0 + w(i)*d(i)   	! weighted
         dav1= dav1 + f*w(i)*d(i)   	! weighted and scaled
      enddo
      dav= dav/ndt
      dav0= dav0/ndt
      dav1= dav1/ndt

      s= 0
      ss= 0
      ss1= 0
      do i=1,ndt
         s= d(i)*1000 - dav*1000 		! in msec
         s1= w(i)*d(i)*1000 - dav0*1000 	! weighted, in msec
         ss= ss + s
         ss1= ss1 + s1
         dvar= dvar + s**2
         dvar1= dvar1 + s1**2
      enddo
      if(ndt.gt.4*nev) then
         dvar= (dvar - ss**2/ndt) / (ndt - 4*nev) ! / by the # of deg of freedom
         dvar1= (dvar1 - ss1**2/ndt) / (ndt - 4*nev)
      else
         dvar= dvar / 1   ! / by the # of degrees of freedom
         dvar1= dvar1 / 1
c         write(*,*)'>>> ndt < 4*nev'
c         write(log,*)'>>> ndt < 4*nev'
         write(*,*)'>>> Warning: ndt < 4*nev'
         write(log,*)'>>> Warning: ndt < 4*nev'
      endif

      if(abs(dum+999).lt.0.0001) then   ! orginal data
         write(log,'(/,"Residual summary of initial data:")')
         write(log,'(a,f7.4)')' absolute mean [s] = ',dav
         write(log,'(a,f7.4)')' weighted mean [s] = ',dav1
         write(log,'(a,f10.4)')' absolute variance [s] = ',dvar/1000
         write(log,'(a,f7.4)')' weighted variance [s] = ',dvar1/1000
         if(idata.eq.1.or.idata.eq.3) then
           write(log,'(a,f7.4)')' absolute cc rms [s] = ',rms_cc0
           write(log,'(a,f7.4)')' weighted cc rms [s] (RMSCC) = ',rms_cc
         endif
         if(idata.eq.2.or.idata.eq.3) then
           write(log,'(a,f7.4)')' absolute ct rms [s] = ',rms_ct0
           write(log,'(a,f7.4)')' weighted ct rms [s] (RMSCT) = ',rms_ct
         endif
      else
         write(log,'(/,"Residual summary:")')
         write(log,'(a,f7.4,a,f7.2,a)')' absolute mean [s] = ',dav,
     & ' (',(dav-davold)*100/abs(davold),' %)'
         write(log,'(a,f7.4,a,f7.2,a)')' weighted mean [s] = ',dav1,
     & ' (',(dav1-dav1old)*100/abs(dav1old),' %)'
         write(log,'(a,f10.4,a,f7.2,a)')' absolute variance [s] = ',
     & dvar/1000, ' (',(dvar-dvarold)*100/dvarold,' %)'
         write(log,'(a,f10.4,a,f7.2,a)')' weighted variance [s] = ',
     & dvar1/1000,' (',(dvar1-dvar1old)*100/dvar1old,' %)'
         if(idata.eq.1.or.idata.eq.3) then
           write(log,'(a,f7.4,a,f7.2,a)')' absolute cc rms [s] = ',
     & rms_cc0,' (',(rms_cc0-rms_cc0old)*100/rms_cc0old,' %)'
           write(log,'(a,f7.4,a,f7.2,a)')' weighted cc rms [s] = ',
     & rms_cc,' (',(rms_cc-rms_ccold)*100/rms_ccold,' %)'
         endif
         if(idata.eq.2.or.idata.eq.3) then
           write(log,'(a,f7.4,a,f7.2,a)')' absolute ct rms [s] = ',
     & rms_ct0,' (',(rms_ct0-rms_ct0old)*100/rms_ct0old,' %)'
           write(log,'(a,f7.4,a,f7.2,a)')' weighted ct rms [s] = ',
     & rms_ct, ' (',(rms_ct-rms_ctold)*100/rms_ctold,' %)'
         endif
      endif

      dum= dvar1
      end !of tine resstat


      subroutine fort_init_e_from_t(state,s_l1,s_l2,s_l3,s_h1,s_h2,s_h3,ns, &
                                    diag,d_l1,d_l2,d_l3,d_h1,d_h2,d_h3,nd, &
                                   lo,hi,a_old) bind(C, name="fort_init_e_from_t")

      use amrex_fort_module, only : rt => amrex_real
      use eos_module
      use meth_params_module, only : URHO, UMX, UMY, UMZ, UEINT, UEDEN, TEMP_COMP, NE_COMP
      use  eos_params_module

      implicit none

      integer , intent(in   ) :: s_l1,s_l2,s_l3,s_h1,s_h2,s_h3,ns
      integer , intent(in   ) :: d_l1,d_l2,d_l3,d_h1,d_h2,d_h3,nd
      real(rt), intent(inout) :: state(s_l1:s_h1,s_l2:s_h2,s_l3:s_h3,ns)
      real(rt), intent(in   ) ::  diag(d_l1:d_h1,d_l2:d_h2,d_l3:d_h3,nd)
      integer , intent(in   ) :: lo(3), hi(3)
      real(rt), intent(in   ) :: a_old

      ! Local variables
      real(rt) :: e, pres, T
      integer  :: i,j,k
      !
      ! Compute energy from the EOS
      !
      do k = lo(3),hi(3)
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)

               T  = diag(i,j,k,TEMP_COMP)

               ! Call EOS to get the internal energy
               call nyx_eos_given_RT(e, pres, state(i,j,k,URHO), diag(i,j,k,TEMP_COMP), &
                                     diag(i,j,k,NE_COMP), a_old)

               state(i,j,k,UEINT) = state(i,j,k,URHO) * e

               state(i,j,k,UEDEN) = state(i,j,k,UEINT) + &
                  0.5d0 * (state(i,j,k,UMX)**2 + state(i,j,k,UMY)**2 + state(i,j,k,UMZ)**2) / state(i,j,k,URHO)

            enddo
         enddo
      enddo

      end subroutine fort_init_e_from_t


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 ELCENT (ELCEN, IX, COORD, NDIM, NUMEL, NELNOD, NUMNP)
      DIMENSION ELCEN(NUMEL, *), IX(NELNOD, *), COORD(NUMNP, *)

      IF (NDIM .EQ. 2) THEN
          DO 10 I=1, NUMEL
              ELCEN(I,1) = (COORD(IX(1,I),1) + COORD(IX(2,I),1) +
     *                      COORD(IX(3,I),1) + COORD(IX(4,I),1))/4.0
              ELCEN(I,2) = (COORD(IX(1,I),2) + COORD(IX(2,I),2) +
     *                      COORD(IX(3,I),2) + COORD(IX(4,I),2))/4.0
   10     CONTINUE
      ELSE
          DO 20 I=1, NUMEL
              ELCEN(I,1) = (COORD(IX(1,I),1) + COORD(IX(2,I),1) +
     *                      COORD(IX(3,I),1) + COORD(IX(4,I),1) +
     *                      COORD(IX(5,I),1) + COORD(IX(6,I),1) +
     *                      COORD(IX(7,I),1) + COORD(IX(8,I),1))/8.0

              ELCEN(I,2) = (COORD(IX(1,I),2) + COORD(IX(2,I),2) +
     *                      COORD(IX(3,I),2) + COORD(IX(4,I),2) +
     *                      COORD(IX(5,I),2) + COORD(IX(6,I),2) +
     *                      COORD(IX(7,I),2) + COORD(IX(8,I),2))/8.0

              ELCEN(I,3) = (COORD(IX(1,I),3) + COORD(IX(2,I),3) +
     *                      COORD(IX(3,I),3) + COORD(IX(4,I),3) +
     *                      COORD(IX(5,I),3) + COORD(IX(6,I),3) +
     *                      COORD(IX(7,I),3) + COORD(IX(8,I),3))/8.0
   20     CONTINUE
      END IF
      RETURN
      END


*DECK DBSPPP
      SUBROUTINE DBSPPP (T, A, N, K, LDC, C, XI, LXI, WORK)
C***BEGIN PROLOGUE  DBSPPP
C***PURPOSE  Convert the B-representation of a B-spline to the piecewise
C            polynomial (PP) form.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      DOUBLE PRECISION (BSPPP-S, DBSPPP-D)
C***KEYWORDS  B-SPLINE, PIECEWISE POLYNOMIAL
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract    **** a double precision routine ****
C         DBSPPP is the BSPLPP routine of the reference.
C
C         DBSPPP converts the B-representation (T,A,N,K) to the
C         piecewise polynomial (PP) form (C,XI,LXI,K) for use with
C         DPPVAL.  Here XI(*), the break point array of length LXI, is
C         the knot array T(*) with multiplicities removed.  The columns
C         of the matrix C(I,J) contain the right Taylor derivatives
C         for the polynomial expansion about XI(J) for the intervals
C         XI(J) .LE. X .LE. XI(J+1), I=1,K, J=1,LXI.  Function DPPVAL
C         makes this evaluation at a specified point X in
C         XI(1) .LE. X .LE. XI(LXI+1)
C
C     Description of Arguments
C
C         Input      T,A are double precision
C          T       - knot vector of length N+K
C          A       - B-spline coefficient vector of length N
C          N       - number of B-spline coefficients
C                    N = sum of knot multiplicities-K
C          K       - order of the B-spline, K .GE. 1
C          LDC     - leading dimension of C, LDC .GE. K
C
C         Output     C,XI,WORK are double precision
C          C       - matrix of dimension at least (K,LXI) containing
C                    right derivatives at break points
C          XI      - XI break point vector of length LXI+1
C          LXI     - number of break points, LXI .LE. N-K+1
C          WORK    - work vector of length K*(N+3)
C
C     Error Conditions
C         Improper input is a fatal error
C
C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C***ROUTINES CALLED  DBSPDR, DBSPEV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBSPPP
C
      INTEGER ILEFT, INEV, K, LDC, LXI, N, NK
      DOUBLE PRECISION A, C, T, WORK, XI
C     DIMENSION T(N+K),XI(LXI+1),C(LDC,*)
C     HERE, * = THE FINAL VALUE OF THE OUTPUT PARAMETER LXI.
      DIMENSION T(*), A(*), WORK(*), XI(*), C(LDC,*)
C***FIRST EXECUTABLE STATEMENT  DBSPPP
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      IF(LDC.LT.K) GO TO 110
      CALL DBSPDR(T, A, N, K, K, WORK)
      LXI = 0
      XI(1) = T(K)
      INEV = 1
      NK = N*K + 1
      DO 10 ILEFT=K,N
        IF (T(ILEFT+1).EQ.T(ILEFT)) GO TO 10
        LXI = LXI + 1
        XI(LXI+1) = T(ILEFT+1)
        CALL DBSPEV(T,WORK(1),N,K, K,XI(LXI),INEV,C(1,LXI),WORK(NK))
   10 CONTINUE
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'DBSPPP', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'DBSPPP', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'DBSPPP', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
      END


C    @(#)srsfb.f	20.3 2/13/96
      subroutine srsfb (ne,x, iodx,fmtx,ifmtx, diag)
C
C         THIS SUBROUTINE PERFORMS THE DOWNWARD OPERATION AND
C         BACKWARD SUBSTITUTION ON A REAL SYMMETRIC MATRIX
C         FACTORED AS L D L(TRANSPOSE).  DATA FORMAT IS THE SAME
C         AS THAT FOR THE  FPS SUBROUTINE SRSFB.
C           X    IS THE RIGHT-HAND-SIDE VECTOR. IT CONTAINS THE SOLUTION
C                ON OUTPUT.
C
      integer ifmtx(1)
      dimension x(1),iodx(1),fmtx(1),diag(1)
C
C     DOWNWARD OPERATION -- I.E. SOLVE L Y = B
C
      ne1 = ne - 1
C
      do 200 j=1,ne1
      g = x(j)
      ji = iodx(j)
      jl = iodx(j+1) - 1
      if (ji .gt. jl) go to 200
C
      do 100 m=ji,jl
         mrow = ifmtx(m)
  100 x(mrow) = x(mrow) - g * fmtx(m)
  200 continue
C
C     BACKWARD SUBSTITUTION -- I.E. SOLVE D L(TRANS.) = Y
C
      x(ne) = diag(ne) * x(ne)
      do 400 i=1,ne1
      j = ne - i
      ji = iodx(j)
      jl = iodx(j+1) - 1
      x(j) = x(j) * diag(j)
      if (ji .gt. jl) go to 400
C
      do 300 m=ji,jl
          mcol = ifmtx(m)
  300 x(j) = x(j) - x(mcol) * fmtx(m)
  400 continue
      return
      end


C
C  REVISION HISTORY
c    1-97 ...cca... added distortion center as parameters cl,cs
C    4-94 ...CCA... INITIAL RELEASE
C    6-97 ...RRD... MADE PORTABLE FOR UNIX

        INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
      IMPLICIT INTEGER(A-Z)
      REAL*4 OBUF(1800),A,RADSQ,DSC,DLC,D,LC,SC
      INTEGER*4 GSL,GSS,GSS0

	CALL XVMESSAGE('RADDIST VERSION 1.15.97',' ')
C-------GRID SIZE FROM PARAMETERS
	CALL XVPARM('NROW',NROW,ICNT,IDEF,0)
	CALL XVPARM('NCOL',NCOL,ICNT,IDEF,0)
	CALL XVPARM('INCR',INC,ICNT,IDEF,0)
	CALL XVPARM('CONSTANT',A,ICNT,IDEF,0)

C-------LINE AND SAMPLE CENTER ADDED ON 1/97
	CALL XVPARM('CL',LC,ICNT,IDEF,0)
	CALL XVPARM('CS',SC,ICNT,IDEF,0)
C
	NPOINTS = NROW*NCOL
	IF (NPOINTS .EQ. 0) GO TO 994
	IF (NPOINTS .GT. 900) GO TO 998

C-------STARTING VALUES
	GSL = INC
	GSS = INC
	GSS0 = GSS
C
c*******old code****
C-------FIND CENTER OF GRID
C	LINE NUMBER OF FIRST GRID = GSL
C	LINE NUMBER OF LAST GRID  = GSL + ((NROW-1)*INC)/2
C	CENTER = (FIRST + LAST)/2
CCCCCCC	LC = GSL + (NROW-1)*INC/2
CCCCCCC	SC = GSS + (NCOL-1)*INC/2
c*******
C
C-------DERIVATION:   (r = Rold)
C	Assumed distortion model:  Rnew = r + A*r**3
c	deltaInRadius = A*r**3
c	triangle with sides: deltaInRadius, deltaInLine, deltaInSamp is
c       similar to the triangle with sides: r, L-LC, S-SC
c	So, deltaInLine = A*r**3*(L-LC)/r = A*r**2*(L-LC)
c	So, deltaInSamp = A*r**3*(S-SC)/r = A*r**2*(S-SC)
c
	K = 1

	DO J=1,NROW		!ROWS
          DO I=1,NCOL   	!COLUMNS
	      LINE = GSL
	      SAMP = GSS

	      DLC = (LINE - LC)
	      DSC = (SAMP - SC)

	      RADSQ = DLC*DLC + DSC*DSC

	      D = DLC*A*RADSQ
              OBUF(K) = GSL + D

	      D = DSC*A*RADSQ
              OBUF(K+1) = GSS + D
              K = K + 2
              GSS = GSS + INC
          ENDDO
          GSS = GSS0
          GSL = GSL + INC
	ENDDO

	CALL XVUNIT(IO,'OUT',1,IST,' ')

	CALL XVOPEN(IO,IST,'U_NL',1,'U_NS',NPOINTS*2,'O_FORMAT','REAL',
     1             'U_FORMAT','REAL','OP','WRITE','OPEN_ACT','SA',
     2             'IO_ACT','SA',' ')
	CALL XVWRIT(IO,OBUF,IST,' ')
	CALL XLADD(IO,'HISTORY','GRID_NROW',NROW,STAT,'FORMAT','INT',
     1             ' ')
	CALL XLADD(IO,'HISTORY','GRID_NCOL',NCOL,STAT,'FORMAT','INT',
     1             ' ')
	CALL XLADD(IO,'HISTORY','CONSTANT',A,STAT,'FORMAT','REAL',' ')
	CALL XVCLOSE(IO,IST,' ')

	RETURN
C
994	CALL XVMESSAGE('GRID SIZE MUST BE GT ZERO',' ')
	CALL ABEND
998	CALL XVMESSAGE('NUMBER OF COORDINATES MUST NOT EXCEED 900',' ')
	CALL ABEND
	END


c     ****************************************************************
c     *                                                              *
c     *                      subroutine equiv_strain                 *
c     *                                                              *
c     *                       written by : kck                       *
c     *                                                              *
c     *                   last modified : 12/14/2018 rhd             *
c     *                                                              *
c     *     this subroutine computes mises yield function value      *
c     *     at the nodes/elem after the primary values have          *
c     *     been averaged                                            *
c     *                                                              *
c     ****************************************************************
c
      subroutine equiv_strain( results, maxnum, num )
      implicit none
c
      integer :: maxnum, num
      double precision :: results(maxnum,*)
c
      integer :: i
      double precision, parameter :: root23=0.471404d0, onep5=1.5d0
c
      do i = 1, num
        results(i,7) = root23 * sqrt(
     &     ( results(i,1) - results(i,2) ) ** 2 +
     &     ( results(i,2) - results(i,3) ) ** 2 +
     &     ( results(i,1) - results(i,3) ) ** 2 +
     &   onep5 * ( results(i,4)**2 + results(i,5)**2+
     &         results(i,6)**2 ) )
      end do
c
      return
      end


    !
    ! This program may be freely redistributed under the
    ! condition that the copyright notices (including this
    ! entire header) are not removed, and no compensation
    ! is received through use of the software.  Private,
    ! research, and institutional use is free.  You may
    ! distribute modified versions of this code UNDER THE
    ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE
    ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE
    ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE
    ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR
    ! NOTICE IS GIVEN OF THE MODIFICATIONS.  Distribution
    ! of this code as part of a commercial system is
    ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE
    ! AUTHOR.  (If you are not directly supplying this
    ! code to a customer, and you are instead telling them
    ! how they can obtain it for free, then you are not
    ! required to make any arrangement with me.)
    !
    ! Disclaimer:  Neither I nor: Columbia University, the
    ! National Aeronautics and Space Administration, nor
    ! the Massachusetts Institute of Technology warrant
    ! or certify this code in any way whatsoever.  This
    ! code is provided "as-is" to be used at your own risk.
    !
    !

    !
    ! INV.f90: block-wise solution of small linear systems.
    !
    ! Darren Engwirda
    ! 25-Mar-2019
    ! de2363 [at] columbia [dot] edu
    !
    !

    pure subroutine inv_2x2(amat,adim,ainv,vdim, &
        &                   adet)

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent( in) :: amat(adim,*)
        integer, intent( in) :: adim
        real*8 , intent(out) :: ainv(vdim,*)
        integer, intent( in) :: vdim
        real*8 , intent(out) :: adet

    !------------------------------------------- form A^-1 !

        adet   = amat(1,1) * amat(2,2) &
               - amat(1,2) * amat(2,1)

        ainv(1,1) =          amat(2,2)
        ainv(1,2) =        - amat(1,2)
        ainv(2,1) =        - amat(2,1)
        ainv(2,2) =          amat(1,1)

        return

    end  subroutine

    pure subroutine inv_3x3(amat,adim,ainv,vdim, &
        &                   adet)

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent( in) :: amat(adim,*)
        integer, intent( in) :: adim
        real*8 , intent(out) :: ainv(vdim,*)
        integer, intent( in) :: vdim
        real*8 , intent(out) :: adet

    !------------------------------------------- variables !
        real*8 :: &
        aa2233,aa2332,aa2133,aa2331,aa2132,&
        aa2231,aa1233,aa1332,aa1223,aa1322,&
        aa1133,aa1331,aa1123,aa1321,aa1132,&
        aa1231,aa1122,aa1221

    !------------------------------------------- form A^-1 !

        aa2233 = amat(2,2) * amat(3,3)
        aa2332 = amat(2,3) * amat(3,2)
        aa2133 = amat(2,1) * amat(3,3)
        aa2331 = amat(2,3) * amat(3,1)
        aa2132 = amat(2,1) * amat(3,2)
        aa2231 = amat(2,2) * amat(3,1)

        adet =  &
        amat(1,1) *  (aa2233 - aa2332) - &
	    amat(1,2) *  (aa2133 - aa2331) + &
	    amat(1,3) *  (aa2132 - aa2231)

        aa1233 = amat(1,2) * amat(3,3)
        aa1332 = amat(1,3) * amat(3,2)
        aa1223 = amat(1,2) * amat(2,3)
        aa1322 = amat(1,3) * amat(2,2)
        aa1133 = amat(1,1) * amat(3,3)
        aa1331 = amat(1,3) * amat(3,1)
        aa1123 = amat(1,1) * amat(2,3)
        aa1321 = amat(1,3) * amat(2,1)
        aa1132 = amat(1,1) * amat(3,2)
        aa1231 = amat(1,2) * amat(3,1)
        aa1122 = amat(1,1) * amat(2,2)
        aa1221 = amat(1,2) * amat(2,1)

        ainv(1,1) =  (aa2233 - aa2332)
        ainv(1,2) = -(aa1233 - aa1332)
        ainv(1,3) =  (aa1223 - aa1322)

        ainv(2,1) = -(aa2133 - aa2331)
        ainv(2,2) =  (aa1133 - aa1331)
        ainv(2,3) = -(aa1123 - aa1321)

        ainv(3,1) =  (aa2132 - aa2231)
        ainv(3,2) = -(aa1132 - aa1231)
        ainv(3,3) =  (aa1122 - aa1221)

        return

    end  subroutine

    pure subroutine mul_2x2(amat,adim,bmat,bdim, &
        &                   scal,cmat,cdim)

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent(in)    :: amat(adim,*)
        integer, intent(in)    :: adim
        real*8 , intent(in)    :: bmat(bdim,*)
        integer, intent(in)    :: bdim
        real*8 , intent(in)    :: scal
        real*8 , intent(inout) :: cmat(cdim,*)
        integer, intent(in)    :: cdim

    !-------------------------------- C = C + scal * A * B !

        if (scal .eq. +1.d0) then

        cmat(1,1) = cmat(1,1) &
             + ( amat(1,1) * bmat(1,1) &
               + amat(1,2) * bmat(2,1) )
        cmat(2,1) = cmat(2,1) &
             + ( amat(2,1) * bmat(1,1) &
               + amat(2,2) * bmat(2,1) )

        cmat(1,2) = cmat(1,2) &
             + ( amat(1,1) * bmat(1,2) &
               + amat(1,2) * bmat(2,2) )
        cmat(2,2) = cmat(2,2) &
             + ( amat(2,1) * bmat(1,2) &
               + amat(2,2) * bmat(2,2) )

        else &
        if (scal .eq. -1.d0) then

        cmat(1,1) = cmat(1,1) &
             - ( amat(1,1) * bmat(1,1) &
               + amat(1,2) * bmat(2,1) )
        cmat(2,1) = cmat(2,1) &
             - ( amat(2,1) * bmat(1,1) &
               + amat(2,2) * bmat(2,1) )

        cmat(1,2) = cmat(1,2) &
             - ( amat(1,1) * bmat(1,2) &
               + amat(1,2) * bmat(2,2) )
        cmat(2,2) = cmat(2,2) &
             - ( amat(2,1) * bmat(1,2) &
               + amat(2,2) * bmat(2,2) )

        else

        cmat(1,1) = cmat(1,1) + &
        scal * ( amat(1,1) * bmat(1,1) &
               + amat(1,2) * bmat(2,1) )
        cmat(2,1) = cmat(2,1) + &
        scal * ( amat(2,1) * bmat(1,1) &
               + amat(2,2) * bmat(2,1) )

        cmat(1,2) = cmat(1,2) + &
        scal * ( amat(1,1) * bmat(1,2) &
               + amat(1,2) * bmat(2,2) )
        cmat(2,2) = cmat(2,2) + &
        scal * ( amat(2,1) * bmat(1,2) &
               + amat(2,2) * bmat(2,2) )

        end if

        return

    end  subroutine

    pure subroutine mul_3x3(amat,adim,bmat,bdim, &
        &                   scal,cmat,cdim)

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent(in)    :: amat(adim,*)
        integer, intent(in)    :: adim
        real*8 , intent(in)    :: bmat(bdim,*)
        integer, intent(in)    :: bdim
        real*8 , intent(in)    :: scal
        real*8 , intent(inout) :: cmat(cdim,*)
        integer, intent(in)    :: cdim

    !-------------------------------- C = C + scal * A * B !

        if (scal .eq. +1.d0) then

        cmat(1,1) = cmat(1,1) + &
             + ( amat(1,1) * bmat(1,1) &
               + amat(1,2) * bmat(2,1) &
               + amat(1,3) * bmat(3,1) )
        cmat(2,1) = cmat(2,1) + &
             + ( amat(2,1) * bmat(1,1) &
               + amat(2,2) * bmat(2,1) &
               + amat(2,3) * bmat(3,1) )
        cmat(3,1) = cmat(3,1) + &
             + ( amat(3,1) * bmat(1,1) &
               + amat(3,2) * bmat(2,1) &
               + amat(3,3) * bmat(3,1) )

        cmat(1,2) = cmat(1,2) + &
             + ( amat(1,1) * bmat(1,2) &
               + amat(1,2) * bmat(2,2) &
               + amat(1,3) * bmat(3,2) )
        cmat(2,2) = cmat(2,2) + &
             + ( amat(2,1) * bmat(1,2) &
               + amat(2,2) * bmat(2,2) &
               + amat(2,3) * bmat(3,2) )
        cmat(3,2) = cmat(3,2) + &
             + ( amat(3,1) * bmat(1,2) &
               + amat(3,2) * bmat(2,2) &
               + amat(3,3) * bmat(3,2) )

        cmat(1,3) = cmat(1,3) + &
             + ( amat(1,1) * bmat(1,3) &
               + amat(1,2) * bmat(2,3) &
               + amat(1,3) * bmat(3,3) )
        cmat(2,3) = cmat(2,3) + &
             + ( amat(2,1) * bmat(1,3) &
               + amat(2,2) * bmat(2,3) &
               + amat(2,3) * bmat(3,3) )
        cmat(3,3) = cmat(3,3) + &
             + ( amat(3,1) * bmat(1,3) &
               + amat(3,2) * bmat(2,3) &
               + amat(3,3) * bmat(3,3) )

        else &
        if (scal .eq. -1.d0) then

        cmat(1,1) = cmat(1,1) + &
             - ( amat(1,1) * bmat(1,1) &
               + amat(1,2) * bmat(2,1) &
               + amat(1,3) * bmat(3,1) )
        cmat(2,1) = cmat(2,1) + &
             - ( amat(2,1) * bmat(1,1) &
               + amat(2,2) * bmat(2,1) &
               + amat(2,3) * bmat(3,1) )
        cmat(3,1) = cmat(3,1) + &
             - ( amat(3,1) * bmat(1,1) &
               + amat(3,2) * bmat(2,1) &
               + amat(3,3) * bmat(3,1) )

        cmat(1,2) = cmat(1,2) + &
             - ( amat(1,1) * bmat(1,2) &
               + amat(1,2) * bmat(2,2) &
               + amat(1,3) * bmat(3,2) )
        cmat(2,2) = cmat(2,2) + &
             - ( amat(2,1) * bmat(1,2) &
               + amat(2,2) * bmat(2,2) &
               + amat(2,3) * bmat(3,2) )
        cmat(3,2) = cmat(3,2) + &
             - ( amat(3,1) * bmat(1,2) &
               + amat(3,2) * bmat(2,2) &
               + amat(3,3) * bmat(3,2) )

        cmat(1,3) = cmat(1,3) + &
             - ( amat(1,1) * bmat(1,3) &
               + amat(1,2) * bmat(2,3) &
               + amat(1,3) * bmat(3,3) )
        cmat(2,3) = cmat(2,3) + &
             - ( amat(2,1) * bmat(1,3) &
               + amat(2,2) * bmat(2,3) &
               + amat(2,3) * bmat(3,3) )
        cmat(3,3) = cmat(3,3) + &
             - ( amat(3,1) * bmat(1,3) &
               + amat(3,2) * bmat(2,3) &
               + amat(3,3) * bmat(3,3) )

        else

        cmat(1,1) = cmat(1,1) + &
        scal * ( amat(1,1) * bmat(1,1) &
               + amat(1,2) * bmat(2,1) &
               + amat(1,3) * bmat(3,1) )
        cmat(2,1) = cmat(2,1) + &
        scal * ( amat(2,1) * bmat(1,1) &
               + amat(2,2) * bmat(2,1) &
               + amat(2,3) * bmat(3,1) )
        cmat(3,1) = cmat(3,1) + &
        scal * ( amat(3,1) * bmat(1,1) &
               + amat(3,2) * bmat(2,1) &
               + amat(3,3) * bmat(3,1) )

        cmat(1,2) = cmat(1,2) + &
        scal * ( amat(1,1) * bmat(1,2) &
               + amat(1,2) * bmat(2,2) &
               + amat(1,3) * bmat(3,2) )
        cmat(2,2) = cmat(2,2) + &
        scal * ( amat(2,1) * bmat(1,2) &
               + amat(2,2) * bmat(2,2) &
               + amat(2,3) * bmat(3,2) )
        cmat(3,2) = cmat(3,2) + &
        scal * ( amat(3,1) * bmat(1,2) &
               + amat(3,2) * bmat(2,2) &
               + amat(3,3) * bmat(3,2) )

        cmat(1,3) = cmat(1,3) + &
        scal * ( amat(1,1) * bmat(1,3) &
               + amat(1,2) * bmat(2,3) &
               + amat(1,3) * bmat(3,3) )
        cmat(2,3) = cmat(2,3) + &
        scal * ( amat(2,1) * bmat(1,3) &
               + amat(2,2) * bmat(2,3) &
               + amat(2,3) * bmat(3,3) )
        cmat(3,3) = cmat(3,3) + &
        scal * ( amat(3,1) * bmat(1,3) &
               + amat(3,2) * bmat(2,3) &
               + amat(3,3) * bmat(3,3) )

        end if

        return

    end  subroutine

    pure subroutine slv_2x2(amat,adim,vrhs,vdim, &
        &                   nrhs,fEPS,okay)

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent(in)    :: amat(adim,*)
        integer, intent(in)    :: adim
        real*8 , intent(inout) :: vrhs(vdim,*)
        integer, intent(in)    :: vdim
        integer, intent(in)    :: nrhs
        real*8 , intent(in)    :: fEPS
        logical, intent(inout) :: okay

    !------------------------------------------- variables !
        real*8                 :: ainv(2,2)
        real*8                 :: adet
        real*8                 :: vtmp(  2)
        integer                :: irhs

        integer, parameter     :: LDIM = 2

    !---------------------------------------- calc. inv(A) !

        call inv_2x2(amat,adim,ainv,LDIM,&
                     adet)

        okay = (abs(adet) .gt. fEPS)

        if (okay.eqv..false.) return

    !---------------------------------------- v = A^-1 * v !

        do irhs = 1, nrhs

        vtmp(1) =  &
          + ( &
        ainv(1, 1) *   vrhs(1,irhs) &
      + ainv(1, 2) *   vrhs(2,irhs) &
            ) / adet

        vtmp(2) =  &
          + ( &
        ainv(2, 1) *   vrhs(1,irhs) &
      + ainv(2, 2) *   vrhs(2,irhs) &
            ) / adet

        vrhs(1,irhs) = vtmp(1)
        vrhs(2,irhs) = vtmp(2)

        end do

        return

    end  subroutine

    pure subroutine slv_3x3(amat,adim,vrhs,vdim, &
        &                   nrhs,fEPS,okay)

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent(in)    :: amat(adim,*)
        integer, intent(in)    :: adim
        real*8 , intent(inout) :: vrhs(vdim,*)
        integer, intent(in)    :: vdim
        integer, intent(in)    :: nrhs
        real*8 , intent(in)    :: fEPS
        logical, intent(inout) :: okay

    !------------------------------------------- variables !
        real*8                 :: ainv(3,3)
        real*8                 :: adet
        real*8                 :: vtmp(  3)
        integer                :: irhs

        integer, parameter     :: LDIM = 3

    !---------------------------------------- calc. inv(A) !

        call inv_3x3(amat,adim,ainv,LDIM,&
                     adet)

        okay = (abs(adet) .gt. fEPS)

        if (okay.eqv..false.) return

    !---------------------------------------- v = A^-1 * v !

        do irhs = 1, nrhs

        vtmp(1) =  &
          + ( &
        ainv(1, 1) *   vrhs(1,irhs) &
      + ainv(1, 2) *   vrhs(2,irhs) &
      + ainv(1, 3) *   vrhs(3,irhs) &
            ) / adet

        vtmp(2) =  &
          + ( &
        ainv(2, 1) *   vrhs(1,irhs) &
      + ainv(2, 2) *   vrhs(2,irhs) &
      + ainv(2, 3) *   vrhs(3,irhs) &
            ) / adet

        vtmp(3) =  &
          + ( &
        ainv(3, 1) *   vrhs(1,irhs) &
      + ainv(3, 2) *   vrhs(2,irhs) &
      + ainv(3, 3) *   vrhs(3,irhs) &
            ) / adet

        vrhs(1,irhs) = vtmp(1)
        vrhs(2,irhs) = vtmp(2)
        vrhs(3,irhs) = vtmp(3)

        end do

        return

    end  subroutine

    pure subroutine slv_4x4(amat,adim,vrhs,vdim, &
        &                   nrhs,fEPS,okay)

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent(in)    :: amat(adim,*)
        integer, intent(in)    :: adim
        real*8 , intent(inout) :: vrhs(vdim,*)
        integer, intent(in)    :: vdim
        integer, intent(in)    :: nrhs
        real*8 , intent(in)    :: fEPS
        logical, intent(inout) :: okay

    !------------------------------------------- variables !
        real*8                 :: ainv(2,2)
        real*8                 :: lmat(2,2)
        real*8                 :: umat(2,2)
        real*8                 :: smat(2,2)
        real*8                 :: sinv(2,2)
        real*8                 :: adet,sdet
        real*8                 :: vtmp(  2)
        integer                :: irhs

        integer, parameter     :: LDIM = 2

    !---------------------- form a block LDU factorisation !

        call inv_2x2(amat(1,1),adim,ainv,LDIM, &
                     adet)

        okay = (abs(adet) .gt. fEPS)

        if (okay.eqv..false.) return

    !---------------------------------------- L = C * A^-1 !

        lmat(1,1) = +0.d0
        lmat(1,2) = +0.d0
        lmat(2,1) = +0.d0
        lmat(2,2) = +0.d0

        call mul_2x2(amat(3,1),adim,ainv,LDIM, &
                    +1.d0,lmat,LDIM)

    !---------------------------------------- U = A^-1 * B !

        umat(1,1) = +0.d0
        umat(1,2) = +0.d0
        umat(2,1) = +0.d0
        umat(2,2) = +0.d0

        call mul_2x2(ainv,LDIM,amat(1,3),adim, &
                    +1.d0,umat,LDIM)

    !-------------------------------- S = D - C * A^-1 * B !

        smat(1,1) = amat(3,3)
        smat(1,2) = amat(3,4)
        smat(2,1) = amat(4,3)
        smat(2,2) = amat(4,4)

        call mul_2x2(lmat,LDIM,amat(1,3),adim, &
                    -1.d0/adet,smat,LDIM)

        call inv_2x2(smat,LDIM,sinv,LDIM,sdet)

        okay = (abs(adet) .gt. fEPS)

        if (okay.eqv..false.) return

    !-------------------------------- back-solve LDU = rhs !

        do irhs = 1, nrhs

    !---------------------------------------- solve L part !

        vrhs(3,irhs) = vrhs(3,irhs) &
          - ( &
        lmat(1, 1) *   vrhs(1,irhs) &
      + lmat(1, 2) *   vrhs(2,irhs) &
            ) / adet

        vrhs(4,irhs) = vrhs(4,irhs) &
          - ( &
        lmat(2, 1) *   vrhs(1,irhs) &
      + lmat(2, 2) *   vrhs(2,irhs) &
            ) / adet

    !---------------------------------------- solve D part !

        vtmp(1) =  &
          + ( &
        ainv(1, 1) *   vrhs(1,irhs) &
      + ainv(1, 2) *   vrhs(2,irhs) &
            ) / adet

        vtmp(2) =  &
          + ( &
        ainv(2, 1) *   vrhs(1,irhs) &
      + ainv(2, 2) *   vrhs(2,irhs) &
            ) / adet

        vrhs(1,irhs) = vtmp(1)
        vrhs(2,irhs) = vtmp(2)

        vtmp(1) =  &
          + ( &
        sinv(1, 1) *   vrhs(3,irhs) &
      + sinv(1, 2) *   vrhs(4,irhs) &
            ) / sdet

        vtmp(2) =  &
          + ( &
        sinv(2, 1) *   vrhs(3,irhs) &
      + sinv(2, 2) *   vrhs(4,irhs) &
            ) / sdet

        vrhs(3,irhs) = vtmp(1)
        vrhs(4,irhs) = vtmp(2)

    !---------------------------------------- solve U part !

        vrhs(1,irhs) = vrhs(1,irhs) &
          - ( &
        umat(1, 1) *   vrhs(3,irhs) &
      + umat(1, 2) *   vrhs(4,irhs) &
            ) / adet

        vrhs(2,irhs) = vrhs(2,irhs) &
          - ( &
        umat(2, 1) *   vrhs(3,irhs) &
      + umat(2, 2) *   vrhs(4,irhs) &
            ) / adet

        end do

        return

    end  subroutine

    pure subroutine slv_6x6(amat,adim,vrhs,vdim, &
        &                   nrhs,fEPS,okay)

        implicit none

    !------------------------------------------- arguments !
        real*8 , intent(in)    :: amat(adim,*)
        integer, intent(in)    :: adim
        real*8 , intent(inout) :: vrhs(vdim,*)
        integer, intent(in)    :: vdim
        integer, intent(in)    :: nrhs
        real*8 , intent(in)    :: fEPS
        logical, intent(inout) :: okay

    !------------------------------------------- variables !
        real*8                 :: ainv(3,3)
        real*8                 :: lmat(3,3)
        real*8                 :: umat(3,3)
        real*8                 :: smat(3,3)
        real*8                 :: sinv(3,3)
        real*8                 :: adet,sdet
        real*8                 :: vtmp(  3)
        integer                :: irhs

        integer, parameter     :: LDIM = 3

    !---------------------- form a block LDU factorisation !

        call inv_3x3(amat(1,1),adim,ainv,LDIM, &
                     adet)

        okay = (abs(adet) .gt. fEPS)

        if (okay.eqv..false.) return

    !---------------------------------------- L = C * A^-1 !

        lmat(1,1) = +0.d0
        lmat(1,2) = +0.d0
        lmat(1,3) = +0.d0
        lmat(2,1) = +0.d0
        lmat(2,2) = +0.d0
        lmat(2,3) = +0.d0
        lmat(3,1) = +0.d0
        lmat(3,2) = +0.d0
        lmat(3,3) = +0.d0

        call mul_3x3(amat(4,1),adim,ainv,LDIM, &
                    +1.d0,lmat,LDIM)

    !---------------------------------------- U = A^-1 * B !

        umat(1,1) = +0.d0
        umat(1,2) = +0.d0
        umat(1,3) = +0.d0
        umat(2,1) = +0.d0
        umat(2,2) = +0.d0
        umat(2,3) = +0.d0
        umat(3,1) = +0.d0
        umat(3,2) = +0.d0
        umat(3,3) = +0.d0

        call mul_3x3(ainv,LDIM,amat(1,4),adim, &
                    +1.d0,umat,LDIM)

    !-------------------------------- S = D - C * A^-1 * B !

        smat(1,1) = amat(4,4)
        smat(1,2) = amat(4,5)
        smat(1,3) = amat(4,6)
        smat(2,1) = amat(5,4)
        smat(2,2) = amat(5,5)
        smat(2,3) = amat(5,6)
        smat(3,1) = amat(6,4)
        smat(3,2) = amat(6,5)
        smat(3,3) = amat(6,6)

        call mul_3x3(lmat,LDIM,amat(1,4),adim, &
                    -1.d0/adet,smat,LDIM)

        call inv_3x3(smat,LDIM,sinv,LDIM,sdet)

        okay = (abs(adet) .gt. fEPS)

        if (okay.eqv..false.) return

    !-------------------------------- back-solve LDU = rhs !

        do irhs = 1, nrhs

    !---------------------------------------- solve L part !

        vrhs(4,irhs) = vrhs(4,irhs) &
          - ( &
        lmat(1, 1) *   vrhs(1,irhs) &
      + lmat(1, 2) *   vrhs(2,irhs) &
      + lmat(1, 3) *   vrhs(3,irhs) &
            ) / adet

        vrhs(5,irhs) = vrhs(5,irhs) &
          - ( &
        lmat(2, 1) *   vrhs(1,irhs) &
      + lmat(2, 2) *   vrhs(2,irhs) &
      + lmat(2, 3) *   vrhs(3,irhs) &
            ) / adet

        vrhs(6,irhs) = vrhs(6,irhs) &
          - ( &
        lmat(3, 1) *   vrhs(1,irhs) &
      + lmat(3, 2) *   vrhs(2,irhs) &
      + lmat(3, 3) *   vrhs(3,irhs) &
            ) / adet

    !---------------------------------------- solve D part !

        vtmp(1) =  &
          + ( &
        ainv(1, 1) *   vrhs(1,irhs) &
      + ainv(1, 2) *   vrhs(2,irhs) &
      + ainv(1, 3) *   vrhs(3,irhs) &
            ) / adet

        vtmp(2) =  &
          + ( &
        ainv(2, 1) *   vrhs(1,irhs) &
      + ainv(2, 2) *   vrhs(2,irhs) &
      + ainv(2, 3) *   vrhs(3,irhs) &
            ) / adet

        vtmp(3) =  &
          + ( &
        ainv(3, 1) *   vrhs(1,irhs) &
      + ainv(3, 2) *   vrhs(2,irhs) &
      + ainv(3, 3) *   vrhs(3,irhs) &
            ) / adet

        vrhs(1,irhs) = vtmp(1)
        vrhs(2,irhs) = vtmp(2)
        vrhs(3,irhs) = vtmp(3)

        vtmp(1) =  &
          + ( &
        sinv(1, 1) *   vrhs(4,irhs) &
      + sinv(1, 2) *   vrhs(5,irhs) &
      + sinv(1, 3) *   vrhs(6,irhs) &
            ) / sdet

        vtmp(2) =  &
          + ( &
        sinv(2, 1) *   vrhs(4,irhs) &
      + sinv(2, 2) *   vrhs(5,irhs) &
      + sinv(2, 3) *   vrhs(6,irhs) &
            ) / sdet

        vtmp(3) =  &
          + ( &
        sinv(3, 1) *   vrhs(4,irhs) &
      + sinv(3, 2) *   vrhs(5,irhs) &
      + sinv(3, 3) *   vrhs(6,irhs) &
            ) / sdet

        vrhs(4,irhs) = vtmp(1)
        vrhs(5,irhs) = vtmp(2)
        vrhs(6,irhs) = vtmp(3)

    !---------------------------------------- solve U part !

        vrhs(1,irhs) = vrhs(1,irhs) &
          - ( &
        umat(1, 1) *   vrhs(4,irhs) &
      + umat(1, 2) *   vrhs(5,irhs) &
      + umat(1, 3) *   vrhs(6,irhs) &
            ) / adet

        vrhs(2,irhs) = vrhs(2,irhs) &
          - ( &
        umat(2, 1) *   vrhs(4,irhs) &
      + umat(2, 2) *   vrhs(5,irhs) &
      + umat(2, 3) *   vrhs(6,irhs) &
            ) / adet

        vrhs(3,irhs) = vrhs(3,irhs) &
          - ( &
        umat(3, 1) *   vrhs(4,irhs) &
      + umat(3, 2) *   vrhs(5,irhs) &
      + umat(3, 3) *   vrhs(6,irhs) &
            ) / adet

        end do

        return

    end  subroutine


      real*8 function dotpra(array1,array2,nmax)
c
c     This subroutine computes the dot product of two real*8 arrays
c     array1 and array2.
c
c     This subroutine is nearly identical to EQLIBU/ddot.f, which has
c     the same function, but a different calling sequence.
c
c     This subroutine is called by:
c
c       EQLIBU/sgeco.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       array1 =  real*8 vector with nmax elements
c       array2 =  real*8 vector with nmax elements
c
c     Output:
c
c       dotpra = the dot product
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nmax
c
      real*8 array1(nmax),array2(nmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,ileft
c
      real*8 dx
c
c-----------------------------------------------------------------------
c
c     Note the use of a local variable (ax) within the loop.
c     Note also that the loop is unrolled.
c
      dx = 0.
      ileft = (nmax/8)*8
c
      do i = 1,ileft,8
        dx = dx + array1(i)*array2(i) + array1(i + 1)*array2(i + 1)
     $  + array1(i + 2)*array2(i + 2) + array1(i + 3)*array2(i + 3)
     $  + array1(i + 4)*array2(i + 4) + array1(i + 5)*array2(i + 5)
     $  + array1(i + 6)*array2(i + 6) + array1(i + 7)*array2(i + 7)
      enddo
c
      do i = ileft + 1,nmax
        dx = dx + array1(i)*array2(i)
      enddo
c
      dotpra = dx
c
      end


      SUBROUTINE W3FC05(U, V, DIR, SPD)                                 11260000
C$$$  SUBPROGRAM DOCUMENTATION BLOCK                                    11270000
C                .      .    .                                       .  11280000
C SUBPROGRAM:  W3FC05        EARTH U,V WIND COMPONENTS TO DIR AND SPD   11290000
C   PRGMMR: KEYSER           ORG: W/NMC22     DATE: 92-10-21            11300000
C                                                                       11310000
C ABSTRACT: GIVEN THE TRUE (EARTH ORIENTED) WIND COMPONENTS             11320000
C   COMPUTE THE WIND DIRECTION AND SPEED.                               11330000
C   INPUT WINDS AT THE POLE ARE ASSUMED TO FOLLOW THE WMO               11340000
C   CONVENTIONS, WITH THE OUTPUT DIRECTION COMPUTED IN ACCORDANCE       11350000
C   WITH WMO STANDARDS FOR REPORTING WINDS AT THE POLE.                 11360000
C   (SEE OFFICE NOTE 241 FOR WMO DEFINITION.)                           11370000
C                                                                       11380000
C PROGRAM HISTORY LOG:                                                  11390000
C   92-10-21  D.A.KEYSER  ADDED 1.E-3 TO DIRECTION TO ALLOW TRUNCATION  11391000
C                         TO NEAREST WHOLE DEGREE TO BE CORRECT         11391100
C                         (KEEPS AGREEMENT BETWEEN CRAY & NAS VERSIONS) 11391200
C   91-03-05  R.E.JONES   CHANGES FOR CRAY CFT77 FORTRAN                11391300
C   88-10-19  CHASE, P.   ALLOW OUTPUT VALUES TO OVERLAY INPUT          11392000
C   81-12-30  STACKPOLE, JOHN                                           11400000
C                                                                       11430000
C USAGE:    CALL W3FC05 (U, V, DIR, SPD)                                11440000
C                                                                       11450000
C   INPUT ARGUMENT LIST:                                                11460000
C     U        - REAL   EARTH-ORIENTED U-COMPONENT                      11470001
C     V        - REAL   EARTH-ORIENTED V-COMPONENT                      11480001
C                                                                       11490000
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)                  11500000
C     DIR      - REAL   WIND DIRECTION, DEGREES.  VALUES WILL           11510001
C                BE FROM 0 TO 360 INCLUSIVE.                            11520000
C     SPD      - REAL   WIND SPEED IN SAME UNITS AS INPUT               11530001
C                                                                       11540000
C   INPUT FILES:   NONE                                                 11550000
C                                                                       11560000
C   OUTPUT FILES:   NONE                                                11570000
C                                                                       11580000
C   SUBPROGRAMS CALLED:                                                 11590000
C     LIBRARY:                                                          11600000
C       COMMON   - SQRT, ATAN2                                          11610000
C                                                                       11620000
C REMARKS:  IF SPEED IS LESS THAN 1E-10 THEN DIRECTION WILL BE SET      11630000
C   TO ZERO.                                                            11640000
C                                                                       11650000
C ATTRIBUTES:                                                           11660000
C   LANGUAGE: CRAY CFT77 FORTRAN                                        11670000
C   MACHINE:  CRAY Y-MP8/832                                            11680000
C                                                                       11690000
C$$$                                                                    11700000
C                                                                       11710000
C     VARIABLES.....                                                    11720000
C                                                                       11730000
      REAL   U, V, DIR, SPD, XSPD                                       11740000
C                                                                       11750000
C     CONSTANTS.....                                                    11760000
C                                                                       11770000
      DATA  SPDTST/1.0E-10/                                             11780000
      DATA  RTOD  /57.2957795/                                          11790000
      DATA  DCHALF/180.0/                                               11800000
C                                                                       11810000
      XSPD = SQRT(U * U + V * V)                                        11820000
      IF (XSPD .LT. SPDTST) THEN                                        11830000
         DIR = 0.0                                                      11840000
      ELSE                                                              11850000
         DIR = ATAN2(U,V) * RTOD + DCHALF + 1.E-3                       11860000
      ENDIF                                                             11870000
      SPD = XSPD                                                        11880000
      RETURN                                                            11890000
      END                                                               11900000


FUNCTION FSTRSE(VOID,BMECH1,BMECH2,BMECH3)

  ! **  FSTRSE IS WATER SPECIFIC WEIGHT NORMALIZED EFFECTIVE STRESS
  !
  IMPLICIT NONE

  REAL :: FSTRSE,VOID,BMECH1,BMECH2,BMECH3,TMP,FSTRSELOG

  IF( BMECH1 > 0.0 )THEN
    TMP=-(VOID-BMECH2)/BMECH3
    FSTRSE=BMECH1*EXP(TMP)
  ELSE
    FSTRSELOG=-0.0147351*(VOID**3)+0.311854*(VOID**2)-2.96371*VOID+7.34698
    FSTRSE=EXP(FSTRSELOG)
  ENDIF

END FUNCTION


      SUBROUTINE HUEANG (R,G,B, ANG, DIST)

C  This program calculates a characteristic angle for a hue from the
C  RGB color cube.  It does so by rotating the cube 45 deg around the
C  y-axis and atan(sqrt(2)) around the z-axis (assuming xyz = RGB).
C  This lines up the black-white cube diagonal (0,0,0 to 1,1,1) along
C  the y-axis.  Now, transformed points along the color-saturated
C  vertices are such that their angle in the x-z plane is a measure
C  of hue; so atan2 is used to compute the hue of any RGB point.

C  BTW, somewhat surprisingly, the points which are transformed into
C  the x=0 plane are all those in the old plane described by:
C  x -2y + z = 0 (this plane contains the points (0,0,0), (1,1,1),
C  and (0,.5,1), all of which can be "seen" to be rotated into x=0
C  plane).  This plane is such that it is satisfied by any points of
C  the form: (q, q+c, q+2c), so that sample points like (3,4,5) will
C  always transform into the x=0 plane.

C  Hueang also returns the distance of the RGB point from the
C  neutral (black-white) axis.

      REAL TMAT(4,4), R,G,B, XO,YO,ZO, PI,A45, ZZ,U, ANG, DIST

      ZZ = 0.0
      U = 1.0
      PI = 3.14159265
      A45 = PI/4.0

      CALL EBLTM3 (ZZ,ZZ,ZZ, ZZ,ZZ,ZZ, ZZ,A45,ATAN(SQRT(2.0)),
     1             U,U,U, TMAT)

10    CONTINUE

      CALL ETP3 (R,G,B, TMAT,  XO,YO,ZO)

      DIST = SQRT(XO*XO + ZO*ZO)

      IF (DIST .EQ. ZZ) THEN
         ANG = -666.0
      ELSE
C  Normalize to 0..1
         ANG = ATAN2(XO,ZO) / (2*PI)
         IF (ANG .LT. 0.0) ANG = ANG + 1
      ENDIF

      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 hpsi
  use global_variables
  implicit none
! finite difference
  real(dp),parameter :: cN0=-205d0/72d0,cN1=8d0/5d0
  real(dp),parameter :: cN2=-1d0/5d0,cN3=8d0/315d0
  real(dp),parameter :: cN4=-1d0/560d0
  integer :: ix,iy
  real(dp) :: c0,c1,c2,c3,c4
  real(dp) :: c0e,c1e,c2e,c3e,c4e,c0n,c1n,c2n,c3n,c4n
! nine-points formula
  c0e=-0.5d0*cN0/(dx**2)/mu_e
  c1e=-0.5d0*cN1/(dx**2)/mu_e
  c2e=-0.5d0*cN2/(dx**2)/mu_e
  c3e=-0.5d0*cN3/(dx**2)/mu_e
  c4e=-0.5d0*cN4/(dx**2)/mu_e

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

  tmp_wfn_b(:,:)=0d0
  tmp_wfn_b(0:Nx,0:NR) = tmp_wfn(0:Nx,0:NR)
  tmp_wfn_b(0:Nx,-1) = tmp_wfn(0:Nx,1)
  tmp_wfn_b(0:Nx,-2) = tmp_wfn(0:Nx,2)
  tmp_wfn_b(0:Nx,-3) = tmp_wfn(0:Nx,3)
  tmp_wfn_b(0:Nx,-4) = tmp_wfn(0:Nx,4)

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

  end do
  end do

  tmp_hwfn(:,:) = tmp_hwfn(:,:) + v_all(:,:)*tmp_wfn(:,:)
  return
end subroutine hpsi


      subroutine pvE0scalar(E0,p1,p2,p3,p4,p5,p1p2,p2p3,p3p4,p4p5,p5p1,
     . m1s,m2s,m3s,m4s,m5s)
      implicit none
      include 'TRscale.f'
      double complex E0(-2:0),Det,
     . D01(-2:0),D02(-2:0),D03(-2:0),D04(-2:0),D05(-2:0)
      double precision p1,p2,p3,p4,p5,p1p2,p2p3,p3p4,p4p5,p5p1,
     . m1s,m2s,m3s,m4s,m5s
      integer i, j,ep
      Double Complex Y(5,5), Yi(5,5),detYi(5)
      Double Complex Yflat(25), Yiflat(25)
      equivalence (Y, Yflat)
      equivalence (Yi, Yiflat)

      Double Complex pvXDet,trI4
      external pvXDet
c      Double Complex Det5

      Y(1,1) = dcmplx(2*m1s)
      Y(1,2) = dcmplx(m1s + m2s - p1)
      Y(2,1) = Y(1,2)
      Y(1,3) = dcmplx(m1s + m3s - p1p2)
      Y(3,1) = Y(1,3)
      Y(1,4) = dcmplx(m1s + m4s - p4p5)
      Y(4,1) = Y(1,4)
      Y(1,5) = dcmplx(m1s + m5s - p5)
      Y(5,1) = Y(1,5)
      Y(2,2) = dcmplx(2*m2s)
      Y(2,3) = dcmplx(m2s + m3s - p2)
      Y(3,2) = Y(2,3)
      Y(2,4) = dcmplx(m2s + m4s - p2p3)
      Y(4,2) = Y(2,4)
      Y(2,5) = dcmplx(m2s + m5s - p5p1)
      Y(5,2) = Y(2,5)
      Y(3,3) = dcmplx(2*m3s)
      Y(3,4) = dcmplx(m3s + m4s - p3)
      Y(4,3) = Y(3,4)
      Y(3,5) = dcmplx(m3s + m5s - p3p4)
      Y(5,3) = Y(3,5)
      Y(4,4) = dcmplx(2*m4s)
      Y(4,5) = dcmplx(m4s + m5s - p4)
      Y(5,4) = Y(4,5)
      Y(5,5) = dcmplx(2*m5s)

      do i = 1, 5
        do j = 1, 25
          Yiflat(j) = Yflat(j)
        enddo
        do j = 1, 5
          Yi(j,i) = dcmplx(1d0,0d0)
        enddo
        detYi(i) = pvXDet(Yi, 5)
      enddo

        do ep=-2,0
        D01(ep)=trI4(p2,p3,p4,p5p1,p2p3,p3p4,m2s,m3s,m4s,m5s,musq,ep)
        enddo

        do ep=-2,0
        D02(ep)=trI4(p1p2,p3,p4,p5,p4p5,p3p4,m1s,m3s,m4s,m5s,musq,ep)
        enddo
        do ep=-2,0
        D03(ep)=trI4(p1,p2p3,p4,p5,p4p5,p5p1,m1s,m2s,m4s,m5s,musq,ep)
        enddo
        do ep=-2,0
        D04(ep)=trI4(p1,p2,p3p4,p5,p1p2,p5p1,m1s,m2s,m3s,m5s,musq,ep)
        enddo
        do ep=-2,0
        D05(ep)=trI4(p1,p2,p3,p4p5,p1p2,p2p3,m1s,m2s,m3s,m4s,musq,ep)
        enddo

      Det=pvXDet(Y,5)

        do ep=-2,0
        E0(ep) = -(
     &    detYi(1)*D01(ep)+detYi(2)*D02(ep)+detYi(3)*D03(ep)
     &   +detYi(4)*D04(ep)+detYi(5)*D05(ep))/Det

        enddo
      end