!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine nutrel ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Release (nutrients/detritus) by of mortality algae DYNAMO

!
!     Description of the module :
!
! Name    T   L I/O   Description                                   Unit
! ----    --- -  -    -------------------                            ---
! FL( 1)  R*4 1 O autolysis of NN4                               [gN/m3/
! FL( 2)  R*4 1 O production of N-det                            [gN/m3/
! FL( 3)  R*4 1 O autolysis of P                                 [gP/m3/
! FL( 4)  R*4 1 O production of P-det                            [gP/m3/
! FL( 5)  R*4 1 O autolysis of Si                               [gSi/m3/
! FL( 6)  R*4 1 O production of Si-det                         [gSiC/m3/
! MRT1    R*4 1 I fraction of mortality dissolved as nutrients         [
! MRT2    R*4 1 I fraction of mortality dissolved as nutrients         [
! NCRAT1  R*4 1 I Nitrogen-Carbon ratio in green-algea             [gN/g
! NCRAT2  R*4 1 I Nitrogen-Carbon ratio in diatoms                 [gN/g
! PCRAT1  R*4 1 I Phosphorus-Carbon ratio in green-algea           [gP/g
! PCRAT2  R*4 1 I Phosphorus-Carbon ratio in diatoms               [gP/g
! RESP1   R*4 1 L total respiration rate const. green-algea          [1/
! RESP2   R*4 1 L total respiration rate const. diatoms              [1/
! SCRAT3  R*4 1 I Silicate-Carbon ratio in diatoms                [gSi/g

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------

      IMPLICIT REAL (A-H,J-Z)

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4

      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
      IP11 = IPOINT(11)
!
      IFLUX = 0
      DO 9000 ISEG = 1 , NOSEG
!!    CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
!!    IF (IKMRK1.GT.0) THEN
      IF (BTEST(IKNMRK(ISEG),0)) THEN
!

      MORT1     = PMSA(IP1 )
      NCRAT1    = PMSA(IP2 )
      PCRAT1    = PMSA(IP3 )
      FMRT1A    = PMSA(IP4 )
      FMRT2A    = PMSA(IP5 )
      MORT2     = PMSA(IP6 )
      NCRAT2    = PMSA(IP7 )
      PCRAT2    = PMSA(IP8 )
      SCRAT2    = PMSA(IP9 )
      FMRT1D    = PMSA(IP10)
      FMRT2D    = PMSA(IP11)

!***********************************************************************
!**** Processes connected to the ALGEA model
!***********************************************************************

!     Calculate fractions for carbon (different from nutrient fractions)
!     no part of carbon to autolyse!
       FDCA = 0.0
       FDCD = 0.0
       IF (FMRT1A .LT. 1.0) FDCA = FMRT2A / (1-FMRT1A)
       IF (FMRT1D .LT. 1.0) FDCD = FMRT2D / (1-FMRT1D)

!@    Production of DETC
      FL ( 1 + IFLUX ) = ( MORT1 * FDCA +
     &            MORT2 * FDCD )

!@    Production of OOC
      FL ( 2 + IFLUX ) = ( MORT1 * ( 1.0 - FDCA ) +
     &            MORT2 * ( 1.0 - FDCD ) )

!@    Autolysis of NH4
      FL ( 3 + IFLUX ) = ( MORT1 * NCRAT1 * FMRT1A +
     &            MORT2 * NCRAT2 * FMRT1D )

!@    Production of DETN
      FL ( 4 + IFLUX ) = ( MORT1 * NCRAT1 * FMRT2A +
     &            MORT2 * NCRAT2 * FMRT2D )

!@    Production of OON
      FL ( 5 + IFLUX ) = ( MORT1 * NCRAT1 * ( 1.0 - FMRT1A - FMRT2A ) +
     &            MORT2 * NCRAT2 * ( 1.0 - FMRT1D - FMRT2D ) )

!@    Autolysis of PO4
      FL ( 6 + IFLUX ) = ( MORT1 * PCRAT1 * FMRT1A +
     &            MORT2 * PCRAT2 * FMRT1D )

!@    Production of DETP
      FL ( 7 + IFLUX ) = ( MORT1 * PCRAT1 * FMRT2A +
     &            MORT2 * PCRAT2 * FMRT2D )

!@    Production of OOP
      FL ( 8 + IFLUX ) = ( MORT1 * PCRAT1 * ( 1.0 - FMRT1A - FMRT2A ) +
     &            MORT2 * PCRAT2 * ( 1.0 - FMRT1D - FMRT2D ) )

!@    Autolysis of Si
      FL ( 9 + IFLUX ) =   MORT2 * SCRAT2  * FMRT1D

!@    Production of Si-det
      FL (10 + IFLUX ) =   MORT2 * SCRAT2 * FMRT2D

!@    Production of OOSI
      FL (11 + IFLUX ) =   MORT2 * SCRAT2 * ( 1.0 - FMRT1D - FMRT2D )

      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP1   = IP1   + INCREM (  1 )
      IP2   = IP2   + INCREM (  2 )
      IP3   = IP3   + INCREM (  3 )
      IP4   = IP4   + INCREM (  4 )
      IP5   = IP5   + INCREM (  5 )
      IP6   = IP6   + INCREM (  6 )
      IP7   = IP7   + INCREM (  7 )
      IP8   = IP8   + INCREM (  8 )
      IP9   = IP9   + INCREM (  9 )
      IP10  = IP10  + INCREM ( 10 )
      IP11  = IP11  + INCREM ( 11 )
!
 9000 CONTINUE
!
      RETURN
      END


#include "../defines.inc"
!--------------------------------------------------------------*
!
!           Makes Monti Carlo Moves
!
!    Quinn separated out this file on 8/9/17
!
!---------------------------------------------------------------

! variables that need to be allocated only on certain branches moved into MD to prevent segfaults
! please move other variables in as you see fit
subroutine mc_chem_move(IB1, IB2, IT1, IT2, WindoW, rand_stat, success)
! values from wlcsim_data
   use params, only: wlc_V, wlc_R, wlc_RP, wlc_AB, wlc_U &
                     , wlc_UP, wlc_ABP, wlc_VP, wlc_pointsMoved, wlc_nPointsMoved

   use mersenne_twister
   use params, only: dp
   use windowTools, only: draw_window
   use polydispersity, only: get_I

   implicit none
   integer, intent(out) :: IB1   ! Test bead position 1
   integer, intent(out) :: IT1   ! Index of test bead 1
   integer, intent(out) :: IB2   ! Test bead position 2
   integer, intent(out) :: IT2   ! Index of test bead 2
   logical, intent(out) ::success
   integer dib   ! number of beads moved by move

   integer IP    ! Test polymer
   integer J  ! Test indices
! Things for random number generator
   type(random_stat), intent(inout) :: rand_stat  ! status of random number generator
   real(dp) urnd(1) ! single random number
   real(dp), intent(in) :: WindoW ! Size of window for bead selection

   integer, parameter, dimension(0:3) :: changeBoth = [3, 2, 1, 0]
   integer, parameter, dimension(0:3) :: changeFirst = [2, 3, 0, 1]
   integer, parameter, dimension(0:3) :: changeSecond = [1, 0, 3, 2]

!TOdo saving RP is not actually needed, even in these cases, but Brad's code assumes that we have RP.
   if (WLC_P__RING .OR. WLC_P__INTERP_BEAD_LENNARD_JONES) then
      wlc_RP = wlc_R
      wlc_UP = wlc_U
   endif

! Change wlc_AB (a.k.a HP1 binding type fore section of polymer)

   call draw_window(window, WLC_P__MAXWINDOW_SLIDE_MOVE, .false., rand_stat, &
                    IT1, IT2, IB1, IB2, IP, DIB, success)
   if (success .eqv. .false.) return

!keep binding constant within monomers
   if (WLC_P__NBPM > 1) then
      IB1 = IB1 - MOD(IB1 - 1, WLC_P__NBPM)
      IB2 = IB2 - MOD(IB2 - 1, WLC_P__NBPM) + WLC_P__NBPM - 1
      IT1 = get_I(IT1, IP)
      IT2 = get_I(IT2, IP)
   endif

   if (WLC_P__TWO_TAIL) then
      call random_number(urnd, rand_stat)
      if (urnd(1) > WLC_P__PROBSINGLESWAP) then
         do J = IT1, IT2
            wlc_ABP(J) = changeBoth(wlc_AB(J))
         enddo
      elseif (urnd(1) < WLC_P__PROBSINGLESWAP/2.0_dp) then
         do J = IT1, IT2
            wlc_ABP(J) = changeFirst(wlc_AB(J))
         enddo
      else
         do J = IT1, IT2
            wlc_ABP(J) = changeSecond(wlc_AB(J))
         enddo
      endif
   else
      do J = IT1, IT2
         wlc_ABP(J) = 1 - wlc_AB(J)
      ENDdo
   endif

! Copy over R,U,V to RP, UP, and VP
   wlc_RP(:, IT1:IT2) = wlc_R(:, IT1:IT2)
   wlc_UP(:, IT1:IT2) = wlc_U(:, IT1:IT2)
   if (WLC_P__LOCAL_TWIST) wlc_VP(:, IT1:IT2) = wlc_V(:, IT1:IT2)
   do J = IT1, IT2
      wlc_nPointsMoved = wlc_nPointsMoved + 1
      wlc_pointsMoved(wlc_nPointsMoved) = J
   enddo
end subroutine


	SUBROUTINE DC_RTIM  ( irundt, irptdy, irpthr, irptmn, ndyb,
     +			      irptdt, iret )
C************************************************************************
C* DC_RTIM								*
C*									*
C* This subroutine combines a run date-time, report day, report hour,	*
C* and report minute into a report date-time.  The report day must be	*
C* within NDYB days before the run day or one day after the run day.	*
C* The maximum allowable value for NDYB is 25.				*
C*									*
C* DC_RTIM  ( IRUNDT, IRPTDY, IRPTHR, IRPTMN, NDYB, IRPTDT, IRET )	*
C*									*
C* Input parameters:							*
C*	IRUNDT (*)	INTEGER		Run date-time(YYYY,MM,DD,HH,MM)	*
C*	IRPTDY		INTEGER		Report day 			*
C*	IRPTHR		INTEGER		Report hour 			*
C*	IRPTMN		INTEGER		Report minute 			*
C*	NDYB 		INTEGER		Maximum number of days before	*
C*                                      run day that report day can be	*
C*									*
C* Output parameters:							*
C*	IRPTDT (*)	INTEGER	Report date-time(YYYY,MM,DD,HH,MM) 	*
C*	IRET		INTEGER		Return code 			*
C*					  0 = Normal return 		*
C*					 -1 = Could not compute the	*
C*					      report date-time 		*
C**									*
C* Log:									*
C* J. Ator/NCEP		03/96						*
C* R. Hollern/NCEP      06/96   Added logic to compute report date/time *
C*                              for reports more than 24 hours old      *
C* J. Ator/NCEP		06/96	Corrected logic for reports more than	*
C*				one day old but which are in same month	*
C*				as run day, and restricted NDYB <= 25 	*
C* J. Ator/NCEP		07/96	Renamed from TI_RTIM 			*
C* J. Ator/NCEP		09/96	Added check for bad return codes from	*
C*				TI_SUBD and TI_ADDD; restructured logic *
C* D. Kidwell/NCEP	04/97	Changed name from UT_RTIM, cleaned up   *
C* D. Kidwell/NCEP	10/97	Cleaned up                              *
C* D. Kidwell/NCEP	12/97	Renamed from MA_RTIM                    *
C************************************************************************
	INTEGER		irundt (*), irptdt (*)
C*
	INTEGER		iwrkdt (5)
C*
	PARAMETER	( MXDYB = 25 )
C*---------------------------------------------------------------------
	iret = -1
C
C*	Store default values for the report date-time.
C
	irptdt ( 1 ) = irundt ( 1 )
	irptdt ( 2 ) = irundt ( 2 )
	irptdt ( 3 ) = irptdy
	irptdt ( 4 ) = irpthr
	irptdt ( 5 ) = irptmn
C
	IF ( irundt ( 3 ) .eq. irptdy ) THEN
C
C*	    The report day and run day are the same, so no further
C*	    action is required.
C
	    iret = 0
	    RETURN
	END IF
C
C*	Subtract as many as MXDYB days from the run date-time.
C*	For each resulting date-time that is computed, check if the
C*	day matches the report day and, if so, then use the resulting
C*	year and month as the report year and month.
C
	DO i = 1, 5
	    iwrkdt ( i ) = irundt ( i )
	END DO
C
	IF ( ndyb .lt. MXDYB ) THEN
	    nb = ndyb
	  ELSE
	    nb = MXDYB
	END IF
C
        DO ii = 1, nb
	    CALL TI_SUBD  ( iwrkdt, iwrkdt, iersbd )
	    IF ( iersbd .ne. 0 ) THEN
		RETURN
	      ELSE IF ( iwrkdt ( 3 ) .eq. irptdy ) THEN
		irptdt ( 1 ) = iwrkdt ( 1 )
		irptdt ( 2 ) = iwrkdt ( 2 )
		iret = 0
		RETURN
	    END IF
	END DO
C
C*	Add a day to the run date-time and check if the day from
C*	the resulting date-time matches the report day.  If so,
C*	then use the resulting year and month as the report year
C*	and month.
C
	DO i = 1, 5
	    iwrkdt ( i ) = irundt ( i )
	END DO
C
	CALL TI_ADDD  ( iwrkdt, iwrkdt, ieradd )
	IF ( ieradd .ne. 0 ) THEN
	    RETURN
	  ELSE IF ( iwrkdt ( 3 ) .eq. irptdy ) THEN
	    irptdt ( 1 ) = iwrkdt ( 1 )
	    irptdt ( 2 ) = iwrkdt ( 2 )
	    iret = 0
	    RETURN
	END IF
C*
	RETURN
	END


c
c     ****************************************************************
c     *                                                              *
c     *                   subroutine overshoot_CTOA                  *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 4/8/96                     *
c     *                                                              *
c     *        This routine traverses the nodes on the current       *
c     *        crack front, extrapolating the CTOA for each angle    *
c     *        between the crack front and it's neighbors. If any    *
c     *        of the extrapolated angles are larger than            *
c     *        overshoot_limit of of the critical release CTOA,      *
c     *        reduce the size of the load step to come closer       *
c     *        to the release CTOA.                                  *
c     *                                                              *
c     ****************************************************************
c
c
c
      subroutine overshoot_CTOA ( new_load_fact, mf, mf_nm1, debug )
      use global_data ! old common.main
c
      use node_release_data, only : inv_crkpln_nodes, num_neighbors,
     &     neighbor_nodes, crack_front_nodes, crkpln_nodes_state
      use main_data, only : cnstrn
      use damage_data
c
      implicit integer (a-z)
c
      double precision
     &     d32460, angle, two, new_load_fact, crit_angle, one, mf,
     &     mf_nm1, zero, dtemp
      character(len=1) :: dums
      data d32460, two, one, zero / 32460.0, 2.0, 1.0, 0.0 /
      logical debug
c
c          If this step starts a new loading condition, then we do
c          not have enough information to change the load
c          step size; return to calling routine.
c          If there are no more crack plane
c         nodes, then return to calling routine.
c
      if ( debug ) write (out,*) '>>>>>> in overshoot_control'
      if (mf_nm1 .eq. zero) then
         if ( debug ) write (out,*) ' new loading condition; skip'
         goto 9999
      endif
c
c          traverse the linked list of crack front nodes and
c          check angles.
c
c             set pointer to top of list, and the previous node
c             pointer to null.
c
      prev_node_ptr = -1
      node_ptr = crack_front_start
      if (node_ptr .eq. -1) goto 9999
c
c             traverse the list of crack front nodes.  Extrapolate the angles
c             between the crack front node and each of its neighbors for the
c             forthcoming step.  If prediction indicates the angle
c             will be more than overshoot_limit of the critical angle,
c             set a factor which reduces the load step size to an
c             acceptible level.
c
 10   continue
c
      node = crack_front_nodes( node_ptr, 1 )
      node_data_entry = inv_crkpln_nodes( node )
c
      if ( debug ) write (out,*) ' >> Checking node ', node
c
c                loop over neighbor nodes
c
      do neighbor = 1, num_neighbors( node_data_entry )
c
c                if neighbor is constrained in the direction normal
c                to the crack plane, skip it
c
         neighbor_node = neighbor_nodes( neighbor, node_data_entry )
         dof= dstmap( neighbor_node ) + crk_pln_normal_idx - 1
         if ( cnstrn(dof).ne.d32460 ) cycle
         if ( debug ) write (out,'("     neighbor is: ",i6)')
     &        neighbor_node
c
c                find angle and appropriate critical angle ( initial
c                growth or continued growth )
c
         call get_slope( neighbor_node, node, crk_pln_normal_idx,
     &        angle )
         if ( crkpln_nodes_state( inv_crkpln_nodes( neighbor_node ) )
     &        .eq.0 ) then
            crit_angle = init_crit_ang
         else
            crit_angle = critical_angle
         endif
         if ( debug ) write (out,'("     Angle is: ",f6.3)') angle
     &        * two
c
c                if current angle is less than critical angle, check
c                for potential overshoot in upcoming step
c
         if ( angle .lt. crit_angle * ( one - CTOA_range ) )
     &        call check_CTOA_overshoot (
     &        node_ptr, neighbor, angle, crit_angle, new_load_fact,
     &        mf, mf_nm1, debug )
c
      end do
c
c            move to the next entry in the list, unless we are at the end.
c
      prev_node_ptr = node_ptr
      node_ptr = crack_front_nodes( node_ptr, 2 )
      if ( node_ptr .ne. -1 ) goto 10
c
c            if load factor has been changed, alert the user
c
      if ( new_load_fact .ne. one ) then
        dtemp =  max(new_load_fact, min_load_fact)
        call errmsg ( 270, dum, dums, real(overshoot_limit), dtemp )
      end if
c
c
 9999 continue
      if ( debug ) write(out,*) '<<<<< leaving overshoot_reduction'
c
      return
      end
c
c     ****************************************************************
c     *                                                              *
c     *                   subroutine over_CTOA_const                 *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 4/8/96                     *
c     *                                                              *
c     *        This routine traverses the nodes on the current       *
c     *        crack front, extrapolating the CTOA for each angle    *
c     *        between the crack front and it's neighbors. If any    *
c     *        of the extrapolated angles are larger than            *
c     *        overshoot_limit of of the critical release CTOA,      *
c     *        reduce the size of the load step to come closer       *
c     *        to the release CTOA.                                  *
c     *                                                              *
c     ****************************************************************
c
c
c
      subroutine over_CTOA_const ( new_load_fact, mf, mf_nm1, debug )
      use global_data ! old common.main
      use damage_data
      implicit integer (a-z)
c
      double precision
     &     d32460, angle, two, new_load_fact, crit_angle, one, mf,
     &     mf_nm1, zero, dtemp, dtol
      character(len=1) :: dums
      data d32460, two, one, zero, dtol / 32460.0, 2.0, 1.0, 0.0, 0.001/
      logical debug, use_init
c
      if ( debug ) write(out,*) '>>>>> entering over_CTOA_master'
c
c         loop over master_lines
c
      do num_line = 1, num_crack_fronts
c
         if (debug) write (out,'("    check front:",i7)') num_line
         call get_slope_master_line( num_line, use_init, angle, idummy )
         if (angle .le. dtol) cycle
c
         if ( use_init ) then
            crit_angle = init_crit_ang
         else
            crit_angle = critical_angle
         endif
         if ( debug ) write (out,'("     Angle is: ",f6.3)') angle
     &        * two
c
c                if current angle is less than critical angle, check
c                for potential overshoot in upcoming step
c
         if ( angle .lt. crit_angle * ( one - CTOA_range ) )
     &        call check_CTOA_overshoot (
     &        num_line, 1, angle, crit_angle, new_load_fact,
     &        mf, mf_nm1, debug )
c
      end do
c
c            if load factor has been changed, alert the user
c
      if ( new_load_fact .ne. one ) then
        dtemp =  max(new_load_fact, min_load_fact)
        call errmsg ( 270, dum, dums, real(overshoot_limit), dtemp )
      end if
c
c
 9999 continue
      if ( debug ) write(out,*) '<<<<< leaving over_CTOA_master'
c
      return
      end
c
c     ****************************************************************
c     *                                                              *
c     *                subroutine check_CTOA_overshoot               *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 04/05/96                   *
c     *                                                              *
c     *        This routine finds the extrapolated opening angle     *
c     *        for given node and neighbor for next step.  If this   *
c     *        is more than allowed overshoot_limit of the           *
c     *        critical release angle, then it calculates the        *
c     *        reduction in load step size required to release the   *
c     *        node closer to the critical angle.                    *
c     *                                                              *
c     ****************************************************************
c
      subroutine check_CTOA_overshoot ( node_ptr, neighbor, angle,
     &     crit_angle, new_load_fact, mf, mf_nm1, debug )
      use global_data ! old common.main
      use node_release_data, only : old_angles_at_front
      use damage_data
      implicit integer (a-z)
c
      double precision
     &     angle, crit_angle, new_load_fact, mf, mf_nm1,
     &     new_angle, load_fact, two, one
      data two, one /2.0, 1.0/
      logical debug
c
c             find projected angle. If last load step was reduced by
c             the step reduction algorithm, then divide change in angle by
c             the load factor to approxiate angle as if the load step
c             had not been reduced.  If multiplication factors
c             have changed over the step, include change in estimate.
c             If load factor has been reduced permanently, reduce the
c             estimate by the same factor.
c
      new_angle = angle + ( angle - old_angles_at_front( node_ptr,
     &     neighbor ) ) / control_load_fact  * mf / mf_nm1
     &     * perm_load_fact
      if ( debug ) write (out,'("     prediction:",f6.3)')
     &     new_angle * two
c
c             if projected angle is larger than the max accepted angle
c             (crit_angle * (1 + % allowed error)), calculate the new
c             load factor term -- if it is smaller than the one calculated
c             so far, store the new one.  In calculating the load factor,
c             include effects of permanent load size reductions and
c             changes in the multiplication factor.
c
      if ( new_angle .gt. ( ( one + overshoot_limit ) *
     &     crit_angle ) ) then
         load_fact = ( crit_angle - angle ) *  control_load_fact /
     &        ( angle - old_angles_at_front( node_ptr, neighbor ) )
     &        * ( mf_nm1 / mf ) / perm_load_fact
         if ( debug ) write (out,'("     new load fact:",e13.6)')
     &        load_fact
         new_load_fact = min( new_load_fact, load_fact )
      endif
c
c             store current angle for use in next step load reduction
c
      old_angles_at_front( node_ptr, neighbor ) = angle
c
c
 9999 continue
      return
      end
c
c     ****************************************************************
c     *                                                              *
c     *                   subroutine CTOA_cut_step                   *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 4/8/96                     *
c     *                                                              *
c     *         This routine checks if the load step size is too     *
c     *         large. We find all neighbors of crack front nodes    *
c     *         which produce CTOAs larger than the critical angle.  *
c     *         If the number of load steps since release of one     *
c     *         of these neighbors is smaller than the minimum       *
c     *         number ( min_steps_for_release ), then cut the load  *
c     *         step size by half.                                   *
c     *                                                              *
c     ****************************************************************
c
      subroutine CTOA_cut_step ( debug )
      use global_data ! old common.main
c
      use node_release_data, only : inv_crkpln_nodes, num_neighbors,
     &     neighbor_nodes, crack_front_nodes, crkpln_nodes_state
      use damage_data
      use main_data, only : cnstrn
c
      implicit integer (a-z)
c
      double precision
     &     d32460, angle, two, crit_angle, one
      character(len=1) :: dums
      real dumr
      data d32460, two, one / 32460.0, 2.0, 1.0 /
      logical debug
c
c
      if ( debug ) write (out,*) '>>>>>> in CTOA_cut_step'
c
c          traverse the linked list of crack front nodes and
c          check angles.
c
c             set pointer to top of list, and the previous node
c             pointer to null.  If there are no more crack plane
c            nodes, then skip rest of routine.
c
      prev_node_ptr = -1
      node_ptr = crack_front_start
      if (node_ptr .eq. -1) goto 9999
c
c             traverse the list of crack front nodes. If node is about
c             to be released, check each neighbor who creates angle
c             larger than the critical angle, and find how many steps
c             since the neighbor was released.  If less than
c             min_steps_for_release, cut step size in half.
c
 10   continue
c
      node = crack_front_nodes( node_ptr, 1 )
      node_data_entry = inv_crkpln_nodes( node )
c
c                loop over neighbor nodes
c
      do neighbor = 1, num_neighbors( node_data_entry )
c
c                if neighbor is constrained in the direction normal
c                to the crack plane, skip it
c
         neighbor_node = neighbor_nodes( neighbor, node_data_entry )
         dof = dstmap( neighbor_node ) + crk_pln_normal_idx - 1
         if ( cnstrn(dof).ne.d32460 ) cycle
c
c                find angle and appropriate critical angle ( initial
c                growth or continued growth ).  See if node will be
c                released.
c
         call get_slope( neighbor_node, node, crk_pln_normal_idx,
     &        angle )
         if ( crkpln_nodes_state( inv_crkpln_nodes( neighbor_node ) )
     &        .eq.0 ) then
            crit_angle = init_crit_ang * (one - CTOA_range)
         else
            crit_angle = critical_angle * (one - CTOA_range)
         end if
c
c                if current angle is larger than critical angle, then
c                node will be released this step. Check
c                if number of steps since release of neighbor is less
c                the min_steps_for_release.
c
         if ( angle .gt. crit_angle )then
            neighbor_state = crkpln_nodes_state( inv_crkpln_nodes
     &                       (neighbor_node) )
            if ( neighbor_state.gt.0 .and.
     &           neighbor_state.lt.min_steps_for_release) then
c
c                    too few steps between release. cut rate in
c                    half.  Note that we change the perm_load_fact
c                    variable -- unlike the temp_load_fact, which
c                    changes the load step size for one step, this
c                    variable changes the load step size permenantly.
c
               perm_load_fact = perm_load_fact / two
               call errmsg ( 273, dum, dums, dumr, perm_load_fact )
               goto 9999
            end if
         end if
c
      end do
c
c            move to the next entry in the list, unless we are at the end.
c
      prev_node_ptr = node_ptr
      node_ptr = crack_front_nodes( node_ptr, 2 )
      if ( node_ptr .ne. -1 ) go to 10
c
 9999 continue
c
      if ( debug ) then
         write (out,'("  ===== perm load fact:",e13.6)') perm_load_fact
         write(out,*) '<<<<< leaving CTOA_cut_step'
      end if
c
      return
      end
c     ****************************************************************
c     *                                                              *
c     *                   subroutine CTOA_cut_step_const             *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 4/8/96                     *
c     *                                                              *
c     *         This routine checks if the load step size is too     *
c     *         large. We find all master nodes with CTOAs           *
c     *         larger than the critical angle.                      *
c     *         If the number of load steps since release of         *
c     *         of previous master node is smaller than the minimum  *
c     *         number ( min_steps_for_release ), then cut the load  *
c     *         step size by half.                                   *
c     *                                                              *
c     ****************************************************************
c
      subroutine CTOA_cut_step_const ( debug )
      use global_data ! old common.main
      use node_release_data, only : inv_crkpln_nodes,
     &     crkpln_nodes_state, master_lines
      use damage_data
      implicit integer (a-z)
c
      double precision
     &     d32460, angle, two, crit_angle, one, zero
      character(len=1) :: dums
      real dumr
      data d32460, two, one, zero / 32460.0, 2.0, 1.0, 0.0 /
      logical debug, use_init
c
c
      if ( debug ) write (out,*) '>>>>>> in CTOA_cut_step'
c
c          loop over the master lines for the master_nodes. If
c          node is about to be released, find how many steps
c          since nearest neighbor was released.  If less than
c          min_steps_for_release, cut step size in half.
c
      do num_line = 1, num_crack_fronts
c
         if (debug) write (out,'("    check front:",i7)') num_line
         call get_slope_master_line( num_line, use_init, angle, idummy )
         if (angle .eq. zero) cycle
         if ( debug ) write (out,'("     Angle is: ",e13.6)') angle
c
         if ( use_init ) then
            crit_angle = init_crit_ang * (one - CTOA_range)
         else
            crit_angle = critical_angle * (one - CTOA_range)
         end if
c
c                if current angle is larger than critical angle, then
c                node will be released this step. Check
c                if number of steps since release of neighbor is less
c                the min_steps_for_release.
c
         if ( angle .gt. crit_angle )then
            neighbor_state = crkpln_nodes_state( inv_crkpln_nodes
     &                       (master_lines(num_line,2)) )
            if ( neighbor_state.gt.0 .and.
     &           neighbor_state.lt.min_steps_for_release) then
c
c                    too few steps between release. cut rate in
c                    half.  Note that we change the perm_load_fact
c                    variable -- unlike the temp_load_fact, which
c                    changes the load step size for one step, this
c                    variable changes the load step size permenantly.
c
               perm_load_fact = perm_load_fact / two
               call errmsg ( 273, dum, dums, dumr, perm_load_fact )
               goto 9999
            end if
         end if
c
      end do
c
 9999 continue
c
      if ( debug ) then
         write (out,'("  ===== perm load fact:",e13.6)') perm_load_fact
         write(out,*) '<<<<< leaving CTOA_cut_step'
      end if
c
      return
      end


function velocity(x,y,z,ips)

v0=vrefmod(z,ips)

dv_prev=dv_mod_2d(x,y,z,ips)

velocity = v0 + dv_prev

!write(*,*)' velocity=',v0,dv_prev
if(velocity.lt.0.00001) stop

return
end


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This software is governed by the CeCILL license under French law and
! abiding by the rules of distribution of free software. You can use,
! modify and/or redistribute the software under the terms of the CeCILL
! license as circulated by CEA, CNRS and Inria at the following URL
! "http://www.cecill.info".
!
! As a counterpart to the access to the source code and rights to copy,
! modify and redistribute granted by the license, users are provided only
! with a limited warranty and the software's author, the holder of the
! economic rights, and the successive licensors have only limited
! liability.
!
! In this respect, the user's attention is drawn to the risks associated
! with loading, using, modifying and/or developing or reproducing the
! software by the user in light of its specific status of free software,
! that may mean that it is complicated to manipulate, and that also
! therefore means that it is reserved for developers and experienced
! professionals having in-depth computer knowledge. Users are therefore
! encouraged to load and test the software's suitability as regards their
! requirements in conditions enabling the security of their systems and/or
! data to be ensured and, more generally, to use and operate it in the
! same conditions as regards security.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

! elastic solver

subroutine compute_forces_elastic_GPU()

  use specfem_par

  implicit none

  integer:: iphase
  logical:: phase_is_inner
  real(kind=CUSTOM_REAL),dimension(2,NGLLX,nspec_bottom) :: b_absorb_elastic_bottom_slice
  real(kind=CUSTOM_REAL),dimension(2,NGLLX,nspec_left) :: b_absorb_elastic_left_slice
  real(kind=CUSTOM_REAL),dimension(2,NGLLX,nspec_right) :: b_absorb_elastic_right_slice
  real(kind=CUSTOM_REAL),dimension(2,NGLLX,nspec_top) :: b_absorb_elastic_top_slice

  ! check
  if( PML_BOUNDARY_CONDITIONS ) &
    call exit_MPI('PML conditions not yet implemented for routine compute_forces_viscoelastic_GPU()')

  ! distinguishes two runs: for points on MPI interfaces, and points within the partitions
  do iphase=1,2

    !first for points on MPI interfaces
    if( iphase == 1 ) then
      phase_is_inner = .false.
    else
      phase_is_inner = .true.
    endif

    ! elastic term
    ! contains both forward SIM_TYPE==1 and backward SIM_TYPE==3 simulations
    call compute_forces_viscoelastic_cuda(Mesh_pointer, iphase, deltatf, &
                                          nspec_outer_elastic, &
                                          nspec_inner_elastic, &
                                          ANY_ANISOTROPY)

    ! while inner elements compute "Kernel_2", we wait for MPI to
    ! finish and transfer the boundary terms to the device asynchronously
    if(phase_is_inner .eqv. .true.) then
      !daniel: todo - this avoids calling the fortran vector send from CUDA routine
      ! wait for asynchronous copy to finish

     call sync_copy_from_device(Mesh_pointer,iphase,buffer_send_vector_ext_mesh)

      ! sends mpi buffers
      call assemble_MPI_vector_send_cuda(NPROC, &
                  buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
                  ninterface,max_nibool_interfaces_ext_mesh, &
                  nibool_interfaces_ext_mesh,&
                  my_neighbours, &
                  tab_requests_send_recv_vector,ninterface_elastic,inum_interfaces_elastic)

      ! transfers mpi buffers onto GPU
      call transfer_boundary_to_device(NPROC,Mesh_pointer,buffer_recv_vector_ext_mesh, &
                  ninterface,max_nibool_interfaces_ext_mesh, &
                  tab_requests_send_recv_vector,ninterface_elastic,inum_interfaces_elastic)

    endif ! inner elements

    ! adds elastic absorbing boundary term to acceleration (Stacey conditions)

    if( STACEY_BOUNDARY_CONDITIONS ) then
      call compute_stacey_viscoelastic_GPU(phase_is_inner,b_absorb_elastic_bottom_slice,b_absorb_elastic_left_slice,&
                                           b_absorb_elastic_right_slice,b_absorb_elastic_top_slice)
    endif

    ! acoustic coupling
    if( any_acoustic ) then
      if( num_fluid_solid_edges > 0 ) then
        call compute_coupling_el_ac_cuda(Mesh_pointer,phase_is_inner, &
                                         num_fluid_solid_edges)
      endif
    endif

    ! poroelastic coupling
    ! poroelastic coupling
    if(any_poroelastic )  then
          stop 'not implemented yet'
    endif

    ! adds source term (single-force/moment-tensor solution)

    call compute_add_sources_viscoelastic_GPU(phase_is_inner)

    ! assemble all the contributions between slices using MPI
    if( phase_is_inner .eqv. .false. ) then

        ! sends accel values to corresponding MPI interface neighbors

        ! transfers boundary region to host asynchronously. The
        ! MPI-send is done from within compute_forces_viscoelastic_cuda,
        ! once the inner element kernels are launched, and the
        ! memcpy has finished. see compute_forces_viscoelastic_cuda: ~ line 1655

        call transfer_boundary_from_device_a(Mesh_pointer)

        ! adjoint simulations
        if( SIMULATION_TYPE == 3 ) then
           call transfer_boun_accel_from_device(Mesh_pointer,&
                        b_buffer_send_vector_ext_mesh,&
                        3) ! <-- 3 == adjoint b_accel
           call assemble_MPI_vector_send_cuda(NPROC, &
                        b_buffer_send_vector_ext_mesh,b_buffer_recv_vector_ext_mesh, &
                        ninterface,max_nibool_interfaces_ext_mesh, &
                        nibool_interfaces_ext_mesh,&
                        my_neighbours, &
                        b_tab_requests_send_recv_vector,ninterface_elastic,inum_interfaces_elastic)
        endif !adjoint

    else

!       waits for send/receive requests to be completed and assembles values
         call assemble_MPI_vector_write_cuda(NPROC,Mesh_pointer,&
                      buffer_recv_vector_ext_mesh,ninterface,&
                      max_nibool_interfaces_ext_mesh, &
                      nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
                      tab_requests_send_recv_vector, &
                      1,ninterface_elastic,inum_interfaces_elastic)
         ! adjoint simulations
         if( SIMULATION_TYPE == 3 ) then
           call assemble_MPI_vector_write_cuda(NPROC,Mesh_pointer,&
                              b_buffer_recv_vector_ext_mesh,ninterface,&
                              max_nibool_interfaces_ext_mesh, &
                              nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
                              b_tab_requests_send_recv_vector, &
                              3,ninterface_elastic,inum_interfaces_elastic)
         endif !adjoint

    endif  ! Phase_is_inner

  enddo ! Phase_is_inner

 ! multiplies with inverse of mass matrix (note: rmass has been inverted already)
 call kernel_3_a_cuda(Mesh_pointer,deltatover2f,b_deltatover2f)

end subroutine compute_forces_elastic_GPU

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

! absorbing boundary term for elastic media (Stacey conditions)

  subroutine compute_stacey_viscoelastic_GPU(phase_is_inner,b_absorb_elastic_bottom_slice,b_absorb_elastic_left_slice,&
                                             b_absorb_elastic_right_slice, b_absorb_elastic_top_slice)

  use constants
  use specfem_par, only : nspec_bottom,nspec_left,nspec_top,nspec_right,b_absorb_elastic_left,b_absorb_elastic_right,&
                          b_absorb_elastic_bottom, b_absorb_elastic_top,SIMULATION_TYPE,SAVE_FORWARD,NSTEP,it,&
                          nelemabs,Mesh_pointer
  implicit none

! communication overlap
  logical :: phase_is_inner

  real(kind=CUSTOM_REAL),dimension(2,NGLLX,nspec_bottom) :: b_absorb_elastic_bottom_slice
  real(kind=CUSTOM_REAL),dimension(2,NGLLX,nspec_left) :: b_absorb_elastic_left_slice
  real(kind=CUSTOM_REAL),dimension(2,NGLLX,nspec_right) :: b_absorb_elastic_right_slice
  real(kind=CUSTOM_REAL),dimension(2,NGLLX,nspec_top) :: b_absorb_elastic_top_slice

  ! checks if anything to do
  if( nelemabs == 0 ) return

if( SIMULATION_TYPE == 3 ) then
    if( phase_is_inner .eqv. .false. ) then

    b_absorb_elastic_bottom_slice(1,:,:)=b_absorb_elastic_bottom(1,:,:,NSTEP-it+1)
    b_absorb_elastic_left_slice(1,:,:)=b_absorb_elastic_left(1,:,:,NSTEP-it+1)
    b_absorb_elastic_right_slice(1,:,:)=b_absorb_elastic_right(1,:,:,NSTEP-it+1)
    b_absorb_elastic_top_slice(1,:,:)=b_absorb_elastic_top(1,:,:,NSTEP-it+1)

    b_absorb_elastic_bottom_slice(2,:,:)=b_absorb_elastic_bottom(3,:,:,NSTEP-it+1)
    b_absorb_elastic_left_slice(2,:,:)=b_absorb_elastic_left(3,:,:,NSTEP-it+1)
    b_absorb_elastic_right_slice(2,:,:)=b_absorb_elastic_right(3,:,:,NSTEP-it+1)
    b_absorb_elastic_top_slice(2,:,:)=b_absorb_elastic_top(3,:,:,NSTEP-it+1)

    endif
endif

  call compute_stacey_viscoelastic_cuda(Mesh_pointer,phase_is_inner,b_absorb_elastic_left_slice,&
                   b_absorb_elastic_right_slice,b_absorb_elastic_top_slice,b_absorb_elastic_bottom_slice)

  ! adjoint simulations: stores absorbed wavefield part
  if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD ) then
    ! writes out absorbing boundary value only when second phase is running
    if( phase_is_inner .eqv. .true. ) then
    b_absorb_elastic_bottom(1,:,:,it) = b_absorb_elastic_bottom_slice(1,:,:)
    b_absorb_elastic_right(1,:,:,it) = b_absorb_elastic_right_slice(1,:,:)
    b_absorb_elastic_top(1,:,:,it) = b_absorb_elastic_top_slice(1,:,:)
    b_absorb_elastic_left(1,:,:,it) = b_absorb_elastic_left_slice(1,:,:)

    b_absorb_elastic_bottom(3,:,:,it) = b_absorb_elastic_bottom_slice(2,:,:)
    b_absorb_elastic_right(3,:,:,it) = b_absorb_elastic_right_slice(2,:,:)
    b_absorb_elastic_top(3,:,:,it) = b_absorb_elastic_top_slice(2,:,:)
    b_absorb_elastic_left(3,:,:,it) = b_absorb_elastic_left_slice(2,:,:)

    endif
  endif

  end subroutine compute_stacey_viscoelastic_GPU

!
!=====================================================================
! for elastic solver on GPU

  subroutine compute_add_sources_viscoelastic_GPU(phase_is_inner)

  use constants
  use specfem_par,only: NSTEP,SIMULATION_TYPE,nadj_rec_local,it,Mesh_pointer

  implicit none

  logical :: phase_is_inner

! forward simulations
  if (SIMULATION_TYPE == 1 ) call compute_add_sources_el_cuda(Mesh_pointer,phase_is_inner,it)

! adjoint simulations
  if (SIMULATION_TYPE == 3 .and. nadj_rec_local > 0 .and. it < NSTEP ) then
        call add_sources_el_sim_type_2_or_3(Mesh_pointer,phase_is_inner, NSTEP -it + 1, nadj_rec_local,NSTEP)
  endif

! adjoint simulations
  if (SIMULATION_TYPE == 3 ) call compute_add_sources_el_s3_cuda(Mesh_pointer,phase_is_inner,NSTEP -it + 1)

  end subroutine compute_add_sources_viscoelastic_GPU