! Copyright (c) "2012, Alexandr Fonari
!                URL: https://github.com/alexandr-fonari/emc
!                License: MIT License"

program emc_calc ! version 1.0
use emc_functions
implicit none
real(kind=8), parameter :: b2a = 0.52917721092d0
real(kind=8), parameter :: pi = 4.d0*DATAN(1.d0)
real(kind=8), parameter :: ev2h = 1.d0/27.21138505d0
integer(kind=4), parameter :: nkpoints = 61
integer(kind=4), parameter :: iunt = 10, ilog = 11
character(len=8), parameter :: version_number = '1.5f'

real(kind=8) :: get_next_eigeval, get_2nd_deriv, get_mixed_deriv1
real(kind=8) :: f(3,3), g(3,3), ev(3,3), v(3), len
real(kind=8) :: E(-2:2,-2:2,-2:2), m(3,3), b(3), WORK(100)
real(kind=8) :: kp(3), dk
integer i, i1, j, j1, ok
integer(kind=4) :: itrash, count, nbands, band, A(4)
character(len=1) :: prg
external :: DSYEV

open(unit=ilog,file='emc_calc.log',form='formatted')
write(ilog,*) "Effective Mass Calculator calculator ", version_number
call print_time(ilog)
write(ilog,*)

! read input ########################################################

open(unit=iunt,file='inp',form='formatted')
    read(iunt,fmt=*) (kp(j),j=1,3)
    read(iunt,fmt=*) dk
    read(iunt,fmt=*) band
    read(iunt,fmt=*) prg
    read(iunt,*) ((f(i,j),j=1,3),i=1,3)
close(iunt)

if(prg .eq. 'C') then
    write(ilog,*) "It is Crystal - setting band to 1"
    band=1
end if

! g = inverse(transpose(f)), will do it in two steps
g=f
g=transpose(g)
call inverse(g, 3)
g=g*2.d0*pi

write(ilog,*) "direct lattice vectors              reciprocal lattice vectors"
do i=1,3
    write(ilog,"(3F10.6,A,3F10.6)") , (f(i,j), j=1,3), "     ", (g(i,j), j=1,3)
end do
write(ilog,*)

! read EIGENVAL ###########################################

open(unit=iunt,file='EIGENVAL',form='formatted')

read(iunt,fmt=*)
read(iunt,fmt=*)
read(iunt,fmt=*)
read(iunt,fmt=*)
read(iunt,fmt=*)
read(iunt,fmt=*) itrash, itrash, nbands

write(ilog,"(A,2I5,F10.6)") "nbands, band, dk: ", nbands, band, dk
write(ilog,"(A,3F10.6)") "k-point in reciprocal space:", (kp(j), j=1,3)
write(ilog,*)

E(0,0,0) = get_next_eigeval(iunt, band, nbands)

! http://stackoverflow.com/questions/9791001/loop-in-fortran-from-a-list
A = (/ -2, -1, 1, 2 /)
! x
do i = 1, size(A)
    i1 = A(i)
    E(i1,0,0) = get_next_eigeval(iunt, band, nbands)
end do

! y
do i = 1, size(A)
    i1 = A(i)
    E(0,i1,0) = get_next_eigeval(iunt, band, nbands)
end do

! z
do i = 1, size(A)
    i1 = A(i)
    E(0,0,i1) = get_next_eigeval(iunt, band, nbands)
end do

! xy
do i = 1, size(A)
    i1 = A(i)
    do j=1, size(A)
        j1 = A(j)
        E(j1,i1,0) = get_next_eigeval(iunt, band, nbands)
    end do
end do

! xz
do i = 1, size(A)
    i1 = A(i)
    do j=1, size(A)
        j1 = A(j)
        E(j1,0,i1) = get_next_eigeval(iunt, band, nbands)
    end do
end do

! yz
do i = 1, size(A)
    i1 = A(i)
    do j=1, size(A)
        j1 = A(j)
        E(0,j1,i1) = get_next_eigeval(iunt, band, nbands)
    end do
end do

close(iunt)

E = E*ev2h ! to Hartree, we want to deal with a.u.

!d2N
m(1,1) = get_2nd_deriv(E, dk, 1, 0, 0)
m(2,2) = get_2nd_deriv(E, dk, 0, 1, 0)
m(3,3) = get_2nd_deriv(E, dk, 0, 0, 1)

!dxdN
m(2,1) = get_mixed_deriv1(E, dk, 1, 0)
m(3,1) = get_mixed_deriv1(E, dk, 0, 1)

!dydz
m(3,2) = (-63.0D0*(E(0,1,-2) + E(0,2,-1) + E(0,-2,1) +  E(0,-1,2))&
         &+63.0D0*(E(0,-1,-2)+ E(0,-2,-1)+ E(0,1,2) +   E(0,2,1))&
         &+44.0D0*( E(0,2,-2)+ E(0, -2, 2)-  E(0,-2,-2)- E(0,2,2))&
         &+74.0D0*( E(0,-1,-1)+E(0, 1, 1) -  E(0,1,-1)-E(0,-1,1)))&
         &/(600.0D0*dk**2)

m(1,2) = m(2,1)
m(1,3) = m(3,1)
m(2,3) = m(3,2)

write(ilog,*) "Original matrix:"
write(ilog,"(3F15.8)") ((m(i,j), j=1,3),i=1,3)
write(ilog,*)

! At this point m can be either (a) inverted and diagonalized or (b) diagonalized and eigenvalues inverted.
! The problem with (a) is that the inverse procedure does NOT guarantee symmetric matrix as the result.
! (a):
!   call inverse(m, 3)
!   call DGEEV('N', 'V', 3, m, 3, b, bi, DUMMY, 1, ev, 3, WORK, 12, ok)
!
! (b):
call DSYEV( 'V', 'U', 3, m, 3, b, WORK, size(WORK), ok )
if (ok .eq. 0) then
    write(ilog,*) "Principle effective masses and directions:"
    do i=1,3
        write(ilog,"(A25,F10.3)") "Effective mass:", 1.0D0/b(i)
        write(ilog,"(A25,3F10.6)") "Cartesian coordinate:", (m(j,i), j=1,3)
        v = pureDGESV(f, m(:,i), 'T')
        v = normal(v, size(v))
        write(ilog,"(A25,3F10.3)") "Direct lattice vectors:", (v(j), j=1,3)
        write(ilog,*)
    end do
else
    write (ilog,*) "INFO from DGEEV: ", ok
endif

end program

real(kind=8) function get_2nd_deriv(E, dk, x, y, z)
    implicit none
    integer(kind=4) :: x, y, z
    real(kind=8) :: E(-2:2,-2:2,-2:2), dk

    get_2nd_deriv = (-E(-2*x,-2*y,-2*z) + 16.0D0*E(-1*x,-1*y,-1*z) - 30.0D0*E(0,0,0)&
         &+16.0D0*E(1*x,1*y,1*z) - E(2*x,2*y,2*z))/(12.0D0*dk**2.0D0)
    return
end function

real(kind=8) function get_mixed_deriv1(E, dk, y, z)
    implicit none
    integer(kind=4) :: x, y, z
    real(kind=8) :: E(-2:2,-2:2,-2:2), dk

    get_mixed_deriv1=&
    &(-63.0D0*(E(1,-2*y,-2*z) + E(2,-1*y,-1*z) + E(-2,1*y,1*z) +  E(-1,2*y,2*z))&
     &+63.0D0*(E(-1,-2*y,-2*z)+ E(-2,-1*y,-1*z)+  E(1,2*y,2*z) +   E(2,1*y,1*z))&
     &+44.0D0*( E(2,-2*y,-2*z)+ E(-2, 2*y, 2*z)-  E(-2,-2*y,-2*z)- E(2,2*y,2*z))&
    &+74.0D0*( E(-1,-1*y,-1*z)+E(1, 1*y, 1*z) -  E( 1,-1*y,-1*z)-E(-1,1*y,1*z)))&
    &/(600.0D0*dk**2.0D0)
    return
end function

real(kind=8) function get_next_eigeval(iunt, band, nbands)
    implicit none
    integer(kind=4) :: iunt, band, nbands, j, itrash

    read(iunt,fmt=*)
    read(iunt,fmt=*)
    do j=1,nbands
        if(j == band) then
            read(iunt,fmt=*) itrash, get_next_eigeval
            ! write(*,*) get_next_eigeval
        else
            read(iunt,fmt=*)
        end if
    end do
    return
end function


!
      SUBROUTINE PSCAUCHY_COMPUTE( N,K, ALPHA,A,LDA,DESCA,B,LDB,&
                  BETA, C, LDC, IMROW, IMCOL, WORK )
!
      IMPLICIT NONE
!
!  -- PSMMA Package routine (version 0.1) --
!     This routine is designed for structured DC algorithm. We assume that
!     A is a general matrix and B is a structured matrix with O(N) parameters.
!     Here B is a Cauchy-like matrix, which is defined by SIX vectors, stored in
!     F,D,U,V, and B(i,j) = U(i)*V(j) / (F(i)-D(j)).
!     We assume that every processes has a local copy of matrix B, the generators.
!
!     Written by Shengguo Li, 2020-06-26
!     National University of Defense Technology, Changsha 410073, China.
!
!   =======================================
!
!     .. Scalar Arguments ..
      INTEGER            IMROW, IMCOL, LDA, LDB, LDC
      INTEGER            N, K
      DOUBLE PRECISION   ALPHA, BETA
!     ..
!     .. Array Arguments ..
      INTEGER            DESCA(*)
      DOUBLE PRECISION             :: A( LDA, * ), C( LDC,* )
      DOUBLE PRECISION, INTENT(IN) :: B(LDB,4)
      DOUBLE PRECISION   WORK( * )
!     ..
!
!  Parameters
!  ==========
!
!  M      - (input) INTEGER
!           M specifies the (global) number of rows of the matrix A and
!           of the matrix C.  M >= 0.
!
!  N      - (input) INTEGER
!           N specifies the (global) number of columns of the matrix B
!           and of the matrix C.  N >= 0.
!
!  K      - (input) INTEGER
!           K specifies the (global) number of columns of the matrix A
!           and the (global) number of rows of the matrix B.  K >= 0.
!
!  MB     - (input) INTEGER
!           MB specifies the row block size of the matrix A and of the
!           matrix C.  MB >= 1.
!
!  NB     - (input) INTEGER
!           NB specifies the column block size of the matrix B and of
!           the matrix C.  NB >= 1.
!
!  KB     - (input) INTEGER
!           KB specifies the column block size of the matrix A and the
!           row block size of the matrix B.  KB >= 1.
!
!  ALPHA  - (input) DOUBLE PRECISION
!           ALPHA specifies the scalar alpha.
!
!  A      - (input) DOUBLE PRECISION array of DIMENSION ( LDA, Kq ).
!           The leading Mp by Kq part of the array A must contain the
!           (local) matrix A.  Mp and Kq are local variables  (see de-
!           scription of local parameters).
!
! ICTXT     (input) INTEGER
!            The Process grid CONTEXT
!
!  LDA    - (input) INTEGER
!           The leading dimension of the (local) array A.
!           LDA >= max( 1, Mp ).
!
!  B      - (input) DOUBLE PRECISION array of DIMENSION ( LDB, NCB ).
!           The leading N and NCB rows and columns store the generators
!           of the Cauchy-like matrix.
!
!  LDB    - (input) INTEGER
!           The leading dimension of the array B.
!
!  NCB    - (input) INTEGER
!           The number of columns of matrix B. It is Four.
!
!  BETA   - (input) DOUBLE PRECISION
!           BETA  specifies the scalar  beta.  When  BETA  is
!           supplied as zero then C need not be set on input.
!
!  C      - (input/output) DOUBLE PRECISION array of DIMENSION (LDC,Nq)
!           On entry, the leading Mp by Nq part of the array C must
!           contain the (local) matrix C except when  beta  is zero,
!           in which case C need not be set on entry.  Mp and Nq are
!           local variables (see description of local parameters).
!           On exit, the array C is overwritten by the Mp by Nq matrix
!           ( alpha*A*B + beta*C ).
!
!  LDC    - (input) INTEGER
!           The leading dimension of the (local) array C.
!           LDC >= max( 1, Mp ).
!
!  IMROW  - (input) INTEGER
!           IMROW specifies a row of the process template, which holds
!           the first block of the matrices.  0 <= IMROW < NPROW.
!
!  IMCOL  - (input) INTEGER
!           IMCOL specifies a column of the process template, which
!           holds the first block of the matrices.  0 <= IMCOL < NPCOL.
!
!  WORK   - (workspace) DOUBLE PRECISION array
!           See requirements.
!
!  IWORK  - (workspace) INTEGER array
!           See requirements.
!
!  Local  Parameters
!  =================
!
!     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_, &
                         MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,  &
                         CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,   &
                         RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ONE,           ZERO
      PARAMETER          ( ONE  = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER              INFO, IPA, IPB, ICTXT
      INTEGER              K1, KAQ, KBP, Rk, KP, NB, KB
      INTEGER              MP, MRCOL, MRROW, MYCOL, MYROW, LengthC
      INTEGER              NPCOL, NPROW, NROLL, NQ, ierr, LengthR, &
                           IPDW, IPB2
      DOUBLE PRECISION     TBETA
      LOGICAL              islowrank
!     ..
!     .. Local Arrays ..
      INTEGER, ALLOCATABLE :: RIndex(:), CIndex(:)
!     Record the Row and Column indexes of generators
!     ..
!     .. External Subroutines ..
      EXTERNAL             PXERBLA, DGEMM, is_intersect
      EXTERNAL             BLACS_GRIDINFO, DGESD2D, DGERV2D
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC            MAX, MOD
!     ..
!     .. External Functions ..
      INTEGER, EXTERNAL    :: NUMROC
!     ..
!     ..
!     .. Executable Statements ..
!
!     Get grid parameters
!
      ICTXT = DESCA( CTXT_ )
      ! We assume MB == NB
      NB = DESCA( NB_ )
      KB = NB

      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )

!     Test for the input parameters.
!
      INFO = 0
      IF( N  .LT. 0                      ) THEN
         INFO = 2
      ELSE IF( K  .LT. 0                      ) THEN
         INFO = 3
      ELSE IF( NB .LT. 1                      ) THEN
         INFO = 5
      ELSE IF( KB .LT. 1                      ) THEN
         INFO = 6
      ELSE IF( LDA.LT. 1                      ) THEN
         INFO = 9
      ELSE IF( LDC.LT. 1                      ) THEN
         INFO = 14
      ELSE IF( IMROW.LT.0 .OR. IMROW.GE.NPROW ) THEN
         INFO = 15
      ELSE IF( IMCOL.LT.0 .OR. IMCOL.GE.NPCOL ) THEN
         INFO = 16
      END IF
!
   10 CONTINUE
      IF( INFO .NE. 0 ) THEN
          CALL PXERBLA( ICTXT, 'PSCAUCHY_COMPUTE ', INFO )
          RETURN
      END IF
!
      MRROW = MOD( NPROW+MYROW-IMROW, NPROW )
      MRCOL = MOD( NPCOL+MYCOL-IMCOL, NPCOL )
!
      ! ********* For some process, MP and NQ can be ZERO. *******
      MP = NUMROC( N, NB, MRROW, 0, NPROW )
      NQ = NUMROC( K, NB, MRCOL, 0, NPCOL )
      KP = NUMROC( K, KB, MRROW, 0, NPROW )

      IF( MP.EQ.0 ) GOTO 900
!
!     Test for the input parameters again with local parameters
!
      IF(      LDA .LT. MP ) THEN
         INFO = 9
      ELSE IF( LDC .LT. MP ) THEN
         INFO = 14
      END IF
      IF( INFO .NE. 0 ) GO TO 10
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR. &
        ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
      TBETA  = BETA
      KAQ    = NUMROC( K, KB, MRCOL, 0, NPCOL )
!     Note that KAQ == NQ.
!
!     Compute pointer addresses for buffer
!
      IPA = 1
      IPB = IPA +  MP*NQ
      IPDW = IPB + (NQ+NB)*NQ  ! only for without low-rank
!
!     Copy all blocks of A to WORK(IPA) with column block presorting
!
!      ===================================
      CALL DLACPY( 'A', MP, NQ, A, LDA, WORK(IPA), MP  )

!     Allocate the Row and Column index of generators
      ALLOCATE( RIndex(NQ+NB), CIndex(NQ),stat=ierr )
      IF( ierr .ne. 0 ) THEN
            WRITE(*,*) 'Allocation failed in pdmnnbeig, and return'
            RETURN
      END IF
!
      CALL ConstIndex( K,NB, MRCOL,NPCOL,CIndex,LengthC )
!
!     Main Multiplication Routine
!
      DO 40 K1 = 0, NPCOL-1
!
         NROLL = MOD( MRCOL+K1,NPCOL )
         CALL ConstIndex( K,KB,NROLL,NPCOL,RIndex,LengthR )
         KBP = LengthR
!
         IF( LengthC.EQ.0 .OR. LengthR.EQ. 0) GOTO 80
!
         call is_intersect( LengthC,CIndex,LengthR,RIndex,islowrank )
!         islowrank=.false.
!
         IF ( islowrank ) THEN
            CALL ConstCauchylowrank( KBP,NQ,B,LDB,WORK(IPB),RIndex,CIndex,Rk )
!
             IF( Rk == MIN(KBP,NQ) ) THEN
                  CALL DGEMM( 'N', 'N', MP, NQ, KBP,ALPHA,WORK(IPA), &
                    MAX(1,MP),WORK(IPB),MAX(1,KBP),TBETA, C,LDC )
             ELSE
                  CALL DGEMM( 'N','N',MP,Rk,KBP,ONE,WORK(IPA),MAX(1,MP), &
                        WORK(IPB),KBP,ZERO,WORK(IPDW),MP  )
!                 MP == KBP
                  IPB2 = IPB+KBP*Rk
                   CALL DGEMM( 'N','N',MP,NQ,Rk,ALPHA,WORK(IPDW),MP,WORK(IPB2),&
                        Rk, TBETA, C, LDC )
             END IF
             TBETA = ONE
!
         ELSE
            ! Construct full local submatrix B
            CALL ConstCauchy( KBP,NQ,B,LDB,WORK(IPB),RIndex,CIndex )

             CALL DGEMM( 'N', 'N', MP, NQ, KBP,ALPHA,WORK(IPA), &
                    MAX(1,MP),WORK(IPB),MAX(1,KBP),TBETA, C,LDC )
             TBETA = ONE
!
         END IF

!        Shift A (WORK(IPA)) to the left
!
   80    IF( K1.LT.NPCOL-1 ) THEN
!
!            Rotate A (WORK(IPA))
!
             CALL DGESD2D( ICTXT, MP, KAQ, WORK(IPA), MP, MYROW, &
                           MOD(NPCOL+MYCOL-1, NPCOL) )
             KAQ = NUMROC( K, KB, MRCOL+K1+1, 0, NPCOL )
             CALL DGERV2D( ICTXT, MP, KAQ, WORK(IPA), MP, MYROW, &
                           MOD(MYCOL+1, NPCOL) )
         END IF
   40 CONTINUE

       DEALLOCATE(RIndex, CIndex)
!
  900  CONTINUE

      RETURN
!
!     End of PSCAUCHY_COMPUTE
!
      END SUBROUTINE PSCAUCHY_COMPUTE


  CASE(5) !NEMO depths from e3t=T-cell thickness
           usv=bathy(ele,1:4) !ISSUE!!!!
            mus= MAXVAL(usv)

        do b=1,mus
	    E30 = getInterp("E3T0e",b) !NEMO
 	    E30w = getInterp("E3W0e",b)
 	    E3T(b) = E30*(1.0 + zeta/h)
            E3W(b) = E30w*( 1.0 + zeta/h )
	enddo

            dept(1)=0.5*E3W(1)
            depw(1)=0.0

           do a=2,mus
              dept(a) = dept(a-1) + E3W(a)
              depw(a) = depw(a-1) + E3T(a-1)
	   enddo
	do a=1,mus !Flip over NEMO
        fdepw(a)=depw((mus+1)-a)
	enddo

        getWlevel = DBLE(-1.0) * fdepw(i)


SUBROUTINE eq3_tsinghua(upstream)

! Code converted using TO_F90 by Alan Miller
! Date: 2005-08-23  Time: 12:57:31

use common_h
use time_h
use reservoir_h

IMPLICIT NONE

INTEGER, INTENT(IN OUT)                  :: upstream
INTEGER :: j,g,factor_sed !i,h,id,ih,irout,imun,dummy1,
!real:: dummy2

real :: wat_dens,sed_dens
real :: visc

!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
REAL :: tempres(step,upstream)

real :: discharge(200),depth(200),hydrad(200),energslope(200)
real :: manning(200),topwidth(200),meanvel(200)

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

do j=1,nbrsec(res_index(upstream))
  if (j /= nbrsec(res_index(upstream))) then
    discharge(j)=(discharge_sec(j,res_index(upstream))+discharge_sec(j+1,res_index(upstream)))/2.
    depth(j)=(depth_sec(j,res_index(upstream))+depth_sec(j+1,res_index(upstream)))/2.
    hydrad(j)=(hydrad_sec(j,res_index(upstream))+hydrad_sec(j+1,res_index(upstream)))/2.
    energslope(j)=(energslope_sec(j,res_index(upstream))+energslope_sec(j+1,res_index(upstream)))/2.
    manning(j)=(manning_sec(j,res_index(upstream))+manning_sec(j+1,res_index(upstream)))/2.
    topwidth(j)=(topwidth_sec(j,res_index(upstream))+topwidth_sec(j+1,res_index(upstream)))/2.
    meanvel(j)=(meanvel_sec(j,res_index(upstream))+meanvel_sec(j+1,res_index(upstream)))/2.
  else
    discharge(j)=discharge_sec(j,res_index(upstream))
    depth(j)=depth_sec(j,res_index(upstream))
    hydrad(j)=hydrad_sec(j,res_index(upstream))
    energslope(j)=energslope_sec(j,res_index(upstream))
    manning(j)=manning_sec(j,res_index(upstream))
    topwidth(j)=topwidth_sec(j,res_index(upstream))
    meanvel(j)=meanvel_sec(j,res_index(upstream))
  endif
enddo

! TOTAL LOAD FORMULA

! loop to calculate the sediment carrying capacity
DO j=1,nbrsec(res_index(upstream))

  if (discharge(j) /= 0.) then
    DO g=1,n_sed_class
      if(diam(g)*1000.<=0.01) factor_sed=1600
      if(diam(g)*1000.>0.01 .and. diam(g)*1000.<=0.1) factor_sed=650
      if(diam(g)*1000.>0.1  .and. diam(g)*1000.<=2.)  factor_sed=300
      if(diam(g)*1000.>2.) factor_sed=180
	enddo

! total suspended sediment transport (m3/day)
    DO g=1,n_sed_class
      fr_capacity(g,j)=factor_sed*(discharge(j)**1.6)*(energslope(j)**1.2)/(topwidth(j)*.6)
      fr_capacity(g,j)=fr_capacity(g,j)*86400./1.65
    END DO

  else
    DO g=1,n_sed_class
      fr_capacity(g,j)=0.
	enddo
  endif

! Gravitacional acceleration (m/s2)
! 9.807

! density of water and density of natural sediments (kg/m3)
  wat_dens=1.*1000.
  sed_dens=2.65*1000.

!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
  tempres(step,upstream)=20.

! kinematic viscosity (m2/s)
  visc=(1.14-0.031*(tempres(step,upstream)-15.)+  &
      0.00068*((tempres(step,upstream)-15.)**2.))*1.e-6

! loop to calculate the sediment carrying capacity for suspended load
  DO g=1,n_sed_class

! settling velocity (m/s)
    setvel(g)=SQRT((13.95*visc/diam(g))**2.+1.09*  &
        ((sed_dens-wat_dens)/wat_dens)*9.807*diam(g))-13.95*visc/diam(g)
  enddo

  DO g=1,n_sed_class
!write(*,'(3I4,3F20.5)')d,j,g,fr_capacity(g,j),susp_frtransp(g,j),bed_frtransp(g,j)
  END DO

!if (d==54)read(*,*)
END DO

RETURN
END SUBROUTINE eq3_tsinghua


! Module for matrix multiplication (absolutely crucial for APOS speed).
! Includes routines for orthogonalization, computing the SVD, and
! radializing data matrices with the SVD.
MODULE MATRIX_OPERATIONS
  USE ISO_FORTRAN_ENV, ONLY: RT => REAL32
  IMPLICIT NONE

CONTAINS

  ! Convenience wrapper routine for calling matrix multiply.
  SUBROUTINE GEMM(OP_A, OP_B, OUT_ROWS, OUT_COLS, INNER_DIM, &
       AB_MULT, A, A_ROWS, B, B_ROWS, C_MULT, C, C_ROWS)
    CHARACTER, INTENT(IN) :: OP_A, OP_B
    INTEGER, INTENT(IN) :: OUT_ROWS, OUT_COLS, INNER_DIM, A_ROWS, B_ROWS, C_ROWS
    REAL(KIND=RT), INTENT(IN) :: AB_MULT, C_MULT
    REAL(KIND=RT), INTENT(IN), DIMENSION(:,:) :: A
    REAL(KIND=RT), INTENT(IN), DIMENSION(:,:) :: B
    REAL(KIND=RT), INTENT(OUT), DIMENSION(:,:) :: C
    ! Call external single-precision matrix-matrix multiplication
    !  (should be provided by hardware manufacturer, if not use custom).
    EXTERNAL :: SGEMM
    CALL SGEMM(OP_A, OP_B, OUT_ROWS, OUT_COLS, INNER_DIM, &
       AB_MULT, A, A_ROWS, B, B_ROWS, C_MULT, C, C_ROWS)
    ! ! Fortran intrinsic version of general matrix multiplication routine,
    ! !   first compute the initial values in the output matrix,
    ! C(:,:) = C_MULT * C(:)
    ! !   then compute the matrix multiplication.
    ! IF (OP_A .EQ. 'N') THEN
    !    IF (OP_B .EQ. 'N') THEN
    !       C(:,:) = C(:,:) + AB_MULT * MATMUL(A(:,:), B(:,:))
    !    ELSE
    !       C(:,:) = C(:,:) + AB_MULT * MATMUL(A(:,:), TRANSPOSE(B(:,:)))
    !    END IF
    ! ELSE
    !    IF (OP_B .EQ. 'N') THEN
    !       C(:,:) = C(:,:) + AB_MULT * MATMUL(TRANSPOSE(A(:,:)), B(:,:))
    !    ELSE
    !       C(:,:) = C(:,:) + AB_MULT * MATMUL(TRANSPOSE(A(:,:)), TRANSPOSE(B(:,:)))
    !    END IF
    ! END IF
  END SUBROUTINE GEMM

  ! Generate randomly distributed vectors on the N-sphere.
  SUBROUTINE RANDOM_UNIT_VECTORS(COLUMN_VECTORS)
    REAL(KIND=RT), INTENT(OUT), DIMENSION(:,:) :: COLUMN_VECTORS
    ! Local variables.
    REAL(KIND=RT), DIMENSION(SIZE(COLUMN_VECTORS,1), SIZE(COLUMN_VECTORS,2)) :: TEMP_VECS
    REAL(KIND=RT), PARAMETER :: PI = 3.141592653589793
    REAL(KIND=RT) :: LEN
    INTEGER :: I, J, K
    ! Skip empty vector sets.
    IF (SIZE(COLUMN_VECTORS) .LE. 0) RETURN
    ! Generate random numbers in the range [0,1].
    CALL RANDOM_NUMBER(COLUMN_VECTORS(:,:))
    CALL RANDOM_NUMBER(TEMP_VECS(:,:))
    ! Map the random uniform numbers to a radial distribution.
    COLUMN_VECTORS(:,:) = SQRT(-LOG(COLUMN_VECTORS(:,:))) * COS(PI * TEMP_VECS(:,:))
    ! Orthogonalize the vectors in (random) order.
    IF (SIZE(COLUMN_VECTORS,1) .GT. 1) THEN
       ! Compute the last vector that is part of the orthogonalization.
       K = MIN(SIZE(COLUMN_VECTORS,1), SIZE(COLUMN_VECTORS,2))
       ! Orthogonalize the "lazy way" without column pivoting.
       ! Could result in imperfectly orthogonal vectors (because of
       ! rounding errors being enlarged by upscaling), that is acceptable.
       DO I = 1, K-1
          LEN = NORM2(COLUMN_VECTORS(:,I))
          IF (LEN .GT. 0.0_RT) THEN
             ! Make this column unit length.
             COLUMN_VECTORS(:,I) = COLUMN_VECTORS(:,I) / LEN
             ! Compute multipliers (store in row of TEMP_VECS) and subtract
             ! from all remaining columns (doing the orthogonalization).
             TEMP_VECS(1,I+1:K) = MATMUL(COLUMN_VECTORS(:,I), COLUMN_VECTORS(:,I+1:K))
             DO J = I+1, K
                COLUMN_VECTORS(:,J) = COLUMN_VECTORS(:,J) - TEMP_VECS(1,J) * COLUMN_VECTORS(:,I)
             END DO
          ELSE
             ! This should not happen (unless the vectors are at least in the
             !   tens of thousands, in which case a different method should be used).
             PRINT *, 'ERROR: Random unit vector failed to initialize correctly, rank deficient.'
          END IF
       END DO
       ! Make the rest of the column vectors unit length.
       DO I = K, SIZE(COLUMN_VECTORS,2)
          LEN = NORM2(COLUMN_VECTORS(:,I))
          IF (LEN .GT. 0.0_RT)  COLUMN_VECTORS(:,I) = COLUMN_VECTORS(:,I) / LEN
       END DO
    END IF
  END SUBROUTINE RANDOM_UNIT_VECTORS

  ! Orthogonalize and normalize column vectors of A with pivoting.
  SUBROUTINE ORTHOGONALIZE(A, LENGTHS, RANK, ORDER)
    REAL(KIND=RT), INTENT(INOUT), DIMENSION(:,:) :: A
    REAL(KIND=RT), INTENT(OUT), DIMENSION(:) :: LENGTHS ! SIZE(A,2)
    INTEGER, INTENT(OUT), OPTIONAL :: RANK
    INTEGER, INTENT(OUT), DIMENSION(:), OPTIONAL :: ORDER ! SIZE(A,2)
    REAL(KIND=RT) :: L, V
    INTEGER :: I, J, K
    IF (PRESENT(RANK)) RANK = 0
    IF (PRESENT(ORDER)) THEN
       FORALL (I=1:SIZE(A,2)) ORDER(I) = I
    END IF
    column_orthogonolization : DO I = 1, SIZE(A,2)
       LENGTHS(I:) = SUM(A(:,I:)**2, 1)
       ! Pivot the largest magnitude vector to the front.
       J = I-1+MAXLOC(LENGTHS(I:),1)
       IF (J .NE. I) THEN
          IF (PRESENT(ORDER)) THEN
             K = ORDER(I)
             ORDER(I) = ORDER(J)
             ORDER(J) = K
          END IF
          L = LENGTHS(I)
          LENGTHS(I) = LENGTHS(J)
          LENGTHS(J) = L
          ! Perform the pivot.
          DO K = 1, SIZE(A,1)
             V = A(K,I)
             A(K,I) = A(K,J)
             A(K,J) = V
          END DO
       END IF
       ! Subtract the first vector from all others.
       IF (LENGTHS(I) .GT. EPSILON(1.0_RT)) THEN
          LENGTHS(I) = SQRT(LENGTHS(I))
          A(:,I) = A(:,I) / LENGTHS(I)
          IF (I .LT. SIZE(A,2)) THEN
             LENGTHS(I+1:) = MATMUL(A(:,I), A(:,I+1:))
             DO J = I+1, SIZE(A,2)
                A(:,J) = A(:,J) - LENGTHS(J) * A(:,I)
             END DO
          END IF
          IF (PRESENT(RANK)) RANK = RANK + 1
       ELSE
          LENGTHS(I:) = 0.0_RT
          EXIT column_orthogonolization
       END IF
    END DO column_orthogonolization
  END SUBROUTINE ORTHOGONALIZE

  ! Compute the singular values and right singular vectors for matrix A.
  SUBROUTINE SVD(A, S, VT, RANK, STEPS, BIAS)
    IMPLICIT NONE
    REAL(KIND=RT), INTENT(IN), DIMENSION(:,:) :: A
    REAL(KIND=RT), INTENT(OUT), DIMENSION(:) :: S ! MIN(SIZE(A,1),SIZE(A,2))
    REAL(KIND=RT), INTENT(OUT), DIMENSION(:,:) :: VT ! MIN(SIZE(A,1),SIZE(A,2)), MIN(SIZE(A,1),SIZE(A,2))
    INTEGER, INTENT(OUT), OPTIONAL :: RANK
    INTEGER, INTENT(IN), OPTIONAL :: STEPS
    REAL(KIND=RT), INTENT(IN), OPTIONAL :: BIAS
    ! Local variables.
    REAL(KIND=RT), DIMENSION(MIN(SIZE(A,1),SIZE(A,2)),MIN(SIZE(A,1),SIZE(A,2))) :: ATA, Q
    INTEGER :: I, J, K, NUM_STEPS
    REAL(KIND=RT) :: MULTIPLIER
    EXTERNAL :: SSYRK
    ! Set the number of steps.
    IF (PRESENT(STEPS)) THEN
       NUM_STEPS = STEPS
    ELSE
       NUM_STEPS = 1
    END IF
    ! Set "K" (the number of components).
    K = MIN(SIZE(A,1),SIZE(A,2))
    ! Find the multiplier on A.
    MULTIPLIER = MAXVAL(ABS(A(:,:)))
    IF (MULTIPLIER .EQ. 0.0_RT) THEN
       S(:) = 0.0_RT
       VT(:,:) = 0.0_RT
       RETURN
    END IF
    IF (PRESENT(BIAS)) MULTIPLIER = MULTIPLIER / BIAS
    MULTIPLIER = 1.0_RT / MULTIPLIER
    ! Compute ATA.
    IF (SIZE(A,1) .LE. SIZE(A,2)) THEN
       ! ATA(:,:) = MATMUL(AT(:,:), TRANSPOSE(AT(:,:)))
       CALL SSYRK('U', 'N', K, SIZE(A,2), MULTIPLIER**2, A(:,:), &
            SIZE(A,1), 0.0_RT, ATA(:,:), K)
    ELSE
       ! ATA(:,:) = MATMUL(TRANSPOSE(A(:,:)), A(:,:))
       CALL SSYRK('U', 'T', K, SIZE(A,1), MULTIPLIER**2, A(:,:), &
            SIZE(A,1), 0.0_RT, ATA(:,:), K)
    END IF
    ! Copy the upper diagnoal portion into the lower diagonal portion.
    DO I = 1, K
       ATA(I+1:,I) = ATA(I,I+1:)
    END DO
    ! Compute initial right singular vectors.
    VT(1:SIZE(ATA,1),1:SIZE(ATA,2)) = ATA(:,:)
    ! Fill remaining columns (if extra were provided) with zeros.
    IF ((SIZE(VT,1) .GT. SIZE(ATA,1)) .OR. (SIZE(VT,2) .GT. SIZE(ATA,2))) THEN
       VT(SIZE(ATA,1)+1:,SIZE(ATA,2)+1:) = 0.0_RT
    END IF
    ! Orthogonalize and reorder by magnitudes.
    CALL ORTHOGONALIZE(VT(:,:), S(:), RANK)
    ! Do power iterations.
    power_iteration : DO I = 1, NUM_STEPS
       Q(:,:) = VT(1:SIZE(Q,1),1:SIZE(Q,2))
       ! Q(:,:) = MATMUL(TRANSPOSE(ATA(:,:)), QTEMP(:,:))
       CALL GEMM('N', 'N', K, K, K, 1.0_RT, &
            ATA(:,:), K, Q(:,:), K, 0.0_RT, &
            VT(:,:), K)
       CALL ORTHOGONALIZE(VT(:,:), S(:), RANK)
    END DO power_iteration
    ! Compute the singular values.
    WHERE (S(:) .NE. 0.0_RT)
       S(:) = SQRT(S(:)) / MULTIPLIER
    END WHERE
  END SUBROUTINE SVD

  ! If there are at least as many data points as dimension, then
  ! compute the principal components and rescale the data by
  ! projecting onto those and rescaling so that each component has
  ! identical singular values (this makes the data more "radially
  ! symmetric").
  SUBROUTINE RADIALIZE(X, SHIFT, VECS, INVERT_RESULT, FLATTEN, STEPS)
    REAL(KIND=RT), INTENT(INOUT), DIMENSION(:,:) :: X
    REAL(KIND=RT), INTENT(OUT), DIMENSION(:) :: SHIFT
    REAL(KIND=RT), INTENT(OUT), DIMENSION(:,:) :: VECS
    LOGICAL, INTENT(IN), OPTIONAL :: INVERT_RESULT
    LOGICAL, INTENT(IN), OPTIONAL :: FLATTEN
    INTEGER, INTENT(IN), OPTIONAL :: STEPS
    ! Local variables.
    LOGICAL :: INVERSE, FLAT
    REAL(KIND=RT), DIMENSION(SIZE(VECS,1),SIZE(VECS,2)) :: TEMP_VECS
    REAL(KIND=RT), DIMENSION(SIZE(X,1)) :: VALS
    REAL(KIND=RT), DIMENSION(SIZE(X,1), SIZE(X,2)) :: X1
    REAL(KIND=RT) :: RN
    INTEGER :: I, D
    ! Set the default value for "INVERSE".
    IF (PRESENT(INVERT_RESULT)) THEN
       INVERSE = INVERT_RESULT
    ELSE
       INVERSE = .FALSE.
    END IF
    ! Set the default value for "FLAT".
    IF (PRESENT(FLATTEN)) THEN
       FLAT = FLATTEN
    ELSE
       FLAT = .TRUE.
    END IF
    ! Shift the data to be be centered about the origin.
    D = SIZE(X,1)
    RN = REAL(SIZE(X,2),RT)
    SHIFT(:) = -SUM(X(:,:),2) / RN
    DO I = 1, D
       X(I,:) = X(I,:) + SHIFT(I)
    END DO
    ! Set the unused portion of the "VECS" matrix to the identity.
    VECS(D+1:,D+1:) = 0.0_RT
    DO I = D+1, SIZE(VECS,1)
       VECS(I,I) = 1.0_RT
    END DO
    ! Find the directions along which the data is most elongated.
    IF (PRESENT(STEPS)) THEN
       CALL SVD(X, VALS, VECS(:D,:D), STEPS=STEPS)
    ELSE
       CALL SVD(X, VALS, VECS(:D,:D), STEPS=10)
    END IF
    ! Normalize the values to make the output componentwise unit mean squared magnitude.
    IF (FLAT) THEN
       VALS(:) = VALS(:) / SQRT(RN)
       ! For all nonzero vectors, rescale them so that the
       !  average squared distance from zero is exactly 1.
       DO I = 1, D
          IF (VALS(I) .GT. 0.0_RT) THEN
             VECS(:,I) = VECS(:,I) / VALS(I)
          END IF
       END DO
    ELSE
       ! Rescale all vectors by the average magnitude.
       VALS(:) = SUM(VALS(:)) / (SQRT(RN) * REAL(D,RT))
       IF (VALS(1) .GT. 0.0_RT) THEN
          VECS(:,:) = VECS(:,:) / VALS(1)
       END IF
    END IF
    ! Apply the column vectors to the data to make it radially symmetric.
    X1(:,:) = X(:,:)
    CALL GEMM('T', 'N', D, SIZE(X,2), D, 1.0_RT, &
         VECS(:D,:D), D, &
         X1(:,:), D, &
         0.0_RT, X(:,:), D)
    ! Compute the inverse of the transformation if requested.
    IF (INVERSE) THEN
       VALS(:) = VALS(:)**2
       DO I = 1, D
          IF (VALS(I) .GT. 0.0_RT) THEN
             VECS(:D,I) = VECS(:D,I) * VALS(I)
          END IF
       END DO
       VECS(:D,:D) = TRANSPOSE(VECS(:D,:D))
       SHIFT(:) = -SHIFT(:)
    END IF
  END SUBROUTINE RADIALIZE

  ! Perform least squares with LAPACK.
  !
  !   A is column vectors (of points) if TRANS='T', and row vectors
  !     (of points) if TRANS='N'.
  !   B must be COLUMN VECTORS of fit output (1 row = 1 point).
  !   X always has a first dimension that is nonpoint axis size of A,
  !     and the second dimension is determined by B's columns (or rank),
  !     or (if smaller), then B is reduced to its principal components.
  SUBROUTINE LEAST_SQUARES(TRANS, A, B, X)
    REAL(KIND=RT), INTENT(INOUT), DIMENSION(:,:) :: A, B
    CHARACTER, INTENT(IN) :: TRANS
    REAL(KIND=RT), INTENT(OUT), DIMENSION(:,:) :: X ! MIN(SIZE(A,1),SIZE(A,2)),SIZE(B,2)
    ! Local variables.
    INTEGER :: M, N, R, NRHS, LDA, LDB, LWORK, INFO
    REAL(KIND=RT), DIMENSION(:), ALLOCATABLE :: WORK
    REAL(KIND=RT), DIMENSION(:,:), ALLOCATABLE :: PROJECTION
    EXTERNAL :: SGELS
    ! Reduce the rank of B to the desired size, if appropriate.
    IF (SIZE(X,2) .LT. SIZE(B,2)) THEN
       NRHS = MIN(SIZE(B,1), SIZE(B,2))
       ALLOCATE( WORK(NRHS), PROJECTION(NRHS,NRHS) )
       ! Compute the SVD to use as the projection.
       CALL SVD(B, WORK, PROJECTION, RANK=NRHS, STEPS=10)
       ! Project B down (and zero out the remaining columns).
       NRHS = MIN(NRHS, SIZE(X,2))
       B(:,:NRHS) = MATMUL(B(:,:), PROJECTION(:,:NRHS))
       IF (SIZE(B,2) .GT. NRHS) B(:,NRHS+1:) = 0.0_RT
       DEALLOCATE(PROJECTION, WORK)
    END IF
    ! Set variables for calling least squares routine.
    M = SIZE(A,1)
    N = SIZE(A,2)
    NRHS = R
    LDA = SIZE(A,1)
    LDB = SIZE(B,1)
    ! Allocate the work space for the call.
    LWORK = MAX(1, MIN(M,N) + MAX(MIN(M,N), NRHS))
    ALLOCATE(WORK(LWORK))
    ! Make the call to the least squares routine.
    CALL SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )
    ! Store the result.
    IF (SIZE(X,2) .LE. SIZE(B,2)) THEN
       X(:,:) = B(:SIZE(X,1),:SIZE(X,2))
    ELSE
       X(:,:SIZE(B,2)) = B(:SIZE(X,1),:SIZE(B,2))
    END IF
  END SUBROUTINE LEAST_SQUARES

END MODULE MATRIX_OPERATIONS


SUBROUTINE UMAT(STRESS, STATEV, DDSDDE, SSE, SPD, SCD, RPL, &
     DDSDDT, DRPLDE, DRPLDT, STRAN, DSTRAN, TIME, DTIME, TEMP, DTEMP, &
     PREDEF, DPRED, CMNAME, NDI, NSHR, NTENS, NSTATV, PROPS, NPROPS, &
     COORDS, DROT, PNEWDT, CELENT, DFGRD0, DFGRD1, NOEL, NPT, LAYER, &
     KSPT, KSTEP, KINC)

  IMPLICIT NONE
  REAL(8), PARAMETER :: ZERO=0.E+00_8, ONE=1.E+00_8, TWO=2.E+00_8
  REAL(8), PARAMETER :: THREE=3.E+00_8, SIX=6.E+00_8
  CHARACTER*8, INTENT(IN) :: CMNAME
  INTEGER, INTENT(IN) :: NDI, NSHR, NTENS, NSTATV, NPROPS
  INTEGER, INTENT(IN) :: NOEL, NPT, LAYER, KSPT, KSTEP, KINC
  REAL(8), INTENT(IN) :: SSE, SPD, SCD, RPL, DRPLDT, TIME, DTIME, TEMP, DTEMP
  REAL(8), INTENT(IN) :: PNEWDT, CELENT
  REAL(8), INTENT(INOUT) :: STRESS(NTENS), STATEV(NSTATV), DDSDDE(NTENS, NTENS)
  REAL(8), INTENT(INOUT) :: DDSDDT(NTENS), DRPLDE(NTENS)
  REAL(8), INTENT(IN) :: STRAN(NTENS), DSTRAN(NTENS)
  REAL(8), INTENT(IN) :: PREDEF(1), DPRED(1), PROPS(NPROPS), COORDS(3)
  REAL(8), INTENT(IN) :: DROT(3, 3), DFGRD0(3, 3), DFGRD1(3, 3)

  ! LOCAL ARRAYS
  ! EELAS - ELASTIC STRAINS
  ! ETHERM - THERMAL STRAINS
  ! DTHERM - INCREMENTAL THERMAL STRAINS
  ! DELDSE - CHANGE IN STIFFNESS DUE TO TEMPERATURE CHANGE
  INTEGER :: K1, K2
  REAL(8) :: EELAS(6), ETHERM(6), DTHERM(6), DELDSE(6,6), ENU
  REAL(8) :: FAC0, FAC1, EBULK3, EG, EG0, EG2, EG20, ELAM, ELAM0, EMOD
  CHARACTER*120 :: MSG
  CHARACTER*8 :: CHARV(1)
  INTEGER :: INTV(1)
  REAL(8) :: REALV(1)

  IF (NSTATV /= 12) THEN
     MSG = "EXPECTED 12 STATE VARIABLES, GOT %I"
     INTV(1) = NSTATV
     CALL STDB_ABQERR(-3, MSG, INTV, REALV, CHARV)
  END IF

  ! UMAT FOR ISOTROPIC THERMO-ELASTICITY WITH LINEARLY VARYING
  ! MODULI - CANNOT BE USED FOR PLANE STRESS
  ! PROPS(1) - E(T0)
  ! PROPS(2) - NU(T0)
  ! PROPS(3) - T0
  ! PROPS(4) - E(T1)
  ! PROPS(5) - NU(T1)
  ! PROPS(6) - T1
  ! PROPS(7) - ALPHA
  ! PROPS(8) - T_INITIAL

  ! ELASTIC PROPERTIES AT START OF INCREMENT
  FAC1 = (TEMP - PROPS(3)) / (PROPS(6) - PROPS(3))
  IF (FAC1 .LT. ZERO) FAC1 = ZERO
  IF (FAC1 .GT. ONE) FAC1 = ONE
  FAC0 = ONE - FAC1
  EMOD = FAC0 * PROPS(1) + FAC1 * PROPS(4)
  ENU = FAC0 * PROPS(2) + FAC1 * PROPS(5)
  EBULK3 = EMOD / (ONE - TWO * ENU)
  EG20 = EMOD / (ONE + ENU)
  EG0 = EG20 / TWO
  ELAM0 = (EBULK3 - EG20) / THREE

  ! ELASTIC PROPERTIES AT END OF INCREMENT
  FAC1 = (TEMP + DTEMP - PROPS(3)) / (PROPS(6) - PROPS(3))
  IF (FAC1 .LT. ZERO) FAC1 = ZERO
  IF (FAC1 .GT. ONE) FAC1 = ONE
  FAC0 = ONE - FAC1
  EMOD = FAC0 * PROPS(1) + FAC1 * PROPS(4)
  ENU = FAC0 * PROPS(2) + FAC1 * PROPS(5)
  EBULK3 = EMOD / (ONE - TWO * ENU)
  EG2 = EMOD / (ONE + ENU)
  EG = EG2 / TWO
  ELAM = (EBULK3 - EG2) / THREE

  ! ELASTIC STIFFNESS AT END OF INCREMENT AND STIFFNESS CHANGE
  DO K1 = 1,NDI
     DO K2 = 1,NDI
        DDSDDE(K2,K1) = ELAM
        DELDSE(K2,K1) = ELAM - ELAM0
     END DO
     DDSDDE(K1,K1) = EG2 + ELAM
     DELDSE(K1,K1) = EG2 + ELAM - EG20 - ELAM0
  END DO
  DO K1 = NDI + 1,NTENS
     DDSDDE(K1,K1) = EG
     DELDSE(K1,K1) = EG - EG0
  END DO

  ! CALCULATE THERMAL EXPANSION
  DO K1 = 1,NDI
     ETHERM(K1) = PROPS(7) * (TEMP - PROPS(8))
     DTHERM(K1) = PROPS(7) * DTEMP
  END DO
  DO K1 = NDI + 1,NTENS
     ETHERM(K1) = ZERO
     DTHERM(K1) = ZERO
  END DO

  ! CALCULATE STRESS, ELASTIC STRAIN AND THERMAL STRAIN
  DO K1 = 1, NTENS
     DO K2 = 1, NTENS
        STRESS(K2) = STRESS(K2) + DDSDDE(K2,K1) * (DSTRAN(K1) - DTHERM(K1)) &
                   + DELDSE(K2,K1) * (STRAN(K1) - ETHERM(K1))
     END DO
     ETHERM(K1) = ETHERM(K1) + DTHERM(K1)
     EELAS(K1) = STRAN(K1) + DSTRAN(K1) - ETHERM(K1)
  END DO

  ! STORE ELASTIC AND THERMAL STRAINS IN STATE VARIABLE ARRAY
  DO K1 = 1, NTENS
     STATEV(K1) = EELAS(K1)
     STATEV(K1 + NTENS) = ETHERM(K1)
  END DO
  RETURN
END SUBROUTINE UMAT


  module X

    implicit none

    contains

      subroutine nsold(omega, ss, uu, ff, lo, ng)

        integer, intent(in)             :: ng, lo(:)
        double precision, intent(in)    :: omega
        double precision, intent(in   ) :: ff(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
        double precision, intent(inout) :: uu(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
        double precision, intent(in)    :: ss(lo(1):, lo(2):, lo(3):, 0:)
        integer                         :: i, j, k, ioff, hi(size(lo))
        double precision                :: dd
        logical                         :: jface, kface, doit

        hi = ubound(ff)

        if ((size(ss,dim=4) .eq. 21) .or. (size(ss,dim=4) .eq. 27)) then

           do k = lo(3),hi(3)
              kface = .false. ; if ( (k.eq.lo(3)) .or. (k.eq.hi(3)) ) kface = .true.

              do j = lo(2),hi(2)
                 jface = .false. ; if ( (j.eq.lo(2)) .or. (j.eq.hi(2)) ) jface = .true.

                 do i = lo(1),hi(1)

                    doit = .true.

                    if ( jface .or. kface .or. (i.eq.lo(1)) .or. (i.eq.hi(1)) ) then
                       doit = .false.
                    end if

                    if (doit) then
                       dd = ss(i,j,k,0)*uu(i,j,k) &
                            + ss(i,j,k, 1) * uu(i-1,j-1,k-1) + ss(i,j,k, 2) * uu(i  ,j-1,k-1) &
                            + ss(i,j,k, 3) * uu(i+1,j-1,k-1) + ss(i,j,k, 4) * uu(i-1,j  ,k-1) &
                            + ss(i,j,k, 5) * uu(i+1,j  ,k-1) + ss(i,j,k, 6) * uu(i-1,j+1,k-1) &
                            + ss(i,j,k, 7) * uu(i  ,j+1,k-1) + ss(i,j,k, 8) * uu(i+1,j+1,k-1) &
                            + ss(i,j,k, 9) * uu(i-1,j-1,k  ) + ss(i,j,k,10) * uu(i+1,j-1,k  ) &
                            + ss(i,j,k,11) * uu(i-1,j+1,k  ) + ss(i,j,k,12) * uu(i+1,j+1,k  ) &
                            + ss(i,j,k,13) * uu(i-1,j-1,k+1) + ss(i,j,k,14) * uu(i  ,j-1,k+1) &
                            + ss(i,j,k,15) * uu(i+1,j-1,k+1) + ss(i,j,k,16) * uu(i-1,j  ,k+1) &
                            + ss(i,j,k,17) * uu(i+1,j  ,k+1) + ss(i,j,k,18) * uu(i-1,j+1,k+1) &
                            + ss(i,j,k,19) * uu(i  ,j+1,k+1) + ss(i,j,k,20) * uu(i+1,j+1,k+1)

                       uu(i,j,k) = uu(i,j,k) + omega/ss(i,j,k,0)*(ff(i,j,k) - dd)
                    end if
                 end do
              end do
           end do
        end if

      end subroutine nsold

      subroutine nsnew(omega, ss, uu, ff, lo, ng)

        integer, intent(in)             :: ng, lo(:)
        double precision, intent(in)    :: omega
        double precision, intent(in   ) :: ff(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
        double precision, intent(inout) :: uu(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
        double precision, intent(in)    :: ss(0:, lo(1):, lo(2):, lo(3):)
        integer                         :: i, j, k, ioff, hi(size(lo))
        double precision                :: dd
        logical                         :: jface, kface, doit

        hi = ubound(ff)

        if ((size(ss,dim=1) .eq. 21) .or. (size(ss,dim=1) .eq. 27)) then

           do k = lo(3),hi(3)
              kface = .false. ; if ( (k.eq.lo(3)) .or. (k.eq.hi(3)) ) kface = .true.

              do j = lo(2),hi(2)
                 jface = .false. ; if ( (j.eq.lo(2)) .or. (j.eq.hi(2)) ) jface = .true.

                 do i = lo(1),hi(1)

                    doit = .true.

                    if ( jface .or. kface .or. (i.eq.lo(1)) .or. (i.eq.hi(1)) ) then
                       doit = .false.
                    end if

                    if (doit) then
                       dd = ss(0,i,j,k)*uu(i,j,k) &
                            + ss(1,i,j,k ) * uu(i-1,j-1,k-1) + ss(2,i,j,k ) * uu(i  ,j-1,k-1) &
                            + ss(3,i,j,k ) * uu(i+1,j-1,k-1) + ss(4,i,j,k ) * uu(i-1,j  ,k-1) &
                            + ss(5,i,j,k ) * uu(i+1,j  ,k-1) + ss(6,i,j,k ) * uu(i-1,j+1,k-1) &
                            + ss(7,i,j,k ) * uu(i  ,j+1,k-1) + ss(8,i,j,k ) * uu(i+1,j+1,k-1) &
                            + ss(9,i,j,k ) * uu(i-1,j-1,k  ) + ss(10,i,j,k) * uu(i+1,j-1,k  ) &
                            + ss(11,i,j,k) * uu(i-1,j+1,k  ) + ss(12,i,j,k) * uu(i+1,j+1,k  ) &
                            + ss(13,i,j,k) * uu(i-1,j-1,k+1) + ss(14,i,j,k) * uu(i  ,j-1,k+1) &
                            + ss(15,i,j,k) * uu(i+1,j-1,k+1) + ss(16,i,j,k) * uu(i-1,j  ,k+1) &
                            + ss(17,i,j,k) * uu(i+1,j  ,k+1) + ss(18,i,j,k) * uu(i-1,j+1,k+1) &
                            + ss(19,i,j,k) * uu(i  ,j+1,k+1) + ss(20,i,j,k) * uu(i+1,j+1,k+1)

                       uu(i,j,k) = uu(i,j,k) + omega/ss(0,i,j,k)*(ff(i,j,k) - dd)
                    end if
                 end do
              end do
           end do
        end if

      end subroutine nsnew

  end module X

  program main

    use X

    implicit none

    integer, parameter :: N = 64, NG = 1, lo(3) = (/1,1,1/)

    double precision, parameter :: omega = 1.3d0

    double precision :: ssold(N,N,N,0:20)
    double precision :: ssnew(0:20,N,N,N)
    double precision :: ff(1-NG:N+NG,1-NG:N,1-NG:N+NG)
    double precision :: uu(1-NG:N+NG,1-NG:N+NG,1-NG:N+NG)

!    logical, parameter :: oldway = .false.
    logical, parameter :: oldway = .true.

    integer i

    do i = 0,20
       ssold(:,:,:,i) = 1.0d0 + i
       ssnew(i,:,:,:) = 1.0d0 + i
    end do

    uu = 0.0d0

    ff = 1.0d0

    if ( oldway ) then
       do i = 1,250
          call nsold(omega,ssold,uu,ff,lo,NG)
       end do
    else
       do i = 1,250
          call nsnew(omega,ssnew,uu,ff,lo,NG)
       end do
    end if

  end program main


c
      subroutine rz(imsgin,xmsgin,cmsgin,msgtype,nwds,ierr2)
C
C
C#######################################################################
C
C      PURPOSE -
C
C     this routine is used to ratio zone a region of space
C
C
C     FORMAT: RZ/igeom/nx,ny,nz/xi,yi,zi/xf,yf,zf                      &
C     FORMAT:         /ixz/iyz/izz/ixratio/iyratio/izratio/xrz/yrz/zr
C
C
C
C      INPUT ARGUMENTS -
C        imsgin()  - Integer array of command input tokens
C        xmsgin()  - Real array of command input tokens
C        cmsgin()  - Character array of command input tokens
C        msgtype() - Integer array of command input token types
C        nwds      - Number of command input tokens
C
C     OUTPUT ARGUMENTS -
C
C        ierr2 - Error Return Code (==0 ==> OK, <>0 ==> Error)
C
C    LOCAL VARIABLES
C
C      igeom =  xyz ==> x , y , z cartesian geometry
C      igeom =  rtz ==> r , theta , z ==> cylindrical geometry
C      igeom =  rtp ==> r , theta , phi  ==> spherical geometry
C      igeom = line ==> interpolate nx points along line from
C               (xi,yi,zi)  to  (xf,yf,z)
C
C
C
C      nx -- IS THE NUMBER OF NODES (POINTS) IN THE X-DIRECTION.
C               > 0 ==> GENERATE POINTS IN A LINED UP FASHION.
C               < 0 ==> GENERARE POINTS IN A STAGGERED PATTEREN.
C      ny -- IS THE NUMBER OF NODES (POINTS) IN THE Y-DIRECTION.
C               > 0 ==> GENERATE POINTS IN A LINED UP FASHION.
C               < 0 ==> GENERARE POINTS IN A STAGGERED PATTEREN.
C      nz -- IS THE NUMBER OF NODES (POINTS) IN THE Z-DIRECTION.
C               > 0 ==> GENERATE POINTS IN A LINED UP FASHION.
C               < 0 ==> GENERARE POINTS IN A STAGGERED PATTEREN.
C
C
C                   cartesian  cylinderical       spherical
C                     x-y-z      r-theta-z       r-theta-phi
C                   *********  ************      ***********
C
C                          NOTE: ANGLES ARE IN DEGREES
C
C      xi -- minimum    x            r               r
C      yi -- minimum    y      theta(xy-plane)   theta(z-axis)
C      zi -- minimum    z            z           phi(x-axis,xy-plane)
C
C
C      xf -- maximum    x            r               r
C      yf -- maximum    y      theta(xy-plane)   theta(z-axis)
C      zf -- maximum    z            z           phi(x-axis,xy-plane)
C
C
C
C
C     THE REFLECTIVE OR ABSOLUTE ZONING SWITCHES:
C         THESE SWITCH INDICATE WHETHER POINTS ARE GENERATED AT
C            CELL CENTERES (REFLECTIVE POINTS) OR AT CELL VERTICES
C            (ABSOLUTE POINTS).
C
C         ixz = 0 ==> MIN AND MAX X-VALULE ARE USED AS REFLECTIVE
C                        BEGINNING AND ENDDING POINTS.
C         ixz = 1 ==> MIN AND MAX X-VALUES ARE USED AS ABSOLUTE
C                        BEGINNING AND ENDDING POINTS.
C
C         iyz = 0 ==> MIN AND MAX Y-VALULE ARE USED AS REFLECTIVE
C                        BEGINNING AND ENDDING POINTS.
C         iyz = 1 ==> MIN AND MAX Y-VALUES ARE USED AS ABSOLUTE
C                        BEGINNING AND ENDDING POINTS.
C
C         izz = 0 ==> MIN AND MAX Z-VALULE ARE USED AS REFLECTIVE
C                        BEGINNING AND ENDDING POINTS.
C         izz = 1 ==> MIN AND MAX Z-VALUES ARE USED AS ABSOLUTE
C                        BEGINNING AND ENDDING POINTS.
C
C     THE RATIO ZONING SWITCHES.
C
C         ixratio = 0  ==> NO RATIO ZONING IN THE X-DIRECTION.
C         ixratio = 1  ==> RATIO ZONING IN THE X-DIRECTION.
C
C         iyratio = 0  ==> NO RATIO ZONING IN THE Y-DIRECTION.
C         iyratio = 1  ==> RATIO ZONING IN THE Y-DIRECTION.
C
C         izratio = 0  ==> NO RATION ZONING IN THE Z-DIRECTION.
C         izratio = 1  ==> RATIO ZONING IN THE Z-DIRECTION.
C
C
C     THE RATIO ZONE VALUES (I.E., THE ZONING INCREASES OR DECREASES
C                                  BY THIS PERCENTAGE FROM ZONE TO
C                                  ZONE.)
C
C        xrz = THE RATIO ZONING VALUE FOR THE X-DIRECTION.
C        yrz = THE RATIO ZONING VALUE FOR THE Y-DIRECTION.
C        zrz = THE RATIO ZONING VALUE FOR THE Z-DIRECTION.
C
C
C
C      CHANGE HISTORY -
C
C        $Log: rz.f,v $
C        Revision 2.00  2007/11/09 20:04:02  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.27   29 Sep 2004 17:00:30   dcg
CPVCS    remove line that set value for pie - this is set in initlagrit
CPVCS
CPVCS       Rev 1.26   07 May 2003 10:13:00   gable
CPVCS    Fixed error that occured when createpts/line was a
CPVCS    line aligned with the y or z axis. Error resulted
CPVCS    in only cell centered point distributions. Now one
CPVCS    can get correct results when ijz=1 and ikz=1.
CPVCS
CPVCS       Rev 1.25   21 Mar 2002 09:15:40   dcg
CPVCS    fix errors in line mode
CPVCS
CPVCS       Rev 1.24   19 Mar 2001 13:49:08   dcg
CPVCS    make variable pie explicitly double precision
CPVCS
CPVCS       Rev 1.23   Thu Apr 06 13:59:24 2000   dcg
CPVCS    replace get_info_i set_info_i calls
CPVCS
CPVCS       Rev 1.22   26 Jan 2000 13:34:06   dcg
CPVCS    set nx, ny, nz to max (1,input value) to avoid
CPVCS    setting npoint_new to zero (nx*ny*nz)
CPVCS
CPVCS       Rev 1.21   Tue Oct 19 09:02:48 1999   dcg
CPVCS    change print format to allow for more nodes
CPVCS
CPVCS       Rev 1.20   Fri Sep 03 10:02:56 1999   gable
CPVCS    Changed i6 format to i10
CPVCS
CPVCS       Rev 1.19   Thu Jun 24 13:56:50 1999   dcg
CPVCS    get rid of unused variables
CPVCS
CPVCS       Rev 1.17   Fri Jan 22 16:41:34 1999   dcg
CPVCS    add include 'consts.h for subroutine gencurve
CPVCS
CPVCS       Rev 1.16   Fri Jun 19 09:40:12 1998   dcg
CPVCS    remove duplicate declarations
CPVCS
CPVCS       Rev 1.15   Wed May 20 11:12:40 1998   dcg
CPVCS    fix 'line' option
CPVCS
CPVCS       Rev 1.13   Mon Apr 14 17:00:22 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.12   Mon Feb 26 16:48:08 1996   dcg
CPVCS    IBM changes
CPVCS
CPVCS       Rev 1.11   Fri Feb 16 21:50:38 1996   het
CPVCS    Add the curve option.
CPVCS
CPVCS       Rev 1.10   Fri Dec 22 14:17:26 1995   het
CPVCS    Correct errors for inside_ routines.
CPVCS
CPVCS       Rev 1.9   11/20/95 09:09:50   dcg
CPVCS    fix argument type checks
CPVCS
CPVCS       Rev 1.8   11/17/95 15:22:20   dcg
CPVCS    replace literal character strings in calls
CPVCS
CPVCS       Rev 1.7   11/16/95 17:02:48   het
CPVCS    Fix an error with the ipointi/ipointj
CPVCS
CPVCS       Rev 1.6   09/20/95 15:35:00   dcg
CPVCS    HP changes
CPVCS
CPVCS       Rev 1.5   09/18/95 19:44:00   dcg
CPVCS    add argument type test
CPVCS
CPVCS       Rev 1.4   08/23/95 12:56:30   dcg
CPVCS    move cmo calls to subroutine rz from msgtty
CPVCS
CPVCS       Rev 1.3   07/17/95 16:02:08   dcg
CPVCS    activate coordsys changes for rm, rz commands
CPVCS
CPVCS       Rev 1.2   05/26/95 13:13:28   het
CPVCS    Replace subroutine parameter list with subroutine calles.
CPVCS
CPVCS       Rev 1.1   01/04/95 22:05:20   llt
CPVCS    unicos changes (made by het)
CPVCS
CPVCS       Rev 1.0   11/10/94 12:18:28   pvcs
CPVCS    Original version.
C
C#######################################################################
C
      implicit none
C
      include 'chydro.h'
      include 'consts.h'
C
      integer nwds, imsgin(nwds), msgtype(nwds)
      real*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
      character*132 logmess
C
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      real*8 xic(*), yic(*), zic(*)
      pointer (ipitp1, itp1)
      pointer (ipimt1, imt1)
      pointer (ipicr1, icr1)
      integer itp1(*),imt1(*),icr1(*)
C
      character*32 cgeom, cmo, isubname
      integer ierr2,icscode,ipointi,ipointj,ilen,ityp,igeom2,
     * nx,ny,nz,ixratio,iyratio,izratio,ixz,iyz,izz,icount,
     * npoints,i,i1,nx1,ny1,nz1,npoints_new,npoints_save,
     * nx2,ny2,nz2,ix,iy,iz,icntin
      real*8 xi,yi,zi,xf,yf,zf,xrz,yrz,zrz,rsum,dx1,dy1,dz1,
     * x1,y1,z1,x11,y11,z11,x12,y12,z12,
     * r1,z2,xcen,ycen,zcen,ph1,dph,r2,r12,phf,ph11,ph12,dph1,
     *  phi,dth,th1,dth1,th11,dr,dr1,th12,r11,ri,rf,dx,dy,
     *  dz,d1,d2,dzrel1,rsumz,dyrel1,rsumy,rsumx,radtodeg,
     *  radius,angle,degtorad,thi,thf,dxabs1,dyabs1,dzabs1,dxrel1
      real*8 cvmgtr
C
C#######################################################################
C
      isubname='rz'
      ierr2=0
      call cmo_get_name(cmo,ierr2)
      call cmo_get_info('ipointi',cmo,
     *                ipointi,ilen,ityp,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
      call cmo_get_info('ipointj',cmo,
     *                ipointj,ilen,ityp,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
      call cmo_get_info('nnodes',cmo,npoints,ilen,ityp,ierr2)
C
      cgeom=cmsgin(2)
C
C     ******************************************************************
C
C     TO ALLOW FOR AN "OLD" GENERATION OPTION WE CAN SPECIFY THE
C        GENERATION COORDINATE SYSTEM BY NUMBER (1=XYZ, 2=RTZ, 3=RTP).
C
      igeom2=1
      if(cgeom(1:3).eq.'xyz') igeom2=1
      if(cgeom(1:3).eq.'rtz') igeom2=2
      if(cgeom(1:3).eq.'rtp') igeom2=3
      if(cgeom(1:5).eq.'curve') igeom2=4
      if(cgeom(1:5).eq.'line') igeom2=5

C
C     ******************************************************************
C
C     TRANSFORM POINTS AND VELOCITIES TO LOCAL COORD. SYSTEM
C
      if (normflgc .gt. 0) call chglocl(1,npoints,1)
C
      icount=ipointj
      call test_argument_type(3,1,3,imsgin,xmsgin,cmsgin,
     *                         msgtype,nwds)
      call test_argument_type(6,2,6,imsgin,xmsgin,cmsgin,
     *                         msgtype,nwds)
      call test_argument_type(3,1,12,imsgin,xmsgin,cmsgin,
     *                         msgtype,nwds)
      nx=max(1,imsgin(3))
      ny=max(1,imsgin(4))
      nz=max(1,imsgin(5))
      xi=xmsgin(6)
      yi=xmsgin(7)
      zi=xmsgin(8)
      xf=xmsgin(9)
      yf=xmsgin(10)
      zf=xmsgin(11)
      ixz=imsgin(12)
      iyz=imsgin(13)
      izz=imsgin(14)
      if(nwds.le.14) then
        ixratio=0
        iyratio=0
        izratio=0
        xrz=0.
        yrz=0.
        zrz=0.
      else
         call test_argument_type(3,2,18,imsgin,xmsgin,cmsgin,
     *                         msgtype,nwds)
         call test_argument_type(3,1,15,imsgin,xmsgin,cmsgin,
     *                         msgtype,nwds)
         ixratio=imsgin(15)
         iyratio=imsgin(16)
         izratio=imsgin(17)
         xrz=xmsgin(18)
         yrz=xmsgin(19)
         zrz=xmsgin(20)
      endif
C
      if(igeom2.eq.4) then
         radius=xmsgin(21)
         angle=xmsgin(22)
      endif
C
      npoints_new=iabs(nx)*iabs(ny)*iabs(nz)
      npoints_save=ipointj
      npoints=npoints+npoints_new
      call cmo_set_info('nnodes',cmo,npoints,1,1,ierr2)
      call cmo_newlen(cmo,ierr2)
      call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierr2)
      call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierr2)
      call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierr2)
      call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,ierr2)
      call cmo_get_info('imt1',cmo,ipimt1,ilen,ityp,ierr2)
      call cmo_get_info('icr1',cmo,ipicr1,ilen,ityp,ierr2)
C
C     ******************************************************************
C
C     CONVERT ANGLES TO RADIANS.
C
      icntin=icount
      degtorad=pie/180.0
      radtodeg=180.0/pie
C
C     ******************************************************************
C
C     FOR CYLINDRICAL COORDINATES WE CONVERT THE THETA ANGLE FROM
C        DEGREES TO RADIANS.
C
      if(igeom2.eq.2) then
         yi=yi*pie/180.0
         yf=yf*pie/180.0
      endif
C
C     ******************************************************************
C
C     FOR SPHERICAL COORDINATES WE CONVERT THE THETA AND PHI ANGLES FROM
C        DEGREES TO RADIANS.
C
      if(igeom2.eq.3) then
         yi=yi*pie/180.0
         yf=yf*pie/180.0
         zi=zi*pie/180.0
         zf=zf*pie/180.0
      endif
C
C     ******************************************************************
C
C     FILTER THE ZONING FLAGS AND MULTIPLIES TO ALLOW ONLY THE
C        PROPER VALUES.
C
      if(ixz.ne.0.and.ixz.ne.1) ixz=0
      if(iyz.ne.0.and.iyz.ne.1) iyz=0
      if(izz.ne.0.and.izz.ne.1) izz=0
      if(xrz.le.0.0) xrz=1.0
      if(yrz.le.0.0) yrz=1.0
      if(zrz.le.0.0) zrz=1.0
C
C     Do not reset ixz value if point distribution is along a line
C
      if(igeom2 .ne. 5)then
      if(xi.eq.xf.and.ixz.eq.1) ixz=0
      if(yi.eq.yf.and.iyz.eq.1) iyz=0
      if(zi.eq.zf.and.izz.eq.1) izz=0
      endif
C
C     ******************************************************************
C
C     SETUP THE STARTING VALUE AND DELTA FOR THE X-DIRECTION.
C
      nx1=iabs(nx)
      if(nx1.lt.2.and.ixz.gt.0) ixz=0
      if(ixz.eq.0) then
         if(nx1.eq.1) then
            rsum=0.0
         else
            rsum=0.0
            do 10 i1=1,nx1-1
               rsum=rsum+xrz**float(i1)
 10         continue
         endif
         rsumx=0.5+rsum+0.5*xrz**float(nx1+1)
         dxrel1=(xf-xi)/rsumx
         dx1=dxrel1
         x11=xi-0.5*dx1
      else
         if(nx1.eq.2) then
            rsum=0.0
         else
            rsum=0.0
            do 15 i1=1,nx1-2
               rsum=rsum+xrz**float(i1)
 15         continue
         endif
         rsumx=1.0+rsum
         dxabs1=(xf-xi)/rsumx
         dx1=dxabs1/xrz
         x11=xi-dx1
      endif
      x12=x11+0.5*dx1
C
C     ******************************************************************
C
C     SETUP THE STARTING VALUE AND DELTA FOR THE Y-DIRECTION.
C
      ny1=iabs(ny)
      if(ny1.lt.2.and.iyz.gt.0) iyz=0
      if(iyz.eq.0) then
         if(ny1.eq.1) then
            rsum=0.0
         else
            rsum=0.0
            do 20 i1=1,ny1-1
               rsum=rsum+yrz**float(i1)
 20         continue
         endif
         rsumy=0.5+rsum+0.5*yrz**float(ny1+1)
         dyrel1=(yf-yi)/rsumy
         dy1=dyrel1
         y11=yi-0.5*dy1
      else
         if(ny1.eq.2) then
            rsum=0.0
         else
            rsum=0.0
            do 25 i1=1,ny1-2
               rsum=rsum+yrz**float(i1)
 25         continue
         endif
         rsumy=1.0+rsum
         dyabs1=(yf-yi)/rsumy
         dy1=dyabs1/yrz
         y11=yi-dy1
      endif
      y12=y11+0.5*dy1
C
C     ******************************************************************
C
C     SETUP THE STARTING VALUE AND DELTA FOR THE Z-DIRECTION.
C
      nz1=iabs(nz)
      if(nz1.lt.2.and.izz.gt.0) izz=0
      if(izz.eq.0) then
         if(nz1.eq.1) then
            rsum=0.0
         else
            rsum=0.0
            do 30 i1=1,nz1-1
               rsum=rsum+zrz**float(i1)
 30         continue
         endif
         rsumz=0.5+rsum+0.5*zrz**float(nz1+1)
         dzrel1=(zf-zi)/rsumz
         dz1=dzrel1
         z11=zi-0.5*dz1
      else
         if(nz1.eq.2) then
            rsum=0.0
         else
            rsum=0.0
            do 35 i1=1,nz1-2
               rsum=rsum+zrz**float(i1)
 35         continue
         endif
         rsumz=1.0+rsum
         dzabs1=(zf-zi)/rsumz
         dz1=dzabs1/zrz
         z11=zi-dz1
      endif
      z12=z11+0.5*dz1
C
C     ******************************************************************
C
C     CHECK TO SEE IF THIS A 1D LINE IN 3D SPACE. IF SO THEN JUST
C        INTERPOLATE ALONG THE LINE.
      if(igeom2.eq.5) then
C
C
         nx1=iabs(nx)
      endif
C
C     ******************************************************************
C
C     NOW GO TO THE CORRECT GEOMETRY ROUTINE.
C
C
      goto (100 , 200 , 300, 400,500) igeom2
      goto 9999
C
C     ******************************************************************
C
C     DEFINE THE XYZ- COORDINATE SETUP. THE GENERATION ORDER IS:
C        1) INNER  LOOP IS FOR THE X-COORDINATES.
C        2) MIDDLE LOOP IS FOR THE Y-COORDINATES.
C        3) OUTER  LOOP IS FOR THE Z-COORDINATES.
C
 100  continue
      d1=0.0
      d2=0.0
      z1=z11
      z2=z12
      dz=dz1
      do 110 iz=1,nz1
         z1=z1+dz
         if(ny.lt.0) then
            if(mod(iz,2).ne.0) then
               ny2=ny1
               y1=y11
            else
               ny2=ny1-1
               y1=y12
            endif
         else
            ny2=ny1
            y1=y11
         endif
         dy=dy1
         do 120 iy=1,ny2
            y1=y1+dy
            if(nx.lt.0) then
               if(mod(iy,2).ne.0) then
                  nx2=nx1
                  x1=x11
               else
                  nx2=nx1-1
                  x1=x12
               endif
            else
               nx2=nx1
               x1=x11
            endif
            dx=dx1
            do 130 ix=1,nx2
               x1=x1+dx
               icount=icount+1
               xic(icount)=x1
               yic(icount)=y1
               zic(icount)=z1
               dx=cvmgtr(dx*xrz,dx,ixratio.eq.1)
 130        continue
            dy=cvmgtr(dy*yrz,dy,iyratio.eq.1)
 120     continue
         dz=cvmgtr(dz*zrz,dz,izratio.eq.1)
 110  continue
      goto 9998
C
C     ******************************************************************
C
C     DEFINE THE RTZ-COORDINATE SETUP FOR CYLINDRICAL GEOMETRY. THE
C        GENERATION ORDER IS:
C           1) INNER  LOOP IS FOR THE RADIAL-COORDINATES.
C           2) MIDDLE LOOP IS FOR THE  THETA-COORDINATES.
C           3) OUTER  LOOP IS FOR THE      Z-COORDINATES.
C
 200  continue
      d1=0.0
      d2=0.0
      ri=xi
      rf=xf
      thi=yi
      thf=yf
      r11 =x11
      r12 =x12
      dr1 =dx1
      th11=y11
      th12=y12
      dth1=dy1
      z1  =z11
      z2  =z12
      dz  =dz1
      do 210 iz=1,nz1
         z1=z1+dz
         if(nx.lt.0) then
            if(mod(iz,2).ne.0) then
               nx2=nx1
               r1=r11
            else
               nx2=nx1-1
               r1=r12
            endif
         else
            nx2=nx1
            r1=r11
         endif
         dr=dr1
         do 220 ix=1,nx2
            r1=r1+dr
            if(ny.lt.0) then
               if(mod(ix,2).ne.0) then
                  ny2=ny1
                  th1=th11
               else
                  ny2=ny1-1
                  if(thf.eq.2.0*pie) ny2=ny1
                  th1=th12
               endif
            else
               ny2=ny1
               th1=th11
            endif
            dth=dth1
            do 230 iy=1,ny2
               th1=th1+dth
               x1=r1*cos(th1)
               y1=r1*sin(th1)
               icount=icount+1
C*****         call flgrid(2,icount,x1,y1,z1,0.0,0.0,0.0)
               xic(icount)=x1
               yic(icount)=y1
               zic(icount)=z1
               dth=cvmgtr(dth*yrz,dth,iyratio.eq.1)
 230        continue
            dr=cvmgtr(dr*xrz,dr,ixratio.eq.1)
 220     continue
         dz=cvmgtr(dz*zrz,dz,izratio.eq.1)
 210  continue
      goto 9998
C
C     ******************************************************************
C
C     DEFINE THE RTP-COORDINATE SETUP FOR SPHERICAL GEOMETRY. THE
C        GENERATION ORDER IS:
C           1) INNER  LOOP IS FOR THE RADIAL-COORDINATES.
C           2) MIDDLE LOOP IS FOR THE  THETA-COORDINATES.
C           3) OUTER  LOOP IS FOR THE    PHI-COORDINATES.
C
 300  continue
      d1=0.0
      d2=0.0
      ri=xi
      rf=xf
      thi=yi
      thf=yf
      phi=zi
      phf=zf
      r11 =x11
      dr1 =dx1
      th11=y11
      th12=y12
      dth1=dy1
      ph11=z11
      ph12=z12
      dph1=dz1
      r1=r11
      r2=r12
      dr=dr1
      do 310 ix=1,nx1
         r1=r1+dr
         if(ny.lt.0) then
            if(mod(ix,2).ne.0) then
               ny2=ny1
               th1=th11
            else
               ny2=ny1-1
               if(thf.eq.2.0*pie) ny2=ny1
               th1=th12
            endif
         else
            ny2=ny1
            th1=th11
         endif
         dth=dth1
         do 320 iy=1,ny2
            th1=th1+dth
            if(nz.lt.0) then
               if(mod(iy,2).ne.0) then
                  nz2=nz1
                  ph1=ph11
               else
                  nz2=nz1-1
                  if(phf.eq.2.0*pie) nz2=nz1
                  ph1=ph12
               endif
            else
               nz2=nz1
               ph1=ph11
            endif
            dph=dph1
            do 330 iz=1,nz2
               ph1=ph1+dph
               x1=r1*sin(th1)*cos(ph1)
               y1=r1*sin(th1)*sin(ph1)
               z1=r1*cos(th1)
               icount=icount+1
C*****         call flgrid(2,icount,x1,y1,z1,0.0,0.0,0.0)
               xic(icount)=x1
               yic(icount)=y1
               zic(icount)=z1
               dph=cvmgtr(dph*zrz,dph,izratio.eq.1)
 330        continue
            dth=cvmgtr(dth*yrz,dth,iyratio.eq.1)
 320     continue
         dr=cvmgtr(dr*xrz,dr,ixratio.eq.1)
 310  continue
      goto 9998
C
C     ******************************************************************
C
C
 400  continue
      call gencurve(icount,nx,
     *              xic,yic,zic,
     *              xcen,ycen,zcen,
     *              xi,yi,zi,xf,yf,zf,
     *              radius,angle)
      icount=icount+nx
      goto 9998
C
C     ******************************************************************
C    Distribute points along the line from (xi,yi,zi) to (xf,yf,zf)
C
 500  if(nx1.eq.1) then
        icount=icount+1
        if(ixratio.eq.1) then
           xic(icount)=0.5*(xi+xf)
           yic(icount)=0.5*(yi+yf)
           zic(icount)=0.5*(zi+zf)
        else
           xic(icount)= xi
           yic(icount)= yi
           zic(icount)= zi
        endif
      else
C
C  check for ratio spacing
C
         if(ixratio.eq.0) then
c
C  no ratio spacing check for end point or cell centered
C
            if (ixz.eq.1) then
C  end points
               dx1=(xf-xi)/(nx1-1)
               dy1=(yf-yi)/(nx1-1)
               dz1=(zf-zi)/(nx1-1)
               icount=icount+1
               xic(icount)= xi
               yic(icount)= yi
               zic(icount)= zi
               do i=1,nx1-2
                  icount=icount+1
                  xic(icount)=xi+i*dx1
                  yic(icount)=yi+i*dy1
                  zic(icount)=zi+i*dz1
               enddo
               icount=icount+1
               xic(icount)= xf
               yic(icount)= yf
               zic(icount)= zf
            else
C  cell centered
               dx1=(xf-xi)/(nx1)
               dy1=(yf-yi)/(nx1)
               dz1=(zf-zi)/(nx1)
               icount=icount+1
               xic(icount)= xi+0.5*dx1
               yic(icount)= yi+0.5*dy1
               zic(icount)= zi+0.5*dz1
               do i=1,nx1-2
                  icount=icount+1
                  xic(icount)=xi+(i+0.5)*dx1
                  yic(icount)=yi+(i+0.5)*dy1
                  zic(icount)=zi+(i+0.5)*dz1
               enddo
               icount=icount+1
               xic(icount)= xf-0.5*dx1
               yic(icount)= yf-0.5*dy1
               zic(icount)= zf-0.5*dz1
            endif
         else
c
C  ratio spacing
C
            if(ixz.eq.1) then
C  end points
C  get length of first space
               icount=icount+1
               xic(icount)= xi
               yic(icount)= yi
               zic(icount)= zi
               x1=xi
               y1=yi
               z1=zi
               rsum=1.0
               do i=1,nx1-2
                  rsum=rsum+xrz**float(i)
               enddo
               dx1=(xf-xi)/rsum
               dy1=(yf-yi)/rsum
               dz1=(zf-zi)/rsum
               do i=1,nx1-2
                  icount=icount+1
                  xic(icount)=x1+dx1
                  yic(icount)=y1+dy1
                  zic(icount)=z1+dz1
                  x1=  xic(icount)
                  y1=  yic(icount)
                  z1=  zic(icount)
                  dx1=xrz*dx1
                  dy1=xrz*dy1
                  dz1=xrz*dz1
               enddo
               icount=icount+1
               xic(icount)= xf
               yic(icount)= yf
               zic(icount)= zf
           else
C  cell centered
               rsum=1.0
               do i=1,nx1-2
                  rsum=rsum+xrz**float(i)
               enddo
               rsum=0.5+rsum+xrz**float(nx1-1)
               dx1=(xf-xi)/rsum
               dy1=(yf-yi)/rsum
               dz1=(zf-zi)/rsum
               icount=icount+1
               xic(icount)= xi+0.5*dx1
               yic(icount)= yi+0.5*dy1
               zic(icount)= zi+0.5*dz1
               x1=xi+0.5*dx1
               y1=yi+0.5*dy1
               z1=zi+0.5*dz1
               do i=1,nx1-1
                  icount=icount+1
                  xic(icount)=x1+dx1
                  yic(icount)=y1+dy1
                  zic(icount)=z1+dz1
                  x1=  xic(icount)
                  y1=  yic(icount)
                  z1=  zic(icount)
                  dx1=xrz*dx1
                  dy1=xrz*dy1
                  dz1=xrz*dz1
               enddo
            endif
         endif
      endif
      go to 9998

C
C     ******************************************************************
C     PRINT OUT THE POINT NUMBERS GENERATED
C
 9998 write(logmess,6000) icntin+1,icount
 6000 format('  RZ GENERATED POINTS ',i20,' TO ',i20)
      call writloga('default',0,logmess,0,ierr2)
c
c     Initialize ipt1, imt1 and icr1 to zero for new nodes.
C
      do i=icntin+1,icount
         itp1(i)=0
         imt1(i)=0
         icr1(i)=0
      enddo
      goto 9999
 9999 continue
      ipointi=npoints_save+1
      ipointj=icount
      call cmo_get_name(cmo,ierr2)
C
      npoints=ipointj
      call cmo_set_info('nnodes',cmo,npoints,1,1,ierr2)
C
      call cmo_set_info('ipointi',cmo,
     *                ipointi,1,1,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_set_info')
      call cmo_set_info('ipointj',cmo,
     *                ipointj,1,1,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_set_info')
C
C     TRANSFORM POINTS AND VELOCITIES TO NORMAL COORD. SYSTEM
C
      if (normflgc .gt. 0) call chgnorm(1,npoints,1)
C
C     ******************************************************************
C
      return
      end
      subroutine gencurve(icount,npoints,xp,yp,zp,xcen,ycen,zcen,
     *                    xstart,ystart,zstart,xend,yend,zend,
     *                    radius,angle)
C
C#######################################################################
C
      implicit real*8 (a-h, o-z)
      include 'consts.h'
C
      real*8 xp(npoints), yp(npoints), zp(npoints)
      x_deg_to_rad = acos(-1.0d+00)/180.0
      dz=(zend-zstart)/(npoints-1)
      z1=-dz
      dangle=angle/(npoints-1)
      a1=-dangle
      do i=1,npoints
         z1=z1+dz
         a1=a1+dangle
         xp(icount+i)=radius*cos(a1*x_deg_to_rad)
         yp(icount+i)=radius*sin(a1*x_deg_to_rad)
         zp(icount+i)=z1
      enddo
      do i=1,npoints
         xp(icount+i)=xp(icount+i)-radius
      enddo
      amag=sqrt((xend-xstart)**2+(yend-ystart)**2)
      bmag=sqrt((xp(icount+npoints)-xp(icount+1))**2+
     *          (yp(icount+npoints)-yp(icount+1))**2)
      xdot=(xend-xstart)*(xp(icount+npoints)-xp(icount+1)) +
     *     (yend-ystart)*(yp(icount+npoints)-yp(icount+1))
      theta=acos(min(one,max(-one,xdot/(amag*bmag))))
      x1=0.0
      y1=0.0
      z1=1.0d+06
      do i=1,npoints
         call rotatelo(xp(icount+i),yp(icount+i),zp(icount+i),
     *                 xcp,ycp,zcp,
     *                 x1,y1,+z1,
     *                 x1,y1,-z1,
     *                 theta)
         xp(icount+i)=xcp
         yp(icount+i)=ycp
         zp(icount+i)=zcp
      enddo
      do i=1,npoints
         xp(icount+i)=xp(icount+i)+xstart
         yp(icount+i)=yp(icount+i)+ystart
         zp(icount+i)=zp(icount+i)+zstart
      enddo
      xcen=-radius
      ycen=0.0
      zcen=0.0
      x1=0.0
      y1=0.0
      z1=1.0
      call rotatelo(xcen,ycen,zcen,
     *              xcp,ycp,zcp,
     *              x1,y1,+z1,
     *              x1,y1,-z1,
     *              theta)
      xcen=xcp+xstart
      ycen=ycp+ystart
      zcen=zcp
      goto 9999
 9999 continue
      return
      end


! From FLASH2.5/source/cosmology/ExpansionTimestep.F90
afinal = 1./(1.+zfinal)
end


module Mod_supm_StressGenerator
   use typre
   use Mod_MPIObject
   use Mod_Listen
   use Mod_supm_MatrixVector
   use Mod_Element
   implicit none

contains

!------------------------------
! scalar per tensor ht
!------------------------------

   subroutine GetStress2D(tensor,vector)
      implicit none
      real(rp) :: tensor(2,2)
      real(rp) :: vector(3)

      vector(1) = tensor(1,1)
      vector(2) = tensor(2,2)
      vector(3) = tensor(1,2)+tensor(2,1)
   end subroutine

     subroutine GetStress2D_sym(tensor,vector)
      implicit none
      real(rp) :: tensor(2,2)
      real(rp) :: vector(3)

      vector(1) = tensor(1,1)
      vector(2) = tensor(2,2)
      vector(3) = tensor(1,2)
   end subroutine

   subroutine AddSphericalComponent2D(value,vector)
      use typre
      implicit none
      real(rp) :: value
      real(rp) :: vector(3)

      vector(1:2) = vector(1:2) + value
   end subroutine

   subroutine GetStress3D(tensor,vector)
      implicit none
      real(rp) :: tensor(3,3)
      real(rp) :: vector(6)

      vector(1) = tensor(1,1)
      vector(2) = tensor(2,2)
      vector(3) = tensor(3,3)
      vector(4) = tensor(2,3)+tensor(3,2)
      vector(5) = tensor(1,3)+tensor(3,1)
      vector(6) = tensor(1,2)+tensor(2,1)
   end subroutine

    subroutine GetStress3D_sym(tensor,vector)
      implicit none
      real(rp) :: tensor(3,3)
      real(rp) :: vector(6)

      vector(1) = tensor(1,1)
      vector(2) = tensor(2,2)
      vector(3) = tensor(3,3)
      vector(4) = tensor(2,3)
      vector(5) = tensor(1,3)
      vector(6) = tensor(1,2)
   end subroutine

   subroutine AddSphericalComponent3D(value,vector)
      implicit none
      real(rp) :: value
      real(rp) :: vector(6)

      vector(1:3) = vector(1:3) + value
   end subroutine

  subroutine GetStress(ndime,tensor,vector)
      integer(ip) :: ndime
      real(rp)    :: vector(:), tensor(:,:)

      if (ndime == 2) call GetStress2D(tensor,vector)
      if (ndime == 3) call GetStress3D(tensor,vector)
  end subroutine

    subroutine GetStress_sym(ndime,tensor,vector)
      integer(ip) :: ndime
      real(rp)    :: vector(:), tensor(:,:)

      if (ndime == 2) call GetStress2D_sym(tensor,vector)
      if (ndime == 3) call GetStress3D_sym(tensor,vector)

  end subroutine

!------------------------------
! two tensors product st
!------------------------------
   subroutine GetStress2D_tt(tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(2,2), tensor2(3,3)

      tensor2(1,1)=tensor1(1,1)
      tensor2(1,2)=0
      tensor2(1,3)=tensor1(1,2)
      tensor2(2,1)=0
      tensor2(2,2)=tensor1(2,2)
      tensor2(2,3)=tensor1(2,1)
      tensor2(3,1)=tensor1(2,1)
      tensor2(3,2)=tensor1(1,2)
      tensor2(3,3)=tensor1(1,1)+tensor1(2,2)
    end subroutine

   subroutine AddSphericalComponent2D_tt(value,tensor)
      implicit none
      real(rp) :: value
      real(rp) :: tensor(3,3)

      tensor(1,1) = tensor(1,1) + value
      tensor(2,2) = tensor(2,2) + value
      tensor(3,3) = tensor(3,3) + 2.0_rp*value
   end subroutine

   subroutine GetAdvStress2D_tt(auxPTT,vector,tensor)
      implicit none
      real(rp) :: tensor(3,3), vector(3), traza
      integer :: auxPTT
      traza=vector(1)+vector(2)

      tensor(1,1)= (1_ip + auxPTT)*vector(1)+(1_ip - auxPTT)*traza
      tensor(1,2)= (1_ip - auxPTT)*vector(1)
      tensor(1,3)= auxPTT*2.0_rp*vector(3)
      tensor(2,1)= (1_ip - auxPTT)*vector(2)
      tensor(2,2)= (1_ip + auxPTT)*vector(2)+(1_ip - auxPTT)*traza
      tensor(2,3)= auxPTT*2.0_rp*vector(3)
      tensor(3,1)= 2.0_rp*vector(3)
      tensor(3,2)= 2.0_rp*vector(3)
      tensor(3,3)= (1_ip + auxPTT)*(vector(1)+vector(2))+(1_ip - auxPTT)*traza

   end subroutine

   subroutine GetAdvStress2D_tt_B(auxPTT,vector,tensor)
      implicit none
      real(rp) :: tensor(3,3), vector(3), traza
      integer :: auxPTT
      traza=vector(1)+vector(2)

      tensor(1,1)= -auxPTT*vector(1)-(1_ip - auxPTT)*traza
      tensor(1,2)= 0
      tensor(1,3)= -auxPTT*vector(3)
      tensor(2,1)= 0
      tensor(2,2)= -auxPTT*vector(2)-(1_ip - auxPTT)*traza
      tensor(2,3)= -auxPTT*vector(3)
      tensor(3,1)= -auxPTT*vector(3)
      tensor(3,2)= -auxPTT*vector(3)
      tensor(3,3)= 2.0_rp*(-auxPTT*(vector(1)+vector(2))-(1_ip - auxPTT)*traza)

   end subroutine

    subroutine GetStress3D_tt(tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(3,3), tensor2(6,6)

      tensor2(1,1)=tensor1(1,1)
      tensor2(1,2)=0
      tensor2(1,3)=0
      tensor2(1,4)=0
      tensor2(1,5)=tensor1(1,3)
      tensor2(1,6)=tensor1(1,2)

      tensor2(2,1)=0
      tensor2(2,2)=tensor1(2,2)
      tensor2(2,3)=0
      tensor2(2,4)=tensor1(2,3)
      tensor2(2,5)=0
      tensor2(2,6)=tensor1(2,1)

      tensor2(3,1)=0
      tensor2(3,2)=0
      tensor2(3,3)=tensor1(3,3)
      tensor2(3,4)=tensor1(3,2)
      tensor2(3,5)=tensor1(3,1)
      tensor2(3,6)=0

      tensor2(4,1)=0
      tensor2(4,2)=tensor1(3,2)
      tensor2(4,3)=tensor1(2,3)
      tensor2(4,4)=tensor1(3,3)+tensor1(2,2)
      tensor2(4,5)=tensor1(2,1)
      tensor2(4,6)=tensor1(3,1)

      tensor2(5,1)=tensor1(3,1)
      tensor2(5,2)=0
      tensor2(5,3)=tensor1(1,3)
      tensor2(5,4)=tensor1(1,2)
      tensor2(5,5)=tensor1(1,1)+tensor1(3,3)
      tensor2(5,6)=tensor1(3,2)

      tensor2(6,1)=tensor1(2,1)
      tensor2(6,2)=tensor1(1,2)
      tensor2(6,3)=0
      tensor2(6,4)=tensor1(1,3)
      tensor2(6,5)=tensor1(2,3)
      tensor2(6,6)=tensor1(1,1)+tensor1(2,2)

    end subroutine

   subroutine AddSphericalComponent3D_tt(value,tensor)
      implicit none
      real(rp) :: value
      real(rp) :: tensor(6,6)

      tensor(1,1) = tensor(1,1) + value
      tensor(2,2) = tensor(2,2) + value
      tensor(3,3) = tensor(3,3) + value
      tensor(4,4) = tensor(4,4) + 2.0_rp*value
      tensor(5,5) = tensor(5,5) + 2.0_rp*value
      tensor(6,6) = tensor(6,6) + 2.0_rp*value
   end subroutine

   subroutine GetAdvStress3D_tt(auxPTT,vector,tensor)
      implicit none
      real(rp) :: tensor(6,6), vector(6), traza
      integer :: auxPTT
      !if auxPTT =1 is OFF, else auxPTT=0 is ON
      traza=vector(1)+vector(2)+vector(3)

      tensor(1,1)=(1_ip + auxPTT)*vector(1)+(1_ip - auxPTT)*traza
      tensor(1,2)=(1 - auxPTT)*vector(1)
      tensor(1,3)=(1 - auxPTT)*vector(1)
      tensor(1,4)=0
      tensor(1,5)=auxPTT*2.0_rp*vector(5)
      tensor(1,6)=auxPTT*2.0_rp*vector(6)

      tensor(2,1)=(1 - auxPTT)*vector(2)
      tensor(2,2)=(1_ip + auxPTT)*vector(2)+(1_ip - auxPTT)*traza
      tensor(2,3)=(1 - auxPTT)*vector(2)
      tensor(2,4)=auxPTT*2.0_rp*vector(4)
      tensor(2,5)=0
      tensor(2,6)=auxPTT*2.0_rp*vector(6)

      tensor(3,1)=(1 - auxPTT)*vector(3)
      tensor(3,2)=(1 - auxPTT)*vector(3)
      tensor(3,3)=(1_ip + auxPTT)*vector(3)+(1_ip - auxPTT)*traza
      tensor(3,4)=auxPTT*2.0_rp*vector(4)
      tensor(3,5)=auxPTT*2.0_rp*vector(5)
      tensor(3,6)=0

      tensor(4,1)=(1 - auxPTT)*2.0_rp*vector(4)
      tensor(4,2)=2.0_rp*vector(4)
      tensor(4,3)=2.0_rp*vector(4)
      tensor(4,4)=(1_ip + auxPTT)*(vector(2)+vector(3))+(1_ip - auxPTT)*traza
      tensor(4,5)=auxPTT*2.0_rp*vector(6)
      tensor(4,6)=auxPTT*2.0_rp*vector(5)

      tensor(5,1)=2.0_rp*vector(5)
      tensor(5,2)=(1 - auxPTT)*2.0_rp*vector(5)
      tensor(5,3)=2.0_rp*vector(5)
      tensor(5,4)=auxPTT*2.0_rp*vector(6)
      tensor(5,5)=(1_ip + auxPTT)*(vector(1)+vector(3))+(1_ip - auxPTT)*traza
      tensor(5,6)=auxPTT*2.0_rp*vector(4)

      tensor(6,1)=2.0_rp*vector(6)
      tensor(6,2)=2.0_rp*vector(6)
      tensor(6,3)=(1 - auxPTT)*2.0_rp*vector(6)
      tensor(6,4)=auxPTT*2.0_rp*vector(5)
      tensor(6,5)=auxPTT*2.0_rp*vector(4)
      tensor(6,6)=(1_ip + auxPTT)*(vector(1)+vector(2))+(1_ip - auxPTT)*traza

   end subroutine

   subroutine GetAdvStress3D_tt_B(auxPTT,vector,tensor)
      implicit none
      real(rp) :: tensor(6,6), vector(6), traza
      integer :: auxPTT
      !if auxPTT =1 is OFF, else auxPTT=0 is ON
      traza=vector(1)+vector(2)+vector(3)

      tensor(1,1)=-auxPTT*vector(1)-(1_ip - auxPTT)*traza
      tensor(1,2)=0
      tensor(1,3)=0
      tensor(1,4)=0
      tensor(1,5)=-auxPTT*vector(5)
      tensor(1,6)=-auxPTT*vector(6)

      tensor(2,1)=0
      tensor(2,2)=-auxPTT*vector(2)-(1_ip - auxPTT)*traza
      tensor(2,3)=0
      tensor(2,4)=-auxPTT*vector(4)
      tensor(2,5)=0
      tensor(2,6)=-auxPTT*vector(6)

      tensor(3,1)=0
      tensor(3,2)=0
      tensor(3,3)=-auxPTT*vector(3)-(1_ip - auxPTT)*traza
      tensor(3,4)=-auxPTT*vector(4)
      tensor(3,5)=-auxPTT*vector(5)
      tensor(3,6)=0

      tensor(4,1)=0
      tensor(4,2)=-auxPTT*vector(4)
      tensor(4,3)=-auxPTT*vector(4)
      tensor(4,4)=-auxPTT*(vector(2)+vector(3))-(1_ip - auxPTT)*traza
      tensor(4,5)=-auxPTT*vector(6)
      tensor(4,6)=-auxPTT*vector(5)

      tensor(5,1)=-auxPTT*vector(5)
      tensor(5,2)=0
      tensor(5,3)=-auxPTT*vector(5)
      tensor(5,4)=-auxPTT*vector(6)
      tensor(5,5)=-auxPTT*(vector(1)+vector(3))-(1_ip - auxPTT)*traza
      tensor(5,6)=-auxPTT*vector(4)

      tensor(6,1)=-auxPTT*vector(6)
      tensor(6,2)=-auxPTT*vector(6)
      tensor(6,3)=0
      tensor(6,4)=-auxPTT*vector(5)
      tensor(6,5)=-auxPTT*vector(4)
      tensor(6,6)=-auxPTT*(vector(1)+vector(2))-(1_ip - auxPTT)*traza

   end subroutine

     subroutine GetStress_tt(ndime,tensor1,tensor2)
      integer(ip) :: ndime
      real(rp)    :: tensor1(ndime,ndime), tensor2(:,:)

      if (ndime == 2) call GetStress2D_tt(tensor1,tensor2)
      if (ndime == 3) call GetStress3D_tt(tensor1,tensor2)
   end subroutine

    subroutine AddSphericalComponent_tt(ndime,value,tensor1)
      integer(ip) :: ndime
      real(rp)    :: tensor1(:,:), value

      if (ndime == 2) call AddSphericalComponent2D_tt(value,tensor1)
      if (ndime == 3) call AddSphericalComponent3D_tt(value,tensor1)
   end subroutine

    subroutine GetAdvStress_tt(ndime,auxPTT,vector,tensor)
      integer(ip) :: ndime, auxPTT
      real(rp)    :: vector(:), tensor(:,:)

      if (ndime == 2) call GetAdvStress2D_tt(auxPTT,vector,tensor)
      if (ndime == 3) call GetAdvStress3D_tt(auxPTT,vector,tensor)
   end subroutine

    subroutine GetAdvStress_tt_B(ndime,auxPTT,vector,tensor)
      integer(ip) :: ndime, auxPTT
      real(rp)    :: vector(:), tensor(:,:)

      if (ndime == 2) call GetAdvStress2D_tt_B(auxPTT,vector,tensor)
      if (ndime == 3) call GetAdvStress3D_tt_B(auxPTT,vector,tensor)
   end subroutine

!------------------------------
! vector per tensor ut
!------------------------------

   subroutine GetStress2D_ut(tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(2,2), tensor2(3,2)

      tensor2(1,1)=tensor1(1,1)
      tensor2(1,2)=0
      tensor2(2,1)=0
      tensor2(2,2)=tensor1(2,2)
      tensor2(3,1)=tensor1(2,2)
      tensor2(3,2)=tensor1(1,1)
   end subroutine

    subroutine GetStress3D_ut(tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(3,3), tensor2(6,3)

      tensor2(1,1)=tensor1(1,1)
      tensor2(1,2)=0
      tensor2(1,3)=0

      tensor2(2,1)=0
      tensor2(2,2)=tensor1(2,2)
      tensor2(2,3)=0

      tensor2(3,1)=0
      tensor2(3,2)=0
      tensor2(3,3)=tensor1(3,3)

      tensor2(4,1)=0
      tensor2(4,2)=tensor1(3,3)
      tensor2(4,3)=tensor1(2,2)

      tensor2(5,1)=tensor1(3,3)
      tensor2(5,2)=0
      tensor2(5,3)=tensor1(1,1)

      tensor2(6,1)=tensor1(2,2)
      tensor2(6,2)=tensor1(1,1)
      tensor2(6,3)=0
   end subroutine

   subroutine AddSigmaGradVel2D_ut(tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(3,2), tensor2(3,2)

      tensor2(1,1)= tensor1(1,1) + tensor1(3,2) + tensor2(1,1)
      tensor2(1,2)= tensor2(1,2)
      tensor2(2,1)= tensor2(2,1)
      tensor2(2,2)= tensor1(3,1) + tensor1(2,2) + tensor2(2,2)
      tensor2(3,1)= tensor1(2,2) + 2.0_rp*tensor2(3,1)
      tensor2(3,2)= tensor1(1,1) + 2.0_rp*tensor2(3,2)
   end subroutine

   subroutine AddSigmaGradVel3D_ut(tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(6,3), tensor2(6,3)

      tensor2(1,1)=(tensor1(1,1)+tensor1(6,2)+tensor1(5,3)) + tensor2(1,1)
      tensor2(1,2)=tensor2(1,2)
      tensor2(1,3)=tensor2(1,3)

      tensor2(2,1)=tensor2(2,1)
      tensor2(2,2)=(tensor1(6,1)+tensor1(2,2)+tensor1(4,3)) + tensor2(2,2)
      tensor2(2,3)=tensor2(2,3)

      tensor2(3,1)=tensor2(3,1)
      tensor2(3,2)=tensor2(3,2)
      tensor2(3,3)=(tensor1(5,1)+tensor1(4,2)+tensor1(3,3)) + tensor2(3,3)

      tensor2(4,1)=2.0_rp*tensor2(4,1)
      tensor2(4,2)=(tensor1(5,1) + tensor1(4,2) + tensor1(3,3) + 2.0_rp*tensor2(4,2))
      tensor2(4,3)=(tensor1(6,1) + tensor1(2,2) + tensor1(4,3) + 2.0_rp*tensor2(4,3))

      tensor2(5,1)=(tensor1(5,1) + tensor1(4,2) + tensor1(3,3) + 2.0_rp*tensor2(5,1))
      tensor2(5,2)=2.0_rp*tensor2(5,2)
      tensor2(5,3)=(tensor1(1,1) + tensor1(6,2) + tensor1(5,3) + 2.0_rp*tensor2(5,3))

      tensor2(6,1)=(tensor1(6,1) + tensor1(2,2) + tensor1(4,3) + 2.0_rp*tensor2(6,1))
      tensor2(6,2)=(tensor1(1,1) + tensor1(6,2) + tensor1(5,3) + 2.0_rp*tensor2(6,2))
      tensor2(6,3)=2.0_rp*tensor2(6,3)
   end subroutine

   subroutine GetGrVel2D_ut(vector,tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(2,2), tensor2(3,2),vector(2)

      tensor2(1,1)=vector(1)*tensor1(1,1)
      tensor2(1,2)=vector(1)*tensor1(1,2)
      tensor2(2,1)=vector(2)*tensor1(2,1)
      tensor2(2,2)=vector(2)*tensor1(2,2)
      tensor2(3,1)=vector(2)*tensor1(1,1)+vector(1)*tensor1(2,1)
      tensor2(3,2)=vector(2)*tensor1(1,2)+vector(1)*tensor1(2,2)
   end subroutine

   subroutine GetGrVel3D_ut(vector,tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(3,3), tensor2(6,3),vector(3)

      tensor2(1,1)=vector(1)*tensor1(1,1)
      tensor2(1,2)=vector(1)*tensor1(1,2)
      tensor2(1,3)=vector(1)*tensor1(1,3)
      tensor2(2,1)=vector(2)*tensor1(2,1)
      tensor2(2,2)=vector(2)*tensor1(2,2)
      tensor2(2,3)=vector(2)*tensor1(2,3)
      tensor2(3,1)=vector(3)*tensor1(3,1)
      tensor2(3,2)=vector(3)*tensor1(3,2)
      tensor2(3,3)=vector(3)*tensor1(3,3)

      tensor2(4,1)=vector(3)*tensor1(2,1)+vector(2)*tensor1(3,1)
      tensor2(4,2)=vector(3)*tensor1(2,2)+vector(2)*tensor1(3,2)
      tensor2(4,3)=vector(3)*tensor1(2,3)+vector(2)*tensor1(3,3)

      tensor2(5,1)=vector(3)*tensor1(1,1)+vector(1)*tensor1(3,1)
      tensor2(5,2)=vector(3)*tensor1(1,2)+vector(1)*tensor1(3,2)
      tensor2(5,3)=vector(3)*tensor1(1,3)+vector(1)*tensor1(3,3)

      tensor2(6,1)=vector(2)*tensor1(1,1)+vector(1)*tensor1(2,1)
      tensor2(6,2)=vector(2)*tensor1(1,2)+vector(1)*tensor1(2,2)
      tensor2(6,3)=vector(2)*tensor1(1,3)+vector(1)*tensor1(2,3)

   end subroutine

   subroutine GetStress_ut(ndime,tensor1,tensor2)
      integer(ip) :: ndime
      real(rp)    :: tensor1(ndime,ndime), tensor2(:,:)

      if (ndime == 2) call GetStress2D_ut(tensor1,tensor2)
      if (ndime == 3) call GetStress3D_ut(tensor1,tensor2)
   end subroutine

   subroutine AddSigmaGradVel_ut(ndime,tensor1,tensor2)
      integer(ip) :: ndime
      real(rp)    :: tensor1(ndime,ndime), tensor2(:,:)

      if (ndime == 2) call AddSigmaGradVel2D_ut(tensor1,tensor2)
      if (ndime == 3) call AddSigmaGradVel3D_ut(tensor1,tensor2)
   end subroutine

      subroutine GetGrVel_ut(ndime,vector,tensor1,tensor2)
      integer(ip) :: ndime
      real(rp)    :: vector(ndime,ndime), tensor1(ndime,ndime), tensor2(:,:)

      if (ndime == 2) call GetGrVel2D_ut(vector,tensor1,tensor2)
      if (ndime == 3) call GetGrVel3D_ut(vector,tensor1,tensor2)
   end subroutine

!------------------------------
! two vectors uv
!------------------------------

   subroutine GetVel2D_uv(tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(2,2), tensor2(2,2)

      tensor2(1,1) = tensor1(2,2)
      tensor2(1,2) = tensor1(2,1)
      tensor2(2,1) = tensor1(1,2)
      tensor2(2,2) = tensor1(1,1)
   end subroutine

     subroutine AddSphericalComponent2D_uv(value,tensor)
      implicit none
      real(rp) :: value(2)
      real(rp) :: tensor(2,2)

      tensor(1,1) = tensor(1,1) + value(1)
      tensor(2,2) = tensor(2,2) + value(2)

   end subroutine

    subroutine GetVel3D_uv(tensor1,tensor2)
      implicit none
      real(rp) :: tensor1(3,3), tensor2(3,3)

      tensor2(1,1) = tensor1(2,2) + tensor1(3,3)
      tensor2(1,2) = tensor1(2,1)
      tensor2(1,3) = tensor1(3,1)
      tensor2(2,1) = tensor1(1,2)
      tensor2(2,2) = tensor1(1,1) + tensor1(3,3)
      tensor2(2,3) = tensor1(3,2)
      tensor2(3,1) = tensor1(1,3)
      tensor2(3,2) = tensor1(2,3)
      tensor2(3,3) = tensor1(1,1) + tensor1(2,2)
   end subroutine

   subroutine AddSphericalComponent3D_uv(value,tensor)
      implicit none
      real(rp) :: value(3)
      real(rp) :: tensor(3,3)

      tensor(1,1) = tensor(1,1) + value(1)
      tensor(2,2) = tensor(2,2) + value(2)
      tensor(3,3) = tensor(3,3) + value(3)

   end subroutine

    subroutine GetVel_uv(ndime,tensor1,tensor2)
      integer(ip) :: ndime
      real(rp)    :: tensor1(ndime,ndime), tensor2(ndime,ndime)

      if (ndime == 2) call GetVel2D_uv(tensor1,tensor2)
      if (ndime == 3) call GetVel3D_uv(tensor1,tensor2)
   end subroutine

    subroutine AddSphericalComponent_uv(ndime,value,tensor1)
      integer(ip) :: ndime
      real(rp)    :: tensor1(ndime,ndime), value(ndime)

      if (ndime == 2) call AddSphericalComponent2D_uv(value,tensor1)
      if (ndime == 3) call AddSphericalComponent3D_uv(value,tensor1)
   end subroutine

!----------------------------
! rhu
! ----------------------------

   subroutine GetVel2D_hu(tensor,vector)
      implicit none
      real(rp) :: tensor(2,3), vector(2)

      vector(1) = tensor(1,1)+tensor(2,3)
      vector(2) = tensor(2,2)+tensor(1,3)
   end subroutine

   subroutine GetVel3D_hu(tensor,vector)
      implicit none
      real(rp) :: tensor(3,6), vector(3)

      vector(1) = tensor(1,1)+tensor(2,6)+tensor(3,5)
      vector(2) = tensor(1,6)+tensor(2,2)+tensor(3,4)
      vector(3) = tensor(1,5)+tensor(2,4)+tensor(3,3)
   end subroutine

    subroutine GetVel_hu(ndime,tensor,vector)
      integer(ip) :: ndime
      real(rp)    :: tensor(:,:), vector(ndime)

      if (ndime == 2) call GetVel2D_hu(tensor,vector)
      if (ndime == 3) call GetVel3D_hu(tensor,vector)
   end subroutine

!----------------------------
! rhc
! ----------------------------

   subroutine GetGrSig2D_hc(tensor,vector)
      implicit none
      real(rp) :: tensor(2,3), vector(3)

      vector(1) = tensor(1,1)+tensor(2,1)
      vector(2) = tensor(1,2)+tensor(2,2)
      vector(3) = 2.0_rp*(tensor(1,3)+tensor(2,3))
   end subroutine

   subroutine GetGrVel2D_hc(tensor,vector1,vector2)
      implicit none
      real(rp) :: tensor(2,2), vector1(3), vector2(3)

      vector2(1) = tensor(1,1)*vector1(1)+tensor(1,2)*vector1(3)
      vector2(2) = tensor(2,1)*vector1(3)+tensor(2,2)*vector1(2)
      vector2(3) = tensor(2,1)*vector1(1)+tensor(1,2)*vector1(2)
      !vector2(3) = tensor(2,1)*vector1(1)+tensor(1,2)*vector1(2)+(tensor(1,1)+tensor(2,2))*vector1(3)
   end subroutine

    subroutine GetStress2D_hc(auxPTT,tensor,vector)
      implicit none
      real(rp) :: tensor(3,3), vector(3)
      integer :: auxPTT
      vector(1) = auxPTT*(tensor(1,1)+tensor(3,3))+(1 - auxPTT)*(tensor(1,1)+tensor(1,2))
      vector(2) = auxPTT*(tensor(3,3)+tensor(2,2))+(1 - auxPTT)*(tensor(1,2)+tensor(2,2))
      vector(3) = 2.0_rp*(tensor(1,3)+tensor(2,3))
   end subroutine

    subroutine AddValues2D_hc(value,vector)
      implicit none
      real(rp) :: value(3), vector(3)
      vector(1) = vector(1) + value(1)
      vector(2) = vector(2) + value(2)
      vector(3) = vector(3) + 2.0_rp*value(3)
   end subroutine

   subroutine GetGrSig3D_hc(tensor,vector)
      use typre
      implicit none
      real(rp) :: tensor(3,6), vector(6)

      vector(1) = tensor(1,1)+tensor(2,1)+tensor(3,1)
      vector(2) = tensor(1,2)+tensor(2,2)+tensor(3,2)
      vector(3) = tensor(1,3)+tensor(2,3)+tensor(3,3)
      vector(4) = 2.0_rp*(tensor(1,4)+tensor(2,4)+tensor(3,4))
      vector(5) = 2.0_rp*(tensor(1,5)+tensor(2,5)+tensor(3,5))
      vector(6) = 2.0_rp*(tensor(1,6)+tensor(2,6)+tensor(3,6))
   end subroutine

   subroutine GetGrVel3D_hc(tensor,vector1,vector2)
      use typre
      implicit none
      real(rp) :: tensor(3,3), vector1(6), vector2(6)

      vector2(1) = tensor(1,1)*vector1(1)+tensor(1,2)*vector1(6)+tensor(1,3)*vector1(5)
      vector2(2) = tensor(2,1)*vector1(6)+tensor(2,2)*vector1(2)+tensor(2,3)*vector1(4)
      vector2(3) = tensor(3,1)*vector1(5)+tensor(3,2)*vector1(4)+tensor(3,3)*vector1(3)
      vector2(4) = tensor(3,1)*vector1(6)+tensor(3,2)*vector1(2)+(tensor(3,3)+tensor(2,2))*vector1(4)+vector1(5)*tensor(2,1)+vector1(3)*tensor(2,3)
      vector2(5) = tensor(3,1)*vector1(1)+tensor(3,2)*vector1(6)+(tensor(3,3)+tensor(1,1))*vector1(5)+vector1(4)*tensor(1,2)+vector1(3)*tensor(1,3)
      vector2(6) = tensor(2,1)*vector1(1)+tensor(1,2)*vector1(2)+(tensor(2,2)+tensor(1,1))*vector1(6)+vector1(5)*tensor(2,3)+vector1(4)*tensor(1,3)

   end subroutine

    subroutine GetStress3D_hc(auxPTT,tensor,vector)
      use typre
      implicit none
      real(rp) :: tensor(6,6), vector(6)
      integer :: auxPTT
      vector(1) = tensor(1,1)+auxPTT*(tensor(6,6)+tensor(5,5))
      vector(2) = tensor(2,2)+auxPTT*(tensor(6,6)+tensor(4,4))
      vector(3) = tensor(3,3)+auxPTT*(tensor(5,5)+tensor(4,4))
      vector(4) = (1 + auxPTT)*(tensor(2,4)+tensor(3,4))+2.0_rp*auxPTT*tensor(6,5)
      vector(5) = (1 + auxPTT)*(tensor(1,5)+tensor(3,5))+2.0_rp*auxPTT*tensor(4,6)
      vector(6) = (1 + auxPTT)*(tensor(1,6)+tensor(2,6))+2.0_rp*auxPTT*tensor(4,5)
   end subroutine

   subroutine AddValues3D_hc(value,vector)
      use typre
      implicit none
      real(rp) :: value(6), vector(6)
      vector(1:3) = vector(1:3) + value(1:3)
      vector(4:6) = vector(4:6) + 2.0_rp*value(4:6)
   end subroutine

   subroutine GetGrSig_hc(ndime,tensor,vector)
      integer(ip) :: ndime
      real(rp)    :: tensor(:,:), vector(:)

      if (ndime == 2) call GetGrSig2D_hc(tensor,vector)
      if (ndime == 3) call GetGrSig3D_hc(tensor,vector)
   end subroutine

    subroutine GetGrVel_hc(ndime,tensor,vector1,vector2)
      use typre
      implicit none
      integer(ip) :: ndime
      real(rp) :: tensor(:,:)
      real(rp) :: vector1(:), vector2(:)
      if (ndime == 2) call GetGrVel2D_hc(tensor,vector1,vector2)
      if (ndime == 3) call GetGrVel3D_hc(tensor,vector1, vector2)
   end subroutine

    subroutine GetStress_hc(ndime,auxPTT,tensor,vector)
      use typre
      implicit none
      integer(ip) ::   ndime
      real(rp) :: tensor(:,:), vector(:)
      integer :: auxPTT
      if (ndime == 2) call GetStress2D_hc(auxPTT,tensor,vector)
      if (ndime == 3) call GetStress3D_hc(auxPTT,tensor,vector)
   end subroutine

    subroutine AddValues_hc(ndime,value,vector)
      use typre
      implicit none
      integer(ip) ::  auxPTT, ndime
      real(rp) :: value(:), vector(:)
      if (ndime == 2) call AddValues2D_hc(value,vector)
      if (ndime == 3) call AddValues3D_hc(value,vector)
   end subroutine

   subroutine GetGrVel_hu(ndime,tensor,vector)
      use typre
      integer(ip) ::  ndime, itens
      real(rp)    ::  vector(ndime), tensor(ndime,ndime)
       vector=0.0_rp
       do itens=1,ndime
            vector(:)=tensor(:,itens)+vector(:)
        end do
   end subroutine

    subroutine GetGrVel(ndime,vector1,vector2)
      use typre
      integer(ip) ::  ndime, itens
      real(rp)    ::  vector1(ndime), vector2(ndime)
       !vector2=0.0_rp
       do itens=1,ndime
            vector2(itens)=vector1(itens)+vector2(itens)
        end do
   end subroutine

   subroutine GetPlus(ndime,vector,value)
      use typre
      integer(ip) ::  ndime, itens
      real(rp)    ::  vector(ndime), value
       value=0
       value=sum(vector(1:ndime))
   end subroutine

!***************************************************************************
! LCR RELATIONS
!***************************************************************************

   subroutine PassTensor4ToTensor2(e,tens,Tensor4,Tensor2)
      implicit none
      class(FiniteElement) :: e
      integer(ip) :: h,s,t, tens
      real(rp) :: Tensor4(e%ndime,e%ndime,e%ndime,e%ndime)
      real(rp) :: Tensor2(tens,tens)
      real(rp) :: vector1(tens), vector2(tens)
      real(rp) :: tens_stress(e%ndime,e%ndime)
      real(rp) :: tensor_aux2(e%ndime,e%ndime,(e%ndime-1)*(e%ndime-1)+2)

      do s=1,e%ndime
         do t=1,e%ndime
            tens_stress(:,:)=Tensor4(s,t,:,:)
            call GetStress(e%ndime,tens_stress,vector1)
            tensor_aux2(s,t,:)=vector1(:)
         end do
      end do

       do h=1,tens
         tens_stress(:,:)=tensor_aux2(:,:,h)
         call GetStress(e%ndime,tens_stress,vector2)
         Tensor2(:,h)=vector2(:)
       end do

   end subroutine

   subroutine PassTensor3ToTensor2Left(e,tens,Tensor3,Tensor2)
      implicit none
      class(FiniteElement) :: e
      integer(ip) :: h,s,t, tens
      real(rp) :: Tensor3(e%ndime,e%ndime,e%ndime)
      real(rp) :: vector(tens)
      real(rp) :: Tensor2(tens,e%ndime)
      real(rp) :: tens_stress(e%ndime,e%ndime)

      do h=1,e%ndime
         tens_stress(:,:)=Tensor3(:,:,h)
         call GetStress(e%ndime,tens_stress,vector)
         Tensor2(:,h)=vector(:)
      end do

   end subroutine

   subroutine PassTensor3ToTensor2Left_sym(e,tens,Tensor3,Tensor2)
      implicit none
      class(FiniteElement) :: e
      integer(ip) :: h,s,t, tens
      real(rp) :: Tensor3(e%ndime,e%ndime,e%ndime)
      real(rp) :: vector(tens)
      real(rp) :: Tensor2(tens,e%ndime)
      real(rp) :: tens_stress(e%ndime,e%ndime)

      do h=1,e%ndime
         tens_stress(:,:)=Tensor3(:,:,h)
!          call GetStress_sym(e%ndime,tens_stress,vector)
         call PassSymMatrixToVector(e%ndime,tens,tens_stress,vector)
         Tensor2(:,h)=vector(:)
      end do

   end subroutine

    subroutine PassTensor3ToTensor2Right(e,tens,Tensor3,Tensor2)
      implicit none
      class(FiniteElement) :: e
      integer(ip) :: h, tens
      real(rp) :: Tensor3(e%ndime,e%ndime,e%ndime)
      real(rp) :: Tensor2(e%ndime,tens)
      real(rp) :: vector(tens)
      real(rp) :: tens_stress(e%ndime,e%ndime)

      do h=1,e%ndime
         tens_stress(:,:)=Tensor3(h,:,:)
         call GetStress(e%ndime,tens_stress,vector)
         Tensor2(h,:)=vector(:)
      end do

   end subroutine

   subroutine PassGradStressToTensor3(e,tens,Grsig,Tensor3)
      implicit none
      class(FiniteElement) :: e
      integer(ip), intent(in) ::tens
      real(rp), intent(in) :: Grsig(tens,e%ndime)
      real(rp) , intent(out) :: Tensor3(e%ndime,e%ndime,e%ndime)
      real(rp) :: tens_stress(e%ndime,e%ndime),vector(tens)
      integer(ip) :: h,i,j

      do h=1,e%ndime
         vector(:)=Grsig(:,h)
         call sup_SigmaMatrix(e%ndime,tens,vector,tens_stress)
         do concurrent (i=1:e%ndime)
            Tensor3(:,i,h)=tens_stress(:,i)
         end do
      end do

   end subroutine

   subroutine PassSymMatrixToVector(ndime,tens,Matrix,Vector)
      implicit none
      integer(ip), intent(in) ::tens,ndime
      real(rp), intent(in) :: Matrix(ndime,ndime)
      real(rp) , intent(out) :: Vector(tens)
      integer(ip) :: h,i,j

      do i=1,ndime
         Vector(i)=Matrix(i,i)
      end do

      if (ndime==2) then
         Vector(3)=Matrix(1,2)
      else if (ndime==3) then
         Vector(4)=Matrix(2,3)
         Vector(5)=Matrix(1,3)
         Vector(6)=Matrix(1,2)
      end if

   end subroutine

   subroutine PassGradStressToTensor3B(ndime,tens,Grsig,Tensor3)
      implicit none
      integer(ip), intent(in) ::tens,ndime
      real(rp), intent(in) :: Grsig(tens,ndime)
      real(rp) , intent(out) :: Tensor3(ndime,ndime,ndime)
      real(rp) :: tens_stress(ndime,ndime),vector(tens)
      integer(ip) :: h,i,j

      do h=1,ndime
         vector(:)=Grsig(:,h)
         call sup_SigmaMatrix(ndime,tens,vector,tens_stress)
         do concurrent (i=1:ndime)
               Tensor3(:,i,h)=tens_stress(:,i)
         end do
      end do

   end subroutine

end module