#include "../defines.inc"
module windowTools
   implicit none
contains

   function exponential_random_int(window, rand_stat) result(output)
      ! this function gives a random exponentially distributed intiger
      ! the most likely outcome is 0
      use params, only: dp
      use mersenne_twister
      implicit none
      type(random_stat), intent(inout) :: rand_stat  ! status of random number generator
      real(dp) urnd(1) ! single random number
      real(dp), intent(in) :: window
      integer output
      call random_number(urnd, rand_stat)
      output = nint(-1.0_dp*log(urnd(1) + 0.000001_dp)*window + 0.0001_dp)
      output = abs(output)
   end function exponential_random_int

!Expand [IB1,IB2] and [IT1,IT2] regions to include bound pairs
!Return success=False not able to do this
   subroutine enforce_binding(rand_stat, IB1, IB2, IT1, IT2, max_window, success)
! values from wlcsim_data
      use params, only: wlc_ExplicitBindingPair, wlc_network_start_index, wlc_other_beads
      use params, only: dp
      use mersenne_twister
      use polydispersity, only: are_on_same_chain, get_IB
      implicit none
      type(random_stat), intent(inout) :: rand_stat  ! status of random number generator
      integer, intent(inout) :: IT1, IT2, IB1, IB2
      real(dp), intent(in) :: max_window
      logical, intent(out) :: success
      integer otherEnd
      real(dp) urnd(1) ! single random number
      integer IT1_temp, IT2_temp, IB1_temp, IB2_temp, I
      logical test_move
      integer indx
      success = .True.
      if (WLC_P__PROB_BIND_RESPECTING_MOVE < 1.0_dp) then
         call random_number(urnd, rand_stat)
         test_move = WLC_P__PROB_BIND_RESPECTING_MOVE > urnd(1)
      else
         test_move = .TRUE.
      endif
      if (test_move) then
         if (WLC_P__NO_LEF_CROSSING) then
            ! IF we can be guarunteed that not loop will cross
            ! attempt to grow region to garuntee no external loops
            if (WLC_P__NETWORK) then
               print *, "NO_LEF_CROSSING is inconsistant with network"
               stop
            endif
            IB1_temp = IB1
            IT1_temp = IT1
            IB2_temp = IB2
            IT2_temp = IT2
            do I = IT1, IT2
               otherEnd = wlc_ExplicitBindingPair(I)
               if (WLC_P__NP > 1) then
                  ! make sure the other end is on the same polymer
                  if (.not. are_on_same_chain(IT1, otherEnd)) then
                     if (WLC_P__PROB_BIND_RESPECTING_MOVE > 0.9999_dp) then
                        ! If only bind respecting moves allowed
                        ! can't have a loop to a different polymer
                        success = .FALSE.
                        return
                     endif
                     cycle ! don't expand [IT1,IT2] to different polymer
                  endif
               endif
               if (otherEnd < 1) cycle
               if (otherEnd < IT1) then  ! Loop to point before IT1
                  IB1_temp = IB1 - IT1 + otherEnd
                  IT1_temp = otherEnd
               elseif (otherEnd > IT2) then ! Loop to point after IT2
                  IB2_temp = IB2 - IT2 + otherEnd
                  IT2_temp = otherEnd
                  exit
               endif
            enddo
            if (IB2_temp - IB1_temp < max_window) then
               ! prevent extremely long crank shaft moves
               IB1 = IB1_temp
               IT1 = IT1_temp
               IB2 = IB2_temp
               IT2 = IT2_temp
               if (WLC_P__WARNING_LEVEL >= 1) then
                  if (IB2 /= get_IB(IT2) .or. IB1 /= get_IB(IT1)) then
                     print *, "Error in enforce binding"
                     stop 1
                  endif
               endif
               return
            else
               if (WLC_P__PROB_BIND_RESPECTING_MOVE > 0.9999_dp) success = .FALSE.
               return
            endif
            if (WLC_P__WARNING_LEVEL < 1) then
               ! No need to check if we're sure it's taken care of
               return
            endif
         endif ! NO_LEF_CROSSING

         ! Check for any loops out of moved region
         do I = IT1, IT2
            if (WLC_P__NETWORK) then
               do indx = wlc_network_start_index(I), &
                  wlc_network_start_index(I + 1) - 1
                  otherEnd = wlc_other_beads(indx)
                  if (otherEnd < IT1 .or. otherEnd > IT2) then
                     success = .False.
                     return
                  endif
               enddo
            else
               otherEnd = wlc_ExplicitBindingPair(I)
               if ((otherEnd < IT1 .or. otherEnd > IT2) .and. otherEnd > 0) then
                  success = .False.
                  return
               endif
            endif
         enddo
      endif
   end subroutine

   subroutine draw_window(window, maxWindow, enforceBind, rand_stat, IT1, IT2, IB1, IB2, IP, DIB, success)
      use params, only: dp
      use mersenne_twister
      use polydispersity, only: get_IB, length_of_chain, get_IP, get_I
      implicit none
      real(dp), intent(in) :: WindoW ! Size of window for bead selection
      real(dp), intent(in) :: maxWindow
      logical, intent(in) :: enforceBind  ! don't do move with internal bind
      type(random_stat), intent(inout) :: rand_stat  ! status of random number generator
      integer, intent(out) :: IP    ! Test polymer
      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
      integer, intent(out) :: dib   ! number of beads moved by move (plus or minus a few)
      logical, intent(out) :: success
      integer irnd(1)
      real(dp) urnd(1) ! single random number
      integer TEMP
      integer length

      success = .TRUE.  ! True unless set to false
      call random_index(WLC_P__NT, irnd, rand_stat)
      IT1 = irnd(1)
      IP = get_IP(IT1)
      IB1 = get_IB(IT1)
      if (WLC_P__WINTYPE .eq. 0) then
         IB2 = IB1 + exponential_random_int(window, rand_stat)
      elseif (WLC_P__WINTYPE .eq. 1 .and. .not. WLC_P__RING) then
         call random_number(urnd, rand_stat)
         IB2 = IB1 + (2*nint(urnd(1)) - 1)* &
               exponential_random_int(window, rand_stat)
      elseif (WLC_P__WINTYPE .eq. 1 .and. WLC_P__RING) then
         IB2 = IB1 + exponential_random_int(window, rand_stat)
      else
         call stop_if_err(1, "Warning: WLC_P__WINTYPE not recognized")
      endif

      length = length_of_chain(IP)
      if (WLC_P__RING) then
         if (IB2 > IB1 + length) IB2 = IB1 + length
         if (IB2 > length) then
            IB2 = IB2 - length
         endif
         if (WLC_P__EXPLICIT_BINDING) then
            print *, "Ring polymer not set up to use explicit binding"
            print *, "Need to write special loop skiping code"
            stop
         endif
         IT2 = get_I(IB2, IP)
         IT1 = get_I(IB1, IP)
         if (IB1 <= IB2) then
            DIB = IB2 - IB1
         else
            DIB = length - IB1 + IB2
         endif
      else
         if (IB2 > length) then
            IB2 = length
         endif
         if (IB2 < 1) then
            IB2 = 1
         endif
         if (IB2 < IB1) then
            TEMP = IB1
            IB1 = IB2
            IB2 = TEMP
         endif
         IT2 = get_I(IB2, IP)
         IT1 = get_I(IB1, IP)
         if (WLC_P__EXPLICIT_BINDING .and. enforceBind) then
            call enforce_binding(rand_stat, IB1, IB2, IT1, IT2, maxWindow, success)
            if (success .eqv. .False.) return
         endif
         DIB = IB2 - IB1
      endif
   end subroutine draw_window

end module windowTools


      SUBROUTINE SS2D82 (IEQEX,NEQEX,TGRID)
C
C     PHASE 2 OF STRESS DATA RECOVERY FOR 2-D, 8 GRID POINT
C     ISOPARAMETRIC STRUCTURAL ELEMENT
C
C     PH1OUT CONTAINS THE FOLLOWING
C     ELEMENT ID
C     8 SILS
C     TREF
C     ST ARRAY
C     TRANSFORMATION MATRIX FROM GLOBAL TO ELEMENT COORDINATES
C     COORD SYSTEM ID FOR STRESS OUTPUT
C     G MATRIX
C     DNX,DNY AT EACH GRID POINT -EVALUATED 8 TIMES
C
C
      DIMENSION       TGRID(8),ST(3),TA(48),G(9),B(9),DB(72),DISP(24),
     1                SIG(3),BB(72),DNX(8),DNY(8),TB(6),TEMP(9),
     2                ISTRES(3),NSIL(1),NPH1(1),DN(8),XI(8),ETA(8),
     3                PT(3),EX2D82(32),EX2D83(72),SIGS(27),SIGT(24),
     4                IZ(1),STRESS(43)
      COMMON /ZZZZZZ/ Z(1)
      COMMON /SDR2X4/ DUMMY(35),IVEC,IVECN,LDTEMP,DEFORM
      COMMON /SDR2X7/ PH1OUT(100),STR(250),FORVEC(250)
      COMMON /SDR2X8/ DISP,DNX,DNY,DNZ,B,TB,BB,DB,SIG,IBASE,NSTRT,NPT,
     1                IS,IDTEMP
      EQUIVALENCE     (PH1OUT(1),NPH1(1)),(PH1OUT(1),ID),
     1                (NSIL(1),PH1OUT(2)),(TREF,PH1OUT(10)),
     2                (ST(1),PH1OUT(11)),(TA(1),PH1OUT(14)),
     3                (G(1),PH1OUT(63)),(PH1OUT(62),ID1),
     4                (ISTRES(1),STRESS(1)),(LDTEMP,ELTEMP),
     5                (Z(1),IZ(1))
      DATA    EX2D82/
     1 1.86603,-.50000,-.50000, .13397,-.50000, .13397,1.86603,-.50000,
     2  .13397,-.50000,-.50000,1.86603,-.50000,1.86603, .13397,-.50000,
     3  .68301,-.18301, .68301,-.18301,-.18301,-.18301, .68301, .68301,
     4 -.18301, .68301,-.18301, .68301, .68301, .68301,-.18301,-.18301/
      DATA    EX2D83/
     1 2.18694,-.98589, .27778,-.98589, .44444,-.12522, .27778,-.12522,
     2  .03528, .27778,-.12522, .03528,-.98589, .44444,-.12522,2.18694,
     3 -.98589, .27778, .03528,-.12522, .27778,-.12522, .44444,-.98589,
     4  .27778,-.98589,2.18694, .27778,-.98589,2.18694,-.12522, .44444,
     5 -.98589, .03528,-.12522, .27778,-.00000,0.00000,-.00000,1.47883,
     6 -.66667, .18784, .00000,-.00000,-.00000,-.00000, .18784, .00000,
     7 -.00000,-.66667,-.00000, .00000,1.47883, .00000,-.00000,0.00000,
     8  .00000, .18784,-.66667,1.47883, .00000,-.00000, .00000,-.00000,
     9 1.47883, .00000,-.00000,-.66667,-.00000,-.00000, .18784,0.00000/
      DATA    XI    / -1., 1., 1.,-1., 0., 1., 0.,-1./
      DATA    ETA   / -1.,-1., 1., 1.,-1., 0., 1., 0./
C
C     SET UP DISPLACEMENTS FOR THIS ELEMENT
C
      IS  = 0
      DO 10 I = 1,8
      NSTRT = IVEC + NSIL(I) - 1
      DO 10 J = 1,3
      IS  = IS + 1
      NPT = NSTRT + J - 1
      DISP(IS) = Z(NPT)
   10 CONTINUE
C
C     INITIALIZE SOME MATRICES
C
      DO 30 I = 1,72
   30 BB(I) = 0.
C
C     SET UP INDICATOR FOR GRID POINT TEMPERATURES
C
      IDTEMP = 0
      DO 40 I = 1,8
      IF (TGRID(I) .NE. 0.) GO TO 50
   40 CONTINUE
      GO TO 60
   50 IDTEMP = 1
C
C     START LOOPING FOR STRESSES
C
   60 IDN = 4
      IF (ID1 .EQ. 3) IDN = 9
      III = 0
      PT(1) = -0.57735027
      PT(2) = -PT(1)
      IF (ID1 .EQ. 2) GO TO 133
      PT(1) = -0.77459667
      PT(2) = 0.
      PT(3) = -PT(1)
  133 DO 135 JII = 1,ID1
      DO 135 JJJ = 1,ID1
      III = III + 1
C
C     COMPUTE BASE POINTER FOR PICKING UP DERIVATIVES
C
      IBASE = 71 + 16*(III-1)
C
      DO 70 N = 1,8
      NX = N + IBASE
      NY = N + IBASE + 8
      DNX(N) = PH1OUT(NX)
      DNY(N) = PH1OUT(NY)
   70 CONTINUE
C
      DO 130 N = 1,8
C
C     SET UP THE B MATRIX
C
      DO 75 I = 1,9
      TEMP(I) = 0.
   75 B(I) = 0.
      B(1) = DNX(N)
      B(4) = DNY(N)
      B(5) = DNY(N)
      B(6) = DNX(N)
C
C     TRANSFORM TO ELEMENT COORDINATES
C
      KK = 6*N - 6
      DO 80 I = 1,6
      K  = KK + I
      TB(I) = TA(K)
   80 CONTINUE
      CALL GMMATS (B,3,2,0,TB,2,3,0,TEMP(1))
      N3 = 3*N
      BB(N3- 2) = TEMP(1)
      BB(N3- 1) = TEMP(2)
      BB(N3   ) = TEMP(3)
      BB(N3+22) = TEMP(4)
      BB(N3+23) = TEMP(5)
      BB(N3+24) = TEMP(6)
      BB(N3+46) = TEMP(7)
      BB(N3+47) = TEMP(8)
      BB(N3+48) = TEMP(9)
  130 CONTINUE
C
C     BRING IN G MATRIX
C
      CALL GMMATS (G,3,3,0,BB,3,24,0,DB)
C
C     COMPUTE STRESSES
C
      CALL GMMATS (DB,3,24,0,DISP,24,1,0,SIG)
C
C     STORE GAUSS POINT STRESSES INTO SIGT
C
      I3 = 3*(III-1)
      DO 131 I = 1,3
      ISUB = I3 + I
      SIGS(ISUB) = SIG(I)
  131 CONTINUE
C
C     COMPUTE GAUSS POINT  TEMPERATURES
C
      IF (LDTEMP .EQ. -1) GO TO 135
      IF (IDTEMP .EQ.  1) GO TO 229
      RGTEMP = ELTEMP - TREF
      GO TO 250
C
C     ALL TEMPERATURES ARE DEFAULT VALUE
C
  229 DO 230 N = 1,4
      DN(N) = .25*(1.+PT(JII)*XI(N))*(1.+PT(JJJ)*ETA(N))
     1           *(PT(JII)*XI(N)+PT(JJJ)*ETA(N)-1.)
  230 CONTINUE
      DO 231 N = 5,7,2
      DN(N) = .5*(1.-PT(JII)*PT(JII))*(1.+PT(JJJ)*ETA(N))
  231 CONTINUE
      DO 232 N = 6,8,2
      DN(N) = .5*(1.+PT(JII)*XI(N))*(1.-PT(JJJ)*PT(JJJ))
  232 CONTINUE
      GSTEMP = 0.
      DO 240 N = 1,8
      GSTEMP = GSTEMP + DN(N)*TGRID(N)
  240 CONTINUE
      RGTEMP = GSTEMP - TREF
  250 CONTINUE
      DO 260 I = 1,3
      ISUB = I3 + I
      SIGS(ISUB) = SIGS(ISUB) - ST(I)*RGTEMP
  260 CONTINUE
C
  135 CONTINUE
C
C     MULTIPLY BY TRANSFORMATION FROM GAUSS POINTS TO GRID POINTS
C
      IF (ID1 .EQ. 2) CALL GMMATS (EX2D82,8,4,0,SIGS,4,3,0,SIGT)
      IF (ID1 .EQ. 3) CALL GMMATS (EX2D83,8,9,0,SIGS,9,3,0,SIGT)
C
C     FINISH UP
C
      DO 500 III = 1,8
C
C     MOVE A ROW OF SIGT INTO SIG
C
      I3 = 3*(III-1)
      DO 132 I = 1,3
      ISUB = I3 + I
      SIG(I) = SIGT(ISUB)
  132 CONTINUE
C
C     STORE STRESSES
C
      JSUB  = 5*(III-1) + 4
      ISUB1 = IEQEX + 1
      ISUB2 = IEQEX + NEQEX - 1
      DO 161 JJJ = ISUB1,ISUB2,2
      NS = IZ(JJJ)/10
      IF (NS .NE. NSIL(III)) GO TO 161
      ISTRES(JSUB) = IZ(JJJ-1)
      GO TO 162
  161 CONTINUE
      CALL MESAGE (-30,164,IZ(JJJ))
  162 CONTINUE
      ISTRES(JSUB+1) = 0
      DO 170 I = 1,3
      JJSUB = JSUB + 1 + I
      STRESS(JJSUB) = SIG(I)
  170 CONTINUE
C
C     LOOP FOR OTHER GRID POINTS
C
  500 CONTINUE
C
C     FINISH UP
C
C     ELEMENT ID
C
      ISTRES(1) = ID
C
C     NUMBER OF GRID POINTS PER ELEMENT
C
      ISTRES(2) = 8
C
C     NUMBER OF STRESSES OUTPUT PER ELEMENT
C
      ISTRES(3) = 3
C
      DO 600 I = 1,43
  600 STR(I) = STRESS(I)
C
      RETURN
      END


      subroutine PSZHHamps(pa,pb,pc,pd,amp)
C--    Formula taken from Plehn, Spira and Zerwas
C--    Nucl. Phys. B479 (1996) 46
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'scale.f'
      include 'first.f'
      double precision pa(4),pb(4),pc(4),pd(4),pcsq,pdsq,
     & ss,tt,uu,S,T,U,T1,T2,U1,U2,rhoc,rhod,tauQ,mQsq,lambdaHHH
      double complex Ftriangle,Fbox,Gbox,
     & Dabc,Dbac,Dacb,Cab,Cbc,Cac,Ccd,Cbd,Cad,qlI4,qlI3,
     & Cdelta,Cbox,amp(2)

c--- initialize QCDLoop, if necessary
      if (first) then
        call qlinit
        first=.false.
      endif

      mQsq=mt**2
      ss=(pa(4)+pb(4))**2
     &  -(pa(1)+pb(1))**2-(pa(2)+pb(2))**2-(pa(3)+pb(3))**2
      tt=(pa(4)+pc(4))**2
     &  -(pa(1)+pc(1))**2-(pa(2)+pc(2))**2-(pa(3)+pc(3))**2
      uu=(pb(4)+pc(4))**2
     &  -(pb(1)+pc(1))**2-(pb(2)+pc(2))**2-(pb(3)+pc(3))**2
      S=ss/mQsq
      T=tt/mQsq
      U=uu/mQsq
      lambdaHHH=3d0*(hmass/zmass)**2
      rhoc=hmass**2/mQsq
      rhod=hmass**2/mQsq
      T1=T-rhoc
      U1=U-rhoc
      T2=T-rhod
      U2=U-rhod
      tauQ=4d0/S
C      ss=(pa+pb)**2
C      tt=(pa+pc)**2
C      uu=(pb+pc)**2
      pcsq=pc(4)**2-pc(1)**2-pc(2)**2-pc(3)**2
      pdsq=pd(4)**2-pd(1)**2-pd(2)**2-pd(3)**2
      Cab=qlI3(0d0,0d0,ss,mQsq,mQsq,mQsq,musq,0)
      Cbc=qlI3(0d0,pcsq,uu,mQsq,mQsq,mQsq,musq,0)
      Cac=qlI3(0d0,pcsq,tt,mQsq,mQsq,mQsq,musq,0)
      Ccd=qlI3(pcsq,pdsq,ss,mQsq,mQsq,mQsq,musq,0)
      Cbd=qlI3(0d0,pdsq,tt,mQsq,mQsq,mQsq,musq,0)
      Cad=qlI3(0d0,pdsq,uu,mQsq,mQsq,mQsq,musq,0)
      Dabc=qlI4(0d0,0d0,pcsq,pdsq,ss,uu,mQsq,mQsq,mQsq,mQsq,musq,0)
      Dbac=qlI4(0d0,0d0,pcsq,pdsq,ss,tt,mQsq,mQsq,mQsq,mQsq,musq,0)
      Dacb=qlI4(0d0,pcsq,0d0,pdsq,tt,uu,mQsq,mQsq,mQsq,mQsq,musq,0)

      Ftriangle=2d0/S*(2d0+(4d0-S)*mQsq*Cab)

      Fbox=(4d0*S+8d0*S*mQsq*Cab-2d0*S*(S+rhoc+rhod-8d0)
     & *mQsq**2*(Dabc+Dbac+Dacb)
     & +(rhoc+rhod-8d0)*mQsq*(T1*Cac+U1*Cbc+U2*Cad+T2*Cbd
     & -(T*U-rhoc*rhod)*mQsq*Dacb))/S**2
      Gbox=((T**2+rhoc*rhod-8d0*T)*mQsq
     & *(S*Cab+T1*Cac+T2*Cbd-S*T*mQsq*Dbac)
     & +(U**2+rhoc*rhod-8d0*U)*mQsq
     & *(S*Cab+U1*Cbc+U2*Cad-S*U*mQsq*Dabc)
     & -(T**2+U**2-2d0*rhoc*rhod)*(T+U-8d0)*mQsq*Ccd
     & -2d0*(T+U-8d0)*(T*U-rhoc*rhod)*mQsq**2
     & *(Dabc+Dbac+Dacb))/(S*(T*U-rhoc*rhod))

      Cdelta=lambdaHHH*zmass**2/dcmplx(ss-hmass**2,hmass*hwidth)
      Cbox=cone

      amp(1)=Cdelta*Ftriangle+Cbox*Fbox
      amp(2)=Cbox*Gbox
      return
      end


module platemotion

character(len=512) :: input_file
character(len=512) :: output_file
character(len=16) :: plates(2)
double precision :: pole(3)
character(len=32) :: model_name
character(len=32) :: convert_mode

end module

!==================================================================================================!

program main
!----
! Compute relative plate velocities given (a) plates from a hard-coded list or (b) an Euler pole
!----

use io, only: stdout, stdin
use trig, only: d2r
use algebra, only: cross_product, normalize
use earth, only: get_pole, pole_geo2xyz, pole_xyz2geo, deg2km

use platemotion, only: input_file, &
                       output_file, &
                       plates, &
                       pole, &
                       model_name, &
                       convert_mode

implicit none

integer :: ierr, ios, luin, luout
double precision :: xyz_pole(3)
double precision :: lon, lat, lonr, latr, r(3), vel(3), vn, ve, vz
character(len=512) :: input_line

! Parse command line
call gcmdln()

! Convert and exit if convert mode specified
if (convert_mode.eq.'xyz2geo') then
    call pole_xyz2geo(pole(1),pole(2),pole(3),xyz_pole(1),xyz_pole(2),xyz_pole(3),'sphere')
    write(*,*) xyz_pole(1),xyz_pole(2),xyz_pole(3)
    stop
elseif (convert_mode.eq.'geo2xyz') then
    call pole_geo2xyz(pole(1),pole(2),pole(3),xyz_pole(1),xyz_pole(2),xyz_pole(3),'sphere')
    write(*,*) xyz_pole(1),xyz_pole(2),xyz_pole(3)
    stop
endif

! Calculate pole of rotation between plate pair
if (plates(1).ne.'') then
    call get_pole(plates(1),plates(2),model_name,pole,ierr)
    if (ierr.ne.0) then
        call usage('platemotion: problem computing pole of rotation from plate circuit')
    endif
endif

! Convert pole to Cartesian coordinates
call pole_geo2xyz(pole(1),pole(2),pole(3),xyz_pole(1),xyz_pole(2),xyz_pole(3),'sphere')

! Open input and output streams
if (input_file.eq.'') then
    luin = stdin
else
    luin = 11
    open(unit=luin,file=input_file,status='old')
endif

if (output_file.eq.'') then
    luout = stdout
else
    luout = 12
    open(unit=luout,file=output_file,status='unknown')
endif

! Calculate predicted velocities
do
    read(luin,'(A)',iostat=ios) input_line
    if (ios.ne.0) then
        exit
    endif

    ! Read longitude and latitude
    read(input_line,*) lon, lat

    ! Calculate vector from center of Earth to point
    lonr = lon*d2r
    latr = lat*d2r
    ! call ellipsoid_geo2xyz(lon,lat,0.0d0,r(1),r(2),r(3),semimajor_grs80,eccentricity_grs80)
    ! call normalize(r)
    r(1) = dcos(latr)*dcos(lonr)
    r(2) = dcos(latr)*dsin(lonr)
    r(3) = dsin(latr)

    ! Velocity at that point is cross product of angular velocity vector and position vector
    call cross_product(xyz_pole,r,vel)
    ve = -vel(1)           *dsin(lonr) + vel(2)           *dcos(lonr)
    vn = -vel(1)*dsin(latr)*dcos(lonr) - vel(2)*dsin(latr)*dsin(lonr) + vel(3)*dcos(latr)
    vz =  vel(1)*dcos(latr)*dcos(lonr) + vel(2)*dcos(latr)*dsin(lonr) + vel(3)*dsin(latr)

    ! Units are deg/Ma; convert to km/Ma = mm/yr
    ve = ve*deg2km
    vn = vn*deg2km

    ! Write location and velocity
    write(luout,*) lon, lat, ve, vn
enddo

end

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

subroutine gcmdln()

use earth, only: list_plate_models

use platemotion, only: input_file, &
                       output_file, &
                       plates, &
                       pole, &
                       model_name, &
                       convert_mode

implicit none

! Local variables
integer :: i, j, narg
character(len=512) :: tag

! Initialize control parameters
input_file = ''
output_file = ''
plates = ''
pole = 0.0d0
model_name = 'MORVEL56'
convert_mode = ''

! Number of arguments
narg = command_argument_count()
if (narg.eq.0) then
  call usage('')
endif

! Read arguments
i = 1
do while (i.le.narg)

    call get_command_argument(i,tag)

    if (trim(tag).eq.'-plate'.or.trim(tag).eq.'-plates') then
        i = i + 1
        call get_command_argument(i,plates(1))
        j = index(plates(1),'/')
        plates(1)(j:j) = ' '
        read(plates(1),*) plates(2),plates(2)
        plates(1)(j:len(plates(1))) = ''

    elseif (trim(tag).eq.'-pole') then
        i = i + 1
        call get_command_argument(i,tag)
        j = index(tag,'/')
        tag(j:j) = ' '
        j = index(tag,'/')
        tag(j:j) = ' '
        read(tag,*) pole(1),pole(2),pole(3)

    elseif (trim(tag).eq.'-model') then
        i = i + 1
        call get_command_argument(i,model_name)

    elseif (trim(tag).eq.'-list') then
        i = i + 1
        if (i.gt.narg) then
            call list_plate_models('ALL')
        else
            call get_command_argument(i,tag)
            call list_plate_models(tag)
        endif
        stop

    elseif (trim(tag).eq.'-f') then
        i = i + 1
        call get_command_argument(i,input_file)

    elseif (trim(tag).eq.'-o') then
        i = i + 1
        call get_command_argument(i,output_file)

    elseif (tag.eq.'-geo2xyz') then
        convert_mode = 'geo2xyz'
    elseif (tag.eq.'-xyz2geo') then
        convert_mode = 'xyz2geo'

    else
        call usage('platemotion: no command line option '//trim(tag))
    endif

    i = i + 1
enddo

! write(0,*) trim(plates(1)),' ',trim(plates(2))
! write(0,*) pole
! write(0,*) model_name

return
end subroutine

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

subroutine usage(str)
use io, only: stderr
implicit none
character(len=*) :: str

if (trim(str).ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: platemotion -plate|-pole OPT [-model NAME] [-list [MODEL]] [-f IFILE] ',&
                '[-o OFILE]'
write(stderr,*)
write(stderr,*) '-plate P1/P2       Plates (P2 moving w.r.t. fixed P1)'
write(stderr,*) '-pole LON/LAT/VEL  Euler pole (velocity in deg/Ma)'
write(stderr,*) '-model MODEL_NAME  Plate circuit model (default: MORVEL56)'
write(stderr,*) '                       ITRF2005 (Altamimi et al., 2007)'
write(stderr,*) '                       ITRF2008 (Altamimi et al., 2012)'
write(stderr,*) '                       MORVEL (DeMets et al., 2010)'
write(stderr,*) '                       MORVEL56 (Argus et al., 2011)'
write(stderr,*) '                       NUVEL1A  (DeMets et al., 1994)'
write(stderr,*) '-list MODEL        List plates in MODEL (use ALL or leave blank to see all models)'
write(stderr,*) '-geo2xyz           Convert Euler pole in geographic coordinates to Cartesian'
write(stderr,*) '-xyz2geo           Convert Euler pole in Cartesian coordinates to geographic (assumes LON/LAT/VEL is X/Y/Z)'
write(stderr,*) '-f IFILE           Input file (default: stdin)'
write(stderr,*) '-o OFILE           Output file (default: stdout)'
write(stderr,*)

call error_exit(1)
end subroutine


! Adapted from code by C. A. J. O'Hare
! Thanks Ciaran!

module LabFuncs

  implicit none
  double precision :: vv_earthrev,eccentricity,eccentricity_deg,orb_long_ecliptic,v_LSR
  double precision, private :: pi
  parameter (vv_earthrev = 29.8d0)
  parameter (eccentricity = 0.016722d0)
  parameter (eccentricity_deg = 0.9574d0)
  parameter (orb_long_ecliptic = 13.0d0+1.0d0)
  parameter (v_LSR = 220.0d0)
  parameter (pi = 3.1415926535d0)
  double precision,dimension(3),parameter :: lat_ecl_gal =  (/-5.5303d0,59.575d0,29.812d0/)
  double precision,dimension(3),parameter :: long_ecl_gal =  (/266.141d0,-13.3485d0,179.3212d0/)
  double precision,dimension(3),parameter :: v_pec = (/11.1d0,12.2d0,7.3d0/)

contains

!=================================Lab Velocity==========================================!

  function JulianDay(month,day,year,hour) ! Calculates time in JD for a given date
    integer :: month,day,year,year_r,month_r
    double precision :: hour,JulianDay
    year_r = year+4800-floor((14-month)/12.0)
    month_r = month+12*floor((14-month)/12.0)-3
    JulianDay = day + floor((153*month_r+2)/5.0) + 365*year_r &
         + floor(year_r/4.0) -floor(year_r/100.0) + &
         floor(year_r/400.0) - 32045 + (hour-12.0)/24.0
  end function JulianDay

  function LabVelocity(JD, long, lat) ! Time in Julian days -> v_lab in km/s
    double precision :: JD ! input
    double precision :: LabVelocity(3) ! output
    double precision :: UT,MJD,T_0,t_GAST,t_lab, long, lat
    double precision :: v_galrot(3),v_solar(3),v_earthrot(3)
    double precision :: e,lambda_0,L,g,lambda_sun,beta(3),lambda_i(3),v_earthrev(3)

    ! Lab time conversion
    UT = 24*(JD+0.5-floor(JD+0.5)) ! Universal time
    MJD = JD - 2400000.5 ! Modified Julian Day
    T_0 = (floor(MJD)-55197.5)/36525.0
    t_GAST = (101.0308 + 36000.770*T_0 + 15.04107*UT)/15.0
    t_lab = t_GAST + long/15
    t_lab = 15*t_lab ! Lab time in degrees

    ! Galactic (LSR) Rotation
    v_galrot = (/0.0d0,v_LSR,0.0d0/)
    call gal2lab(v_galrot,t_lab, lat) ! transform to lab co-ords

    ! Peculiar solar Motion
    v_solar = v_pec
    call gal2lab(v_solar,t_lab, lat) ! transform to lab co-ords

    ! Earth's revolution (first calculate in galactic frame then transform)
    e = eccentricity
    lambda_0 = orb_long_ecliptic
    L = 281.0298 + 36000.77*T_0 + 0.04107*UT
    g = 357.9258 + 35999.05*T_0 + 0.04107*UT
    lambda_sun = L + (1.915 - 0.0048*T_0)*sin(g*pi/180.0)&
         + 0.020*sin(2*g*pi/180.0)
    beta = lat_ecl_gal
    lambda_i = long_ecl_gal
    v_earthrev = vv_earthrev*(1-e*sin(pi/180.0*(lambda_sun-lambda_0)))*&
         (cos(beta*pi/180.0)*sin(pi/180.0*(lambda_sun-lambda_i)))
    call gal2lab(v_earthrev,t_lab, lat) ! transform to lab co-ords

    ! Earth's rotation
    v_earthrot = 0.465102*cos(lat*pi/180)*(/0.0,-1.0,0.0/) ! already in lab co-ords

    ! Total
    LabVelocity = v_earthrot+v_earthrev+v_solar+v_galrot

  end function LabVelocity

!=================================Co-ord transformations===============================!

! Equatorial (x_e,y_e,z_e) to Laboratory (N,W,Z) [TIME DEPENDENT]
  subroutine eqt2lab(v,t_lab, lat)
    double precision:: v(3),t_lab,t,vp(3),latr, lat
    t = t_lab*pi/180.0
    latr = lat*pi/180.0
    vp = v
    v(1) = -cos(t)*sin(latr)*vp(1) - sin(t)*sin(latr)*vp(2) + cos(latr)*vp(3)
    v(2) = sin(t)*vp(1) - cos(t)*vp(2)
    v(3) = cos(t)*cos(latr)*vp(1) + cos(latr)*sin(t)*vp(2) + sin(latr)*vp(3)
  end subroutine eqt2lab

! Galactic (x_g,y_g,z_g) to Equatorial (x_e,y_e,z_e)
  subroutine gal2eqt(v)
    double precision :: v(3),vp(3)
    vp = v
    v(1) = -0.06699*vp(1) + 0.4927*vp(2) - 0.8676*vp(3)
    v(2) = -0.8728*vp(1) -0.4503*vp(2) -0.1884*vp(3)
    v(3) = -0.4835*vp(1) + 0.7446*vp(2) + 0.4602*vp(3)
  end subroutine gal2eqt

! Galactic (x_g,y_g,z_g) to Laboratory (N,W,Z) [TIME DEPENDENT]
  subroutine gal2lab(v,t_lab, lat)
    double precision :: v(3),t_lab, lat
    call gal2eqt(v)
    call eqt2lab(v,t_lab, lat)
  end subroutine gal2lab

end module LabFuncs


 SUBROUTINE deriv6(ngaus,shape,cartd,x,t,tt,dx,dt)
 !***********************************************************************
 !
 !*****this routine computes configuration derivatives at gauss points
 !           for shell elements
 !***********************************************************************
 IMPLICIT NONE
 !                   routine parameters

 INTEGER (kind=4),INTENT(IN) :: ngaus

 REAL (kind=8),INTENT(IN) :: shape(:,:),cartd(:,:,:),x(:,:),t(:,:)
 REAL (kind=8),INTENT(OUT) :: tt(:,:),dx(:,:,:),dt(:,:,:)

 !                   local variables
 INTEGER (kind=4) :: g,l
 REAL (kind=8) :: norma,aux

 INTERFACE
   INCLUDE 'vecuni.h'
 END INTERFACE

 !     evaluates director & configuration & director derivatives
 tt = MATMUL(t,shape)

 DO g = 1,ngaus
   dx(:,:,g) = MATMUL(x,cartd(:,:,g))
   dt(:,:,g) = MATMUL(t,cartd(:,:,g))
   !  normalizes director field
   CALL vecuni(3,tt(:,g),norma)

   !   correct director derivat.
   DO l=1,2
     aux = DOT_PRODUCT(tt(:,g),dt(:,l,g))
     dt(:,l,g) = (dt(:,l,g)-aux*tt(1:,g))/norma
   END DO
 END DO

 RETURN
 END SUBROUTINE deriv6


SUBROUTINE yawdyn (mjd, r_sat, v_sat, r_sun, satbf, beta0, dparam, beta, eclipsf, eBX_nom, eBX_ecl, Yangle, Mangle)

! ----------------------------------------------------------------------
! SUBROUTINE: yawdyn.f90
! ----------------------------------------------------------------------
! Purpose:
!  Dynamic yaw steering method based on the patent:
!  "Ebert K., Oesterlin W., 2008, Dynamic yaw steering method for spacecraft; European patent specification EP 1526072B1."
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:		Modified Julian Day number in GPS Time (including the fraction of the day)
! - r_sat: 		Satellite position vector (m) in ITRF
! - v_sat: 		Satellite velocity vector (m/sec) in ITRF
! - r_sun:		Sun position vector (m) in ITRF
! - satbf:		Body-frame definition type
!				satbf=1 : Body-fixed frame according to the IGS Conventions (GPS Block IIA)
!				satbf=2 : Body-fixed frame X,Y axes reversal; Case of Galileo and GPS Block IIR
! - beta0:		Limit of the beta angle (Sun elevation angle w.r.t. orbital plane) in degrees
! 				Dynamic yaw sterring is applied when |beta|<= beta0
! - dparam:		Design parameter required in the smoothing function of the dynamic yaw steering
! 				Design parameter's optimum value has been found as 258 by Ebert and Oesterlin (2008)
!
! Output arguments:
! - beta:		Sun elevation angle with respect to the orbital plane (degrees)
! - eclipsf:	Status flag of yaw steering solution:
!				0 = Kinematic Yaw steering solution, Nominal yaw-attitude
!				1 = Dynamic Yaw steering solution, Midnight
!				2 = Non-nominal, noon
! - eBX_nom:	Body-X axis unit vector during noninal yaw-attitude (Kinematic yaw-steering)
! - eBX_ecl:	Body-X axis unit vector during eclipsng yaw-attitude (Dyanmic yaw-steering)
! - Yangle: 	Yaw angle array (in degrees):
!				Yangle(1) = Kinematic Yaw steering (nominal)
!				Yangle(2) = Dynamic Yaw steering (for |beta|<=beta0)
! - Mangle:		Orbit angle between satellite and orbit midnight (degrees)
! ----------------------------------------------------------------------
! Note1:
!  eBX_ecl is set equal to eBX_nom when |beta|>beta0
!
! Note2:
!  Yangle(2) is set equal to Yangle(1) when |beta|>beta0
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia           6 June 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d) :: mjd, r_sat(3), v_sat(3), r_sun(3), beta0
      INTEGER (KIND = prec_int8) :: dparam
      INTEGER (KIND = 4)   :: satbf

! OUT
      REAL (KIND = prec_d) :: Yangle(2)
	  REAL (KIND = prec_d) :: eBX_nom(3), eBX_ecl(3)
      REAL (KIND = prec_d) :: beta, Mangle
      INTEGER (KIND = 4)   :: eclipsf
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: Xsat(3), Xsun(3)
      REAL (KIND = prec_d) :: pcross(3), pcross2(3), pdot
      REAL (KIND = prec_d) :: SVBCOS
      REAL (KIND = prec_d) :: eta, fsmooth, ft1, ft2, fti, beta1, beta2, delta, betaD
	  REAL (KIND = prec_d) :: Yangle_nom, Yangle_ecl
	  REAL (KIND = prec_d) :: Yangle_kin, Yangle_dyn
      INTEGER (KIND = 4)   :: satblk
      REAL (KIND = prec_d) :: delta_Yaw, delta_Yaw_rad
      REAL (KIND = prec_d) :: Rz_yaw(3,3)
! ----------------------------------------------------------------------
! ANOON,ANIGHT variables to be removed
      REAL (KIND = prec_d) :: ANOON, ANIGHT
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Beta angle (in degrees)
      CALL beta_angle (r_sat, v_sat, r_sun, beta)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Unit Vectors
! ----------------------------------------------------------------------
! Xsat:		Satellite position unit vector
      Xsat = (1D0 / sqrt(r_sat(1)**2 + r_sat(2)**2 + r_sat(3)**2) ) * r_sat

! Xsun:		Sun position unit vector
      Xsun = (1D0 / sqrt(r_sun(1)**2 + r_sun(2)**2 + r_sun(3)**2) ) * r_sun
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! E:	Angle between the satellite position vector and the sun position vector
! cos(E) is computed as the dot product between the unit vectors of those position vectors
! ----------------------------------------------------------------------
! SVBCOS:	Cosine of the angle E
      CALL productdot (Xsat, Xsun , pdot)
      SVBCOS = pdot
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Body-frame X-axis unit vector (IGS Conventions)
! ----------------------------------------------------------------------
! eBX_nom = - ( (Xsun x Xsat) x Xsat )
      CALL productcross (Xsun,Xsat , pcross)
      CALL productcross (pcross,Xsat , pcross2 )
      eBX_nom = -1.0D0 * pcross2

! Body-X unit vector points opposite to the Sun; Cases: Galileo and GPS IIR
if (satbf == 2) then
      eBX_nom = -1.0D0 * eBX_nom
end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Satellite orbital angle (mi and eta)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Arguments to be removed from the yaw_nom.f90 subroutine
ANOON  = 0.0D0
ANIGHT = 0.0D0
! ----------------------------------------------------------------------

! Body-frame definition type
if (satbf == 1) then
   satblk = 2
elseif (satbf == 2) then
   satblk = 5
end if

! Mangle: Orbital angle between satellite position vector and orbit midnight (in degrees)
Call yaw_nom (eBX_nom, v_sat, beta, satblk, SVBCOS, ANOON, ANIGHT, Mangle, Yangle_nom)

! eta: Orbital angle between satellite position vector and orbit noon (in degrees)
eta = Mangle - 180.0D0

! Set Orbital angle in the range {-180,+180}
eta = MOD (eta, 360.D0)

If (ABS(eta) > 180.D0) Then
	eta = eta - 360.D0 * (eta / ABS(eta) )
End If
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Kinematic yaw steering
! ----------------------------------------------------------------------
! Nominal yaw angle (in degrees)
Yangle_kin = 0.d0 ! dummy initialise

if (satbf == 1) then
! Body-fixed frame following the IGS Conventions
Yangle_kin = ATAN2( -tan(beta * (PI_global/180.0D0)) , -sin(eta * (PI_global/180.0D0)) ) * (180.0D0 / PI_global)

elseif (satbf == 2) then
! Body-fixed frame following reversed X,Y axes of body-fixed frame w.r.t. IGS Conventions
Yangle_kin = ATAN2( tan(beta * (PI_global/180.0D0)) , sin(eta * (PI_global/180.0D0)) ) * (180.0D0 / PI_global)

end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Dynamic yaw steering
! ----------------------------------------------------------------------
If (abs(beta) <= beta0) Then

! Smoothing function
fsmooth = (cos(eta * (PI_global/180.0D0)))**2 / (1.0D0 + 1.0D0* dparam * (sin(eta * (PI_global/180.0D0)))**2 )

! ----------------------------------------------------------------------
! Delta parameter sign; Delta=+1 or -1
! ----------------------------------------------------------------------
! Test the beta sign at the folllowing two epochs
! - t1: The latest epoch with 'eta' angle equal to 90 degrees
! - t2: The epoch t2=t1+360deg; approximately after one orbital period since t1
ft1 = 90.0D0
ft2 = 90.0D0 + 360.0D0

! Current orbit angle (deg)
fti = eta

! Reduction if eta<90
if (fti < ft1) then
	fti = fti + 360.0D0
end if

! Compute beta angle at t1 and t2
call beta_pred (mjd, r_sat, v_sat, fti, ft1, beta1)
call beta_pred (mjd, r_sat, v_sat, fti, ft2, beta2)

If (beta1 * beta2 > 0.0D0) Then
   ! No sign change of beta
   delta = sign(1.D0,beta1)
Else
   ! Beta sign change
   if (abs(beta1) >= abs(beta2) )  delta = sign(1.D0,beta1)
   if (abs(beta1) <  abs(beta2) )  delta = sign(1.D0,beta2)
End If
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Smoothed beta angle
betaD = beta + fsmooth * (beta0 * delta - beta)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Yaw angle (in degrees) obtained from dynamic yaw steering solution
Yangle_dyn = 0.d0 ! dummy initialise

if (satbf == 1) then
! Body-fixed frame following the IGS Conventions
Yangle_dyn = ATAN2( -tan(betaD * (PI_global/180.0D0)) , -sin(eta * (PI_global/180.0D0)) ) * (180.0D0 / PI_global)

elseif (satbf == 2) then
! Body-fixed frame following reversed X,Y axes of body-fixed frame w.r.t. IGS Conventions
Yangle_dyn = ATAN2( tan(betaD * (PI_global/180.0D0)) , sin(eta * (PI_global/180.0D0)) ) * (180.0D0 / PI_global)

end if
! ----------------------------------------------------------------------

! Status flag: Dynamic yaw steering solution
! Midnight
   if ( abs(Mangle) <= 90.0D0 ) eclipsf = 1
! Noon
   if ( abs(Mangle) >  90.0D0 ) eclipsf = 2

else

! Status flag: Kinematic yaw steering
eclipsf = 0
Yangle_dyn = Yangle_kin

End If
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Output: Yaw angle
Yangle(1) = Yangle_kin
Yangle(2) = Yangle_dyn
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! init Yangle_ecl
Yangle_ecl = 0.d0

! ----------------------------------------------------------------------
! Body-fixed X-axis in ICRF based on the eclipsing yaw angle
! ----------------------------------------------------------------------
If (eclipsf > 0) THEN

! Body-fixed X-axis rotation about body-fixed frame Z-axis

! Rotation matrix: Inertial/Orbital frame to Body-fixed frame
!CALL crf_bff (r_sat, v_sat, Yangle_on, Rcrf_bff, Rrtn_bff)

delta_Yaw = Yangle_ecl - Yangle_nom

! Rz(delta-yaw) rotation matrix:
delta_Yaw_rad = delta_Yaw * (PI_global / 180.0D0)
Rz_yaw(1,1:3) = (/  cos(delta_Yaw_rad),  sin(delta_Yaw_rad),  0.0D0 /)
Rz_yaw(2,1:3) = (/ -sin(delta_Yaw_rad),  cos(delta_Yaw_rad),  0.0D0 /)
Rz_yaw(3,1:3) = (/        0.0D0,            0.0D0,  			1.0D0 /)

! Apply rotation matrix to the Body-fixed X-axis unit vector
eBX_ecl = MATMUL(Rz_yaw, eBX_nom)

Else

	eBX_ecl = eBX_nom

End If
! ----------------------------------------------------------------------

if (1>0) then
PRINT *, "Yangle_nom", Yangle_nom
PRINT *, "Yangle_kin", Yangle_kin
PRINT *, "Yangle_dyn", Yangle_dyn
PRINT *, "Mangle", Mangle
PRINT *, "eta   ", eta
PRINT *, "beta0", beta0
PRINT *, "beta", beta
PRINT *, "betaD", betaD
PRINT *, "fsmooth", fsmooth
PRINT *, "delta", delta
PRINT *, "beta1", beta1
PRINT *, "beta2", beta2
end if

END


!-----------------------------------------------------------------------
!     Function:      db_bode
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          03/02/2012
!     Description:   This subroutine calculates the flux due to a line
!                    segment using bode formula.
!-----------------------------------------------------------------------
      REAL FUNCTION db_bode(x0,y0,z0,x1,y1,z1,cg,ldb)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE virtual_casing_mod
      USE biotsavart
      USE bsc_T
!-----------------------------------------------------------------------
!     Local Variables
!          ier            Error Flag
!          iunit          File ID Number
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER, intent(in) :: cg
      REAL(rprec)   , intent(in) :: x0,y0,z0,x1,y1,z1
      LOGICAL, intent(in), optional :: ldb
      LOGICAL     :: ldb_local
      REAL(rprec) :: delf,delt,dx,dy,dz,xp,yp,zp,bx,by,bz, dl
      REAL(rprec) :: xvec(3),bvec(3)
      INTEGER :: i, ier
      integer, parameter :: nop=5
      real(rprec), dimension(nop), parameter :: ci=(/14./45.,64./45.,24./45.,&
     &                             64./45.,14./45./)
!-----------------------------------------------------------------------
!     Begin Function
!-----------------------------------------------------------------------

      delf = 0.0
      delt = 1./float(nop-1)
      dx = x1-x0
      dy = y1-y0
      dz = z1-z0
      dl = 1.0
      ldb_local=.false.
      IF (PRESENT(ldb)) ldb_local = ldb
      IF (cg > 0) THEN
         DO i = 1, nop
            xvec(1) = x0+(i-1)*dx*delt
            xvec(2) = y0+(i-1)*dy*delt
            xvec(3) = z0+(i-1)*dz*delt
            CALL bsc_b(coil_group(cg),xvec,bvec)
            delf = delf+ ci(i)*(bvec(1)*dx+bvec(2)*dy+bvec(3)*dz)
         END DO
      ELSE
         DO i = 1, nop
            ier = 1
            xp = x0+(i-1)*dx*delt
            yp = y0+(i-1)*dy*delt
            zp = z0+(i-1)*dz*delt
            CALL bfield_vc(xp,yp,zp,bx,by,bz,ier)
            !CALL bfield_virtual_casing_adapt(xp,yp,zp,bx,by,bz,ier)
            !CALL bfield_volint_adapt(xp,yp,zp,bx,by,bz,ier)
            delf = delf+ ci(i)*(bx*dx+by*dy+bz*dz)
         END DO
      END IF
      IF (ldb_local) THEN
         dl = 0.0
         DO i = 1, nop
            xp = x0+(i-1)*dx*delt
            yp = y0+(i-1)*dy*delt
            zp = z0+(i-1)*dz*delt
            dl = dl+ ci(i)*SQRT(dx*dx+dy*dy+dz*dz)
         END DO
      END IF
      db_bode = delf*delt/dl
      RETURN
!-----------------------------------------------------------------------
!     End Function
!-----------------------------------------------------------------------
      END FUNCTION db_bode


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of lk in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: *temp *propunit *tsal lk
!   with respect to varying inputs: *temp *propunit *tsal
!   Plus diff mem management of: temp:in propunit:in tsal:in pres:in
!>    @brief average thermal conductivities on cell faces in z direction
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] ismpl local sample index
!>    @return z thermal conductivity (J/mK,ismpl)
SUBROUTINE LK_AD(i, j, k, ismpl, lk_adv)
  use arrays

  USE ARRAYS_AD

  USE MOD_GENRL
  USE MOD_TEMP
  IMPLICIT NONE
  double precision :: lk_adv
  INTEGER :: ismpl
  INTEGER :: i, j, k
  EXTERNAL LZ
  EXTERNAL LZ_AD
  DOUBLE PRECISION :: f1, f2, prod, summ, LZ
  DOUBLE PRECISION :: f1_ad, f2_ad, prod_ad, summ_ad
  INTEGER :: arg1
  DOUBLE PRECISION :: temporary_ad
  DOUBLE PRECISION :: lk
  IF (k0 .GT. 1 .AND. k .LT. k0) THEN
    f1 = LZ(i, j, k, ismpl)
    arg1 = k + 1
    f2 = LZ(i, j, arg1, ismpl)
    prod = f1*f2
    summ = f1*delz(k+1) + f2*delz(k)
    IF (summ .GT. 0.d0) THEN
      temporary_ad = 2.d0*lk_adv/summ
      prod_ad = temporary_ad
      summ_ad = -(prod*temporary_ad/summ)
    ELSE
      prod_ad = 0.D0
      summ_ad = 0.D0
    END IF
    f1_ad = delz(k+1)*summ_ad + f2*prod_ad
    f2_ad = delz(k)*summ_ad + f1*prod_ad
    CALL LZ_AD(i, j, arg1, ismpl, f2_ad)
    CALL LZ_AD(i, j, k, ismpl, f1_ad)
  END IF
END SUBROUTINE LK_AD


module problem_tagging_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  public

contains

  ! This routine prevents zones bordering center from being refined

  subroutine set_problem_tags(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                              state,state_l1,state_l2,state_l3,state_h1,state_h2,state_h3,&
                              set,clear,&
                              lo,hi,&
                              dx,problo,time,level) &
                              bind(C, name="set_problem_tags")

    use meth_params_module, only: NVAR

    use amrex_fort_module, only : rt => amrex_real
    use amrex_constants_module, only: HALF
    use parallel, only: parallel_IOProcessor
    use prob_params_module, only: center, dim, n_error_buf, ref_ratio, blocking_factor, dx_level
    use probdata_module, only: radius_inner
    implicit none

    integer         ,intent(in   ) :: lo(3),hi(3)
    integer         ,intent(in   ) :: state_l1,state_l2,state_l3, &
                                      state_h1,state_h2,state_h3
    integer         ,intent(in   ) :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
    real(rt)        ,intent(in   ) :: state(state_l1:state_h1, &
                                      state_l2:state_h2, &
                                      state_l3:state_h3,NVAR)
    integer         ,intent(inout) :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
    real(rt)        ,intent(in   ) :: problo(3),dx(3),time
    integer         ,intent(in   ) :: level,set,clear

    integer                        :: i, j, k, n
    real(rt)                       :: loc(3), r

    logical                        :: center_test(3)
    integer                        :: boundary_buf(3), idx(3), icenter(3)

    ! We must ensure that the center zones are untagged.
    ! To do this properly we need to be aware of BoxLib's strategy
    ! for tagging, which is not cell-based, but rather chunk-based.
    ! The size of the chunk on the coarse grid is given by
    ! blocking_factor / ref_ratio -- the idea here being that
    ! blocking_factor is the smallest possible group of cells on a
    ! given level, so the smallest chunk of cells possible on the
    ! coarse grid is given by that number divided by the refinement ratio.
    ! So we cannot tag anything within that distance from the boundary.
    ! Additionally we need to stay a further amount n_error_buf away,
    ! since n_error_buf zones are always added as padding around
    ! tagged zones.

!   icenter(1:dim) = NINT((center(1:dim)-problo(1:dim)) / dx(1:dim))
!   if ( level == 0 ) then
!     boundary_buf(1:dim) = n_error_buf(level) + 1
!   else
!     boundary_buf(1:dim) = n_error_buf(level) + product(ref_ratio(1:dim,0:level),dim=2) - 1
!   end if

!   boundary_buf(1:dim) = n_error_buf(level) + max( blocking_factor(level+1) / ref_ratio(1:dim, level), 1 )
!   do n = level, 1, -1
!     boundary_buf(1:dim) = boundary_buf(1:dim) * ref_ratio(1:dim,n) + n_error_buf(n-1) + blocking_factor(n) / ref_ratio(1:dim,n-1)
!   end do
!   boundary_buf(1:dim) = n_error_buf(0) + blocking_factor(1) / ref_ratio(1:dim,0)
!   do n = 1, level
!     boundary_buf(1:dim) = boundary_buf(1:dim) * ref_ratio(1:dim,n-1) + n_error_buf(n) + blocking_factor(n+1) / ref_ratio(1:dim,n)
!     boundary_buf(1:dim) = boundary_buf(1:dim) * ref_ratio(1:dim,n-1) + 1
!   end do

!   do k = lo(3), hi(3)
!     loc(3) = problo(3) + (dble(k) + HALF) * dx(3) - center(3)
!     do j = lo(2), hi(2)
!       loc(2) = problo(2) + (dble(j) + HALF) * dx(2) - center(2)
!       do i = lo(1), hi(1)
!         loc(1) = problo(1) + (dble(i) + HALF) * dx(1) - center(1)

!         r = ( sum(loc**2) )**HALF
!         idx = [i, j, k]
!         center_test = .false.
!         center_test(1:dim) = abs(loc(1:dim)) <= dble(boundary_buf(1:dim)+1)*dx(1:dim)
!         center_test(1:dim) = abs(loc(1:dim)) <= dble(boundary_buf(1:dim)+1)*dx_level(1:dim,0)
!         center_test(1:dim) = loc(1:dim) >= center(1:dim) - (dble(boundary_buf(1:dim))+HALF)*dx(1:dim) .and. &
!                              loc(1:dim) <= center(1:dim) + (dble(boundary_buf(1:dim))+HALF)*dx(1:dim)
!         center_test(1:dim) = idx(1:dim) >= icenter(1:dim) - 2 - boundary_buf(1:dim) .and. &
!                              idx(1:dim) <= icenter(1:dim)     + boundary_buf(1:dim)

!         if ( r <= maxval( (dble(boundary_buf(1:dim))+1) * dx(1:dim) ) ) then
!         if ( all(center_test(1:dim)) ) then
!           tag(i,j,k) = clear
!           if ( all(idx==icenter) .or. all(idx==icenter-1) ) then
!             !$omp critical
!             write(*,'(a,1i23)')     'level          =', level
!             write(*,'(a,3i23)')     '  ref_ratio    =', ref_ratio(1:dim,level)
!             write(*,'(a,3i23)')     '  icenter      =', icenter(1:dim)
!             write(*,'(a,3i23)')     '  boundary_buf =', boundary_buf(1:dim)
!             write(*,'(a,3es23.15)') '  dx           =', dx(1:dim)
!             write(*,'(a,3es23.15)') '  loc          =', loc(1:dim)
!             write(*,'(a,3i23)')     '  idx          =', idx(1:dim)
!             !$omp end critical
!           end if
!         end if

!       end do
!     end do
!   end do

  end subroutine set_problem_tags

end module problem_tagging_module


!======================================================================!
  SUBROUTINE Inertia(sub)
!----------------------------------------------------------------------!
!                                                                      !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  USE all_mod
  USE gen_mod
  USE div_mod
  USE par_mod
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  INTEGER :: sub                           ! subdomain
!-------------------------------[Locals]-------------------------------!
  INTEGER :: i, NCloc
  REAL    :: xm, ym, zm
  REAL    :: Im(3,3), d(3), v(3,3), d_max(3)
!--------------------------------[CVS]---------------------------------!
!  $Id: Inertia.f90,v 1.2 2002/10/30 16:29:18 niceno Exp $
!  $Source: /home/muhamed/.CVSROOT/T-Rex/Divide/Inertia.f90,v $
!======================================================================!

  xm=0.0
  ym=0.0
  zm=0.0
  NCloc=0
  do i=1,NC
    if(proces(i)==sub) then
      xm = xm + xc(i)
      ym = ym + yc(i)
      zm = zm + zc(i)
      NCloc=NCloc+1
    end if
  end do
  xm=xm/NCloc
  ym=ym/NCloc
  zm=zm/NCloc

  write(*,*) 'Center of mass for subdomain ', sub, ' is: ', xm, ym, zm

  Im = 0.
  do i=1,NC
    if(proces(i)==sub) then
      Im(1,1) = Im(1,1) + (yc(i)-ym)**2 + (zc(i)-zm)**2
      Im(2,2) = Im(2,2) + (xc(i)-xm)**2 + (zc(i)-zm)**2
      Im(3,3) = Im(3,3) + (xc(i)-xm)**2 + (yc(i)-ym)**2

      Im(1,2) = Im(1,2) - (xc(i)-xm)*(yc(i)-ym)
      Im(1,3) = Im(1,3) - (xc(i)-xm)*(zc(i)-zm)
      Im(2,3) = Im(2,3) - (yc(i)-ym)*(zc(i)-zm)
    end if
  end do
  Im(2,1) = Im(1,2)
  Im(3,1) = Im(1,3)
  Im(3,2) = Im(2,3)

  call Jacobi(Im, 3, 3, d, v, i)

  write(*,*) 'd=',d(1), d(2), d(3)

  write(*,*) 'v=', (v(1,i), i=1,3)
  write(*,*) '  ', (v(2,i), i=1,3)
  write(*,*) '  ', (v(3,i), i=1,3)

  if(min(d(1),d(2),d(3)) == d(1)) then
    d_max(1)=v(1,1)
    d_max(2)=v(2,1)
    d_max(3)=v(3,1)
  else if(min(d(1),d(2),d(3)) == d(2)) then
    d_max(1)=v(1,2)
    d_max(2)=v(2,2)
    d_max(3)=v(3,2)
  else if(min(d(1),d(2),d(3)) == d(3)) then
    d_max(1)=v(1,3)
    d_max(2)=v(2,3)
    d_max(3)=v(3,3)
  end if

  write(*,*) 'Sorting the cells'
  do i=1,NC
    iin(i) = i
    criter(i) = xc(i)*d_max(1) + yc(i)*d_max(2) + zc(i)*d_max(3)
  end do
  call RISort(criter(1),iin(1),NC,2)

  return

  END SUBROUTINE Inertia


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Cal_F(r,theta,omega,c_mat_type,F)

      use Global_Elem_Area
      implicit none

      double precision,intent(in)::r,theta,omega
      integer,intent(in)::c_mat_type
      double precision,intent(out)::F(4)

      double precision fac,st2,ct2,s3t2,c3t2,st,ct,
     &                 r2,c_theta

      c_theta = theta
      if (r.ne.0.0D0) then
          r2 = sqrt(r)
      else
          r2 = sqrt(Ave_Elem_Area)*0.1D-4
	      c_theta = 0.0d0
      end if

      ! ------------------------------
      !         ISO material.
      ! ------------------------------
      if (c_mat_type ==1 ) then
	      fac = 0.5D0/r2
	      st2 = sin(c_theta/2.0D0)
	      ct2 = cos(c_theta/2.0D0)
	      s3t2= sin(1.5D0*c_theta)
	      c3t2= cos(1.5D0*c_theta)
	      st  = sin(c_theta)
	      ct  = cos(c_theta)

          ! Tip enrichment functions F.

		  F(1) = r2*st2
		  F(2) = r2*ct2
		  F(3) = r2*st2*st
		  F(4) = r2*ct2*st
      ! ------------------------------
      !       Orthotropic material.
      ! ------------------------------
      elseif (c_mat_type ==2 .or. c_mat_type ==3) then

      end if

      return
      end SUBROUTINE Cal_F


      SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM)
*     .. Scalar Arguments ..
      INTEGER INCX,INCY,N
*     ..
*     .. Array Arguments ..
      REAL SPARAM(5),SX(1),SY(1)
*     ..
*
*  Purpose
*  =======
*
*     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
*
*     (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN
*     (DX**T)
*
*     SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
*     LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY.
*     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
*     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
*
*       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
*     H=(          )    (          )    (          )    (          )
*       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
*     SEE  SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM.
*
*
*  Arguments
*  =========
*
*  N      (input) INTEGER
*         number of elements in input vector(s)
*
*  SX     (input/output) REAL array, dimension N
*         double precision vector with 5 elements
*
*  INCX   (input) INTEGER
*         storage spacing between elements of SX
*
*  SY     (input/output) REAL array, dimension N
*         double precision vector with N elements
*
*  INCY   (input) INTEGER
*         storage spacing between elements of SY
*
*  SPARAM (input/output)  REAL array, dimension 5
*     SPARAM(1)=SFLAG
*     SPARAM(2)=SH11
*     SPARAM(3)=SH21
*     SPARAM(4)=SH12
*     SPARAM(5)=SH22
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO
      INTEGER I,KX,KY,NSTEPS
*     ..
*     .. Data statements ..
      DATA ZERO,TWO/0.E0,2.E0/
*     ..
*
      SFLAG = SPARAM(1)
      IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) GO TO 140
      IF (.NOT. (INCX.EQ.INCY.AND.INCX.GT.0)) GO TO 70
*
      NSTEPS = N*INCX
      IF (SFLAG) 50,10,30
   10 CONTINUE
      SH12 = SPARAM(4)
      SH21 = SPARAM(3)
      DO 20 I = 1,NSTEPS,INCX
          W = SX(I)
          Z = SY(I)
          SX(I) = W + Z*SH12
          SY(I) = W*SH21 + Z
   20 CONTINUE
      GO TO 140
   30 CONTINUE
      SH11 = SPARAM(2)
      SH22 = SPARAM(5)
      DO 40 I = 1,NSTEPS,INCX
          W = SX(I)
          Z = SY(I)
          SX(I) = W*SH11 + Z
          SY(I) = -W + SH22*Z
   40 CONTINUE
      GO TO 140
   50 CONTINUE
      SH11 = SPARAM(2)
      SH12 = SPARAM(4)
      SH21 = SPARAM(3)
      SH22 = SPARAM(5)
      DO 60 I = 1,NSTEPS,INCX
          W = SX(I)
          Z = SY(I)
          SX(I) = W*SH11 + Z*SH12
          SY(I) = W*SH21 + Z*SH22
   60 CONTINUE
      GO TO 140
   70 CONTINUE
      KX = 1
      KY = 1
      IF (INCX.LT.0) KX = 1 + (1-N)*INCX
      IF (INCY.LT.0) KY = 1 + (1-N)*INCY
*
      IF (SFLAG) 120,80,100
   80 CONTINUE
      SH12 = SPARAM(4)
      SH21 = SPARAM(3)
      DO 90 I = 1,N
          W = SX(KX)
          Z = SY(KY)
          SX(KX) = W + Z*SH12
          SY(KY) = W*SH21 + Z
          KX = KX + INCX
          KY = KY + INCY
   90 CONTINUE
      GO TO 140
  100 CONTINUE
      SH11 = SPARAM(2)
      SH22 = SPARAM(5)
      DO 110 I = 1,N
          W = SX(KX)
          Z = SY(KY)
          SX(KX) = W*SH11 + Z
          SY(KY) = -W + SH22*Z
          KX = KX + INCX
          KY = KY + INCY
  110 CONTINUE
      GO TO 140
  120 CONTINUE
      SH11 = SPARAM(2)
      SH12 = SPARAM(4)
      SH21 = SPARAM(3)
      SH22 = SPARAM(5)
      DO 130 I = 1,N
          W = SX(KX)
          Z = SY(KY)
          SX(KX) = W*SH11 + Z*SH12
          SY(KY) = W*SH21 + Z*SH22
          KX = KX + INCX
          KY = KY + INCY
  130 CONTINUE
  140 CONTINUE
      RETURN
      END


module material_nm
use EOS_CC
implicit none
integer,parameter :: material_type = 0
double precision :: a     = 0.00819e11
double precision :: b     = 0.0151e11
double precision :: eps1  = 4.53
double precision :: eps2  = 1.42
double precision :: cv    = 1714.d0*1134.d0
double precision :: gamma = 1.19d0
double precision :: rho0  = 1134.d0
double precision :: q0    = 4.48e6*1134.d0
double precision :: cc    = 2.6e9
double precision :: ta    = 11350.d0
NAMELIST/material_nm_params/ a, b, gamma, cv, eps1, &
                                eps2, rho0, q0, cc, ta

logical :: if_initialized = .false.
contains
subroutine write_material_nm_inp(funit)
  implicit none
  integer,intent(in) :: funit
  write(funit,NML=material_nm_params)
end subroutine write_material_nm_inp

subroutine initial_material_nm(funit)
  implicit none
  integer,intent(in) :: funit
  if(.not.if_initialized) then
  read(funit,NML=material_nm_params)
endif
end subroutine initial_material_nm

subroutine scale_material_nm(rho_rv,u_rv,temp_rv,time_rv, &
                            p_rv,e_rv,l_rv,cv_rv)
  implicit none
  double precision,intent(in) :: rho_rv,u_rv,temp_rv,time_rv, &
                                  p_rv,e_rv,l_rv,cv_rv

    if(.not.if_initialized) then
      !-------Reactant
  a    = a/p_rv
  b    = b/p_rv
  cv   = cv/cv_rv
  rho0 = rho0/rho_rv
  q0   = q0/p_rv
  cc   = cc*time_rv
  ta   = ta/temp_rv
  if_initialized = .true.
endif
end subroutine scale_material_nm

! compute the internal energy of reactant
subroutine compute_internal_energy_nm(ei,p,r)
  implicit none
  double precision,intent(in) :: p,r
  double precision,intent(inout) :: ei
  double precision :: p_ref, ei_ref
  call compute_pref_eos_cc(p_ref,r,a,b,eps1,eps2,rho0)
  call compute_eiref_eos_cc(ei_ref,r,a,b,eps1,eps2,rho0)
  ei = (p - p_ref)/(r*gamma) + ei_ref
end subroutine compute_internal_energy_nm

! compute the sound speed
subroutine compute_sound_speed2_nm(c2,p,rho)
  implicit none
  double precision,intent(in) :: p,rho
  double precision,intent(inout) :: c2
  double precision :: dedp,dedrho
  call compute_dedp_eos_cc(dedp,rho,gamma)
  call compute_dedr_eos_cc(dedrho,p,rho,a,b,eps1,eps2,rho0,gamma)
  c2 = (p/rho**2-dedrho)/dedp
end subroutine compute_sound_speed2_nm

subroutine compute_xi_nm(xi,r)
  implicit none
  double precision :: r
  double precision,intent(inout) :: xi
  double precision :: gg
  xi = 1.d0/gamma
end subroutine compute_xi_nm

subroutine compute_temperature_nm(t,cv_o,p,rho)
  implicit none
  double precision,intent(in) :: p,rho
  double precision,intent(inout) :: t,cv_o
  double precision :: pref
  call compute_pref_eos_cc(pref,rho,a,b,eps1,eps2,rho0)
  t = (p - pref)/(rho*gamma*cv)
  cv_o = cv
end subroutine compute_temperature_nm

subroutine compute_eref_nm(ei_ref,rho)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(inout) :: ei_ref
  call compute_eiref_eos_cc(ei_ref,rho,a,b,eps1,eps2,rho0)
end subroutine compute_eref_nm

subroutine compute_pref_nm(p_ref,rho)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(inout) :: p_ref
  call compute_pref_eos_cc(p_ref,rho,a,b,eps1,eps2,rho0)
end subroutine compute_pref_nm

subroutine compute_rhogamma_nm(rhogamma,rho)
  implicit none
  double precision,intent(in) :: rho
  double precision,intent(inout) :: rhogamma
  rhogamma = rho*gamma
end subroutine compute_rhogamma_nm

subroutine compute_pressure_nm(p,ei,rho)
  implicit none
  double precision,intent(in) :: rho,ei
  double precision,intent(inout) :: p
  double precision :: pref,eref
  call compute_pref_eos_cc(pref,rho,a,b,eps1,eps2,rho0)
  p = pref + gamma*rho*(ei-eref)
end subroutine compute_pressure_nm

! compute the reaction rate of IG model
subroutine compute_source_nm(src0, src_num,                     &
  comm_prim, comm_prim_num,          &
  phs_prim, phs_prim_num,            &
  phs_cpnt_prim, phs_cpnt_prim_num)
  implicit none
  integer,intent(in) :: src_num, comm_prim_num, &
                        phs_prim_num, phs_cpnt_prim_num
  double precision,dimension(comm_prim_num),intent(in) :: comm_prim
  double precision,dimension(phs_prim_num),intent(in) :: phs_prim
  double precision,dimension(phs_cpnt_prim_num),intent(in) :: phs_cpnt_prim
  double precision,dimension(src_num),intent(inout) :: src0
  double precision :: lbd,rho,t,z
  t   = comm_prim(6)
  z   = phs_prim(1)
  rho = phs_prim(2)
  src0(1) =-lbd*cc*exp(-ta/t)*rho*z
end subroutine compute_source_nm
end module


! jacobi_mekh       ADD DESCRIPTION!
! eigsrt            ADD DESCRIPTION!
! M_pow             Calculate C^m where C is 3x3 matrix
! eig_prob          ADD DESCRIPTION!
! us_solve          ADD DESCRIPTION!
! us_gausjor        ADD DESCRIPTION!

Module Miscellaneous_tensors
use Conversions
Implicit none
    CONTAINS

!==============================================================================
recursive SUBROUTINE jacobi_mekh(a,n,np,d,v,nrot)
Implicit none

    INTEGER                     :: n,np,nrot,NMAX
    DOUBLE PRECISION            :: a(np,np),d(np),v(np,np)
    PARAMETER (NMAX=500)
    INTEGER i,ip,iq,j
    DOUBLE PRECISION            :: c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX)

      do 12 ip=1,n
        do 11 iq=1,n
          v(ip,iq)=0.d0
11      continue
        v(ip,ip)=1.d0
12    continue
      do 13 ip=1,n
        b(ip)=a(ip,ip)
        d(ip)=b(ip)
        z(ip)=0.d0
13    continue
      nrot=0
      do 24 i=1,50
        sm=0.d0
        do 15 ip=1,n-1
          do 14 iq=ip+1,n
            sm=sm+abs(a(ip,iq))
14        continue
15      continue
        if(sm.eq.0.d0)return
        if(i.lt.4)then
          tresh=0.2d0*sm/n**2
        else
          tresh=0.d0
        endif
        do 22 ip=1,n-1
          do 21 iq=ip+1,n
            g=100.d0*abs(a(ip,iq))
            if((i.gt.4).and.(abs(d(ip))+&
      g.eq.abs(d(ip))).and.(abs(d(iq))+g.eq.abs(d(iq))))then
              a(ip,iq)=0.d0
            else if(abs(a(ip,iq)).gt.tresh)then
              h=d(iq)-d(ip)
              if(abs(h)+g.eq.abs(h))then
                t=a(ip,iq)/h
              else
                theta=0.5d0*h/a(ip,iq)
                t=1.d0/(dabs(theta)+dsqrt(1.d0+theta**2.d0))
                if(theta.lt.0.d0)t=-t
              endif
              c=1.d0/dsqrt(1.d0+t**2.d0)
              s=t*c
              tau=s/(1.d0+c)
              h=t*a(ip,iq)
              z(ip)=z(ip)-h
              z(iq)=z(iq)+h
              d(ip)=d(ip)-h
              d(iq)=d(iq)+h
              a(ip,iq)=0.d0
              do 16 j=1,ip-1
                g=a(j,ip)
                h=a(j,iq)
                a(j,ip)=g-s*(h+g*tau)
                a(j,iq)=h+s*(g-h*tau)
16            continue
              do 17 j=ip+1,iq-1
                g=a(ip,j)
                h=a(j,iq)
                a(ip,j)=g-s*(h+g*tau)
                a(j,iq)=h+s*(g-h*tau)
17            continue
              do 18 j=iq+1,n
                g=a(ip,j)
                h=a(iq,j)
                a(ip,j)=g-s*(h+g*tau)
                a(iq,j)=h+s*(g-h*tau)
18            continue
              do 19 j=1,n
                g=v(j,ip)
                h=v(j,iq)
                v(j,ip)=g-s*(h+g*tau)
                v(j,iq)=h+s*(g-h*tau)
19            continue
              nrot=nrot+1
            endif
21        continue
22      continue
        do 23 ip=1,n
          b(ip)=b(ip)+z(ip)
          d(ip)=b(ip)
          z(ip)=0.d0
23      continue
24    continue
      write(*,*) 'too many iterations in jacobi_mekh'
      return
end subroutine
!  (C) Copr. 1986-92 Numerical Recipes Software #v([&.
!==============================================================================

!==============================================================================
recursive SUBROUTINE eigsrt(d,v,n,np)
      INTEGER n,np
      DOUBLE PRECISION d(np),v(np,np)
      INTEGER i,j,k
      DOUBLE PRECISION p
      do 13 i=1,n-1
        k=i
        p=d(i)
        do 11 j=i+1,n
          if(d(j).ge.p)then
            k=j
            p=d(j)
          endif
11      continue
        if(k.ne.i)then
          d(k)=d(i)
          d(i)=p
          do 12 j=1,n
            p=v(j,i)
            v(j,i)=v(j,k)
            v(j,k)=p
12        continue
        endif
13    continue
      return
 END subroutine
!  (C) Copr. 1986-92 Numerical Recipes Software #v([&.
!==============================================================================

!==============================================================================
FUNCTION M_pow(a,m) RESULT (am)
! Old name: US_M_POW_GEN
Implicit none

    DOUBLE PRECISION, DIMENSION(:,:), INTENT (IN) ::a
    DOUBLE PRECISION, DIMENSION(size(a,1),size(a,2))::am
    DOUBLE PRECISION  ::av(9),amv(9),la(3),G(3,3),m1(9),m2(9),m3(9)
    DOUBLE PRECISION  :: m

    av(1)=a(1,1)
    av(2)=a(2,2)
    av(3)=a(3,3)
    av(4)=a(1,2)
    av(9)=a(3,2)
    av(5)=a(2,3)
    av(8)=a(2,1)
    av(7)=a(1,3)
    av(6)=a(3,1)

    CALL eig_prob(av,la,G,m1,m2,m3)

    amv=dabs(la(1))**m*m1+dabs(la(2))**m*m2+dabs(la(3))**m*m3

    am(1,1)=amv(1)
    am(2,2)=amv(2)
    am(3,3)=amv(3)
    am(1,2)=amv(4)
    am(2,1)=amv(8)
    am(2,3)=amv(5)
    am(3,2)=amv(9)
    am(1,3)=amv(7)
    am(3,1)=amv(6)

END FUNCTION
!==============================================================================

!==============================================================================
recursive SUBROUTINE eig_prob(EPSE,lambdad,Gvec,M1V,M2V,M3V)
! Purpose: Subroutine for solution of  eigenvalue problem, and
!          some additional, where perturbations are used if neccessary.
!          This routine is a copy of EIGPROBNEW in the file USMATEIG.f
!
! Written by:  Magnus Ekh
! Modified by: Jim Brouzoulis
Implicit none

    DOUBLE PRECISION    :: EPSE,lambda,Gvec,M1V,M2V,M3V,I1,dfact
    DOUBLE PRECISION    :: EPSEM,slask,M1,M2,M3,lmax,TOL,DIST,SLASKM,lambdad,DELTA
    INTEGER             :: nrot,NM,NV,I,J
    PARAMETER (NM=3,NV=9)
    DIMENSION &
            EPSE(NV),lambda(NM),Gvec(NM,NM),M1V(NV),M2V(NV),M3V(NV),&
            dfact(NM),EPSEM(NM,NM),slask(NM),M1(NM,NM),M2(NM,NM),M3(NM,NM),&
            SLASKM(NM,NM),lambdad(NM),DELTA(NM,NM)

    EPSEM = V9_2_M(EPSE)

    CALL jacobi_mekh(EPSEM,NM,NM,lambda,Gvec,nrot)
    ! write(*,*) 'lambda ',lambda
    CALL EIGSRT(lambda,Gvec,NM,NM)
    lambdad=lambda
    ! write(*,*) 'Gvec1 ',Gvec(1:3,1)
    ! write(*,*) 'Gvec2 ',Gvec(1:3,2)
    ! write(*,*) 'Gvec3 ',Gvec(1:3,3)

    !C Find largest |lambda|
    !      lmax=-1.d9
    !      DO I=1,3
    !         IF (ABS(lambda(I)).GT.lmax) THEN
    !            lmax=ABS(lambda(I))
    !
    !         ENDIF
    !      ENDDO
    !
    !      lmax=max(lmax,1.d-12)
    !      TOL=1.d-7*lmax
    !      DIST=TOL/4.d0
    !
    !C Disturb if neccessary
    !      IF (ABS(lambda(1)-lambda(2))/lmax.LT.TOL) THEN
    !         lambdad(1)=lambda(1)*(1.d0+DIST)
    !         lambdad(2)=lambda(2)*(1.d0-DIST)
    !         lambdad(3)=lambda(3)/((1.d0+DIST)*(1.d0-DIST))
    !      ELSEIF (ABS(lambda(2)-lambda(3))/lmax.LT.TOL) THEN
    !         lambdad(2)=lambda(2)*(1.d0+DIST)
    !         lambdad(3)=lambda(3)*(1.d0-DIST)
    !         lambdad(1)=lambda(1)/((1.d0+DIST)*(1.d0-DIST))
    !      ELSE
    !         lambdad(1)=lambda(1)
    !         lambdad(2)=lambda(2)
    !         lambdad(3)=lambda(3)
    !      ENDIF

    !C If the eigenvalues are equal to zero
    !      IF (ABS(lambdad(1)).LT.1.d-12) THEN
    !         lambdad(1)=2.d-12
    !      ELSEIF (ABS(lambdad(2)).LT.1.d-12) THEN
    !         lambdad(2)=1.d-12
    !      ELSEIF (ABS(lambdad(3)).LT.1.d-12) THEN
    !         lambdad(3)=0.5d-12
    !      ENDIF
    !
    !      write(*,*) '???lambdad',lambdad(1:3)
    !C
    !
    !      I1=lambdad(1)+lambdad(2)+lambdad(3)
    !      detJ =lambdad(1)*lambdad(2)*lambdad(3)
    !
    !      DO I=1,NM
    !         dfact(I)=2.d0*lambdad(I)**2.d0-
    !     .    I1*lambdad(I)+detJ/lambdad(I)
    !      ENDDO
    !      write(*,*) '???dfact',dfact(1:3)
    !
    !      CALL USMMM(EPSEM,3,3,EPSEM,3,3,SLASKM)
    !      DO I=1,3
    !         DO J=1,3
    !
    !            DELTA(I,J)=0.d0
    !            IF (I.EQ.J) THEN
    !               DELTA(I,J)=1.d0
    !            ENDIF
    !         ENDDO
    !      ENDDO
    !C23456789012345678901234567890123456789012345678901234567890123456789012
    DO I=1,3
        DO J=1,3
    !      M1(I,J)=1.d0/(dfact(1))*(
    !     .   SLASKM(I,J)-(I1-lambdad(1))*EPSEM(I,J)
    !
    !     .        +detJ/(lambdad(1))*DELTA(I,J) )
           M1(I,J)=Gvec(I,1)*Gvec(J,1)

    !      M2(I,J)=1.d0/(dfact(2))*(
    !     .  SLASKM(I,J)-(I1-lambdad(2))*EPSEM(I,J)
    !     .        +detJ/(lambdad(2))*DELTA(I,J) )
           M2(I,J)=Gvec(I,2)*Gvec(J,2)
    !      M3(I,J)=1.d0/(dfact(3))*(
    !     .   SLASKM(I,J)-(I1-lambdad(3))*EPSEM(I,J)
    !     .        +detJ/(lambdad(3))*DELTA(I,J) )
           M3(I,J)=Gvec(I,3)*Gvec(J,3)

        ENDDO
    ENDDO

    M1V=M_2_V9(M1)
    M2V=M_2_V9(M2)
    M3V=M_2_V9(M3)

    RETURN
END SUBROUTINE
!==============================================================================

!==============================================================================
recursive SUBROUTINE us_solve(LKONV,A,N,B,INVA,X)
      ! Matrix multiplication X=inv(A)*B
      ! Gauss-Jordan elimination with pivoting
      IMPLICIT NONE
      INTEGER N,LKONV
      DOUBLE PRECISION A(N,N),B(N),INVA(N,N),X(N)
      X=B;INVA=A;LKONV=1
        CALL us_gausjor(LKONV,INVA,N,N,X,1,1)
      RETURN

end subroutine us_solve
!==============================================================================

!==============================================================================
recursive SUBROUTINE us_gausjor(LKONV,A,N,NP,B,M,MP)
       !---------------------------------------------------
      ! SUBROUTINE FROM NUMERICAL RECIPES IN FORTRAN p.30
      ! Gauss-Jordan elimination with pivoting
      ! SOLVES A x= B
      ! INPUT: A(NP,NP), B(NP,N)
      ! OUTPUT: inverse matrix as A
      !         solution vector as B
      !         LKOND=0 if singular matrix
      IMPLICIT LOGICAL (A-Z)
      INTEGER M,MP,N,NP,NMAX,LKONV
      DOUBLE PRECISION A(NP,NP),B(NP,MP)
      PARAMETER (NMAX=50)
      INTEGER I,ICOL,IROW,J,K,L,LL,INDXC(NMAX),INDXR(NMAX),IPIV(NMAX)
      DOUBLE PRECISION BIG,DUM,PIVINV
      LKONV=1
      DO J=1,N
        IPIV(J)=0
      ENDDO
      DO I=1,N
        BIG=0.
        DO J=1,N
          IF(IPIV(J).NE.1)THEN
            DO K=1,N
              IF(IPIV(K).EQ.0)THEN
                IF (ABS(A(J,K)).GE.BIG) THEN
                  BIG=ABS(A(J,K))
                  IROW=J;ICOL=K
                ENDIF
              ELSEIF (IPIV(K).GT.1) THEN
                WRITE(*,*) '% singular matrix in us_gausjor'
                LKONV=0; GOTO 666
              ENDIF
            ENDDO
          ENDIF
        ENDDO
        IPIV(ICOL)=IPIV(ICOL)+1
        IF (IROW.NE.ICOL) THEN
          DO L=1,N
            DUM=A(IROW,L)
            A(IROW,L)=A(ICOL,L)
            A(ICOL,L)=DUM
          ENDDO
          DO L=1,M
            DUM=B(IROW,L)
            B(IROW,L)=B(ICOL,L)
            B(ICOL,L)=DUM
          ENDDO
        ENDIF
        INDXR(I)=IROW
        INDXC(I)=ICOL
        IF (A(ICOL,ICOL).EQ.0.d0) THEN
          WRITE(*,*) '% singular matrix in us_gausjor'
          LKONV=0;  GOTO 666
        ENDIF
        PIVINV=1./A(ICOL,ICOL)
        A(ICOL,ICOL)=1.d0
        DO L=1,N
          A(ICOL,L)=A(ICOL,L)*PIVINV
        ENDDO
        DO L=1,M
          B(ICOL,L)=B(ICOL,L)*PIVINV
        ENDDO
        DO LL=1,N
          IF (LL.NE.ICOL) THEN
            DUM=A(LL,ICOL)
            A(LL,ICOL)=0.d0
            DO L=1,N
              A(LL,L)=A(LL,L)-A(ICOL,L)*DUM
            ENDDO
            DO L=1,M
              B(LL,L)=B(LL,L)-B(ICOL,L)*DUM
            ENDDO
          ENDIF
        ENDDO
      ENDDO
      DO L=N,1,-1
        IF (INDXR(L).NE.INDXC(L)) THEN
          DO K=1,N
            DUM=A(K,INDXR(L))
            A(K,INDXR(L))=A(K,INDXC(L))
            A(K,INDXC(L))=DUM
          ENDDO
        ENDIF
      ENDDO
 666  CONTINUE
      RETURN
end subroutine us_gausjor
!==============================================================================

end module


module mod_poisson_DFT
  implicit none

contains

  subroutine poisson_solver_2D(f, dx, dy, phi, bd_ay, bd_by)
    use mod_poisson_green
    implicit none

    real, dimension ( :, : ), intent ( in ) :: f
    real, dimension ( :, : ), intent ( out ) :: phi
    double precision, dimension ( : ), intent ( in ), optional :: &
         bd_ay, bd_by
    real, intent ( in ) :: dx, dy
    character ( 3 ), parameter :: solver="DFT"

    select case ( solver )
    case ( "DFT" )
       call poisson_solver_DFT( f, dx, dy, bd_ay, bd_by, phi )
    case ( "Gre" )
       call poisson_solver_Green ( f, dx, dy, phi )
    end select

  end subroutine poisson_solver_2D

  subroutine poisson_solver_DFT ( rho, dx, dy, bd_ay, bd_by, phi )
    use mkl_poisson
    use mod_poisson_interp
    real, intent ( in ) :: dx, dy
    real, dimension ( :, : ), intent ( in )  :: rho
    real, dimension ( :, : ), intent ( out ) :: phi
    integer :: ipar(128), stat, nx, ny
    double precision :: q, ax, bx, ay, by
    double precision, dimension ( : ), intent ( in ) :: bd_ay, bd_by
    double precision, dimension ( : ), allocatable :: &
         dpar, bd_ax, bd_bx
    character ( 4 ), parameter :: BCTYPE="PPDD"
    double precision, dimension ( :, : ), allocatable :: f_vc
    type(DFTI_DESCRIPTOR), pointer :: xhandle
    integer :: nlon, nlat
    double precision :: average
    integer, parameter :: bc = 9
    logical, parameter :: shift=.false.,interp=.false.

    nlon = size ( rho, 1)
    nlat = size ( rho, 2)
    nx = nlon
    ny = nlat
    allocate ( dpar ( 13 * nx / 2 + 7 ) )
    allocate ( bd_ax ( ny + 1 ), bd_bx ( ny + 1 ) )
    allocate ( f_vc ( nx + 1, ny + 1 ) )
    ax = 0.0e0
    bx = nx * dx
    ay = 0.0e0
    by = ny * dy
    Q = 0.0e0
    bd_ax = 0.0e0
    bd_bx = 0.0e0
    IPAR = 0
    f_vc = 0.0e0

    if ( interp ) then
       call interpolate_mc_to_vc( rho, f_vc, BCTYPE )
    else
       call shift_mc_to_vc ( rho, f_vc )
    end if

    f_vc = -1.0e0 * f_vc

    if ( shift ) then
       average = sum ( f_vc ( 1:nlon + 1, 1:nlat + 1 ) ) / &
            (nlon + 1) / (nlat + 1)
       f_vc = f_vc - average
    end if

    call d_init_Helmholtz_2D( AX, BX, AY, BY, NX, NY, BCTYPE, Q, &
         IPAR, dPAR, STAT )
    call d_commit_Helmholtz_2D( f_vc, bd_ax, bd_bx, bd_ay, bd_by, &
         xhandle, ipar, dpar, stat)
    call d_Helmholtz_2D(f_vc, bd_ax, bd_bx, bd_ay, bd_by, &
         xhandle, ipar, dpar, stat)
    call free_Helmholtz_2D(xhandle, ipar, stat)

    if ( interp ) then
       call interpolate_vc_to_mc( f_vc, phi )
    else
       call shift_vc_to_mc ( f_vc, phi )
    end if

  end subroutine poisson_solver_DFT

  subroutine shift_mc_to_vc ( f_mc, f_vc )
    implicit none

    real, dimension( :, : ), intent(in) :: f_mc
    double precision, dimension( :, : ), intent(out) :: f_vc
    integer :: nlon, nlat

    nlon = size( f_mc, 1)
    nlat = size( f_mc, 2)

    f_vc ( 1 : nlon, 1 : nlat ) = f_mc ( :, : )
    f_vc ( nlon + 1, : ) = f_vc ( 1, : )
    f_vc ( :, nlat + 1 ) = 0.0e0

  end subroutine shift_mc_to_vc

  subroutine shift_vc_to_mc ( f_vc, f_mc )
    implicit none

    double precision, dimension( :, : ), intent(in) :: f_vc
    real, dimension( :, : ), intent(out) :: f_mc

    integer :: nlon, nlat

    nlon = size( f_mc, 1)
    nlat = size( f_mc, 2)

    f_mc ( :, : ) = f_vc ( 1 : nlon, 1 : nlat )

  end subroutine shift_vc_to_mc

end module mod_poisson_DFT


c***********************************************************************
c	                    COORD_VB2H_TP.F
c***********************************************************************
*     PURPOSE: Converts test part from Barycentric to Heliocentric coords.
*              Velocity only
*     ARGUMENTS:  Input is
*                              ntp ==> number of test part (<= NTPMAX)
*                                              (integer)
*                             istat ==>  Status flag
*                    vxbt,vybt,vzbt ==> bary. particle velocities
*                                            (real array)
*		     vxhs,vyhs,vzhs ==> bary vel of the Sun
*                                          (real scalar)
*                 Returned are
*		     vxht,vyht,vzht ==> heliocentric particle velocities
*                                             (real array)
*
*     Authors:  Hal Levison
*     ALGORITHM: Obvious
*     WRITTEN:  11/14/96
*     REVISIONS: 11/15/96

	subroutine coord_vb2h_tp(ntp,istat,vxbt,vybt,vzbt,vxs,
     &      vys,vzs,vxht,vyht,vzht)

      include '../swift.inc'

c...  Inputs:
	integer ntp
	real*8 vxbt(NTPMAX),vybt(NTPMAX),vzbt(NTPMAX)
        real*8 vxs,vys,vzs
        integer istat(ntp)

c...  Outputs:
	real*8 vxht(NTPMAX),vyht(NTPMAX),vzht(NTPMAX)

c...  Internals:
	integer i

c----
c...  Executable code
	do i=1,ntp
           if(istat(i).eq.0) then
              vxht(i) = vxbt(i) - vxs
              vyht(i) = vybt(i) - vys
              vzht(i) = vzbt(i) - vzs
           endif
        enddo

	return
	end     ! coord_vb2h_tp
c--------------------------------------------------------------------------


      subroutine reshape(npts,nfft,kspec,kl,mxdata,dpss,il,xmul,
     $                   mxfreq,yk,wsave,dpsw,mxlin,slin)
c
c  reshapes eigen-ft's around significant spectral lines
c
c  inputs:
c    npts  - number of data points
c    nfft  - number of points in fft's
c    kspec - number of windows
c    kl    - number of spectral line components
c    mxdata- leading dimension of dpss
c    dpss  - double precision array containing kspec tapers
c            of length npts
c    il    - integer vector containing indices of the lines
c    xmul  - complex vector containing the mean values of the lines
c    mxfreq- leading dimension of yk
c    yk    - complex array containing ffts of tapered data
c    wsave - real work vector of dimension at least 4*nfft+15 that
c            contains the fft complex exponentials. these are
c            assumed to have been computed by calling cffti.
c    dpsw  - real work vector of dimension at least 4*nfft
c    mxlin - leading dimension of slin
c
c  outputs:
c    slin  - real array containing total power removed from
c            kspec eigen-ft's at kl frequencies
c
c  calls cfftf
c
c*******************************************************************
c
      double precision dpss,sum1,sum2
      complex yk,t0,t1,xmul,dpsw
      dimension il(kl),wsave(4*nfft+15),yk(mxfreq,kspec),xmul(kl),
     $          dpsw(nfft,2),slin(mxlin,kspec),dpss(mxdata,kspec)
      nfft2=nfft/2
c
c  compute discrete prolate spheroidal wavefunctions by taking
c  fft's of the real dpss.
c  the fft's are computed in pairs by placing adjacent dpss's in the
c  real and imaginary parts of dpsw and sorting the result using
c  the symmetry properties of the fft.
c  the dpsw are normalized so that the integral from -1/2 to 1/2 of
c  dpsw**2 is one. since the fft is unnormalized and the sum of the
c  squares of the dpss is one, this condition is automatically met.
      do 40 j=1,kspec-1,2
        do 10 i=1,npts
   10     dpsw(i,1)=cmplx(dpss(i,j),dpss(i,j+1))
        do 11 i=npts+1,nfft
   11     dpsw(i,1)=0.
        call cfftf(nfft,dpsw,wsave)
        dpsw(1,2)=cmplx(aimag(dpsw(1,1)),0.)
        dpsw(1,1)=cmplx(real(dpsw(1,1)),0.)
        do 20 i=2,nfft2+1
          dpsw(i,2)=cmplx(0.,-0.5)*(dpsw(i,1)-conjg(dpsw(nfft-i+2,1)))
   20     dpsw(i,1)=0.5*(dpsw(i,1)+conjg(dpsw(nfft-i+2,1)))
cvd$ nodepchk
        do 21 i=nfft2+2,nfft
          dpsw(i,1)=conjg(dpsw(nfft-i+2,1))
   21     dpsw(i,2)=conjg(dpsw(nfft-i+2,2))
c  compute and remove mean value for each spectral line
        do 40 k=1,kl
          sum1=0.
          sum2=0.
          do 30 i=1,nfft
            ii=i-il(k)+1
            if(ii.lt.1)ii=ii+nfft
            t0=xmul(k)*dpsw(ii,1)
            yk(i,j)=yk(i,j)-t0
            t1=xmul(k)*dpsw(ii,2)
            yk(i,j+1)=yk(i,j+1)-t1
            sum1=sum1+abs(t0)**2+2.*real(t0*conjg(yk(i,j)))
   30       sum2=sum2+abs(t1)**2+2.*real(t1*conjg(yk(i,j+1)))
          slin(k,j)=sum1
   40     slin(k,j+1)=sum2
c  reshape last eigen-ft if kspec is odd
      if(mod(kspec,2).eq.0)return
      do 60 i=1,npts
   60   dpsw(i,1)=cmplx(dpss(i,kspec),0.d0)
      do 61 i=npts+1,nfft
   61   dpsw(i,1)=0.
      call cfftf(nfft,dpsw,wsave)
      do 80 k=1,kl
        sum1=0.
        do 70 i=1,nfft
          ii=i-il(k)+1
          if(ii.lt.1)ii=ii+nfft
          t0=xmul(k)*dpsw(ii,1)
          yk(i,kspec)=yk(i,kspec)-t0
   70     sum1=sum1+abs(t0)**2+2.*real(t0*conjg(yk(i,kspec)))
   80   slin(k,kspec)=sum1
      return
      end

c $Id$


program variables
!
!
! Demonstrate some properties of variables
!
!

  implicit none

  integer         :: i
  integer(kind=2) :: j
  integer(kind=4) :: k
  integer(kind=8) :: l

  real            :: a
  real(kind=4)    :: b
  real(kind=8)    :: c

write (*,*) 'Huge:   ',huge(i),huge(j),huge(k),huge(l)
write (*,*) 'Digits: ',digits(i),digits(j),digits(k),digits(l)

write (*,*) ''

write (*,*) 'Huge:   ',huge(a),huge(b),huge(c)
write (*,*) 'Digits: ',digits(a),digits(b),digits(c)
write (*,*) 'Epsilon: ',epsilon(a),epsilon(b),epsilon(c)

end program variables


      program main
      integer i, fun1
      external fun1
      i = 1
      if (i.eq.1) then
         i = 2
      else
         i = 3
      endif
      call sub(i, 10)
      call sub2(10,20)
      call sub3
      i = fun1(2)
      end
      subroutine sub(j, k)
      integer i
      parameter (n=10)
      real*8 a(0:n)
      do i=0, k
         a(i) = 0
      enddo
      call sub4(a)
      end
      subroutine sub2(n, m)
      real*4 b(0:10,0:20)
      integer i,j
      do i=0, m
         do j=0, n
            b(j,i) = i + j
         enddo
      enddo
      end
      subroutine sub3
      parameter (n=2, m=3)
      integer i, fun1
      external fun1
      i = n+m
      do while (i.gt.0)
         i = i - 1
         i = i - fun1(0)
      enddo
      end
      subroutine sub4(a)
      parameter (n=10)
      integer i
      real*8 a(0:n)
      real*8 b(0:n)
      do i=0, n
         b(i) = a(i)
      enddo
      do i=1, n-1
         a(i) = 0.25*(b(i-1)+2*b(i)+b(i+1))
      enddo
      end
      integer function fun1(i)
      integer i
      fun1 = 3
      end


PROGRAM exercise13_4
IMPLICIT NONE
REAL :: x = 12., y = -3., result
INTEGER :: i = 6, j = 4
WRITE (*,100) ' Before call: x, y, i, j = ', x, y, i, j
100 FORMAT (A,2F6.1,2I6)
result = exec(y,i)
WRITE (*,*) 'The result is ', result
WRITE (*,100) ' After call:  x, y, i, j = ', x, y, i, j

CONTAINS
   REAL FUNCTION exec(x,i)
   REAL, INTENT(IN) :: x
   INTEGER, INTENT(IN) :: i
   WRITE (*,100) ' In exec:     x, y, i, j = ', x, y, i, j
   100 FORMAT (A,2F6.1,2I6)
   exec = ( x + y ) / REAL ( i + j )
   j = i
   END FUNCTION exec
END PROGRAM exercise13_4


! { dg-do run }
!
! Checks the fix for PR67171, where the second ALLOCATE with and array section
! SOURCE produced a zero index based temporary, which threw the assignment.
!
! Contributed by Anton Shterenlikht  <mexas@bristol.ac.uk>
!
program z
  implicit none
  integer, parameter :: DIM1_SIZE = 10
  real, allocatable :: d(:,:), tmp(:,:)
  integer :: i, errstat

  allocate (d(DIM1_SIZE, 2), source = 0.0, stat=errstat )

  d(:,1) = [( real (i), i=1,DIM1_SIZE)]
  d(:,2) = [( real(2*i), i=1,DIM1_SIZE)]
!  write (*,*) d(1, :)

  call move_alloc (from = d, to = tmp)
!  write (*,*) tmp( 1, :)

  allocate (d(DIM1_SIZE / 2, 2), source = tmp(1 : DIM1_SIZE / 2, :) , stat=errstat)
  if (any (d .ne. tmp(1:DIM1_SIZE/2,:))) STOP 1
  deallocate (d)

  allocate (d(DIM1_SIZE / 2, 2), source = foo (tmp(1 : DIM1_SIZE / 2, :)) , stat=errstat)
  if (any (d .ne. tmp(1 : DIM1_SIZE / 2, :))) STOP 2

  deallocate (tmp , d)

contains
  function foo (arg) result (res)
    real :: arg(:,:)
    real :: res(size (arg, 1), size (arg, 2))
    res = arg
  end function
end program z


       module mzranmod
         INTEGER,PARAMETER :: K4B=selected_int_kind(9)
         INTEGER,PARAMETER :: DP =KIND(1.0D0)
       contains
!***************************************************************************C
!***************************************************************************C
!!
!*********************************************************************
!**                Random Number Generator  (period > 2^94)         **
!**  See  G. Marsaglia and A. Zaman, Comp. Phys. 8, 117-121 (1994)  **
!*********************************************************************
        function rmzran()
        implicit none
        integer (k4b) ::  mzran,n,i,j,k,is,js,ks,ns,mzranset
        real (DP)     ::  rmzran
        save i,j,k,n
        data i,j,k,n/521288629,362436069,16163801,1131199299/
        mzran = i-k
        if(mzran.lt.0) mzran = mzran + 2147483579
        i = j
        j = k
        k = mzran
        n = 69069*n + 1013904243
!        n = ishft(3533*ishft(n,-16)+iand(n,65535),16)+3533*iand(n,65535))
!        n = n + 1013904243
        mzran = mzran + n
!       For random reals on  (0,1): UNI() = .5+.2328306E-9*mzran()
!       For random reals on (-1,1): VNI() = .4656613E-9*mzran()
!
        rmzran = real(mzran,kind=DP)*0.2328306E-9_DP + 0.5_DP
!
        return
        entry mzranset(is,js,ks,ns)
        i = 1+iabs(is)
        j = 1+iabs(js)
        k = 1+iabs(ks)
        n = ns
        mzranset = n
        return
        end function rmzran
!
!*********************************************************************
!*********************************************************************
!
!
!
!*********************************************************************
!**     subrutina de para asegurar que los enteros sean de          **
!**     bits y cumplan los requisitos necesarios para el generador. **
!**
!**       Extraida del Numerical Recipes                            **
!*********************************************************************
!
         SUBROUTINE mzran_init(is,js,ks,n)
           IMPLICIT NONE
           INTEGER(K4B), intent(in), optional :: n,is,js,ks
           INTEGER(K4B),PARAMETER ::hg=huge(1_K4B),hgm=-hg,hgng=hgm-1
           INTEGER(K4B)::new,j,hgt,nl
             hgt=hg
!           The following lines check that kind value K4B is in fact a
!           32-bit integer with the usual properties that we expect it
!           to have (under negation and wrap-around addition).If all of
!           these tests are satisfied,then the routines that use this
!           module are portable,even though they go eyond Fortran 90 's
!           integer model.
           if (hg /=2147483647)call nrerror('ran_init:arith assump 1 fails ')
           if (hgng >=0)call nrerror('ran_init:arith assump 2 fails ')
           if (hgt+1 /=hgng)call nrerror('ran_init:arith assump 3 fails ')
           if (not(hg)>=0)call nrerror('ran_init:arith assump 4 fails ')
           if (not(hgng)<0)call nrerror('ran_init:arith assump 5 fails ')
           if (hg+hgng >=0)call nrerror('ran_init:arith assump 6 fails ')
           if (not(-1_k4b)<0)call nrerror('ran_init:arith assump 7 fails ')
           if (not(0_k4b)>=0)call nrerror('ran_init:arith assump 8 fails ')
           if (not(1_k4b)>=0)call nrerror('ran_init:arith assump 9 fails ')
!
!          si se se quiere iniciar la secuencia de mzran con otras semaillas
!          (no usando las definidas el la funcion mzran)
!
           if (present(is).and.present(js).and.present(ks).and.present(n)) then
             nl = mzranset(is,js,ks,n)
           endif
!
           return
         end subroutine mzran_init
!
!
         SUBROUTINE nrerror(char)
           character, intent(in) :: char
           write(*,*) char
           stop
         end subroutine nrerror
         end module mzranmod


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

! http://www.tek-tips.com/viewthread.cfm?qid=1516435
module emc_functions
    implicit none
contains
function pureDGESV(a, b, trans)
    implicit none
    real(kind=8), intent(in) :: a(3,3), b(3)
    character(len=1), intent(in) :: trans
    real(kind=8) :: a1(3,3), pureDGESV(3)
    integer(kind=4) :: IPIV(3), INFO, i, j
    external :: DGESV

    do i=1,3
        pureDGESV(i)=b(i)
        do j=1,3
            if(trans .eq. 'T') then
                a1(j,i)=a(i,j)
            else
                a1(j,i)=a(j,i)
            end if
        end do
    end do

    IPIV = 0
    call DGESV( 3, 1, a1, 3, IPIV, pureDGESV, 3, INFO )
    if (INFO /= 0) write(*,*) "INFO:", INFO
    return
end function pureDGESV

function pureDEGMV(m, vec, trans)
    implicit none
    integer(kind=4), parameter :: size = 3
    real(kind=8), intent(in) :: m(size,size), vec(size)
    character(len=1), intent(in) :: trans
    real(kind=8) :: pureDEGMV(size)
    external :: DGEMV

    pureDEGMV = 0.d0
    call DGEMV(trans, size, size, 1.d0, m, size, vec, 1, 1.d0, pureDEGMV, 1)
    return
end function pureDEGMV

pure function normal(a, n)
    implicit none
    integer(kind=4), intent(in) :: n
    real(kind=8), intent(in) :: a(n)
    integer(kind=4) :: i
    real(kind=8) :: normal(n), amax

    amax=0.d0
    do i=1, n
       if (DABS(amax) < DABS(a(i))) amax=a(i)
    end do

    normal = a/amax
    return
end function normal

subroutine print_time(iunt)
    implicit none
    integer(kind=4), intent(in) :: iunt
    integer(kind=4) :: today(3), now(3)

    call idate(today)   ! today(1)=day, (2)=month, (3)=year
    call itime(now)     ! now(1)=hour, (2)=minute, (3)=second
    write(iunt,"('Date ',i2.2,'/',i2.2,'/',i4.4,';time ',i2.2,':',i2.2,':',i2.2 )")today(2),today(1),today(3),now
    return
end subroutine print_time

!!!!!!!     UNUSED FUNCTIONS
!!
!
! http://stackoverflow.com/questions/3519959/computing-the-inverse-of-a-matrix-using-lapack-in-c
subroutine inverse(M, n)
    implicit none
    integer(kind=4) :: n, LWORK, ok
    real(kind=8) :: M(n,n)
    integer(kind=4),allocatable :: ipiv(:)
    real(kind=8),allocatable :: WORK(:)
    external DGETRF, DGETRI

    LWORK = n*n
    allocate(WORK(LWORK))
    allocate(ipiv(n+1))

    call DGETRF(n, n, M, n, ipiv, ok)
    if (ok > 0) then
        write(*,*) 'Matrix is singular in: ', ok
        return
    end if

    call DGETRI(n, M, n, ipiv, WORK, LWORK, ok)

    if (ok > 0) then
        write(*,*) 'Matrix is singular in: ', ok
        return
    end if

    deallocate(ipiv)
    deallocate(WORK)
    return
end subroutine

function vect2G(f)
    implicit none
    real(kind=8), parameter :: fact = 180.d0/(4.d0*DATAN(1.d0))
    integer(kind=4), parameter :: size = 3
    real(kind=8), intent(in) :: f(size,size)
    real(kind=8) :: l(3), ang(3), vect2G ! vect2G(size,size),
    integer(kind=4) :: i
    real(kind=8), external :: DDOT

    ! http://theory.cm.utexas.edu/redmine/projects/vtstscripts/repository/entry/pos2cif.pl
    do i=1,3
        l(i) = dsqrt(f(1,i)**2 + f(2,i)**2 + f(3,i)**2)
    end do

    ang(1) = dacos( DDOT(3, f(:,3), 1, f(:,2), 1)/l(2)/l(3) )*fact;
    ang(2) = dacos( DDOT(3, f(:,1), 1, f(:,3), 1)/l(1)/l(3) )*fact;
    ang(3) = dacos( DDOT(3, f(:,1), 1, f(:,2), 1)/l(1)/l(2) )*fact;

    do i=1,3
        write(*,*) l(i), ang(i)
    end do

    return
end function vect2G

end module emc_functions


C
C      **********************************************************************
C      ******************** SUBROUTINE KMDIF ********************************
C      **********************************************************************
C
       SUBROUTINE KMDIF(S, ZU, IU, NTOT, START, BINSIZ, NBIN,
     +                  F, BS, BL, DIFF)

C
C      *       THIS SUBROUTINE COMPUTES AND PRINTS THE DIFFERENTIAL KM      *
C      *       ESTIMATOR BASED ON WARDLE AND KNAPP, 'THE STATISTICAL        *
C      *       DISTRIBUTION OF THE NEUTRAL-HYDROGEN CONTENT OF S0 GALAXIES',*
C      *       ASTRN. J., 91:23 1986.                                       *
C      *                                                                    *
C      *       INPUT     S(L)  :  PL ESTIMATOR                              *
C      *                ZU(I)  :  UNCENSORED DATA POINTS                    *
C      *                 IU    :  NUMBER OF UNCENSORED DATA POINTS          *
C      *                NTOT   :  TOTAL NUMBER OF DATA POINTS,=IU+IC.       *
C      *                START  :  STARTING VALUE OF THE FIRST BIN           *
C      *                BINSIZ :  WIDTH OF THE BIN                          *
C      *                NBIN   :  NUMBER OF BINS                            *
C      *                                                                    *
C      *      OUTPUT                                                        *
C      *                F(I)   :  MASS OF THE I TH DATA POINT               *
C      *               BS(J)   :  STARTING VALUE FOR THE BIN J              *
C      *               BL(J)   :  ENDING VALUE FOR THE BIN J                *
C      *               DIFF(J) :  DIFFERENTIAL KM ESTIMATOR AT BIN J        *
C      *                                                                    *
C      *                                                                    *
C
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)
C
       DIMENSION ZU(NTOT),S(NTOT),F(NTOT)
       DIMENSION BS(NBIN),BL(NBIN),DIFF(NBIN)
C
C       *    FIRST, COMPUTE THE MASS OF EACH POINT                          *
C
        F(1) = 1.0 -S(1)

        DO 610 I = 2, IU
           F(I) = DABS(S(I) - S(I-1))
  610   CONTINUE
C
C       *  SET THE BIN BOUNDARIES.                                          *
C
        DO 620 J = 1, NBIN
           BS(J) = START + BINSIZ*(J-1)
           BL(J) = START + BINSIZ*J
  620   CONTINUE

        I = 1
        J = 0

  630   J = J + 1
        DIFF(J) = 0.0

C
C      *       CHECK WHETHER THE I-TH POINT IS IN THE BIN                  *
C
  640  IF(J .LE. NBIN) THEN
         IF(ZU(I) .LT. BS(J)) THEN
            IF(I .GE. IU) THEN
               GOTO 630
            ENDIF
            I = I + 1
            GOTO 640
         ENDIF

C      *       COMPUTE THE DIFFERENTIAL KM                                 *
C
         IF(ZU(I) .GE. BL(J)) GOTO 630
         DIFF(J) = DIFF(J) + F(I)

         IF(I .LT. IU) THEN
            I = I + 1
            GOTO 640
         ENDIF
         GOTO 630
       ENDIF
C
       RETURN
       END


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

      REAL FUNCTION ESOLVE (A7, A8, A2, ANG1, ANG2)
C***********************************************************************

C  FUNCTION ESOLVE = FINDS A SOLUTION TO THE ELIPSE EQUATION
C                    GIVEN AN INTERVAL THAT CONTAINS THE SOLUTION

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

      EPS = 1.E-6

      F1 = ELIPSE (A7, A8, A2, ANG1)
      IF (ABS(F1) .LT. EPS) THEN
         ESOLVE = ANG1
         GO TO 110
      END IF
      F2 = ELIPSE (A7, A8, A2, ANG2)
      IF (ABS(F2) .LT. EPS) THEN
         ESOLVE = ANG2
         GO TO 110
      END IF

  100 CONTINUE
      IF (ABS(ANG1 - ANG2) .LT. EPS) THEN
         ESOLVE = (ANG1 + ANG2)/2.0
      ELSE
         ANG3 = (ANG1 + ANG2)/2.0
         F3 = ELIPSE (A7, A8, A2, ANG3)

         IF (ABS(F3) .LT. EPS) THEN
            ESOLVE = ANG3
            GO TO 110
         ELSE IF (F1/F3 .LT. 0.0) THEN
            ANG2 = ANG3
            F2 = F3
         ELSE
            ANG1 = ANG3
            F1 = F3
         END IF
         GO TO 100
      END IF

  110 CONTINUE

      RETURN

      END