! Advent of Code 2021 : https://adventofcode.com/2021
! Puzzle for Day 05 part 02 :
! Build with:  gfortran -static-libgcc -o aoc_day05_p2 aoc_day05_p2.f90

program aoc_day05_p2

	use, intrinsic :: iso_fortran_env
	implicit none

	! Declare and set constants the AOC day and part
	integer,parameter :: day = 5, part = 2

	! Declare file related variables
	character(len=*), parameter :: filename = "day05-input.txt"
	character(len=*), parameter :: error1 = "file: '"//''//filename//''//"' not found"

	! Variables to track and manage the program
	integer :: total_lines = 0  ! total number of vent lines in input file
	integer :: i,j,k,m  ! do loop variables

	! Arrays to manage the vent lines and to track intersections
	integer, allocatable :: begin_xy(:,:), end_xy(:,:)
	integer, allocatable :: p1_intersect(:,:)
	integer, allocatable :: p2_intersect(:,:)

	! Output startup message
	call display_welcome(day,part)

	if (.NOT. file_exists(filename)) stop error1
	total_lines = get_line_count(filename)
	write(*,'(A,I0)') " » Total line vent entries: ",total_lines

	call get_vent_lines(filename, total_lines, begin_xy, end_xy)

	j=max(maxval(begin_xy(1,:)),maxval(end_xy(1,:)))
	k=max(maxval(begin_xy(2,:)),maxval(end_xy(2,:)))

	allocate(p1_intersect(j,k))
	allocate(p2_intersect(j,k))

	p1_intersect = 0
	p2_intersect = 0

	do i=1,total_lines
		if (begin_xy(1,i) .eq. end_xy(1,i)) then
			j=min(begin_xy(2,i),end_xy(2,i))
			k=max(begin_xy(2,i),end_xy(2,i))
			p1_intersect(begin_xy(1,i),j:k) = p1_intersect(begin_xy(1,i),j:k) + 1
		else if (begin_xy(2,i) .eq. end_xy(2,i)) then
			j=min(begin_xy(1,i),end_xy(1,i))
			k=max(begin_xy(1,i),end_xy(1,i))
			p1_intersect(j:k,begin_xy(2,i)) = p1_intersect(j:k,begin_xy(2,i)) + 1
		else
			j = 1
			k = 1
			if (begin_xy(1,i) .gt. end_xy(1,i)) j = -1
			if (begin_xy(2,i) .gt. end_xy(2,i)) k = -1
			! PART 2
			do m = 0, abs(begin_xy(1,i) - end_xy(1,i))
				p2_intersect(begin_xy(1,i) + (m * j), begin_xy(2,i) + (m * k)) = &
				p2_intersect(begin_xy(1,i) + (m * j), begin_xy(2,i) + (m * k)) + 1
			end do
		end if
	end do

	write (*,'(A,I0)') " » Horizontal and vertical lines where > two vent lines cross (Part 1): ", count(p1_intersect .gt. 1)
	write (*,'(A,I0)') " » Points where all vent lines cross (Part 2): ", count((p1_intersect + p2_intersect) .gt. 1)

	print *, ""

	deallocate(begin_xy)
	deallocate(end_xy)
	deallocate(p1_intersect)
	deallocate(p2_intersect)

contains

	! Display the AoC puzzle day and part being resolved
	subroutine display_welcome(day,part)
		implicit none
		integer, intent(in) :: day,part
		print *,""
		write (*,'(A,I2.2,A,I2.2)') "AoC 2021 - solution for Day ",day," part ",part
		print *,""
	end subroutine display_welcome

	! Check input filename exists
	function file_exists(filename) result (exists)
		implicit none
		character(len=*), intent(in) :: filename
		logical :: exists ! variable for the return.  NB: no intent(out) needed.

		inquire(file=filename, exist=exists)
	end function file_exists

	! Open the file and count the number of line vents it contains
    function get_line_count(filename) result (lines)
        implicit none
        character(len=*), intent(in) :: filename
        integer :: fileunit,io
        integer :: lines

        open(newunit=fileunit, file=filename, action='read', position='rewind')
        lines = 0
        do
            read(fileunit,*,iostat=io)
            if ( io /= 0 ) exit
            lines = lines + 1
        end do
        close(fileunit)
    end function get_line_count

    ! Read in the vent lines X1,Y1 and X2,Y2 coordinates from puzzle data source file
    subroutine get_vent_lines(filename, total_lines, begin_xy, end_xy)
        character(len=*), intent(in) :: filename
        integer, intent(in) :: total_lines
        integer, allocatable, intent(inout) :: begin_xy(:,:), end_xy(:,:)
        integer :: fileunit, io, i
        character(len=2) :: A   ! account for '->' separator in in file

        open(newunit=fileunit, file=filename, action='read', position='rewind')

        allocate(begin_xy(2,total_lines))
        allocate(end_xy(2,total_lines))

        do i=1,total_lines
            read(fileunit,*) begin_xy(:,i),A,end_xy(:,i)
        end do

        close(fileunit)
    end subroutine get_vent_lines

end program aoc_day05_p2


*DECK XPMUP
      SUBROUTINE XPMUP (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR)
C***BEGIN PROLOGUE  XPMUP
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for XLEGF.
C            This subroutine transforms an array of Legendre functions
C            of the first kind of negative order stored in array PQA
C            into Legendre functions of the first kind of positive
C            order stored in array PQA. The original array is destroyed.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      SINGLE PRECISION (XPMUP-S, DXPMUP-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  XADJ
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  XPMUP
      REAL DMU,NU,NU1,NU2,PQA,PROD
      DIMENSION PQA(*),IPQA(*)
C***FIRST EXECUTABLE STATEMENT  XPMUP
      IERROR=0
      NU=NU1
      MU=MU1
      DMU=MU
      N=INT(NU2-NU1+.1)+(MU2-MU1)+1
      J=1
      IF(MOD(NU,1.).NE.0.) GO TO 210
  200 IF(DMU.LT.NU+1.) GO TO 210
      PQA(J)=0.
      IPQA(J)=0
      J=J+1
      IF(J.GT.N) RETURN
C        INCREMENT EITHER MU OR NU AS APPROPRIATE.
      IF(NU2-NU1.GT..5) NU=NU+1.
      IF(MU2.GT.MU1) MU=MU+1
      GO TO 200
C
C        TRANSFORM P(-MU,NU,X) TO P(MU,NU,X) USING
C        P(MU,NU,X)=(NU-MU+1)*(NU-MU+2)*...*(NU+MU)*P(-MU,NU,X)*(-1)**MU
C
  210 PROD=1.
      IPROD=0
      K=2*MU
      IF(K.EQ.0) GO TO 222
      DO 220 L=1,K
      PROD=PROD*(DMU-NU-L)
  220 CALL XADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
  222 CONTINUE
      DO 240 I=J,N
      IF(MU.EQ.0) GO TO 225
      PQA(I)=PQA(I)*PROD*(-1)**MU
      IPQA(I)=IPQA(I)+IPROD
      CALL XADJ(PQA(I),IPQA(I),IERROR)
      IF (IERROR.NE.0) RETURN
  225 IF(NU2-NU1.GT..5) GO TO 230
      PROD=(DMU-NU)*PROD*(-DMU-NU-1.)
      CALL XADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
      MU=MU+1
      DMU=DMU+1.
      GO TO 240
  230 PROD=PROD*(-DMU-NU-1.)/(DMU-NU-1.)
      CALL XADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
      NU=NU+1.
  240 CONTINUE
      RETURN
      END


program ex10

    use utils

    implicit none

    real(rk) :: r
    integer  :: v

    call initRand()
    call randVal(r, 0.0_rk, 1.0_rk)

    v = nint(50.0_rk - 100.0_rk * r)

    print*, v

    select case (v)
    case (:-20)
        print*, "v <= -1"
    case (0)
        print*, "v == 0"
    case (20:)
        print*, "v >=1"
    case default
        print*, "v is in the default range"
    end select

end program ex10


C$Procedure      PL2NVP ( Plane to normal vector and point )

      SUBROUTINE PL2NVP ( PLANE, NORMAL, POINT )

C$ Abstract
C
C     Return a unit normal vector and point that define a specified
C     plane.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     PLANES
C
C$ Keywords
C
C     GEOMETRY
C     MATH
C     PLANE
C
C$ Declarations

      INTEGER               UBPL
      PARAMETER           ( UBPL   =    4 )

      DOUBLE PRECISION      PLANE  ( UBPL )
      DOUBLE PRECISION      NORMAL (    3 )
      DOUBLE PRECISION      POINT  (    3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     PLANE      I   A SPICELIB plane.
C     NORMAL,
C     POINT      O   A unit normal vector and point that define PLANE.
C
C$ Detailed_Input
C
C     PLANE          is a SPICELIB plane.
C
C$ Detailed_Output
C
C     NORMAL,
C     POINT          are, respectively, a unit normal vector and point
C                    that define the geometric plane represented by
C                    PLANE.  Let the symbol < a, b > indicate the inner
C                    product of vectors a and b; then the geometric
C                    plane is the set of vectors X in three-dimensional
C                    space that satisfy
C
C                       < X - POINT, NORMAL >  =  0.
C
C                    POINT is always the closest point in the input
C                    plane to the origin.  POINT is always a
C                    non-negative scalar multiple of NORMAL.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)  The input plane MUST have been created by one of the SPICELIB
C         routines
C
C            NVC2PL ( Normal vector and constant to plane )
C            NVP2PL ( Normal vector and point to plane    )
C            PSV2PL ( Point and spanning vectors to plane )
C
C         Otherwise, the results of this routine are unpredictable.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     SPICELIB geometry routines that deal with planes use the `plane'
C     data type to represent input and output planes.  This data type
C     makes the subroutine interfaces simpler and more uniform.
C
C     The SPICELIB routines that produce SPICELIB planes from data that
C     define a plane are:
C
C        NVC2PL ( Normal vector and constant to plane )
C        NVP2PL ( Normal vector and point to plane    )
C        PSV2PL ( Point and spanning vectors to plane )
C
C     The SPICELIB routines that convert SPICELIB planes to data that
C     define a plane are:
C
C        PL2NVC ( Plane to normal vector and constant )
C        PL2NVP ( Plane to normal vector and point    )
C        PL2PSV ( Plane to point and spanning vectors )
C
C$ Examples
C
C     1)  Given a plane normal and constant, find a point in
C         the plane.  POINT is the point we seek.
C
C            CALL NVC2PL ( NORMAL, CONST,  PLANE )
C            CALL PL2NVP ( PLANE,  NORMAL, POINT )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] `Calculus and Analytic Geometry', Thomas and Finney.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 01-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     plane to normal vector and point
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      CONST

C
C     Find a unit normal and constant for the plane.  Scaling the
C     unit normal by the constant gives us the closest point in
C     the plane to the origin.
C
      CALL PL2NVC ( PLANE, NORMAL, CONST )
      CALL VSCL   ( CONST, NORMAL, POINT )

      RETURN
      END


!+---------+---------+---------+---------+---------+---------+--------+!
! this subroutine is used to calculate surface state using             !
! green's function method  ---  J.Phys.F.Met.Phys.15(1985)851-858      !
!
! History:
!         by Quan Sheng Wu on 4/20/2010                                !
!            mpi version      4/21/2010
!         Ca3PbO version     11/12/2011
!+---------+---------+---------+---------+---------+---------+--------+!
  subroutine fermiarc

     use mpi
     use para
     implicit none

     integer :: ierr

! general loop index
     integer :: i,j

     integer :: nkx
     integer :: nkz

! kpoint loop index
     integer :: ikp

     real(dp) :: k1(2)
     real(dp) :: k2(2)
     real(dp) :: k(2)

     real(dp) :: kxmin, kxmax, kzmin, kzmax, omega
     real(dp) :: kxmin_shape, kxmax_shape, kzmin_shape, kzmax_shape

     real(dp), allocatable :: kxz(:,:)
     real(dp), allocatable :: kxz_shape(:,:)

     real(dp), allocatable :: dos(:)
     real(dp), allocatable :: dos_mpi(:)

     complex(dp), allocatable :: ones(:,:)
     complex(dp), allocatable :: GLL(:,:), GRR(:,:)
     complex(dp), allocatable :: H00(:,:), H01(:,:)

     nkx = Nk
     nkz = Nk

     allocate( kxz(2, nkx*nkz))
     allocate( kxz_shape(2, nkx*nkz))
     allocate( dos(nkx*nkz))
     allocate( dos_mpi(nkx*nkz))
     allocate( GLL(ndim,ndim), GRR(ndim,ndim))
     kxz=0d0
     kxz_shape=0d0
     dos=0d0
     dos_mpi=0d0

     kzmin=-0.50d0/1d0
     kzmax= 0.50d0/1d0
     kxmin=-0.50d0/1d0
     kxmax= 0.50d0/1d0
     ikp=0
     do i= 1, nkx
     do j= 1, nkz
        ikp=ikp+1
        kxz(1, ikp)=kxmin+ (i-1)*(kxmax-kxmin)/dble(nkx-1)
        kxz(2, ikp)=kzmin+ (j-1)*(kzmax-kzmin)/dble(nkz-1)
        kxz_shape(:, ikp)= kxz(1, ikp)* Ka2+ kxz(2, ikp)* Kb2
     enddo
     enddo

     k1= kxmin*Ka2+ kzmin*Kb2
     k2= kxmax*ka2+ kzmax*kb2
     kxmin_shape= min(k1(1), k2(1))
     kzmin_shape= min(k1(2), k2(2))
     kxmax_shape= max(k1(1), k2(1))
     kzmax_shape= max(k1(2), k2(2))

     allocate(H00(Ndim, Ndim))
     allocate(H01(Ndim, Ndim))
     allocate(ones(Ndim, Ndim))
     GLL= 0d0
     GRR= 0d0
     H00= 0d0
     H01= 0d0
     ones= 0d0

     do i=1,Ndim
        ones(i,i)=1.0d0
     enddo

     omega = E_arc
     eta= eta_arc

     do ikp= 1+cpuid, nkx*nkz, num_cpu
        if (cpuid==0) write(stdout, *) 'Arc', ikp, nkx*nkz
        k(1)= kxz(1, ikp)
        k(2)= kxz(2, ikp)

        call ham_qlayer2qlayer(k,H00,H01)

        !> calculate surface green function
        ! there are two method to calculate surface green's function
        ! the method in 1985 is better, you can find the ref in the
        ! subroutine
        call surfgreen_1985(omega,GLL,GRR,H00,H01,ones)
        ! call surfgreen_1984(omega,GLL,GRR,H00,H01,ones)

        ! calculate spectral function
        do i= 1, ndim
           dos(ikp)=dos(ikp)- aimag(GLL(i,i))
        enddo
     enddo

     !> we don't have to do allreduce operation
     call mpi_reduce(dos, dos_mpi, size(dos),mpi_double_precision,&
                     mpi_sum, 0, mpi_comm_world, ierr)

     if (cpuid.eq.0)then
        open (unit=12, file='arc.dat_l')
        do ikp=1, nkx*nkz
           write(12, '(3f16.8)')kxz_shape(:, ikp), log(dos_mpi(ikp))
           if (mod(ikp, nkz)==0) write(12, *)' '
        enddo
        close(12)
        write(stdout,*)'ndim',ndim
        write(stdout,*) 'Nkx,Nkz,eta',Nkx, Nkz, eta
        write(stdout,*)'calculate density of state successfully'
     endif

     !> write script for gnuplot
     if (cpuid==0) then
        open(unit=101, file='arc_l.gnu')
        write(101, '(a)')'#set terminal  postscript enhanced color'
        write(101, '(a)')"#set output 'arc_l.eps'"
        write(101, '(3a)')'set terminal  png truecolor enhanced', &
           ' transparent font Monaco giant size 3840, 3360'
        write(101, '(a)')"set output 'arc_l.png'"
        write(101,'(2a)') '#set palette defined ( -10 "green", ', &
           '0 "yellow", 10 "red" )'
        write(101, '(a)')'set palette rgbformulae 33,13,10'
        write(101, '(a)')'unset ztics'
        write(101, '(a)')'unset key'
        write(101, '(a)')'set pm3d'
        write(101, '(a)')'set view equal xyz'
        write(101, '(a)')'set view map'
        write(101, '(a)')'#set xtics font ",24"'
        write(101, '(a)')'#set ytics font ",24"'
        write(101, '(a)')'unset xtics'
        write(101, '(a)')'unset ytics'
        write(101, '(a)')'unset colorbox'
        write(101, '(a, f8.5, a, f8.5, a)')'set xrange [', kxmin_shape, ':', kxmax_shape, ']'
        write(101, '(a, f8.5, a, f8.5, a)')'set yrange [', kzmin_shape, ':', kzmax_shape, ']'
        write(101, '(a)')'set pm3d interpolate 2,2'
        write(101, '(2a)')"splot 'arc.dat_l' u 1:2:3 w pm3d"

     endif

  return
  end subroutine


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZUFGRD (Zomplex Unitary hessenberg Factored Givens Rotation Deflation)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks for deflations in a unitary upper hessenberg
! matrix that is stored as a product of givens rotations and a complex
! diagonal matrix. When a deflation occurs the corresponding rotation
! is set to the identity matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  STR             INTEGER
!                    index of the top most givens rotation where
!                    deflation should be checked
!
!  STP             INTEGER
!                    index of the bottom most givens rotation where
!                    deflation should be checked
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for givens rotations
!                    generators must be orthogonal to working precision
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    generators must be orthogonal to working precision
!
!  ITCNT           INTEGER
!                    number of iterations since last deflation
!
! OUTPUT VARIABLES:
!
!  ZERO            INTEGER
!                     index of the last known deflation
!                     on output contains index of newest deflation
!
!  ITS             INTEGER array of dimension (N-1)
!                    Contains the number of iterations per deflation
!
!  INFO            INTEGER
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies N is invalid
!                   INFO = -2 implies STR is invalid
!                   INFO = -3 implies STP is invalid
!                   INFO = -4 implies ZERO is invalid
!                   INFO = -7 implies ITCNT is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZUFGRD(N,STR,STP,ZERO,Q,D,ITCNT,ITS,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  integer, intent(inout) :: STR, STP, ZERO, ITCNT, INFO
  real(8), intent(inout) :: Q(3*(N-1)), D(2*N)
  integer, intent(inout) :: ITS(N-1)

  ! compute variables
  integer :: ii, ind1, ll, jj, k
  real(8), parameter :: tol = epsilon(1d0)
  real(8) :: d1r, d1i, c1r, c1i, s, nrm

  ! initialize info
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check N
    call IARNAN(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-1)
      return
    end if
    call IARINF(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-1)
      return
    end if
    if (N < 2) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
      return
    end if

    ! check STR
    if ((STR < 1).OR.(STR > N-1)) then
      INFO = -2
      call UARERR(__FILE__,__LINE__,"STR must 1 <= STR <= N-1",INFO,INFO)
      return
    end if

    ! check STP
    if ((STP < STR).OR.(STP > N-1)) then
      INFO = -3
      call UARERR(__FILE__,__LINE__,"STP must STR <= STP <= N-1",INFO,INFO)
      return
    end if

    ! check ZERO
    if ((ZERO >= STR).OR.(ZERO < 0)) then
      INFO = -4
      call UARERR(__FILE__,__LINE__,"ZERO must 0 <= ZERO < STR",INFO,INFO)
      return
    end if

    ! check ITCNT
    call IARNAN(ITCNT,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"ITCNT is invalid",INFO,-7)
      return
    end if
    call IARINF(ITCNT,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"ITCNT is invalid",INFO,-7)
      return
    end if
    if (ITCNT < 0) then
      INFO = -7
      call UARERR(__FILE__,__LINE__,"ITCNT must be non-negative",INFO,INFO)
      return
    end if

  end if

  ! check for deflation
  do ii=1,(STP-STR+1)

    ! one less than the index of the rotaion being checked
    ind1 = 3*(STP-ii)

    ! deflate if subdiagonal is small enough
    nrm = abs(Q(ind1+3))
    if(nrm < tol)then

      ! set sub-diagonal to 0
      Q(ind1+3) = 0d0

      ! update first diagonal
      c1r = Q(ind1+1)
      c1i = Q(ind1+2)
      Q(ind1+1) = 1d0
      Q(ind1+2) = 0d0

      ind1 = 2*(STP-ii)
      d1r = D(ind1+1)
      d1i = D(ind1+2)

      nrm = c1r*d1r - c1i*d1i
      d1i = c1r*d1i + c1i*d1r
      d1r = nrm
      nrm = sqrt(d1r*d1r + d1i*d1i)
      if (nrm.NE.0) then
        d1r = d1r/nrm
        d1i = d1i/nrm
      else
        d1r = 0d0
        d1i = 0d0
      end if

      D(ind1+1) = d1r
      D(ind1+2) = d1i

      ! 1x1 deflation
      if(ii == 1)then

        ! update second diagonal
        ind1 = 2*(STP-ii)
        d1r = D(ind1+3)
        d1i = D(ind1+4)

        nrm = c1r*d1r + c1i*d1i
        d1i = c1r*d1i - c1i*d1r
        d1r = nrm
        nrm = sqrt(d1r*d1r + d1i*d1i)
        d1r = d1r/nrm
        d1i = d1i/nrm

        D(ind1+3) = d1r
        D(ind1+4) = d1i

        ! 2x2 or bigger
        else

          ! update Q
          do ll=(STP+1-ii),(STP-1)
            ind1 = 3*(ll)
            d1r = Q(ind1+1)
            d1i = Q(ind1+2)
            s = Q(ind1+3)

            nrm = c1r*d1r + c1i*d1i
            d1i = c1r*d1i - c1i*d1r
            d1r = nrm
            nrm = sqrt(d1r*d1r + d1i*d1i + s*s)
            d1r = d1r/nrm
            d1i = d1i/nrm
            s = s/nrm

            Q(ind1+1) = d1r
            Q(ind1+2) = d1i
            Q(ind1+3) = s
          end do

          ! update second diagonal
          ind1 = 2*(STP)
          d1r = D(ind1+1)
          d1i = D(ind1+2)

          nrm = c1r*d1r + c1i*d1i
          d1i = c1r*d1i - c1i*d1r
          d1r = nrm
          nrm = sqrt(d1r*d1r + d1i*d1i)
          d1r = d1r/nrm
          d1i = d1i/nrm

          D(ind1+1) = d1r
          D(ind1+2) = d1i
        end if

        ! update indices
        ZERO = STP+1-ii
        STR = ZERO + 1

        ! store it_count
        ITS(ZERO) = ITCNT
        ITCNT = 0

        exit
     end if
  end do

end subroutine ZUFGRD


c=======================================================================
c subroutine GTN : Material model according to GURSON, TVERGAARD AND
c NEEDLEMAN (GTN) DAMAGE MODEL
c-----------------------------------------------------------------------
c  This subroutine implement the nmerical solution for the GURSON,
c TVERGAARD AND NEEDLEMAN (GTN) DAMAGE MODEL according to the N.Aravas
c  article.
c-----------------------------------------------------------------------
c Version 0.9.3
c Oct 2021
c-----------------------------------------------------------------------

c Inputs
c   eps6 :epsilon ( current total strain in the form of a vector, latter
c         is trasformed to matrix form, the vector comes from the history
c          of the properties for the material)
c   sdvl : internal state variables (in the form of a vector, contains 3
c          ISV`(plastic strain, tensorial internal variable alpha,
c          scalar hardening variable alpha)
c   Options
c      options(1) : type of tangent stiffnes computation
c              0: analytical
c              1: numerical
c      options(2): stress_case
c              0: 3D
c              1: Plane stress
c      options(3): Material law
c              0: Von Mises
c              1: GTN
c  inputmat: vector with the material's intrinsic properties.
c-----------------------------------------------------------------
c Outputs

c   sig6:  sigma_n+1 (stress at n+1 as a vector)
c   A66:   algritmic tangent stiffness (ATS) tensor(4 grade tensor as a
c          6x6 tensor)
c   sdvup: Updated Internal state variables (the updated 3 ISV of the s
c          dvl input vector)
c==================================================================

      subroutine kGTN (eps6,D_eps6,sdvl,options,inputmat,sig6,A66,sdvup)
       !eps,epsn,epsen
c       INCLUDE 'ABA_PARAM.INC'
        use tensor_operations

        implicit none
c         material parameters
        external plas_corre_GTN
        double precision, dimension(6) :: eps6, D_eps6, epsn6
        double precision, dimension(3,3) :: eps, D_eps, epsn, sig
c             double precision, dimension(:),intent(in) :: sdvl
        double precision, dimension(21) :: sdvl
        double precision, dimension(21) :: sdvup
        double precision, dimension(15):: inputmat
        double precision :: xE     ! Young's modulus
        double precision :: xnu    ! Poisson's ratio
        double precision :: xsigy0 ! initial yield stress
        double precision :: xHk    ! kinematic hardening modulus
        double precision :: xhi     ! isotropic hardening modulus
        double precision :: xmu    !shear modulus
        double precision :: xk     ! bulk modulus
        double precision :: q1, q2, q3, f_0, f_n, s_n, E_n, f_c, NU !Parameters GTN model
        double precision, dimension (3,3) :: epspn, epsp, epse,epsen   !plastic and elastic strain at t0 and t1
        double precision, dimension (3,3):: Balphan, Balpha ! (B=bold= Tensor)strain-like ISV that thermodynamically conjugates to the kinematic hardening at time 0 (input) and t+1 (output)
        double precision :: alphan, alpha, fn, f, epsp_b, epsp_b_n !(scalar) strain-like ISV that thermodynamically conjugates to the Isotropic hardening at time t (input) and t+1 (output)
        double precision, dimension(6,6) :: A66
        double precision, dimension(6) :: sig6
        double precision, dimension (3,3)::sigtr, dsigtr !deviatoric part of the trial stress tensor
        double precision, dimension (3,3)::dsig !deviatoric part of the stress tensor
        double precision, dimension (3,3)::d_epsp  !<----New
        double precision, dimension(3,3,3,3):: P4sym_r !Fouth order identity tensor and deviatoriser tensor
        double precision, dimension(3,3,3,3)::C, Cdev, C_e  !Elasticity tensor
        double precision , dimension (3,3) :: ntr, nxi_a !flow direction from trial state
        double precision :: nxitr !norm of xitr (norm of relative stress tensor)
        double precision :: phitr,q_tr,p_tr !elastic predictor (or trial stress)
        double precision :: Beta1, Beta2 !Term for the ATS
        double precision :: gamma !incremental plastic multiplier

c-------------------Auxiliary variables---------------------------------
        double precision :: tol =1e-8
        integer, dimension (6) :: ii = (/1,2,3,1,2,1/) !Auxiliar iterators
        integer, dimension (6) :: jj = (/1,2,3,2,3,3/) !Auxiliar iterators
        integer, dimension (3) ::ii_PS = (/1,2,2/)
        integer, dimension (3) ::jj_PS = (/1,2,1/)
        integer ::i, j, ATStype, Mat_L, str_case, rec,pru !Iterators and selectors
        integer, dimension (3) :: options
        double precision, dimension (3,3):: xid !Identity
        real:: e, t1(2), t2(2)
        double precision:: time_su (5,2)
c  Especific variables according to the article N. ARAVAS, 1987
       double precision :: q, p, sig_0, d_sig_0_d_epsp_b
       double precision, dimension (3,3) :: D_eps3
c        s_ve_33
       double precision ::D_eps_p, D_eps_q  !p: hydrotatyx stress and equivalent stress
       double precision:: dg_dp, dg_dq, d2g_d2p, d2g_d2q, d2g_dpdq

c=======================================================================
c                   Retrieve material parameters
c=======================================================================
        xE         = inputmat(1)  !Young's modulus
        xnu        = inputmat(2)  !Poison
        xsigy0     = inputmat(3)  !Yield point
        xHk        = inputmat(4) !Kinematic hardeniing parameter
        xhi        = inputmat(5) !Isotropic hardeniing parameter
        q1         = inputmat(6)
        q2         = inputmat(7)
        q3         = inputmat(8)
        f_0        = inputmat(9)
        f_n        = inputmat(10)
        s_n        = inputmat(11)
        E_n        = inputmat(13)
                !

        xmu  = xE/(2.0*(1.0+xnu))    !mu or G: Elastic Shear moduli
        xk   = xE/(3.0*(1.0-2.0*xnu))  !k: Compression (Bulk) Moduli

c=======================================================================
c             Retrieve option parameters
c=======================================================================
        ATStype=options(1) !type of tangent stiffnes computation
        str_case=options(2) !stress_case
        Mat_L=options(3) !Material law

c=======================================================================
c      Retrieve strain drive of the current step and last step
c=======================================================================
        if (str_case==0) then
c=======================================================================
c                            3D
c=======================================================================
c-----Current strain drive input to compute stresses, ATS and ISV-------
          eps = reshape((/eps6(1),      eps6(4)/2.0,  eps6(6)/2.0,
     $                    eps6(4)/2.0,  eps6(2),      eps6(5)/2.0,
     $                    eps6(6)/2.0,  eps6(5)/2.0,  eps6(3)/),
     $                    shape(eps), order=(/2,1/))
c---------------Strain drive input of the previous step-----------------
c    <----------------------------------------------------------------------Change to implement and review
          epsn6=eps6-D_eps6
          epsn = reshape((/epsn6(1),      epsn6(4)/2.0,  epsn6(6)/2.0,
     $                     epsn6(4)/2.0,  epsn6(2),      epsn6(5)/2.0,
     $                     epsn6(6)/2.0,  epsn6(5)/2.0,  epsn6(3)/),
     $                     shape(eps), order=(/2,1/))
          D_eps=eps-epsn
c    <----------------------------------------------------------------------Change until here to implement and review
c--------------------plastic strain at t0-------------------------------
        epspn   = reshape((/sdvl(1),      sdvl(4)/2.0,  sdvl(6)/2.0,
     $                      sdvl(4)/2.0,  sdvl(2),      sdvl(5)/2.0,
     $                      sdvl(6)/2.0,  sdvl(5)/2.0,  sdvl(3)/),
     $                      shape(epspn), order=(/2,1/))

c-------------------------Elastic strain--------------------------------
        epsen  = reshape((/sdvl(1+13),    sdvl(4+13)/2.0,sdvl(6+13)/2.0,
     $                     sdvl(4+13)/2.0,sdvl(2+13),    sdvl(5+13)/2.0,
     $                     sdvl(6+13)/2.0,sdvl(5+13)/2.0,sdvl(3+13)/),
     $                     shape(epspn), order=(/2,1/))

        elseif (str_case==1) then
c=======================================================================
c                      PLANE STRESS
c=======================================================================
c-----Current strain drive input to compute stresses, ATS and ISV-------
          eps(1,1) = eps6(1)
          eps(2,2) = eps6(2)
          eps(1,2) = eps6(3)/2.0
          eps(2,1) = eps6(3)/2.0

c---------------Strain drive input of the previous step-----------------
c    <----------------------------------------------------------------------Change to implement and review
          epsn6=eps6-D_eps6
          epsn(1,1) = epsn6(1)
          epsn(2,2) = epsn6(2)
          epsn(1,2) = epsn6(3)/2.0
          epsn(2,1) = epsn6(3)/2.0
          epsn(1,3) = 0.0; epsn(2,3) = 0.0; epsn(3,1) = 0.0
          epsn(3,2) = 0.0; epsn(3,3) = 0.0
c          epsn(3,1:3,3)=(/0.0, 0.0 ,0.0/)

          D_eps=eps-epsn
c--------------------plastic strain at t0-------------------------------
          epspn(1,1) = sdvl(1)
          epspn(2,2) = sdvl(2)
          epspn(1,2) = sdvl(3)/2.0
          epspn(2,1) = sdvl(3)/2.0
          epspn(1,3) = 0.0; epspn(2,3) = 0.0; epspn(3,1) = 0.0
          epspn(3,2) = 0.0; epspn(3,3) = 0.0
c-------------------------Elastic strain--------------------------------
          epsen(1,1) = sdvl(1+13)
          epsen(2,2) = sdvl(2+13)
          epsen(1,2) = sdvl(3+13)/2.0
          epsen(2,1) = sdvl(3+13)/2.0
          epsen(1,3) = 0.0; epsen(2,3) = 0.0; epsen(3,1) = 0.0
          epsen(3,2) = 0.0; epsen(3,3) = 0.0
        end if
c=======================================================================
c            Retrieve Internal State variables (last step)
c=======================================================================
c --------strain-like ISV that thermodynamically conjugates-------------
c---------------to the kinematic hardening at time t--------------------
        Balphan = reshape((/sdvl(1+6),     sdvl(4+6)/2,   sdvl(6+6)/2.0,
     $                      sdvl(4+6)/2.0, sdvl(2+6),     sdvl(5+6)/2.0,
     $                      sdvl(6+6)/2.0, sdvl(5+6)/2.0, sdvl(3+6)/),
     $                      shape(Balphan), order=(/2,1/))
c--------strain-like ISV that thermodynamically conjugates--------------
c---------------- to the sotropic hardening at time t-------------------
        alphan = sdvl(13)
c-----------------------Void volume fraction----------------------------
        fn  = sdvl(20)
c--------------microscopic equivalent plastic strain--------------------
        epsp_b_n= sdvl(21)

c=======================================================================
c     Start computations
c=======================================================================

cFill the identity and deviatoriser tensor
        call Ident1(xid,3)
        call P4sym(P4sym_r)
        call Iso_hard1(epsp_b_n, sig_0, d_sig_0_d_epsp_b, inputmat)
c      sig_0=xsigy0

        pru=0

c=======================================================================
c                      Elastic prediction
c=======================================================================
       call dtime(t1,e)         !  Startup etime - do not use result

       !Mat_L=0 : VM, Mat_L=1 : GTN
        if (Mat_L==0) then
              call trial_step (eps,epspn,xmu,xHk,Balphan,alphan,xhi,
     &                   xsigy0, phitr, dsigtr, ntr, nxitr)
        else
              call trial_step_GTN (eps,epsn,epsen,xmu,xk,phitr, sig_0,
     &               ntr,q1,q2,q3,fn,dsigtr,sigtr, q_tr,p_tr)
        end if
        call dtime(t1,e)
        time_su(1,:)=t1
c      Evalate if it is required a elastic or elastic-plastic step
        if (phitr<tol) then  !Tol is a number very close to zero
            !print*, "elastic"
            sig=sigtr
            dsig=dsigtr
            Beta1=1.0
            Beta2=1.0
            Balpha=Balphan
            alpha=alphan
            epsp=epspn
            epse=eps
            f=fn
            epsp_b=epsp_b_n
            if (ATStype==0) then
              Cdev=2.0*xmu*P4sym_r
            endif
            if (Mat_L==0) then
c-------------------Update stress---------------------------------------
c-----------Addition of spherical contribution to stress----------------
              sig=dsig+xk*Trace(eps)*xid
              epse=eps-epsp
              C=Cdev+xk*diadic_prod_T2_T2(xid,xid)
            end if
            if (Mat_L==1) then
c-------------------Update stress---------------------------------------
c-----------Addition of spherical contribution to stress----------------
              epse=eps-epsp
              C=Cdev+xk*diadic_prod_T2_T2(xid,xid)
              call m4th_2_66_sym (C, A66)
            end if
c=======================================================================
c                      plastic correction
c=======================================================================
        call dtime(t2,e)
        else

c          Mat_L=0 : VM, Mat_L=1 : GTN
           if (Mat_L==0) then
              !print*, "plastic return VM"
             call plas_corre_VM (phitr, xmu, xHk, xhi,dsig, dsigtr,ntr,
     &            nxitr, epsp, epspn, Balpha, Balphan, alpha, alphan,
     &             beta1,beta2 )
             if (ATStype==0) then
                Cdev=2*xmu*beta1*P4sym_r-2*xmu*beta2*diadic_prod_T2_T2
     $               (ntr,ntr)
c------------   -------Update stress---------------------------------------
c-----------A   ddition of spherical contribution to stress----------------
                 sig=dsig+xk*Trace(eps)*xid
                 epse=eps-epsp
                 C=Cdev+xk*diadic_prod_T2_T2(xid,xid)
             end if

c------------------Algorithmic Tangen Stifness-------------------------
          else

              rec=1
             call plas_corre_GTN (rec, q_tr,p_tr, sigtr,inputmat,fn,
     &       dsigtr, phitr, epsp_b,eps, D_eps, epsp, epse, Balpha,
     &       alpha,sig_0,sig,dsig,f, ATStype, str_case, epspn, epsp_b_n,
     &       A66, plas_corre_GTN)
           end if
        end if
        call dtime(t2,e)
        time_su(2,:)=t2
c=======================================================================
c      Retrieve condensed form of tensors to export information
c=======================================================================
        if (ATStype==0 .and. Mat_L==0 ) then
c-----------------restore stiffness tensor as matrix--------------------
c   Due to the symmetry the tangent stiffness 4 grade tensor can be
c   expressed as a 6x6 matrix
          call m4th_2_66_sym (C, A66)
        end if
c=======================================================================
c                              3D
c=======================================================================
c-----------------------stress tensor as vector-------------------------
        if (str_case==0) then
           do i=1,6
               sig6(i) = sig(ii(i),jj(i))
           end do
c---------------------- store ISV as vector-----------------------------
c-------------------------plastic strain--------------------------------
          sdvup(1:6) =(/epsp(1,1),   epsp(2,2),   epsp(3,3),
     $               2.0*epsp(1,2), 2.0*epsp(2,3), 2.0*epsp(1,3)/)
c---------------------------Back stress---------------------------------
          sdvup(7:12)=(/Balpha(1,1),   Balpha(2,2),   Balpha(3,3),
     $               2.0*Balpha(1,2), 2.0*Balpha(2,3), 2.0*Balpha(1,3)/)
          sdvup(14:19)=(/epse(1,1),   epse(2,2),   epse(3,3),
     $               2.0*epse(1,2), 2.0*epse(2,3), 2.0*epse(1,3)/)

        elseif (str_case==1) then
c=======================================================================
c                         Plane stress
c=======================================================================
          do i=1,3
                 sig6(i) = sig(ii_PS(i),jj_PS(i))
          end do
c---------------------- store ISV as vector-----------------------------
c-------------------------plastic strain--------------------------------
          sdvup(1:3) =(/epsp(1,1),   epsp(2,2),  2.0*epsp(1,2)/)
c---------------------------Back stress---------------------------------
          sdvup(7:9)=(/Balpha(1,1),   Balpha(2,2), 2.0*Balpha(1,2)/)
          sdvup(14:16)=(/epse(1,1),   epse(2,2),   2.0*epse(1,2)/)

        end if

c--------------------------drag stress----------------------------------
        sdvup(13) = alpha
        sdvup(20)=f
        sdvup(21)=epsp_b
      end subroutine kGTN

c==================================================================
c subroutine trial_step (eps,epspn,xmu,xHk,Balphan,alphan,xhi,
c            xsigy0, phitr, dsigtr, ntr, nxitr)
c------------------------------------------------------------------]
c Inputs
c   eps : stain tensor
c   epspn : plastic strain tensor
c   xmu : shear modulus
c   xHk : kinematic hardening modulus, scalar
c   Balphan: tensorial internal variable alpha
c   alphan: scalar hardening variable alpha
c   xh :  isotropic hardening modulus, scalar
c   xsigy0: initial yield stress, uniaxial test
c-----------------------------------------------------------------
c Outputs
c   phitr : trial yield function
c   dsigtr : deviatoric part of the trial stress tensor
c   ntr : flow direction from trial state
c   nxitr : norm of xitr
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c=======================================================================

      subroutine trial_step (eps,epspn,xmu,xHk,Balphan,alphan,xhi,
     $       xsigy0, phitr, dsigtr, ntr, nxitr)
c       INCLUDE 'ABA_PARAM.INC'
       use tensor_operations

       implicit none
       double precision, dimension (3,3) :: eps, xid,deps, dsigtr,
     $                                Bbetatr,Balphan, epspn
       double precision:: betatr, xHk, xhi, xmu, alphan, xsigy0
       double precision, dimension (3,3) :: xitr !trial value of deviatoric stress difference
       double precision :: nxitr !norm of xitr
       double precision , dimension (3,3) :: ntr !flow direction from trial state
       double precision :: phitr !trial value of the yield function

       call Ident1(xid,3)
       !deviatoric part of the strain tensor
       deps = eps - Trace(eps)*xid/3.0
       !deviatoric part of the trial stress tensor
       dsigtr = 2.0*xmu*(deps-epspn)

       !trial value of the back-stress tensor
       Bbetatr = xHk*Balphan
       !trial value of the increase in yield stress (scalar beta: drag stress)
       betatr =xhi*alphan
       !trial value of deviatoric stress difference
       xitr =dsigtr-Bbetatr
       !norm of xitr
       nxitr = (contrac_2nd_2nd(xitr,xitr))**0.5
       !flow direction from trial state
       ntr = xitr/nxitr
c-----------------------trial yield function----------------------------
       phitr = nxitr-(2.0/3.0)**(0.5)*(xsigy0+betatr)

      end subroutine trial_step

c=======================================================================
c subroutine trial_step_GTN (eps,epsn,epsen,xmu,xk,phitr, sig_0,ntr)
c=======================================================================
c=======================================================================
c Inputs
c   eps : stain tensor acording to load
c   epsn : strain tensor last step
c   epsen : elastic strain tensor last step
c   xmu : shear moduli
c   xk : Bulk moduli
c   phitr : trial yield function
c   sig_0 : equivalent tensile flow stress
c   ntr : normalized flow direction from trial state (according to article)
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c=======================================================================

      subroutine trial_step_GTN (eps,epsn,epsen,xmu,xk,phitr, sig_0,
     $     n_a_tr,q1,q2,q3,f,dsig_tr,sig_e_tr, q_tr,p_tr)
c           INCLUDE 'ABA_PARAM.INC'
           use tensor_operations
           implicit none
           double precision, dimension (3,3) :: eps, epsn, xid,deps,
     $                                dsigtr,sig_e_tr, sig_test
           double precision::   xhi, xmu,xk, alphan, sig_0, q1, q2,q3
           double precision, dimension (3,3) :: xitr, dsig_tr !trial value of deviatoric stress difference
           double precision , dimension (3,3) :: s_tr, n_a_tr !flow direction from trial state
           double precision , dimension (3,3) :: C_e          !Elasticity tensor in voigth notation due to simmetry
           double precision :: phitr, q_tr, p_tr, f           !trial value of the yield function
           double precision , dimension (3,3) :: epsen        !elastic strain last step
           double precision , dimension (3,3):: D_eps         !Change strain
           !Variables plain strain
           double precision:: pe
           double precision , dimension (3,3)::D_eps_b !Delta Strain in the plane of stressing
           double precision , dimension (3,3)::dD_eps_b !viatoric of D_eps_b
           double precision , dimension (3,3)::D_epse !Delta elastic eps
           double precision , dimension (3,3):: depse  !Deviatoric elastic eps
           double precision , dimension (3,3)::a,ad !e3e3 and its deviatoric

           call Ident1(xid,3)
           !Elasticity tensor

           C_e=2.0*xmu*Xid
           !Change strain in the step
           D_eps=eps-epsn

           !Elastic predictor (trial). All the strain is supoused to be elastic
           sig_e_tr=C_e*(epsen+D_eps)
           !trial values for p, s and q
              p_tr= - 1.0/3.0*Trace(sig_e_tr)
              dsig_tr=sig_e_tr-1.0/3.0*Trace(sig_e_tr)*xid
              q_tr=(3.0/2.0*contrac_2nd_2nd(dsig_tr,dsig_tr))**0.5

           !norm according to the article
           n_a_tr = 3.0/2.0*dsig_tr/q_tr
           sig_test=-p_tr*xid+(2.0/3.0)*q_tr*n_a_tr

           phitr = (q_tr/sig_0)**2+2.0*q1*f*cosh(-3.0*q2*p_tr/
     &                (2.0*sig_0))-(1.0+q3*f**2)

      end subroutine trial_step_GTN

c=======================================================================
c subroutine plas_corre_VM (phitr, xmu, xHk, xhi,dsig, dsigtr,ntr,
c       epsp, epspn, Balpha, Balphan, alpha, alphan)
c=======================================================================
c
c------------------------------------------------------------------------
c coded by: W. Mora Sep 2021
c=======================================================================

      subroutine plas_corre_VM (phitr, xmu, xHk, xhi,dsig, dsigtr,ntr,
     &  nxitr, epsp, epspn, Balpha, Balphan, alpha, alphan,beta1,beta2)
c       INCLUDE 'ABA_PARAM.INC'
       implicit none

       double precision, dimension (3,3) ::  dsig, dsigtr,ntr,
     &    epsp, epspn, Balpha, Balphan
       double precision :: phitr, xmu, xHk, alpha, alphan, beta1, beta2,
     &    gamma,xhi, nxitr
       gamma=phitr/(2.0*xmu+xHk+2.0*xhi/3.0)
       dsig=dsigtr-2.0*xmu*gamma*ntr
       epsp=epspn+(dsigtr-dsig)/(2*xmu) !This is the same, you can solve from the avobe equation this expression

       Balpha = Balphan+gamma*ntr        ! tensorial internal variable alpha
       alpha = alphan+(2.0/3.0)**(0.5)*gamma           !scalar hardening variable alpha
       beta1=1.0-(phitr/nxitr)*(1.0/(1.0+xHk/(2.0*xmu)+
     $          xhi/(3.0*xmu)))
       beta2=(1.0-phitr/nxitr)*(1.0/(1.0+xHk/(2.0*xmu)+
     $          xhi/(3.0*xmu)))
      end subroutine plas_corre_VM

c=======================================================================
c subroutine plas_corre_GTN (q, p, sig,inputmat,fn, dsig,PHI,
c              d_epsp, epsp_b,epsp,epse)
c=======================================================================
c=======================================================================
c Inputs
c   q : hydrostac stress trial
c   p : equivalent stress trial
c   sig : stress trial
c   inputmat : vector with the material's intrinsic properties.
c   fn : void fraction trial
c   dsig : deviatoric stress trial
c   PHI : yield suface trial
c-----------------------------------------------------------------------
c Outputs
c   phitr :
c------------------------------------------------------------------------
c coded by: W. Mora Oct 2021
c=======================================================================

      subroutine plas_corre_GTN (rec, q,p, sig,inputmat,f, dsig,phi,
     &      epsp_b,eps,D_eps, epsp, epse, Balpha, alpha, sig_0, sig1,
     &      dsig1,f1,ATStype, str_case, epspn, epsp_b_n, ATS66,dumbsub)
c            INCLUDE 'ABA_PARAM.INC'
            use tensor_operations
            implicit none
            external dumbsub
c  Especific variables according to the article N. ARAVAS, 1987
            !Parameters material
            double precision, dimension (15)::inputmat
            !Material parameters
            double precision :: q, p, sig_0, q1, q2, q3,f,f1, xE,
     &         xsigy0,  xk, xmu, xnu, q_e, p_tr, q_tr
            double precision :: f_c, f_s, f_f, df_s_df, k_b, f_su !Parameters GTN model (Needleman part)
            double precision ::A_c

            !Change of parameter between steps
            double precision ::D_eps_p, D_eps_q, D_epsp_b,D_f, D_eps_pn,
     &       D_eps_qn
            double precision, dimension (3,3) ::D_epsp,D_epspn1, dsig,
     &       dsig_e, D_eps
            !Current value of ISV
            double precision :: epsp_b, epsp_b1, alpha, alphan  ! microscopic equivalent plastic strain
            double precision, dimension (3,3) ::sig ,epsp, eps, epsn,
     &            eps_pp, epse, n_a, sign_l, Balpha, Balphan, sig1,dsig1
            !derivates defined in article of real type
            double precision:: dg_dp, dg_dq, d2g_d2p, d2g_d2q, d2g_dpdq,
     &        d2g_dpdf, d2g_dqdf, d2g_dq_d_epsp,
     &        dDf_dDeps_p, dDepsp_b_dDeps_p, dDf_dDeps_q, dDepsp_b_dq,
     &        dDf_dp, dDepsp_b_dDeps_q, dPHI_dp, dPHI_dq, dPHI_df,
     &        dPHI_d_epsp_b, d_epsp_b_dDeps_p, d_epsp_b_dp, dDepsp_b_dp,
     &        A11, A12, A21, A22, b1, b2, PHI, A11_D, A12_D, A21_D,
     &        A22_D, B11_D, B12_D, B21_D, B22_D, b1_D, b2_D, df_dp,
     &        d_epsp_dp, d_epsp_b_dq, df_dq, d_epsp_dq, df_d_epsp_b,
     &        d2g_dq_d_epsp_b, d2g_dp_d_epsp, d2g_dp_d_epsp_b,
     &        df_dDeps_p, dH_alpha_dDeps_p, dDf_dq, df_dDeps_q,
     &        dH_alpha_dDeps_q, d_epsp_b_dDeps_q, d_sig0_d_f,
     &        d_sig0_d_epsp_b, dA_d_epsp_b, dDepsp_b_df, d2g_dqdsig_0,
     &        dDf_d_epsp_b, dDf_df,dDepsp_b_d_epsp_b, NU,
     &        d_sig_0_d_epsp_b
            !derivates defined in article of tensorial (3,3) type
            double precision, dimension (3,3) ::  dDepsp_dDeps_p,
     &         dDepsp_dp,d_epsp_dDeps_p, dDepsp_dDeps_q, dDepsp_dq,
     &          d_epsp_dDeps_q, dPHI_d_epsp
            double precision, dimension (3,3,1) :: dou_sum1_P2,
     &       dou_sum2_P2
            !Secondary derivatives and variables
            double precision:: c_f_f, c_f_epsp, c_f_epsp_b
     &        , c_epsp_b_epsp , c_epsp_b_f, c_epsp_b_epsp_b
     &        , sum1, sum2, sum3, sum4 , dou_sum1, dou_sum1_P1,
     &        dou_sum2, dou_sum3, dou_sum4, dou_sum5, dou_sum6,
     &        sum32, sum42,
     &        dou_sum7, dou_sum8 , dD_eps_p,dD_eps_q
            double precision, dimension (3,3) :: nxi_a,
     &         c_epsp_f, c_epsp_epsp, c_epsp_epsp_b, D_sig
            !Parameters nucleation
            double precision :: f_0, f_n, s_n, E_n ! E_n: mean value Parameter used in the nucleation equations
            !Auxiliar variables
            double precision, dimension (3,3) ::  xid, Delta_sig66
            double precision :: pi, tol_conv_cor,conv_D_eps_p,
     &          conv_D_eps_q, pert, con, ATS_ave
            double precision, dimension(2,2) :: M,M_inv,ML,MR,dD_eps_pq
            double precision, dimension(2) :: b_v, c_corr
            double precision, dimension(6) :: eps6_pp, sig6_pp,
     &          Delta_sig6
            double precision, dimension(6,6) ::  ATS66,A66_t,
     &       C_e66_tem
            double precision, dimension(3,3,3,3)::C, Cdev, C_e, C_e_inv,
     &           M_4T, ATS, dn_d_sig,I4dikdjl_r,I4dijdkl_r
            integer :: iterartion, i,j, rc,sc, ATStype, str_case,rec
            double precision :: Beta1, Beta2, tol
            integer, dimension(6):: ii, jj

c      Variables for plane stress elastoplastic equations
c
            double precision ::A23_PS, A31_PS, A32_PS, A33_PS, b3_PS,
     &         A13_PS, D_eps3, dev_e_33, dq_dDeps3, pe, D_eps3n,
     &         conv_d_eps3, ome31, ome32, ome33
            double precision, dimension(3,3) :: M_ps, M_ps_inv,D_eps_b,
     &          dD_eps_b, depse, se, a, da, ATS_PS
            double precision, dimension(3) :: b_ps_v, c_corr_ps
            !Auxiliar variables
            double precision::conv_D_eps_p_ps, conv_D_eps_q_ps,D_eps11,
     &           D_eps22
            double precision, dimension (3,3) :: sigtr, dsigtr, epsen,
     &       epspn, ntr
            double precision:: epsp_b_n, fn, phitr

c   rec       : number of recursive iterations
c   ATStype   : Type of computation of algorithmic tangent
c   str_case  : Tyoe of analysis 3D or plane stress
c   conv_     : convergence
c   PS        : variable for the plane stress case
c   D_ or D.. :      : Delta
c   D_        : variable used in computation of ATS lineaation module
c   d:        : derivative, total or partial depending of the context
c   d2        : second derivative, total or partial depending of the context
c   sum       ;auxiliary variable to store the result of a summatory
c   dou_sum   :auxiliary variable store the result of a double summatory
c   _P1, _P2  : auxiliary variable to assign the part of a long equation
c   eps       : total strain
c   epse      : elastic strain
c   epsp      : plastic strain
c   epsp_b    : microscopic eqivalent platic strain
c   ..tr      : trial value
c   ATS       : Algorithmic tangent stiffness 4th order tensor
c   ATS66     : ATS retrieved in 6x6 2nd order tensor
c   A66_t     : auxiliary ATS66 matrix to run the recursive code
c   p         : hydrotatic stress
c   q         : equivalent stress
c   dsig      : stress deviatoric
c   A_c       : Parmeter for nucleation strain Chu and Needleman
c   M_4T      : Variable M, 4th order tensor used in solutions ATS
c   M,ML, MR  : matrix representing linear systems of equations (LSE)
c   b         : colum vector independent terms LSE.
c iterartion  : iterator
c i,j, rc,sc  : iterators
c   f_s       : f* function of the void volume fraction
c   f_su      : ultimate value of f* at ductile rupture
c   k_b       : Relation in the Needleman model
c   f_c       : critical void volume at which coids coalesce
c   f_F       : void volume fraction at final failure of the
            xE        = inputmat(1)
            xnu       = inputmat(2)  !Poison
            xsigy0    = inputmat(3)  !Yield point
            q1        = inputmat(6)
            q2        = inputmat(7)
            q3        = inputmat(8)
            f_0       = inputmat(9)
            f_n       = inputmat(10)
            s_n       = inputmat(11)
            f_f       = inputmat(12)
            E_n       = inputmat(13)
            f_c       = inputmat(14)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c Constants
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
            xmu  = xE/(2.0*(1.0+xnu))    !(G)Shear modulus
            xk   = xE/(3.0*(1-2.0*xnu))  !(K) Compression Modulus
            call Ident1(xid,3)
            pi=4.D0*DATAN(1.D0)
            tol_conv_cor=0.5e-10

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c Initial values to start iteration
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
            f_su=1.0/q1
            k_b=(f_su-f_c)/(f_F-f_c)
            if (f .le. f_c) then
              df_s_df=1
              f_s=f
            else
              df_s_df=k_b
              f_s=f_c+k_b*(f-f_c)
            end if

            PHI=(q/sig_0)**2+2.0*f*q1*cosh(-3.0*q2*p/(2.0*sig_0))
     &                -(1.0+q3*f**2)
         if (str_case==0) then
c-----------------------------------------------------------------------
c          THREE DIMENSIONAL GEOMETRIES
c-----------------------------------------------------------------------

c  return direction (only depends on the trial step)
            dsig_e=sig-Trace(sig)*xid
            q_e=(3.0/2.0*contrac_2nd_2nd(dsig_e,dsig_e))**0.5
            n_a=3.0/2.0*dsig_e/q_e  !<--------This is computed only with the trial values, does not include correction. Last equation of page 1399
            p_tr=p
            q_tr=q
            sig1=sig

         else
c-----------------------------------------------------------------------
c                       PLAIN STRAIN CASE
c-----------------------------------------------------------------------

            PHI=(q/sig_0)**2+2.0*f*q1*cosh(-3.0*q2*p/(2.0*sig_0))
     &                -(1.0+q3*f**2)

c  return direction (only depends on the trial step            )
            dsig_e=sig-Trace(sig)*xid
            q_e=(3.0/2.0*contrac_2nd_2nd(dsig_e,dsig_e))**0.5
            n_a=3.0/2.0*dsig_e/q_e  !<--------This is computed only with the trial values, does not include correction. Last equation of page 1399

            D_eps_p=0.0
            D_eps_q=0.0
            D_eps11=D_eps(1,1)
            D_eps22=D_eps(2,2)
            D_eps3=D_eps(3,3)
            pe=-xk*(Trace(epse)+D_eps11+D_eps22)

            D_eps_b(:2,:2)=D_eps(:2,:2) !In the aricle is called Delta e bar
            dD_eps_b=D_eps_b-1.0/3.0*Trace(D_eps_b)*xid !In the aricle is called deviatoric Delta e bar
            depse=epse-1.0/3.0*Trace(epse)*xid !In the article is called e^e, deviatoric elastic eps
            se=2*xmu*(depse+dD_eps_b) !se is the article name. This is a deviatoric with out name
            a=reshape((/0,0,0,0,0,0,0,0,1/),shape(a), order=(/2,1/))
            da=a-1.0/3.0*Trace(a)*xid !Deviatoric of e33
            dsig=se+2.0*xmu*(D_eps3*da-3.0/2.0*D_eps_q/q*dsig)
            p_tr=pe
            q_tr=q  !This q is qe, which comes form the arguments, does not change before this point

         end if
            sig1=sig

c  Set guess values to enter to the iterative algorithm
            D_eps_p=0.000
            D_eps_q=0.0000001
            D_eps3=0.000
            iterartion=0
            D_eps_pn=D_eps_p
            D_eps_qn=D_eps_q
            D_eps3n=D_eps3
            conv_D_eps_p=1.0
            conv_D_eps_q=3.0
            c_corr(1)=1.0
            c_corr(2)=2.0
            f1=f
c=======================================================================
c     Volumetric and deviatoric plastic strain increments according to
c      a Newton scheme, and D_eps3 for in case of the plain stress case
c=======================================================================
   10     if ((abs(c_corr(1)) .gt. tol_conv_cor) .or.
     $        (abs(c_corr(2)).gt. tol_conv_cor ) .and. (PHI>1e-1)) then

            iterartion=iterartion+1
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C           Materal parameter initial values
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c------------------Relation between f and f*----------------------------
            if (f1 .le. f_c) then
              df_s_df=1
              f_s=f1
            else
              df_s_df=k_b
              f_s=f_c+k_b*(f1-f_c)
            end if
          if (str_case==0) then
c-----------------------------------------------------------------------
c          THREE DIMENSIONAL GEOMETRIES
c-----------------------------------------------------------------------

c------- Update microscopic equivalent plasic strain and sig_0----------
            D_epsp_b=(-p*D_eps_p+q*D_eps_q)/(1.0-f1)/sig_0
            epsp_b1=epsp_b+D_epsp_b
            if (epsp_b1 < 0.0) then
              epsp_b1=epsp_b_n
            end if
            call Iso_hard1(epsp_b1, sig_0, d_sig_0_d_epsp_b, inputmat)
c----------- Update Hydrostatic and equivalent stress-------------------
            p=p_tr+xk*D_eps_p
            q=q_tr-3.0*xmu*D_eps_q

            A_c=f_n/(s_n*(2.0*pi)**0.5)*DEXP(-1.0/2.0*((epsp_b1-E_n)/
     &              s_n)**2) !Chu and Needleman parameter A
            D_f=(1.0-f1)*D_eps_p+A_c*D_epsp_b
            f1=f+D_f
          else
c-----------------------------------------------------------------------
c                       PLAIN STRAIN CASE
c-----------------------------------------------------------------------
c Update Hydrostatic and equivalent stress

            D_epsp_b=(-p*D_eps_p+q*D_eps_q)/(1.0-f1)/sig_0
            epsp_b1=epsp_b+D_epsp_b
            call Iso_hard1(epsp_b1, sig_0, d_sig_0_d_epsp_b, inputmat)

            p=p_tr-xk*(D_eps3-D_eps_p)
            q=-3.0*xmu*D_eps_q+(q_tr**2+6.0*xmu*se(3,3)*D_eps3+
     &         4.0*xmu**2*D_eps3**2)**0.5   !here q^e is q_tr

            A_c=f_n/(s_n*(2.0*pi)**0.5)*DEXP(-1.0/2.0*((epsp_b1-E_n)/
     &              s_n)**2) !Chu and Needleman parameter A
            D_f=(1.0-f1)*D_eps_p+A_c*D_epsp_b
            f1=f+D_f

c     &        "D_epsp", D_epsp,

          end if
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C   Compute the required derivates to compute the constant of the LSE
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c Derivatives to solve system of equations to solve D_eps_p and D_eps_q
            dg_dq =2.0*(q/sig_0**2)
            dg_dp = -3.0*q1*q2/sig_0*f1*sinh(-3.0*q2*p/(2.0*sig_0))
            d2g_dpdq=0.0
            d2g_d2p=(9.0/2.0) *q1*f1*(q2/sig_0)**2
     &               *cosh((-3.0*q2*p)/(2.0*sig_0))  !
            d2g_d2q=(2.0/(sig_0**2))

            d_sig0_d_epsp_b= 3.0*xmu*NU*(sig_0/xsigy0+3.0*xmu*epsp_b1/
     &       xsigy0)**(NU-1)/(1.0-NU*(sig_0/xsigy0+3.0*xmu*epsp_b1/
     &       xsigy0)**(NU-1))
            d2g_dpdf=-3.0*q1*q2*sinh(-3.0*q2*p/(2.0*sig_0))/sig_0
     &          *df_s_df

            dA_d_epsp_b=f_n/(s_n*(2.0*pi)**0.5)*DEXP(-0.5*((epsp_b1-
     &        E_n)/s_n)**2.0)*(-((epsp_b1-E_n)/s_n)*(1/s_n))
            dDepsp_b_df=(-p*D_eps_p+q*D_eps_q)/((1-f1)**2*sig_0)
            df_d_epsp_b=(dA_d_epsp_b*D_epsp_b)/(1.0+D_eps_p)
            dDepsp_b_d_epsp_b=0.0
            d2g_dp_d_epsp_b= -3.0*q1*q2*( -df_d_epsp_b/sig_0*sinh(-q2*
     &        3.0*p/(2.0*sig_0))-f1/sig_0**2*d_sig0_d_epsp_b*sinh(-q2*
     &        3.0*p/(2.0*sig_0))+f1/sig_0*cosh(-q2*3.0*p/(2.0*sig_0))*
     &        q2*3.0*p/(2.0*sig_0**2)*d_sig0_d_epsp_b)

            d2g_dqdsig_0=(-4.0*q/sig_0**3)
            d2g_dqdf= 0 !d2g_dqdsig_0*d_sig0_d_f

            d2g_dq_d_epsp_b= d2g_dqdsig_0*d_sig0_d_epsp_b

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c    !dH_alpha_dDeps_p = df_dDeps_p + d_epsp_dDeps_p + d_epsp_b_dDeps_p
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c  !Compute df_dDeps_p

            dDf_dDeps_p=(1.0-f1)

            dDf_d_epsp_b=dA_d_epsp_b*D_epsp_b+ A_c*dDepsp_b_d_epsp_b
            d_epsp_b_dp=-D_eps_p/((1.0-f1)*sig_0)
            dDf_dp=dDf_d_epsp_b*d_epsp_b_dp

            dDepsp_b_dDeps_p=-p/((1.0-f1)*sig_0)
            dDepsp_b_dp=-D_eps_p/((1.0-f1)*sig_0)

            dDf_df= -D_eps_p
            c_f_f = 1.0/(Kron_d(1,1)-dDf_df)

            c_f_epsp_b=1.0/(Kron_d(1,3)-dDf_d_epsp_b)
            df_dDeps_p=c_f_f*(dDf_dDeps_p+xk*dDf_dp)
     &            +c_f_epsp_b*(dDepsp_b_dDeps_p+xk*dDepsp_b_dp)

            c_epsp_b_f =1.0/(Kron_d(3,1)-dDepsp_b_df)

            c_epsp_b_epsp_b=1/(Kron_d(3,3)-dDepsp_b_d_epsp_b)

            d_epsp_b_dDeps_p=c_epsp_b_f*(dDf_dDeps_p+xk*dDf_dp)
     &            +c_epsp_b_epsp_b*(dDepsp_b_dDeps_p+xk*dDepsp_b_dp)

            dH_alpha_dDeps_p= df_dDeps_p + d_epsp_b_dDeps_p
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c     dH_alpha_dDeps_q = df_dDeps_q + d_epsp_dDeps_q+ d_epsp_b_dDeps_q
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c  Compute df_dDeps_q

            dDf_dDeps_q=0
            d_epsp_b_dq=D_eps_q/((1-f1)*sig_0)
            !dDf_dq=A_c * D_eps_q/(1.0-f)/sig_0
            dDf_dq=dDf_d_epsp_b*d_epsp_b_dq

            dDepsp_b_dDeps_q= q/((1.0-f1)*sig_0)
            dDepsp_b_dq     = D_eps_q/((1.0-f1)*sig_0)

            df_dDeps_q=c_f_f*(dDf_dDeps_q-3.0*xmu*dDf_dq)
     &         +c_f_epsp_b*(dDepsp_b_dDeps_q-3.0*xmu*d_epsp_b_dq)

c Compute d_epsp_b_dDeps_q
            d_epsp_b_dDeps_q=c_epsp_b_f*(dDf_dDeps_q-3.0*xmu*dDf_dq)
     &        +c_epsp_b_epsp_b*(dDepsp_b_dDeps_q-3.0*xmu*d_epsp_b_dq)
c   Finally compute dH_alpha_dDeps_q
            dH_alpha_dDeps_q = df_dDeps_q + d_epsp_b_dDeps_q
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c    dPHI_d
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
            dPHI_dp =dg_dp !q1*f*sinh(-3.0*q2*p/(2.0*sig_0))
            dPHI_dq=dg_dq  !2*(q/sig_0**2)
c  Compute all  dPHI_dH_alpha = dPHI_df, dPHI_d_epsp

            dPHI_df = (2*q1-cosh(-3*q2*p/(2*sig_0))-2*q3*f1)*df_s_df

            dPHI_d_epsp_b= (-2.0*q**2/sig_0**3)*d_sig0_d_epsp_b+2*q1*
     &        (df_d_epsp_b *cosh(-3.0/2.0*q2*p/sig_0) + f_s*sinh
     &        (-3.0/2.0*q2*p/sig_0)*(3.0/2.0*q2*p/sig_0**2)*
     &        d_sig0_d_epsp_b)-2.0*f_s*q3*df_d_epsp_b              ! Option 2 considering relation between f  on epsp_b

            PHI=(q/sig_0)**2+2.0*f_s*q1*cosh(-3.0*q2*p/(2.0*sig_0))
     &                -(1.0+q3*f_s**2)

C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c Consolidation of Elastoplastic equation constants A11, A12, A21, A22,
c b1, b2 and solution of LSE
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
            sum1=d2g_dqdf*df_dDeps_p+d2g_dq_d_epsp_b*d_epsp_b_dDeps_p

            sum2=d2g_dpdf*df_dDeps_p+d2g_dp_d_epsp_b*d_epsp_b_dDeps_p

            A11=dg_dq+D_eps_p*(xk*d2g_dpdq+sum1)+D_eps_q*(xk*d2g_d2p
     &          +sum2)
            sum3=d2g_dqdf*df_dDeps_q+d2g_dq_d_epsp_b*d_epsp_b_dDeps_q
            sum4=d2g_dpdf*df_dDeps_q+d2g_dp_d_epsp_b*d_epsp_b_dDeps_q
c            A12= dg_dp+D_eps_p*(-3.0*xmu*d2g_d2q+sum1)
c     &             + D_eps_p*(-3*xmu*d2g_dpdq+sum2)  !The article has this error, the derivative is not with respect to dDeps_q
            A12= dg_dp+D_eps_p*(-3.0*xmu*d2g_d2q+sum3)
     &             + D_eps_q*(-3*xmu*d2g_dpdq+sum4)
            sum32=dPHI_df*df_dDeps_p+dPHI_d_epsp_b*d_epsp_b_dDeps_p

            A21=xk*dPHI_dp+sum32
            sum42=dPHI_df*df_dDeps_q+dPHI_d_epsp_b*d_epsp_b_dDeps_q

            A22=-3.0*xmu*dPHI_dq+sum42

            b1=-D_eps_p*dg_dq-D_eps_q*dg_dp
            b2= -PHI

         if (str_case==1) then
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c Consolidation of Elastoplastic equation constants A13, A23, A31, A32,
c b3 / Applies only to plane stress
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

            A13_PS=D_eps_p*(-xk*d2g_dpdq+dq_dDeps3*d2g_d2q)+
     &        D_eps_q*(-xk*d2g_d2p+dq_dDeps3*d2g_dpdq)
            A23_PS=-xk*dPHI_dp+dq_dDeps3*dPHI_dq
            A31_PS=xk*(q+3.0*xmu*D_eps_q)
            A32_PS=3.0*xmu*dev_e_33
            A33_PS=dq_dDeps3*p-xk*(q+3.0*xmu*D_eps_q)-(4.0/3.0)*
     &        xmu*q-(dev_e_33+(4.0/3.0)*xmu*D_eps3)*dq_dDeps3
            dq_dDeps3= (3.0*xmu*dev_e_33+4.0*xmu**2*D_eps3)/
     &        (q+3.0*xmu*D_eps_q)
            b3_PS=-(q+3.0*xmu*D_eps_q)*p+(dev_e_33+
     &        (4.0/3.0)*xmu*D_eps3)*q

         end if
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c      Solution of LSE for the correction values and update of volumetric
c       and deviatoric plastic strain increments
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         if (str_case==0) then
c-----------------------------------------------------------------------
c          THREE DIMENSIONAL GEOMETRIES
c-----------------------------------------------------------------------
c  Solution of LSE for the correction values
            M = reshape((/A11, A12,
     $                    A21, A22/),shape(M), order=(/2,1/))
            b_v=(/b1,b2/)
            M_inv = inv_T_2D(M)
            c_corr = matmul(inv_T_2D(M), b_v)

c Update volumetric and deviatoric plastic strain increments

            D_eps_p=D_eps_p+c_corr(1)
            D_eps_q=D_eps_q+c_corr(2)
c Evaluate step convergence
            conv_D_eps_p=abs(D_eps_p-D_eps_pn)
            conv_D_eps_q=abs(D_eps_p-D_eps_pn)
            D_eps_pn=D_eps_p
            D_eps_qn=D_eps_q
         else
c-----------------------------------------------------------------------
c                       PLAIN STRESS CASE
c-----------------------------------------------------------------------
c  Solution of LSE for the correction values

            M_ps = reshape ((/A11, A12, A13_PS,
     &                       A21, A22, A23_PS,
     &                       A31_PS, A32_PS, A33_PS/),
     &                       shape(M_ps), order=(/2,1/))
            b_ps_v =(/b1, b2, b3_PS/)
            M_ps_inv=inv_T_2D(M_ps)
            c_corr_ps=matmul(M_ps_inv, b_ps_v)

c Update volumetric and deviatoric plastic strain increments and D_eps3

            D_eps_p=D_eps_p+c_corr_ps(1)
            D_eps_q=D_eps_q+c_corr_ps(2)
            D_eps3=D_eps_q+c_corr_ps(3)

c Evaluate step convergence
            conv_D_eps_p=abs(D_eps_p-D_eps_pn)
            conv_D_eps_q=abs(D_eps_p-D_eps_pn)
            conv_D_eps3=abs(D_eps3-D_eps3n)
            D_eps_pn=D_eps_p
            D_eps_qn=D_eps_q
            D_eps3n=D_eps3

         end if
        goto 10
        endif

            sig=-p*xid+(2.0/3.0)*q*n_a
            dsig=sig-1.0/3.0*xid*Trace(sig)
            D_epsp=1.0/3.0*D_eps_p*xid+D_eps_q*n_a
            epsp=epsp + D_epsp
            epse=eps-epsp

            Balpha=Balphan
            alpha= alphan
            D_sig =sig-sig1
            sig1=sig
            dsig1=dsig
            epsp_b=epsp_b_n+D_epsp_b
            f1=f+D_f

         if (ATStype==0) then
c=======================================================================
c          Compute Material tangent stiffness "analitical" solution
c=======================================================================
c-----------------------------------------------------------------------
c          THREE DIMENSIONAL GEOMETRIES
c-----------------------------------------------------------------------

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c  Additional derivatives
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
            df_dp=D_eps_p/(D_epsp_b*sig_0)
            df_dq=D_eps_q/(D_epsp_b*sig_0)
            call I4dikdjl(I4dikdjl_r)
            call I4dijdkl(I4dijdkl_r)

            dn_d_sig=1.0/q*(3.0*I4dikdjl_r/2.0-diadic_prod_T2_T2(xid,
     &         xid)/2.0-diadic_prod_T2_T2(n_a, n_a))

            dou_sum1=(D_eps_p*d2g_dqdf+D_eps_q*d2g_dpdf)*(c_f_f*
     &         df_dDeps_p+c_f_epsp_b*d_epsp_b_dDeps_p)+
     &         (D_eps_p*d2g_dq_d_epsp_b+D_eps_q*d2g_dp_d_epsp_b)*
     &         (c_epsp_b_f*df_dDeps_p+
     &         c_epsp_b_epsp_b*d_epsp_b_dDeps_p)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c  Consolidation of constants to compute LSE to solve D: A11, A12,
c  A21, A22, B11, B12, B21, B22 and solution of LSE
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

            A11_D=dg_dq+dou_sum1
            dou_sum2=(D_eps_p*d2g_dqdf+D_eps_q*d2g_dpdf)*(c_f_f*
     &         df_dDeps_q+c_f_epsp_b*d_epsp_b_dDeps_q)+
     &         (D_eps_p*d2g_dq_d_epsp_b+D_eps_q*d2g_dp_d_epsp_b)*
     &         (c_epsp_b_f*df_dDeps_q+c_epsp_b_epsp_b*d_epsp_b_dDeps_q)
            A12_D=dg_dp+dou_sum2
            A21_D=dPHI_df *(c_f_f*df_dDeps_p+
     &         +c_f_epsp_b*d_epsp_b_dDeps_p)+
     &         dPHI_d_epsp_b*(c_epsp_b_f*df_dDeps_p
     &         +c_epsp_b_epsp_b*d_epsp_b_dDeps_p)
            A22_D=dPHI_df *(c_f_f*df_dDeps_q+
     &         c_f_epsp_b*d_epsp_b_dDeps_q)+
     &         dPHI_d_epsp_b*(c_epsp_b_f*df_dDeps_q+
     &         c_epsp_b_epsp_b*d_epsp_b_dDeps_q)
           dou_sum3=(d2g_dqdf)*(c_f_f*df_dp+c_f_epsp_b*d_epsp_b_dp)+
     &         (d2g_dq_d_epsp_b)*(c_epsp_b_f*df_dp+
     &          c_epsp_b_epsp_b*d_epsp_b_dp)
           dou_sum4=(d2g_dpdf)*(c_f_f*df_dp+c_f_epsp_b*d_epsp_b_dp)+
     &         (d2g_dp_d_epsp_b)*(c_epsp_b_f*df_dp
     &         +c_epsp_b_epsp_b*d_epsp_b_dp)
           B11_D=(1.0/3.0)*(D_eps_p*(d2g_dpdq+dou_sum3)+D_eps_q*(d2g_d2p
     &            +dou_sum4))
           dou_sum5=(d2g_dqdf)*(c_f_f*df_dq+c_f_epsp_b*d_epsp_b_dq)+
     &         (d2g_dq_d_epsp_b)*(c_epsp_b_f*df_dq+
     &         c_epsp_b_epsp_b*d_epsp_b_dq)
           dou_sum6=(d2g_dpdf)*(c_f_f*df_dq+
     &         +c_f_epsp_b*d_epsp_b_dq)+
     &         (d2g_dp_d_epsp_b)*(c_epsp_b_f*df_dq
     &         +c_epsp_b_epsp_b*d_epsp_b_dq)
           B12_D=-D_eps_p*(d2g_d2q+dou_sum5)-D_eps_q*(d2g_dpdq+dou_sum6)
           dou_sum7=dPHI_df *(c_f_f*df_dp+
     &         +c_f_epsp_b*d_epsp_b_dp)+
     &         dPHI_d_epsp_b*(c_epsp_b_f*df_dp+
     &         c_epsp_b_epsp_b*d_epsp_b_dp)
           B21_D=(1.0/3.0)*(dPHI_dp+dou_sum7)
           dou_sum8=dPHI_df *(c_f_f*df_dq+
     &         +c_f_epsp_b*d_epsp_b_dq)+
     &         dPHI_d_epsp_b*(c_epsp_b_f*df_dq
     &         +c_epsp_b_epsp_b*d_epsp_b_dq)
           B22_D=-(dPHI_dq+dou_sum8)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c  Solution of LSE to find patial(D_eps_p) and partial(D_eps_q)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

       ML = reshape((/A11_D, A12_D,
     $               A21_D, A22_D/),shape(M), order=(/2,1/))
       MR = reshape((/B11_D, B12_D,
     $               B21_D, B22_D/),shape(M), order=(/2,1/))

        M_inv = inv_T_2D(ML)
        dD_eps_pq = matmul(M_inv, MR)
        !print*, "mpn/3", dD_eps_pq(1,2)/3 ,"mql", dD_eps_pq(1,2)
        !print*, "partial delta eps_p, partial delta eps_p", c_corr

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c  Find ATS using patial(D_eps_p) and partial(D_eps_q)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

       M_4T=dD_eps_pq(1,1)*diadic_prod_T2_T2(xid, xid)/3.0
     &     +dD_eps_pq(1,2)*diadic_prod_T2_T2(xid, n_a)/3.0
     &     +dD_eps_pq(2,1)*diadic_prod_T2_T2(n_a, xid)
     &     +dD_eps_pq(2,2)*diadic_prod_T2_T2(n_a, n_a)
     &     +D_eps_q*dn_d_sig

       C_e=2.0*xmu*I4dikdjl_r-(xk-2.0/3.0*xmu)*I4dijdkl_r

       call invT4(C_e,C_e_inv)

       call invT4(M_4T+C_e_inv,ATS)

      end if

c-----------------------------------------------------------------------
c                       PLAIN STRESS CASE
c-----------------------------------------------------------------------
       ome31=-ATS(3,3,3,1)/ATS(3,3,3,3)
       ome32=-ATS(3,3,3,1)/ATS(3,3,3,3)
       ome33=-2*ATS(3,3,3,1)/ATS(3,3,3,3)
      ATS_PS= reshape((/ ATS(1,1,1,1)+ome31*ATS(1,1,3,3),
     & ATS(1,1,2,2)+ome32*ATS(1,1,3,3), ATS(1,1,1,2)+ome33*ATS(1,1,3,3),
     & ATS(2,2,1,1)+ome31*ATS(2,2,3,3),
     & ATS(2,2,2,2)+ome32*ATS(2,2,3,3), ATS(2,2,1,2)+ome33*ATS(2,2,3,3),
     & ATS(1,2,1,1)+ome31*ATS(1,2,3,3),
     & ATS(1,2,2,2)+ome32*ATS(1,2,3,3), ATS(1,2,1,2)+ome33*ATS(1,2,3,3)
     & /),shape(ATS_PS), order=(/2,1/))

      if (str_case==1) then
         ATS66(1:3,1:3)=ATS_PS
      end if

      end subroutine plas_corre_GTN

c=======================================================================
c                    subroutine Iso_hard1
c=======================================================================
c returns the yield stress and its derivative with respecto
c to epsp_b  of the full dense matrix according to an Isotropic hardening
c funtion of the microscopic equvalent plastic stress according to
c sig_0/sigy0=(sig_0/sigy0+3G*epsp_b/sigy0)^N
c------------------------------------------------------------------------
c Inputs
c epsp_b Microscopic equivaent plastic strain
c sig_0 : yield stress of the full dense matrix
c d_sig_0_d_epsp_b : derivative d_sig_0 with respect to epsp_b
c coded by: W. Mora Oct 2021
c=======================================================================

      subroutine Iso_hard1(epsp_b, sig_0,d_sig_0_d_epsp_b,inputmat)
        use tensor_operations

        implicit none
        double precision:: xE, xnu, mu, sigy0, sig_0, epsp_b
     &   , conv,sig_0n, NU, G, D_Y , d_sig_0_d_epsp_b, xsigy0
        double precision, dimension(15):: inputmat
        integer::i

        xE        = inputmat(1)
        xnu       = inputmat(2)  !Poison
        sigy0     = inputmat(3)  !Yield point
        NU        = inputmat(15)

        mu       = xE/(2.0*(1.0+xnu))
        conv=1.0
        sig_0=sigy0
        i=0
   15 if (conv .gt. 1e-6) then

          G=sig_0/sigy0-(sig_0/sigy0+3*mu/sigy0*epsp_b)**NU
          d_sig_0_d_epsp_b=3.0*mu*NU*(sig_0/sigy0+3.0*mu*epsp_b/sigy0)
     &              **(NU-1.0)/(1.0-NU*(sig_0/sigy0+
     &              3.0*mu*epsp_b/sigy0)**(NU-1))
          D_Y=-G/d_sig_0_d_epsp_b
          sig_0n=sig_0
          sig_0=sig_0+D_Y
          conv=abs(sig_0-sig_0n)
       goto 15
       endif
      end subroutine Iso_hard1


C-----------------------------------------------------------------------
      SUBROUTINE SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPUV2DZ     COMPUTE DIVERGENCE AND VORTICITY FROM WINDS
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: COMPUTES THE DIVERGENCE AND VORTICITY FROM WIND COMPONENTS
C           IN SPECTRAL SPACE.
C           SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY.
C           IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER,
C           EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS,
C           THEN THE DIVERGENCE D IS COMPUTED AS
C             D(L,N)=I*L*A*U(L,N)
C                    +EPS(L,N+1)*N*A*V(L,N+1)-EPS(L,N)*(N+1)*A*V(L,N-1)
C           AND THE VORTICITY Z IS COMPUTED AS
C             Z(L,N)=I*L*A*V(L,N)
C                    -EPS(L,N+1)*N*A*U(L,N+1)+EPS(L,N)*(N+1)*A*U(L,N-1)
C           WHERE U IS THE ZONAL WIND AND V IS THE MERIDIONAL WIND.
C           U AND V ARE WEIGHTED BY THE SECANT OF LATITUDE.
C           EXTRA TERMS ARE USED OVER TOP OF THE SPECTRAL DOMAIN.
C           ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0
C           IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN.
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C
C USAGE:    CALL SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C     ENN1     - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2
C     ELONN1   - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A
C     EON      - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A
C     EONTOP   - REAL (M+1) EPSILON/N*A OVER TOP
C     U        - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (OVER COSLAT)
C     V        - REAL ((M+1)*((I+1)*M+2)) MERID WIND (OVER COSLAT)
C     UTOP     - REAL (2*(M+1)) ZONAL WIND (OVER COSLAT) OVER TOP
C     VTOP     - REAL (2*(M+1)) MERID WIND (OVER COSLAT) OVER TOP
C
C   OUTPUT ARGUMENT LIST:
C     D        - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE
C     Z        - REAL ((M+1)*((I+1)*M+2)) VORTICITY
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
      REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2)
      REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1)
      REAL U((M+1)*((I+1)*M+2)),V((M+1)*((I+1)*M+2))
      REAL UTOP(2*(M+1)),VTOP(2*(M+1))
      REAL D((M+1)*((I+1)*M+2)),Z((M+1)*((I+1)*M+2))
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE TERMS FROM THE SPECTRAL DOMAIN
      K=1
      D(2*K-1)=0.
      D(2*K)=0.
      Z(2*K-1)=0.
      Z(2*K)=0.
      DO K=2,(M+1)*((I+1)*M+2)/2-1
        D(2*K-1)=-ELONN1(K)*U(2*K)+EON(K+1)*V(2*K+1)-EON(K)*V(2*K-3)
        D(2*K)=ELONN1(K)*U(2*K-1)+EON(K+1)*V(2*K+2)-EON(K)*V(2*K-2)
        Z(2*K-1)=-ELONN1(K)*V(2*K)-EON(K+1)*U(2*K+1)+EON(K)*U(2*K-3)
        Z(2*K)=ELONN1(K)*V(2*K-1)-EON(K+1)*U(2*K+2)+EON(K)*U(2*K-2)
      ENDDO
      K=(M+1)*((I+1)*M+2)/2
      D(2*K-1)=-ELONN1(K)*U(2*K)-EON(K)*V(2*K-3)
      D(2*K)=ELONN1(K)*U(2*K-1)-EON(K)*V(2*K-2)
      Z(2*K-1)=-ELONN1(K)*V(2*K)+EON(K)*U(2*K-3)
      Z(2*K)=ELONN1(K)*V(2*K-1)+EON(K)*U(2*K-2)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE TERMS FROM OVER TOP OF THE SPECTRAL DOMAIN
CDIR$ IVDEP
      DO L=0,M
        K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1
        D(2*K-1)=D(2*K-1)+EONTOP(L+1)*VTOP(2*L+1)
        D(2*K)=D(2*K)+EONTOP(L+1)*VTOP(2*L+2)
        Z(2*K-1)=Z(2*K-1)-EONTOP(L+1)*UTOP(2*L+1)
        Z(2*K)=Z(2*K)-EONTOP(L+1)*UTOP(2*L+2)
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  MULTIPLY BY LAPLACIAN TERM
      DO K=2,(M+1)*((I+1)*M+2)/2
        D(2*K-1)=D(2*K-1)*ENN1(K)
        D(2*K)=D(2*K)*ENN1(K)
        Z(2*K-1)=Z(2*K-1)*ENN1(K)
        Z(2*K)=Z(2*K)*ENN1(K)
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END